'MacroName:Ethiopic2Latin 'MacroDescription:Automatically transliterate Ethiopic (Amharic, Ge'ez, etc.) characters into Latin characters 'Macro written by: Joel Hahn, Niles Public Library District 'Macro last modified: 31 October 2013 Declare Function TransEthiopic(sChar As String, sNextChar As String, nPos As Variant) As String Declare Function IsEthiopicChar(sNCR) As Integer Global arrChars() Option Explicit Sub Main Dim CharacterSet As Integer Dim bool as Integer Dim sField As String Dim nHasEthiopic as integer Dim NewField As String Dim i, a Dim sHex As String Dim nHex As Long Dim TempChar As String Dim place3 as Integer Dim place As Integer Dim sBCR As String Dim nTempDigits Dim nTempNum Dim nNumHex Dim CS As Object Set CS = CreateObject("Connex.Client") ReDim arrChars(0) 'nCurRow = CS.CursorRow ' Select Case CS.ItemType ' Case 0, 1, 2, 3, 4, 14, 17, 18, 19, 20, 35 ' 'Viewing a MARC record; proceed ' Case Else ' MsgBox "Not viewing a MARC record. Exiting..." ' Exit Sub ' End Select 'CS.CursorRow = nCurRow bool = CS.GetFieldLineUnicode(CS.CursorRow, sField) NewField = Left(sField, 5) sField = Mid(sField, 6) i = 1 : nHasEthiopic = 0 Do While i <= Len(sField) - 7 a = Mid(sField, i, 8) If IsEthiopicChar(Mid(sField, i, 6)) Then nHasEthiopic = 1 Exit Do End If i = i + 1 Loop If nHasEthiopic = 0 Then MsgBox "Field contains no Ethiopic characters. Exiting..." Exit Sub End If 'Break up Ethiopic field in to separate characters i = 1 Do While i <= Len(sField) ReDim Preserve arrChars(UBound(arrChars) + 1) If Mid(sField, i, 3) = "&#x" Then place = InStr(i, sField, ";") sBCR = Mid(sField, i, (place - i) + 1) arrChars(UBound(arrChars)) = sBCR i = place Else arrChars(UBound(arrChars)) = Mid(sField, i, 1) End If i = i + 1 Loop i = 1 Do While i <= UBound(arrChars) If InStr(arrChars(i), "&#x") Then sHex = Mid(arrChars(i), 4, Len(arrChars(i)) - 2) nHex = Val("&H" & sHex) Select Case nHex Case &H01C2 NewField = NewField & Chr(223) 'delimiter Case &H1369 To &H137C Do While Val("&H" & Mid(arrChars(i), 4, Len(arrChars(i)) - 2) ) >= &H1369 And Val("&H" & Mid(arrChars(i), 4, Len(arrChars(i)) - 2) ) <= &H137C nNumHex = Val("&H" & Mid(arrChars(i), 4, Len(arrChars(i)) - 2) ) Select Case nNumHex Case &H1369 To &H1371 If arrChars(i-1) = "፻" or arrChars(i-1) = "፼" Then nTempNum = nTempNum + nTempDigits nTempDigits = 0 End If nTempDigits = nTempDigits + ((nNumHex - &H1369) Mod 9) + 1 Case &H1372 To &H137A If arrChars(i-1) = "፻" or arrChars(i-1) = "፼" Then nTempNum = nTempNum + nTempDigits nTempDigits = 0 End If nTempDigits = nTempDigits + ((((nNumHex - &H1372) Mod 9) + 1) * 10) Case &H137B If nTempDigits = 0 Then nTempDigits = 1 nTempDigits = nTempDigits * 100 Case &H137C If nTempDigits = 0 Then nTempDigits = 1 nTempDigits = nTempDigits * 10000 End Select If i < UBound(arrChars) Then If Not (arrChars(i+1) Like "&[#]x136[9A-F];" Or arrChars(i+1) Like "&[#]x137[0-9A-C];") Then nTempNum = nTempNum + nTempDigits End If ElseIf i = UBound(arrChars) Then nTempNum = nTempNum + nTempDigits End If i = i + 1 If i>UBound(arrChars) Then Exit Do Loop NewField = NewField & Trim(Str$(nTempNum)) Case &H1200 To &H1369, &H137D To &H1399, &H2D80 To &H2DDF, &HAB00 To &HAB2F If i < UBound(arrChars) Then TempChar = TransEthiopic(arrChars(i), arrChars(i+1), i) Else TempChar = TransEthiopic(arrChars(i), "�", i) End If NewField = NewField & TempChar 'Correct e's that should be omitted for some common words Dim c c = Right(NewField, 12) If Right(NewField, 10) = "mas" & Chr(242) & "eh" & Chr(242) & "a" & Chr(229) & "f" Then 'mashaf NewField = Left(NewField, Len(NewField) - 10) & "mas" & Chr(242) & "h" & Chr(242) & "a" & Chr(229) & "f" ElseIf Right(Newfield, 9) = "ma" & Chr(229) & "h" & Chr(242) & "ebar" Then 'mahbar (h-dot below) NewField = Left(NewField, Len(NewField) - 9) & "ma" & Chr(229) & "h" & Chr(242) & "bar" ElseIf Right(Newfield, 9) = "ma" & Chr(229) & "h" & Chr(246) & "ebar" Then 'mahbar (h-underscore) NewField = Left(NewField, Len(NewField) - 9) & "ma" & Chr(229) & "h" & Chr(246) & "bar" ElseIf Right(NewField, 12) = Chr(174) & "iteyop" & Chr(242) & "eya" & Chr(229) Then 'Ityopya NewField = Left(NewField, Len(NewField) - 12) & Chr(174) & "Ityop" & Chr(242) & "ya" & Chr(229) ElseIf Left(NewField, 3) Like "26[04]" And Right(NewField, 10) = Chr(174) & "as" & Chr(226) & "emara" & Chr(229) Then 'Asmara (s-acute) NewField = Left(NewField, Len(NewField) - 10) & Chr(174) & "as" & Chr(226) & "mara" & Chr(229) ElseIf Left(NewField, 3) Like "26[04]" And Right(NewField, 8) = Chr(174) & "asemara" Then 'Asmara NewField = Left(NewField, Len(NewField) - 8) & Chr(174) & "asmara" End If Case Else NewField = NewField & Chr(252) 'non-Ethiopic Unicode character End Select Else NewField = NewField & arrChars(i) End If i = i + 1 Loop If Mid(NewField, 6, 1) Like "[A-Za-z]" Then Mid(NewField, 6, 1) = UCase(Mid(NewField, 6, 1)) Else i = 6 If Mid(NewField, i, 1) = Chr(223) Then i = 8 Do While ((Mid(NewField, i, 1) Like "[!a-z]") And i <= Len(NewField)) i = i + 1 Loop If i <= Len(NewField) Then If (Mid(NewField, i-1, 1) <> "#") And (Mid(NewField, i-1, 1) Like "[!A-Z]") And Not (Mid(NewField, i-2, 2) Like "[0-9]-") Then Mid(NewField, i, 1) = UCase(Mid(NewField, i, 1)) End If End If place3 = 5 Do While InStr(place3, NewField, Chr(223) ) 'ǂ") 'place3 = InStr(place3, NewField, "ǂ") + 9 place3 = InStr(place3, NewField, Chr(223) ) + 2 Do Until ((Mid(NewField, place3, 1) Like "[A-WY-Za-z]") Or place3 > Len(NewField)) place3 = place3 + 1 Loop If place3 <= Len(NewField) Then If (Mid(NewField, place3, 1) Like "[a-z]") Then If Mid(NewField, place3-1, 1) <> "#" Then Mid(NewField, place3, 1) = UCase(Mid(NewField, place3, 1)) End If End If place3 = place3 + 1 Loop If Left(NewField, 3) Like "26[04]" And Mid(NewField, 6, 12) = Chr(174) & "Adis " & Chr(174) & "ababa" Then Mid(NewField, 6, 12) = Chr(174) & "Adis " & Chr(174) & "Ababa" End If bool = CS.AddFieldLine(CS.CursorRow + 1, NewField) CS.CursorRow = CS.CursorRow -1 CS.SendKeys "%ekl", -1 End Sub '############################################################################## Function TransEthiopic(sChar As String, sNextChar As String, nPos As Variant) As String Dim sHex As String Dim nHex As Integer Dim TempTranslit As String Dim sNextHex As String Dim nNextHex As Long Dim IsConsonant As Integer Dim nColumn As Integer Dim nBaseChar As Integer IsConsonant = 0 sHex = Mid(sChar, 4, Len(sChar) - 2) nHex = Val("&H" & sHex) sNextHex = Mid(sNextChar, 4, Len(sNextChar) - 1) nNextHex = Val("&H" & sNextHex) Dim c Select Case nHex Case &H1200 To &H1247, &H1250 To &H1257, &H1260 To &H1287, &H1290 To &H12AF, &H12B8 To &H12BF, &H12C8 To &H130F, &H1318 To &H1357, &H2DA0 To &H2DDF, &HAB00 To &HAB17, &HAB20 To &HAB2E nColumn = (nHex - &H1200) Mod 8 nBaseChar = nHex - nColumn Select Case nBaseChar Case &H1200 TempTranslit = "h" Case &H1208 TempTranslit = "l" Case &H1210 TempTranslit = "h" & Chr(242) 'h-dot below Case &H1218 TempTranslit = "m" Case &H1220 TempTranslit = "s" & Chr(226) 's-acute Case &H1228 TempTranslit = "r" Case &H1230 TempTranslit = "s" Case &H1238 TempTranslit = "s" & Chr(233) 's-hacek Case &H1240 TempTranslit = "q" Case &H1250 TempTranslit = "q" & Chr(229) 'q-macron (Tigrinya) Case &H1260 TempTranslit = "b" Case &H1268 TempTranslit = "v" Case &H1270 TempTranslit = "t" Case &H1278 TempTranslit = "c" & Chr(233) 'c-hacek Case &H1280 TempTranslit = "h" & Chr(246) 'h-underscore Case &H1290 TempTranslit = "n" Case &H1298 TempTranslit = "n" & Chr(228) 'n-tilde Case &H12A0 TempTranslit = Chr(174) 'alif Case &H12A8 TempTranslit = "k" Case &H12B8 TempTranslit = "x" Case &H12C8 TempTranslit = "w" Case &H12D0 TempTranslit = Chr(176) 'ayn Case &H12D8 TempTranslit = "z" Case &H12E0 TempTranslit = "z" & Chr(233) 'z-hacek Case &H12E8 TempTranslit = "y" Case &H12F0 TempTranslit = "d" Case &H12F8 TempTranslit = "d" & Chr(245) 'Not on LC's table; approximation: d-double underscore Case &H1300 TempTranslit = "g" & Chr(233) 'g-hacek Case &H1308 TempTranslit = "g" Case &H1318 TempTranslit = "g" & Chr(245) 'Not on LC's table; approximation: g-double underscore Case &H1320 TempTranslit = "t" & Chr(242) 't-dot below Case &H1328 TempTranslit = "c" & Chr(231) 'c-superior dot Case &H1330 TempTranslit = "p" & Chr(242) 'p-dot below Case &H1338 TempTranslit = "s" & Chr(242) 's-dot below Case &H1340 TempTranslit = "s" & Chr(231) 's-superior dot Case &H1348 TempTranslit = "f" Case &H1350 TempTranslit = "p" Case &H2DA0 TempTranslit = "s" & Chr(245) 'Not on LC's table; approximation: s-double underscore Case &H2DA8 TempTranslit = "c" & Chr(245) 'Not on LC's table; approximation: c-double underscore Case &H2DB0 TempTranslit = "z" & Chr(245) 'Not on LC's table; approximation: z-double underscore Case &H2DB8 TempTranslit = "c" & Chr(245) 'Not on LC's table; approximation: c-double underscore Case &H2DC0 TempTranslit = "q" & Chr(245) 'Not on LC's table; approximation: q-double underscore Case &H2DC8 TempTranslit = "k" & Chr(245) 'Not on LC's table; approximation: k-double underscore Case &H2DD0 TempTranslit = "h" & Chr(245) 'Not on LC's table; approximation: h-double underscore Case &H2DD8 TempTranslit = "g" & Chr(245) 'Not on LC's table; approximation: g-double underscore Case &HAB00 TempTranslit = "t" & Chr(245) 'Not on LC's table; approximation: t-double underscore Case &HAB08 TempTranslit = "d" & Chr(245) 'Not on LC's table; approximation: d-double underscore Case &HAB10 TempTranslit = "j" & Chr(245) 'Not on LC's table; approximation: j-double underscore Case &HAB20 TempTranslit = "c" & Chr(245) 'Not on LC's table; approximation: c-double underscore Case &HAB28 TempTranslit = "b" & Chr(245) 'Not on LC's table; approximation: b-double underscore End Select Select Case nColumn Case 0 TempTranslit = TempTranslit & "a" Case 1 TempTranslit = TempTranslit & "u" Case 2 TempTranslit = TempTranslit & "i" Case 3 TempTranslit = TempTranslit & "a" & Chr(229) 'a-macron Case 4 TempTranslit = TempTranslit & "e" & Chr(226) 'a-acute Case 5 If IsEthiopicChar(sNextChar) And nNextHex <> &H1361 Then TempTranslit = TempTranslit & "e" '*** Only include the e in the middle of a word End If Case 6 TempTranslit = TempTranslit & "o" Case 7 Select Case nHex Case &H1247, &H1287, &H12AF, &H12BF, &H12CF, &H12D7 TempTranslit = TempTranslit & "oa" Case &H12A7 TempTranslit = "a" & Chr(230) 'a-breve Case Else TempTranslit = TempTranslit & "wa" End Select End Select Case &H1248 To &H124D nColumn = (nHex - &H1248) Mod 8 TempTranslit = "qw" Select Case nColumn Case 0 TempTranslit = TempTranslit & "a" Case 2 TempTranslit = TempTranslit & "i" Case 3 TempTranslit = TempTranslit & "a" & Chr(229) 'a-macron Case 4 TempTranslit = TempTranslit & "e" & Chr(226) 'e-acute Case 5 TempTranslit = TempTranslit & "e" Case Else TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart End Select Case &H1258 To &H125D nColumn = (nHex - &H1258) Mod 8 TempTranslit = "q" & Chr(229) & "w" 'q-macron (Tigrinya) Select Case nColumn Case 0 TempTranslit = TempTranslit & "a" Case 2 TempTranslit = TempTranslit & "i" Case 3 TempTranslit = TempTranslit & "a" & Chr(229) 'a-macron Case 4 TempTranslit = TempTranslit & "e" & Chr(226) 'e-acute Case 5 TempTranslit = TempTranslit & "e" Case Else TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart End Select Case &H1288 To &H128D nColumn = (nHex - &H1288) Mod 8 TempTranslit = "h" & Chr(246) &"w" 'h-underscore-w Select Case nColumn Case 0 TempTranslit = TempTranslit & "a" Case 2 TempTranslit = TempTranslit & "i" Case 3 TempTranslit = TempTranslit & "a" & Chr(229) 'a-macron Case 4 TempTranslit = TempTranslit & "e" & Chr(226) 'e-acute Case 5 TempTranslit = TempTranslit & "e" Case Else TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart End Select Case &H12B0 To &H12B5 nColumn = (nHex - &H12B0) Mod 8 TempTranslit = "kw" Select Case nColumn Case 0 TempTranslit = TempTranslit & "a" Case 2 TempTranslit = TempTranslit & "i" Case 3 TempTranslit = TempTranslit & "a" & Chr(229) 'a-macron Case 4 TempTranslit = TempTranslit & "e" & Chr(226) 'e-acute Case 5 TempTranslit = TempTranslit & "e" Case Else TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart End Select Case &H12C0 To &H12C5 nColumn = (nHex - &H12C0) Mod 8 TempTranslit = "xw" '(Tigrinya) Select Case nColumn Case 0 TempTranslit = TempTranslit & "a" Case 2 TempTranslit = TempTranslit & "i" Case 3 TempTranslit = TempTranslit & "a" & Chr(229) 'a-macron Case 4 TempTranslit = TempTranslit & "e" & Chr(226) 'e-acute Case 5 TempTranslit = TempTranslit & "e" Case Else TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart End Select Case &H1310 To &H1315 nColumn = (nHex - &H1310) Mod 8 TempTranslit = "gw" Select Case nColumn Case 0 TempTranslit = TempTranslit & "a" Case 2 TempTranslit = TempTranslit & "i" Case 3 TempTranslit = TempTranslit & "a" & Chr(229) 'a-macron Case 4 TempTranslit = TempTranslit & "e" & Chr(226) 'e-acute Case 5 TempTranslit = TempTranslit & "e" Case Else TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart End Select Case &H1380 To &H1383 nColumn = (nHex - &H1380) Mod 4 TempTranslit = "m" & Chr(245) & "w" 'Not on LC's table; approximation: m-double underscore-w Select Case nColumn Case 0 TempTranslit = TempTranslit & "a" Case 1 TempTranslit = TempTranslit & "i" Case 2 TempTranslit = TempTranslit & "e" & Chr(226) 'e-acute Case 3 TempTranslit = TempTranslit & "e" Case Else TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart End Select Case &H1384 To &H1387 nColumn = (nHex - &H1384) Mod 4 TempTranslit = "b" & Chr(245) & "w" 'Not on LC's table; approximation: b-double underscore-w Select Case nColumn Case 0 TempTranslit = TempTranslit & "a" Case 1 TempTranslit = TempTranslit & "i" Case 2 TempTranslit = TempTranslit & "e" & Chr(226) 'e-acute Case 3 TempTranslit = TempTranslit & "e" Case Else TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart End Select Case &H1388 To &H138B nColumn = (nHex - &H1388) Mod 4 TempTranslit = "f" & Chr(245) & "w" 'Not on LC's table; approximation: f-double underscore-w Select Case nColumn Case 0 TempTranslit = TempTranslit & "a" Case 1 TempTranslit = TempTranslit & "i" Case 2 TempTranslit = TempTranslit & "e" & Chr(226) 'e-acute Case 3 TempTranslit = TempTranslit & "e" Case Else TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart End Select Case &H138C To &H138F nColumn = (nHex - &H138C) Mod 4 TempTranslit = "p" & Chr(245) & "w" 'Not on LC's table; approximation: p-double underscore-w Select Case nColumn Case 0 TempTranslit = TempTranslit & "a" Case 1 TempTranslit = TempTranslit & "i" Case 2 TempTranslit = TempTranslit & "e" & Chr(226) 'e-acute Case 3 TempTranslit = TempTranslit & "e" Case Else TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart End Select Case &H1358 TempTranslit = "rya" Case &H1359 TempTranslit = "mya" Case &H135A TempTranslit = "fya" Case &H2D80 To &H2D92 TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart Case &H2D93 To &H2D96 TempTranslit = Chr(252) 'Character that isn't on LC's transliteration chart Case &H1361 TempTranslit = " " Case &H1362 TempTranslit = "." Case &H1363 TempTranslit = "," Case &H1364 TempTranslit = ";" Case &H1365, &H1366 TempTranslit = ":" Case &H1367 TempTranslit = "?" 'Case &H1369 To &H1371 ' nColumn = (nHex - &H1369) Mod 9 ' TempTranslit = Str$(nColumn + 1) 'Case &H1372 To &H137A ' nColumn = (nHex - &H1369) Mod 9 ' TempTranslit = Str$((nColumn + 1) * 10) 'Case &H137B ' TempTranslit = "100" 'Case &H137C ' TempTranslit = "10,000" Case &H135D To &H135F TempTranslit = "" 'untransliterated diacritics Case &H1360 TempTranslit = "[section]" 'section mark Case &H1368 TempTranslit = "" 'paragraph mark Case &H1390 To &H1399 TempTranslit = "" 'untransliterated tonal marks Case Else 'Unknown/non-Ethiopic character TempTranslit= Chr(252) End Select TransEthiopic = TempTranslit End Function '############################################################################## Function IsEthiopicChar(sNCR) As Integer Dim b b = Mid(sNCR, 1, 6) If Len(sNCR) >= 6 And (Mid(sNCR, 1, 6) Like "&[#]x1[23][0-9A-F]" Or Mid(sNCR, 1, 6) Like "&[#]x2D[89A-D]" Or Mid(sNCR, 1, 6) Like "&[#]xAB[0-2]") Then IsEthiopicChar = 1 Else IsEthiopicChar = 0 End If End Function