VBA Outlook 2013 latin to cyrillic transliteration (mongolian)

vb_eng_to_mon.vb

'http://www.utf8-chartable.de/unicode-utf8-table.pl?start=1024&utf8=-&unicodeinhtml=dec
Public Sub RunEngToMon()
Dim msg As Outlook.MailItem
Dim insp As Outlook.Inspector
Dim strTemp As String

If Application.ActiveInspector Is Nothing Then
    If Application.ActiveExplorer.Selection.Count = 1 Then
        If Application.ActiveExplorer.Selection.Item(1).Class = olMail Then
            Set msg = Application.ActiveExplorer.Selection.Item(1)
        End If
    Else
        MsgBox "Please select one email"
    End If
Else
    Set insp = Application.ActiveInspector
    If insp.CurrentItem.Class = olMail Then
        Set msg = insp.CurrentItem
    End If
End If

If msg Is Nothing Then
    MsgBox "could not determine the mail item"
Else
    If msg.GetInspector.EditorType = olEditorWord Then
        Set hed = msg.GetInspector.WordEditor
        Set appWord = hed.Application
        Set Rng = appWord.Selection
        strTemp = Rng.Text
        Rng.Text = EngMon(strTemp)
    End If
End If

Set appWord = Nothing
Set insp = Nothing
Set Rng = Nothing
Set hed = Nothing
Set msg = Nothing

End Sub

Function EngMon(Mon As String)
    Mon = Replace(Mon, Chr(146), Chr(39)) 
    Mon = Replace(Mon, "ai", ChrW(1072) + ChrW(1081), 1, -1, 1)
    Mon = Replace(Mon, "oi", ChrW(1086) + ChrW(1081), 1, -1, 1)
    Mon = Replace(Mon, "ii", ChrW(1080) + ChrW(1081), 1, -1, 1)
    Mon = Replace(Mon, "ui", ChrW(1091) + ChrW(1081), 1, -1, 1)
    Mon = Replace(Mon, "u'i", ChrW(1199) + ChrW(1081), 1, -1, 1)
    Mon = Replace(Mon, "ei", ChrW(1101) + ChrW(1081), 1, -1, 1)
    
    letters = Array("O'","o'","U'","u'","TS", "CH", "SH", "SCH", "ts", "ch", "sh", "sch", "YE","YO","YU", "YA","ye","yo", "yu", "ya", "A", "B", "V", "G", "D", "E", "J", "Z", "I", "I", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "H", "", "II", "", "E", "a", "b", "v", "g", "d", "e", "j", "z", "i", "y", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "h", "", "y", "", "e")
    monletters = Array(1256,1257,1198,1199,1062, 1063, 1064, 1065, 1094, 1095, 1096, 1097,1045,1025, 1070, 1071, 1077, 1105, 1102, 1103, 1040, 1041, 1042, 1043, 1044, 1069, 1046, 1047, 1048, 1049, 1050, 1051, 1052, 1053, 1054, 1055, 1056, 1057, 1058, 1059, 1060, 1061, 1066, 1067, 1068, 1069, 1072, 1073, 1074, 1075, 1076, 1101, 1078, 1079, 1080, 1081, 1082, 1083, 1084, 1085, 1086, 1087, 1088, 1089, 1090, 1091, 1092, 1093, 1098, 1099, 1100, 1101)
    
    i = 0
    For Each letter In letters
        Dim val As String
        Select Case letter
            Case letters(i)
               val = ChrW(monletters(i))
       
        End Select
        Mon = Replace(Mon, letter, val)
        i = i + 1
    Next letter
    
    EngMon = Mon
End Function