offline
- rgdrajko
- Građanin
- Pridružio: 06 Maj 2007
- Poruke: 241
- Gde živiš: Beograd
|
Napisano: 28 Maj 2015 17:51
To sam davno uradio, za YUSCII kodnu stranu u cirilicu 1251. Prepravi za svoje potrebe.
U VBA koristis komandu ChrW$ koja omogucava da se ispise ascii kod veci od 255, sto chr$ ne moze vec ispisuje karaktere do ascii koda 255.
The valid range for Chr is 0 through 255, and the valid range for ChrW is -32768 through 65535.
Evo koda:
If TipKonverzijeKodneStrane = 4 Then
'Konvertovanje iz kodne strane YUSCII u Serbian(Cirilic, Serbia) 1251
For n = 1 To Len(Tekst)
'Mala slova
'Velika slova
If Asc(Mid(Tekst, n, 1)) = 13 Then
novitekst = novitekst & Chr(Asc(Mid(Tekst, n, 1)))
End If
If Asc(Mid(Tekst, n, 1)) > 31 And Asc(Mid(Tekst, n, 1)) < 47 Then
novitekst = novitekst & Chr(Asc(Mid(Tekst, n, 1)))
End If
If Asc(Mid(Tekst, n, 1)) > 47 And Asc(Mid(Tekst, n, 1)) < 64 Then
novitekst = novitekst & Chr(Asc(Mid(Tekst, n, 1)))
End If
If Mid(Tekst, n, 1) = "_" Then
novitekst = novitekst & Chr(95)
End If
If Mid(Tekst, n, 1) = "A" Then
novitekst = novitekst & ChrW$(1040)
End If
If Mid(Tekst, n, 1) = "B" Then
novitekst = novitekst & ChrW$(1041)
End If
If Mid(Tekst, n, 1) = "V" Then
novitekst = novitekst & ChrW$(1042)
End If
If Mid(Tekst, n, 1) = "G" Then
novitekst = novitekst & ChrW$(1043)
End If
If Mid(Tekst, n, 1) = "D" Then
novitekst = novitekst & ChrW$(1044)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "\" Then
novitekst = novitekst & ChrW$(1026)
End If
'''''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "E" Then
novitekst = novitekst & ChrW$(1045)
End If
If Mid(Tekst, n, 1) = "@" Then
novitekst = novitekst & ChrW$(1046)
End If
If Mid(Tekst, n, 1) = "Z" Then
novitekst = novitekst & ChrW$(1047)
End If
If Mid(Tekst, n, 1) = "I" Then
novitekst = novitekst & ChrW$(1048)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "J" Then
novitekst = novitekst & ChrW$(1032)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "K" Then
novitekst = novitekst & ChrW$(1050)
End If
If Mid(Tekst, n, 1) = "L" Then
novitekst = novitekst & ChrW$(1051)
End If
''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "Q" Then
novitekst = novitekst & ChrW$(1033)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "M" Then
novitekst = novitekst & ChrW$(1052)
End If
If Mid(Tekst, n, 1) = "N" Then
novitekst = novitekst & ChrW$(1053)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "W" Then
novitekst = novitekst & ChrW$(1034)
End If
'''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "O" Then
novitekst = novitekst & ChrW$(1054)
End If
If Mid(Tekst, n, 1) = "P" Then
novitekst = novitekst & ChrW$(1055)
End If
If Mid(Tekst, n, 1) = "R" Then
novitekst = novitekst & ChrW$(1056)
End If
If Mid(Tekst, n, 1) = "S" Then
novitekst = novitekst & ChrW$(1057)
End If
If Mid(Tekst, n, 1) = "T" Then
novitekst = novitekst & ChrW$(1058)
End If
'''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "]" Then
novitekst = novitekst & ChrW$(1035)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "U" Then
novitekst = novitekst & ChrW$(1059)
End If
If Mid(Tekst, n, 1) = "F" Then
novitekst = novitekst & ChrW$(1060)
End If
If Mid(Tekst, n, 1) = "H" Then
novitekst = novitekst & ChrW$(1061)
End If
If Mid(Tekst, n, 1) = "C" Then
novitekst = novitekst & ChrW$(1062)
End If
If Mid(Tekst, n, 1) = "^" Then
novitekst = novitekst & ChrW$(1063)
End If
'''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "X" Then
novitekst = novitekst & ChrW$(1039)
End If
'''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "[" Then
novitekst = novitekst & ChrW$(1064)
End If
' Mala slova
If Mid(Tekst, n, 1) = "a" Then
novitekst = novitekst & ChrW$(1072)
End If
If Mid(Tekst, n, 1) = "b" Then
novitekst = novitekst & ChrW$(1073)
End If
If Mid(Tekst, n, 1) = "v" Then
novitekst = novitekst & ChrW$(1074)
End If
If Mid(Tekst, n, 1) = "g" Then
novitekst = novitekst & ChrW$(1075)
End If
If Mid(Tekst, n, 1) = "d" Then
novitekst = novitekst & ChrW$(1076)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "|" Then
novitekst = novitekst & ChrW$(1106)
End If
'''''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "e" Then
novitekst = novitekst & ChrW$(1077)
End If
If Mid(Tekst, n, 1) = "`" Then
novitekst = novitekst & ChrW$(1078)
End If
If Mid(Tekst, n, 1) = "z" Then
novitekst = novitekst & ChrW$(1079)
End If
If Mid(Tekst, n, 1) = "i" Then
novitekst = novitekst & ChrW$(1080)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "j" Then
novitekst = novitekst & ChrW$(1112)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "k" Then
novitekst = novitekst & ChrW$(1082)
End If
If Mid(Tekst, n, 1) = "l" Then
novitekst = novitekst & ChrW$(1083)
End If
''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "q" Then
novitekst = novitekst & ChrW$(1113)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "m" Then
novitekst = novitekst & ChrW$(1084)
End If
If Mid(Tekst, n, 1) = "n" Then
novitekst = novitekst & ChrW$(1085)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "w" Then
novitekst = novitekst & ChrW$(1114)
End If
'''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "o" Then
novitekst = novitekst & ChrW$(1086)
End If
If Mid(Tekst, n, 1) = "p" Then
novitekst = novitekst & ChrW$(1087)
End If
If Mid(Tekst, n, 1) = "r" Then
novitekst = novitekst & ChrW$(1088)
End If
If Mid(Tekst, n, 1) = "s" Then
novitekst = novitekst & ChrW$(1089)
End If
If Mid(Tekst, n, 1) = "t" Then
novitekst = novitekst & ChrW$(1090)
End If
'''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "}" Then
novitekst = novitekst & ChrW$(1115)
End If
''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "u" Then
novitekst = novitekst & ChrW$(1091)
End If
If Mid(Tekst, n, 1) = "f" Then
novitekst = novitekst & ChrW$(1092)
End If
If Mid(Tekst, n, 1) = "h" Then
novitekst = novitekst & ChrW$(1093)
End If
If Mid(Tekst, n, 1) = "c" Then
novitekst = novitekst & ChrW$(1094)
End If
If Mid(Tekst, n, 1) = "~" Then
novitekst = novitekst & ChrW$(1095)
End If
'''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "x" Then
novitekst = novitekst & ChrW$(1119)
End If
'''''''''''''''''''''''''''''''''
If Mid(Tekst, n, 1) = "{" Then
novitekst = novitekst & ChrW$(1096)
End If
Dopuna: 28 Maj 2015 18:00
Evo vam macro za preslovljavanje u Wordu iz cirilice u latinicu sa upustvom i druge konverzije...
https://www.mycity.rs/must-login.png
Dopuna: 07 Jun 2015 22:55
Evo Makro by VRACKO (1995) Latinicno cirilicni konvertor za Word,
posto je to trazeno:
Attribute VB_Name = "LatToCir"
Rem *****************************************************
Rem * *
Rem * Makro by VRACKO (1995) *
Rem * Latinicno cirilicni konvertor *
Rem * *
Rem * Opciju za konvertovanje samo selektovanog dela *
Rem * teksta (12/04/2001), konvertovanje u headerima *
Rem * i footerima (24/04/2001), konvertovanje u *
Rem * futnotama, endnotama i komentarima (01/05/2001) *
Rem * dodao Sasa Babic *
Rem * *
Rem *****************************************************
Dim TriSlovaLat(3) As String
Dim TriSlovaCir(3) As String
Dim Lat(60) As String
Dim Cir(60) As String
Public Sub CirToLat()
On Error GoTo greska
TriSlovaLat(0) = "LJ": TriSlovaLat(1) = "NJ": TriSlovaLat(2) = "D" + ChrW$(381)
TriSlovaCir(0) = ChrW$(1033): TriSlovaCir(1) = ChrW$(1034): TriSlovaCir(2) = ChrW$(1039)
Lat(0) = ChrW$(76) + ChrW$(106): Lat(1) = ChrW$(78) + ChrW$(106): _
Lat(2) = ChrW$(68) + ChrW$(382): Lat(3) = ChrW$(108) + ChrW$(106): _
Lat(4) = ChrW$(110) + ChrW$(106): Lat(5) = ChrW$(100) + ChrW$(382): _
Lat(6) = ChrW$(65): Lat(7) = ChrW$(66): Lat(8) = ChrW$(86): Lat(9) = ChrW$(71) _
: Lat(10) = ChrW$(68): Lat(11) = ChrW$(272): Lat(12) = ChrW$(69): Lat(13) = ChrW$(381) _
: Lat(14) = ChrW$(90): Lat(15) = ChrW$(73): Lat(16) = ChrW$(74): Lat(17) = ChrW$(75) _
: Lat(18) = ChrW$(76): Lat(19) = ChrW$(77): Lat(20) = ChrW$(78): Lat(21) = ChrW$(79) _
: Lat(22) = ChrW$(80): Lat(23) = ChrW$(82): Lat(24) = ChrW$(83): Lat(25) = ChrW$(84) _
: Lat(26) = ChrW$(262): Lat(27) = ChrW$(85): Lat(28) = ChrW$(70): Lat(29) = ChrW$(72) _
: Lat(30) = ChrW$(67): Lat(31) = ChrW$(268): Lat(32) = ChrW$(352): Lat(33) = ChrW$(97) _
: Lat(34) = ChrW$(98): Lat(35) = ChrW$(118): Lat(36) = ChrW$(103): Lat(37) = ChrW$(100) _
: Lat(38) = ChrW$(273): Lat(39) = ChrW$(101): Lat(40) = ChrW$(382): Lat(41) = ChrW$(122) _
: Lat(42) = ChrW$(105): Lat(43) = ChrW$(106): Lat(44) = ChrW$(107): Lat(45) = ChrW$(108) _
: Lat(46) = ChrW$(109): Lat(47) = ChrW$(110): Lat(48) = ChrW$(111): Lat(49) = ChrW$(112) _
: Lat(50) = ChrW$(114): Lat(51) = ChrW$(115): Lat(52) = ChrW$(116): Lat(53) = ChrW$(263) _
: Lat(54) = ChrW$(117): Lat(55) = ChrW$(102): Lat(56) = ChrW$(104): Lat(57) = ChrW$(99) _
: Lat(58) = ChrW$(269): Lat(59) = ChrW$(353)
Cir(0) = ChrW$(1033): Cir(1) = ChrW$(1034): Cir(2) = ChrW$(1039): Cir(3) = ChrW$(1113) _
: Cir(4) = ChrW$(1114): Cir(5) = ChrW$(1119): Cir(6) = ChrW$(1040): Cir(7) = ChrW$(1041) _
: Cir(8) = ChrW$(1042): Cir(9) = ChrW$(1043): Cir(10) = ChrW$(1044): Cir(11) = ChrW$(1026) _
: Cir(12) = ChrW$(1045): Cir(13) = ChrW$(1046): Cir(14) = ChrW$(1047): Cir(15) = ChrW$(1048): Cir(16) = ChrW$(1032): Cir(17) = ChrW$(1050): Cir(18) = ChrW$(1051): Cir(19) = ChrW$(1052) _
: Cir(20) = ChrW$(1053): Cir(21) = ChrW$(1054): Cir(22) = ChrW$(1055): Cir(23) = ChrW$(1056) _
: Cir(24) = ChrW$(1057): Cir(25) = ChrW$(1058): Cir(26) = ChrW$(1035): Cir(27) = ChrW$(1059) _
: Cir(28) = ChrW$(1060): Cir(29) = ChrW$(1061): Cir(30) = ChrW$(1062): Cir(31) = ChrW$(1063) _
: Cir(32) = ChrW$(1064): Cir(33) = ChrW$(1072): Cir(34) = ChrW$(1073): Cir(35) = ChrW$(1074) _
: Cir(36) = ChrW$(1075): Cir(37) = ChrW$(1076): Cir(38) = ChrW$(1106): Cir(39) = ChrW$(1077) _
: Cir(40) = ChrW$(1078): Cir(41) = ChrW$(1079): Cir(42) = ChrW$(1080): Cir(43) = ChrW$(1112) _
: Cir(44) = ChrW$(1082): Cir(45) = ChrW$(1083): Cir(46) = ChrW$(1084): Cir(47) = ChrW$(1085) _
: Cir(48) = ChrW$(1086): Cir(49) = ChrW$(1087): Cir(50) = ChrW$(1088): Cir(51) = ChrW$(1089) _
: Cir(52) = ChrW$(1090): Cir(53) = ChrW$(1115): Cir(54) = ChrW$(1091): Cir(55) = ChrW$(1092) _
: Cir(56) = ChrW$(1093): Cir(57) = ChrW$(1094): Cir(58) = ChrW$(1095): Cir(59) = ChrW$(1096)
Klik = 0
LatToCirForm.CommandButton1.Caption = "Latinica->" + ChrW$(1035) + ChrW$(1080) + ChrW$(1088) _
+ ChrW$(1080) + ChrW$(1083) + ChrW$(1080) + ChrW$(1094) + ChrW$(1072)
LatToCirForm.CommandButton2.Caption = ChrW$(1035) + ChrW$(1080) + ChrW$(1088) _
+ ChrW$(1080) + ChrW$(1083) + ChrW$(1080) + ChrW$(1094) + ChrW$(1072) + "->Latinica"
LatToCirForm.Show
Set pozicija = Selection.Range
tipprozora = ActiveDocument.ActiveWindow.View.Type
Application.ScreenUpdating = False
Application.ScreenUpdating = False
If Selection.Range.Start <> Selection.Range.End Then
CirLat
Else
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
CirLat
For Each oblik In ActiveDocument.Shapes
If oblik.TextFrame.HasText Then
oblik.TextFrame.TextRange.Select
CirLat
Else
End If
Next
For Each sekc In ActiveDocument.Sections
For Each heder In sekc.Headers
heder.Range.Select
If Len(Selection.Range.Text) > 1 Then
CirLat
End If
Next
For Each futer In sekc.Footers
futer.Range.Select
If Len(Selection.Range.Text) > 1 Then
CirLat
End If
Next
Next
For Each oblik In Selection.HeaderFooter.Shapes
If oblik.TextFrame.HasText Then
oblik.TextFrame.TextRange.Select
CirLat
End If
Next
For Each fusnota In ActiveDocument.Footnotes
fusnota.Range.Select
CirLat
Next
For Each endnota In ActiveDocument.Endnotes
endota.Range.Select
CirLat
Next
For Each komentar In ActiveDocument.Comments
komentar.Range.Select
CirLat
Next
If ActiveWindow.Panes.Count > 1 Then
ActiveWindow.ActivePane.Close
End If
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
ActiveWindow.ActivePane.View.Type = tipprozora
Else
ActiveWindow.View.Type = tipprozora
End If
End If
pozicija.Select
Application.ScreenUpdating = True
kraj:
Exit Sub
greska:
MsgBox Err.Description, vbExclamation, "Greska: " & Err.Number
GoTo kraj
End Sub
Public Sub CirLat()
iz = LatToCirForm.Klik
If iz = 1 Then
For x = 0 To 2
Selection.Find.Execute FindText:=TriSlovaLat(x), MatchCase:=True, ReplaceWith:=TriSlovaCir(x), _
Replace:=wdReplaceAll
Next
For x = 0 To 59
Selection.Find.Execute FindText:=Lat(x), MatchCase:=True, ReplaceWith:=Cir(x), _
Replace:=wdReplaceAll
Next
Else
For x = 0 To 59
Selection.Find.Execute FindText:=Cir(x), MatchCase:=True, ReplaceWith:=Lat(x), _
Replace:=wdReplaceAll
Next
End If
End Sub
|