Проверяйте. Функция должна работать с любыми кодовыми страницами Windows и с любыми региональными настройками.
| Код |
|---|
Option Explicit
Function KzCyrToLat(ByVal s As String) As String
Static cyr, lat, Dict As Object
Dim i As Long, s1 As String, s2 As String, arr() As String, b As Boolean, n As Long
If IsEmpty(cyr) Then
' буквы казахского алфавита
cyr = Array(1072, 1073, 1074, 1075, 1076, 1077, 1105, 1078, 1079, 1080, 1081, 1082, 1083, 1084, 1085, 1086, 1087, 1088, 1089, 1090, 1091, 1092, 1093, 1094, 1095, 1096, 1097, 1098, 1099, 1100, 1101, 1102, 1103, 1241, 1110, 1187, 1171, 1199, 1201, 1179, 1257, 1211)
lat = Array("a", "b", "v", "g", "d", "e", "yo", "zh", "z", "i", "y", "k", _
"l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", _
"sh", "sch", "", "y", "", "e", "yu", "ya", "a", "i", "ng", "g", "u", "u", "k", "o", "h")
If UBound(cyr) <> UBound(lat) Then
MsgBox "Dimensions of arrays cyr and lat must be the same", vbCritical
Exit Function
End If
Set Dict = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(cyr)
Dict(ChrW(cyr(i))) = lat(i)
Dict(UCase(ChrW(cyr(i)))) = StrConv(lat(i), vbProperCase)
Next i
End If ' первоначального заполнения
ReDim arr(1 To Len(s))
For i = 1 To Len(s)
s1 = Mid(s, i, 1)
If Dict.exists(s1) Then
arr(i) = Dict(s1)
Else
arr(i) = s1
End If
Next i
' Обработка "особых" правил
n = UBound(arr)
For i = 1 To n
s1 = arr(i)
If LCase(s1) = "e" Then ' добавляем y к е
If i = 1 Then
b = True
Else
b = LCase(arr(i - 1)) Like "[aouiye]"
End If
If b Then arr(i) = IIf(s1 = "e", "ye", "Ye")
ElseIf LCase(s1) = "y" And i > 1 And i < n Then
arr(i) = IIf(arr(i) = "y", "i", "I")
ElseIf LCase(s1) = "s" And i > 1 And i < n Then
If LCase(arr(i - 1)) Like "[aouiye]" And LCase(arr(i + 1)) Like "[aouiye]" Then arr(i) = IIf(arr(i) = "s", "ss", "Ss")
End If
Next i
KzCyrToLat = Join(arr, "")
End Function |
Владимир
