1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
Dim FLAG As Long
Sub MM1_RUS_LAT() '''mm140616 испр 180324
Debug.Print Translit("абв гдеё ж зий клмн опрст уф х ц ч ш щ ъыь э ю я объект мальчик")
' abv gdee zh ziy klmn oprst uf kh ts tch sh sch `y` e yu ya
Debug.Print Translit("с учётом регистра символов")
''абв гдеё ж зий клмн опрст уф х ц ч ш щ ъыь э ю я объект мальчик
''abv gdee zh ziy klmn oprst uf kh ts tch sh sch `y` e yu ya ob`ekt mal`tchik
''с учётом регистра символов
''s utchetom registra simvolov
End Sub
Sub mm2_LAT_RUS()
FLAG = 0
Translit2 "zdravstvuite, mogli bi vi mne pomoch otladit bazu? konechnoje ne za besplatno."
Translit2 "k sojaleniu ia bukvalno 2 nedeli nazad v pervie stalknulsia s Access, po rabote ochen ponadobilsia."
Translit2 "to chto ia uje zdelal v principe rabotaet,no xotelos bi detalno otladit."
Translit2 "esli pomojete, xotelos bi kontaktirovat xotia bi cherez skaip."
Translit2 "ia sam naxajus v gruzii, zdes znaiushix po etoi chasti kak bi ne nashel."
Translit2 "izvinite chto na latinice pishu, u nouta net russkoi klaviaturi."
Translit2 "zavut menia David"
''3 a а
''3 b б
''3 v в
''3 g г
''3 d д
''3 e е
''3 e ё
''3 zh ж
''3 z з
''3 i и
''3 y й
''3 k к
''3 l л
''3 m м
''3 n н
''3 o о
''3 p п
''3 r р
''3 s с
''3 t т
''3 u у
''3 f ф
''3 kh х
''3 ts ц
''3 tch ч
''3 sh ш
''3 sch щ
'' 3 ` ъ
''3 y ы
'' 3 ` ь
''3 e э
''3 yu ю
''3 ya я
''здравствуите, могли би ви мне помоch отладит базу? конеchноjе не за бесплатно.
''-------
'' 2 k sojaleniu ia bukvalno 2 nedeli nazad v pervie stalknulsia s Access, po rabote ochen ponadobilsia.
''к соjалениу иа буквално 2 недели назад в первие сталкнулсиа с аccесс, по работе оchен понадобилсиа.
''-------
'' 3 to chto ia uje zdelal v principe rabotaet,no xotelos bi detalno otladit.
''то chто иа уjе зделал в принcипе работает,но xотелос би детално отладит.
''-------
'' 4 esli pomojete, xotelos bi kontaktirovat xotia bi cherez skaip.
''если помоjете, xотелос би контактироват xотиа би chерез скаип.
''-------
'' 5 ia sam naxajus v gruzii, zdes znaiushix po etoi chasti kak bi ne nashel.
''иа сам наxаjус в грузии, здес знаиушиx по етои chасти как би не нашел.
''-------
'' 6 izvinite chto na latinice pishu, u nouta net russkoi klaviaturi.
''извините chто на латиниcе пишу, у ноута нет русскои клавиатури.
''-------
'' 7 zavut menia David
''завут мениа давид
''-------
End Sub
Function Translit(ByVal txt As String) As String
' с учётом регистра символов
Debug.Print txt
Dim txtRussian$, arrTranslit, iCount%, txt2
txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя"
arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _
"l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _
"sh", "sch", "`", "y", "`", "e", "yu", "ya")
txt2 = txt
For iCount% = 1 To 33
txt2 = Replace(txt2, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare) ' строчные
txt2 = Replace(txt2, UCase(Mid(txtRussian$, iCount%, 1)), UCase(arrTranslit(iCount%)), , , vbBinaryCompare) ' прописные
Next
Translit$ = txt2
End Function
Function Translit2(ByVal txt As String) As String
' с учётом регистра символов
FLAG = FLAG + 1
Debug.Print FLAG, txt
Dim txtRussian$, arrTranslit, iCount%, txt2, SL, SK, J2
txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя"
arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _
"l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _
"sh", "sch", "`", "y", "`", "e", "yu", "ya")
txt2 = txt
For iCount% = 3 To 1 Step -1
For J2 = 1 To 33
SL = arrTranslit(J2)
SK = Mid(txtRussian$, J2, 1)
If iCount = 3 And FLAG = 1 Then
Debug.Print iCount, SL, SK
End If
If Len(SL) = iCount Then
''
'' txt2 = Replace(txt2, SL, SK, , , vbBinaryCompare) ' строчные
''
'' txt2 = Replace(txt2, UCase(SL), UCase(SK), , , vbBinaryCompare) ' прописные
txt2 = Replace(txt2, SL, SK) ' строчные
txt2 = Replace(txt2, UCase(SL), UCase(SK)) ' прописные
End If
Next J2
Next iCount
Translit2 = txt2
Debug.Print txt2
Debug.Print "-------"
End Function
