'MacroName:Latin2Ethiopic 'MacroDescription:Automatically untransliterate a field with Latin characters into Ethiopic (Amharic, Ge'ez, etc.) characters 'Macro created by: Joel Hahn, Niles Public Library District 'Macro last modified: 31 October 2013 Option Explicit Option Compare Binary Declare Function TransEthiopic(sField As String) As String Declare Function VowelColumn(sVowel As String, nTable As Integer) As Integer Declare Function IsVowel(sString As String) As Integer Global arrDigits(9) Global arrTens(9) Sub Main Dim sField As String Dim bool As Integer Dim sTranslit As String Dim i As Integer Dim CharacterSet As Integer Dim sLang As String Dim CS As Object On Error Resume Next Set CS = GetObject(,"Connex.Client") On Error GoTo 0 If CS Is Nothing Then Set CS = CreateObject("Connex.Client") End If ' Select Case CS.ItemType ' Case -1, 5 To 13, 15 To 16, 21 To 25 ' MsgBox "Not viewing a MARC record. Exiting..." ' Exit Sub ' End Select bool = CS.GetFieldLine(CS.CursorRow, sField) If InStr(sField, "Data contains non-latin script") Then 'bool = CS.GetFieldLineUnicode(CS.CursorRow, sField) MsgBox "The selected field already contains vernacular data. Exiting..." Exit Sub ElseIf sField = Chr(252) & Chr(252) & Chr(252) & " " Or Trim(Mid(sField, 6)) = "" Then MsgBox "The selected field contains no data. Exiting..." Exit Sub End If arrDigits(1) = "፩" arrDigits(2) = "፪" arrDigits(3) = "፫" arrDigits(4) = "፬" arrDigits(5) = "፭" arrDigits(6) = "፮" arrDigits(7) = "፯" arrDigits(8) = "፰" arrDigits(9) = "፱" arrTens(1) = "፲" arrTens(2) = "፳" arrTens(3) = "፴" arrTens(4) = "፵" arrTens(5) = "፶" arrTens(6) = "፷" arrTens(7) = "፸" arrTens(8) = "፹" arrTens(9) = "፺" For i = 1 to 5 If Asc(Mid(sField, i, 1)) = 252 Then sTranslit = sTranslit & "∎" Else sTranslit = sTranslit & Mid(sField, i, 1) End If Next sTranslit = sTranslit & TransEthiopic(sField) bool = CS.AddFieldLine(CS.CursorRow, sTranslit) CS.SendKeys "%ekl", -1 End Sub '################################################################################ Function TransEthiopic(sField As String) As String Dim i As Long Dim j As Integer Dim sNewField As String sNewField = "" Dim nBaseChar As Long Dim nVowel As Integer Dim nLenVowel As Integer Dim nTable As Integer Dim nOffset As Integer Dim sDigits As String Dim nDigits As Long Dim place Dim sTempNum As String i = 6 Do nBaseChar = 0 nTable = 0 nOffset = 0 nLenVowel = 0 nVowel = 0 If Mid(sField, i, 1) = Chr(223) Then sNewField = sNewField & "ǂ" & Mid(sField, i+1, 1) i = i + 2 Else If InStr(" !@#$%^&*()[]{}'/\=+-" & Chr(34), Mid(sField, i, 1)) Then sNewField = sNewField & Mid(sField, i, 1) ElseIf Mid(sField, i, 1) = "?" Then sNewField = sNewField & "፧" ElseIf Mid(sField, i, 1) = ":" Then If Mid(sField, i+1, 1) = Chr(223) Or Mid(sField, i+1, 2) = " " & Chr(223) Or i = Len(sField) Then sNewField = sNewField & Mid(sField, i, 1) Else sNewField = sNewField & "፥" End If ElseIf Mid(sField, i, 1) = ";" Then If Mid(sField, i+1, 1) = Chr(223) Or Mid(sField, i+1, 2) = " " & Chr(223) Or i = Len(sField) Then sNewField = sNewField & Mid(sField, i, 1) Else sNewField = sNewField & "፤" End If ElseIf Mid(sField, i, 1) = "," Then If Mid(sField, i+1, 1) = Chr(223) Or Mid(sField, i+1, 2) = " " & Chr(223) Or i = Len(sField) Then sNewField = sNewField & Mid(sField, i, 1) Else sNewField = sNewField & "፣" End If ElseIf Mid(sField, i, 1) = "." Then If Mid(sField, i+1, 1) = Chr(223) Or Mid(sField, i+1, 2) = " " & Chr(223) Or i = Len(sField) Then sNewField = sNewField & Mid(sField, i, 1) Else sNewField = sNewField & "።" End If ElseIf InStr("0123456789", Mid(sField, i, 1)) Then If Left(sField, 3) Like "26[04]" Then sNewField = sNewField & Mid(sField, i, 1) Else place = i + 1 Do While Mid(sField, place, 1) Like "[0-9,]" place = place + 1 Loop sDigits = Mid(sField, i, place - i) Do While InStr(sDigits, ",") > 0 place = InStr(sDigits, ",") sDigits = Left(sDigits, place - 1) & Mid(sDigits, place + 1) i = i + 1 Loop 'nDigits = CLng(sDigits) sTempNum = "" j = Len(sDigits) Dim msg Dim Has1s Dim nDecimalPlace as Integer Dim nNumThousands As Integer Dim sTempDigit As String Dim k Do sTempDigit = "" nDecimalPlace = (Len(sDigits) - j) + 1 if (Len(sDigits) - j + 1) Mod 2 = 1 Then msg = (Len(sDigits) - j) Mod 4 & ":" & (Len(sDigits) - j) \ 4 else msg = (Len(sDigits) - j - 1) Mod 4 & ":" & (Len(sDigits) - j - 1) \ 4 End If If Len(sDigits) = 1 And sDigits = "0" Then sTempNum = sDigits Else If nDecimalPlace Mod 2 = 1 Then If Mid(sDigits, j, 1) <> "0" Then Has1s = "Y" If nDecimalPlace = 1 Or Mid(sDigits, j, 1) <> "1" Or nDecimalPlace < Len(sDigits) Then If nDecimalPlace < Len(sDigits) Then If Mid(sDigits, j-1, 1) <> "0" Then sTempDigit = arrDigits(Val(Mid(sDigits, j, 1))) End If Else sTempDigit = arrDigits(Val(Mid(sDigits, j, 1))) End If End If If (nDecimalPlace - 1) Mod 4 = 2 Then sTempDigit = sTempDigit & "፻" '100s character End If nNumThousands = (nDecimalPlace - 1) \ 4 If nNumThousands > 0 Then For k = 1 to nNumThousands sTempDigit = sTempDigit & "፼" '10,000s character Next End If Else Has1s = "N" End If Else If Mid(sDigits, j, 1) <> "0" Then sTempDigit = arrTens(Val(Mid(sDigits, j, 1))) If Has1s = "N" Then If (nDecimalPlace - 2) Mod 4 = 2 Then sTempDigit = sTempDigit & "፻" '100s character End If nNumThousands = (nDecimalPlace - 2) \ 4 If nNumThousands > 0 Then For k = 1 to nNumThousands sTempDigit = sTempDigit & "፼" '10,000s character Next End If End If End If Has1s = "N" End If If sTempDigit <> "" Then sTempNum = sTempDigit & sTempNum End If End If j = j - 1 Loop While j > 0 i = i + Len(sDigits) sNewField = sNewField & sTempNum End If ElseIf UCase(Mid(sField, i, 1)) = "H" Then If LCase(Mid(sField, i+1, 2)) = Chr(246) & "w" Then 'h-underscore-w nBaseChar = &H1288 nOffset = 2 nTable = 1 ElseIf Mid(sField, i+1, 1) = Chr(246) Then 'h-underscore nBaseChar = &H1280 nOffset = 2 nTable = 0 ElseIf Mid(sField, i+1, 1) = Chr(242) Then 'h-dot below nBaseChar = &H1210 nOffset = 2 nTable = 0 Else nBaseChar = &H1200 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "L" Then nBaseChar = &H1208 nOffset = 1 nTable = 0 ElseIf UCase(Mid(sField, i, 1)) = "M" Then If LCase(Mid(sField, i+1, 1)) = "y" Then sNewField = sNewField & "ፙ" i = i + 2 Else nBaseChar = &H1218 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "S" Then If Mid(sField, i+1, 1) = Chr(226) Then 's-acute nBaseChar = &H1220 nOffset = 2 nTable = 0 ElseIf Mid(sField, i+1, 1) = Chr(231) Then 's-dot above nBaseChar = &H1340 nOffset = 2 nTable = 0 ElseIf Mid(sField, i+1, 1) = Chr(233) Then 's-hacek nBaseChar = &H1238 nOffset = 2 nTable = 0 ElseIf Mid(sField, i+1, 1) = Chr(242) Then 's-dot below nBaseChar = &H1338 nOffset = 2 nTable = 0 Else nBaseChar = &H1230 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "R" Then If LCase(Mid(sField, i+1, 1)) = "y" Then sNewField = sNewField & "ፘ" i = i + 2 Else nBaseChar = &H1228 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "Q" Then If LCase(Mid(sField, i+1, 2)) = Chr(229) & "w" Then 'q-macron-w nBaseChar = &H1258 nOffset = 2 nTable = 1 ElseIf Mid(sField, i+1, 1) = Chr(229) Then 'q-macron nBaseChar = &H1250 nOffset = 2 nTable = 0 ElseIf LCase(Mid(sField, i+1, 1)) = "w" Then 'qw nBaseChar = &H1248 nOffset = 1 nTable = 1 Else nBaseChar = &H1240 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "B" Then nBaseChar = &H1260 nOffset = 1 nTable = 0 ElseIf UCase(Mid(sField, i, 1)) = "V" Then nBaseChar = &H1268 nOffset = 1 nTable = 0 ElseIf UCase(Mid(sField, i, 1)) = "T" Then If Mid(sField, i+1, 1) = Chr(242) Then 't-dot below nBaseChar = &H1320 nOffset = 2 nTable = 0 Else nBaseChar = &H1270 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "C" Then If Mid(sField, i+1, 1) = Chr(231) Then 'c-dot above nBaseChar = &H1328 nOffset = 2 nTable = 0 ElseIf Mid(sField, i+1, 1) = Chr(233) Then 'c-hacek nBaseChar = &H1278 nOffset = 2 nTable = 0 Else sNewField = sNewField & "∎" End If ElseIf UCase(Mid(sField, i, 1)) = "N" Then If Mid(sField, i+1, 1) = Chr(228) Then 'n-tilde nBaseChar = &H1298 nOffset = 2 nTable = 0 Else nBaseChar = &H1290 nOffset = 1 nTable = 0 End If ElseIf Mid(sField, i, 1) = Chr(174) Then 'alif nBaseChar = &H12A0 nOffset = 1 nTable = 0 ElseIf UCase(Mid(sField, i, 1)) = "K" Then If LCase(Mid(sField, i+1, 1)) = "w" Then nBaseChar = &H12B0 nOffset = 1 nTable = 1 Else nBaseChar = &H12A8 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "X" Then If LCase(Mid(sField, i+1, 1)) = "w" Then nBaseChar = &H12C0 nOffset = 1 nTable = 1 Else nBaseChar = &H12B8 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "W" Then nBaseChar = &H12C8 nOffset = 1 nTable = 0 ElseIf Mid(sField, i, 1) = Chr(176) Then 'ayn nBaseChar = &H12D0 nOffset = 1 nTable = 0 ElseIf UCase(Mid(sField, i, 1)) = "Z" Then If Mid(sField, i+1, 1) = Chr(233) Then 'z-hacek nBaseChar = &H12E0 nOffset = 2 nTable = 0 Else nBaseChar = &H12D8 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "Y" Then nBaseChar = &H12E8 nOffset = 1 nTable = 0 ElseIf UCase(Mid(sField, i, 1)) = "D" Then nBaseChar = &H12F0 nOffset = 1 nTable = 0 ElseIf UCase(Mid(sField, i, 1)) = "G" Then If Mid(sField, i+1, 1) = Chr(233) Then 'g-hacek nBaseChar = &H1300 nOffset = 2 nTable = 0 ElseIf LCase(Mid(sField, i+1, 1)) = "w" Then nBaseChar = &H1310 nOffset = 1 nTable = 1 Else nBaseChar = &H1308 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "P" Then If Mid(sField, i+1, 1) = Chr(242) Then 'p-dot below nBaseChar = &H1330 nOffset = 2 nTable = 0 Else nBaseChar = &H1350 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "F" Then If LCase(Mid(sField, i+1, 1)) = "y" Then sNewField = sNewField & "ፚ" i = i + 2 Else nBaseChar = &H1348 nOffset = 1 nTable = 0 End If ElseIf UCase(Mid(sField, i, 1)) = "A" Then If Mid(sField, i+1, 1) = Chr(230) Then sNewField = sNewField & "ኧ" i = i + 1 End If Else sNewField = sNewField & "∎" End If If nBaseChar > 0 Then nLenVowel = IsVowel(Mid(sField, i + nOffset, 4)) If nLenVowel > 0 Then nVowel = VowelColumn(Mid(sField, i + nOffset, nLenVowel), nTable) If nVowel = -1 Then sNewField = sNewField & "∎" Else sNewField = sNewField & "&#x" & Hex(nBaseChar + nVowel) & ";" End If Else If nTable = 0 Then sNewField = sNewField & "&#x" & Hex(nBaseChar + 5) & ";" Else sNewField = sNewField & "∎" End If End If i = i + (nOffset - 1) + nLenVowel Else nLenVowel = IsVowel(Mid(sField, i + 1, 4)) If nLenVowel > 0 Then i = i + nLenVowel - 1 End If End If i = i + 1 End If Loop While i <= Len(sField) TransEthiopic = sNewField End Function '################################################################################ Function VowelColumn(sVowel As String, nTable As Integer) As Integer If nTable = 1 Then If LCase(Left(sVowel, 3)) = "wa" & Chr(229) Then 'wa-macron VowelColumn = 3 ElseIf LCase(Left(sVowel, 3)) = "we" & Chr(226) Then 'we-acute VowelColumn = 4 ElseIf LCase(Left(sVowel, 2)) = "wa" Then VowelColumn = 0 ElseIf LCase(Left(sVowel, 2)) = "wi" Then VowelColumn = 2 ElseIf LCase(Left(sVowel, 2)) = "we" Then VowelColumn = 5 Else VowelColumn = -1 End If 'Select Case sVowel ' Case "wa" ' VowelColumn = 0 ' Case "wi" ' VowelColumn = 2 ' Case "wa" & Chr(229) 'wa-macron ' VowelColumn = 3 ' Case "we" & Chr(226) 'we-acute ' VowelColumn = 4 ' Case "we" ' VowelColumn = 5 ' Case Else ' VowelColumn = -1 'End Select ElseIf nTable = 2 Then If LCase(Left(sVowel, 3)) = "we" & Chr(226) Then 'we-acute VowelColumn = 2 ElseIf LCase(Left(sVowel, 2)) = "wa" Then VowelColumn = 0 ElseIf LCase(Left(sVowel, 2)) = "wi" Then VowelColumn = 1 ElseIf LCase(Left(sVowel, 2)) = "we" Then VowelColumn = 3 Else VowelColumn = -1 End If 'Select Case sVowel ' Case "wa" ' VowelColumn = 0 ' Case "wi" ' VowelColumn = 1 ' Case "we" & Chr(226) 'we-acute ' VowelColumn = 2 ' Case "we" ' VowelColumn = 3 ' Case Else ' VowelColumn = -1 'End Select Else If LCase(Left(sVowel, 2)) = "a" & Chr(229) Then 'a-macron VowelColumn = 3 ElseIf LCase(Left(sVowel, 2)) = "a" & Chr(230) Then 'a-breve VowelColumn = 7 ElseIf LCase(Left(sVowel, 2)) = "e" & Chr(226) Then 'e-acute VowelColumn = 4 ElseIf LCase(Left(sVowel, 2)) = "oa" Then VowelColumn = 7 ElseIf LCase(Left(sVowel, 2)) = "wa" Then VowelColumn = 7 ElseIf LCase(Left(sVowel, 1)) = "a" Then VowelColumn = 0 ElseIf LCase(Left(sVowel, 1)) = "u" Then VowelColumn = 1 ElseIf LCase(Left(sVowel, 1)) = "i" Then VowelColumn = 2 ElseIf LCase(Left(sVowel, 1)) = "e" Then VowelColumn = 5 ElseIf LCase(Left(sVowel, 1)) = "o" Then VowelColumn = 6 Else VowelColumn = -1 End If 'Select Case sVowel ' Case "a" ' VowelColumn = 0 ' Case "u" ' VowelColumn = 1 ' Case "i" ' VowelColumn = 2 ' Case "a" & Chr(229) 'a-macron ' VowelColumn = 3 ' Case "e" & Chr(226) 'e-acute ' VowelColumn = 4 ' Case "e" ' VowelColumn = 5 ' Case "o" ' VowelColumn = 6 ' Case "oa" ' VowelColumn = 7 ' Case "wa" ' VowelColumn = 7 ' Case Else ' VowelColumn = -1 'End Select End If End Function '################################################################################ Function IsVowel(sString As String) As Integer If LCase(Left(sString, 3)) = "wa" & Chr(229) Then 'wa-macron IsVowel = 3 ElseIf LCase(Left(sString, 3)) = "we" & Chr(226) Then 'we-acute IsVowel = 3 ElseIf LCase(Left(sString, 2)) = "a" & Chr(229) Then 'a-macron IsVowel = 2 ElseIf LCase(Left(sString, 2)) = "a" & Chr(230) Then 'a-breve IsVowel = 2 ElseIf LCase(Left(sString, 2)) = "e" & Chr(226) Then 'e-acute IsVowel = 2 ElseIf LCase(Left(sString, 2)) = "oa" Then IsVowel = 2 ElseIf LCase(Left(sString, 2)) = "wa" Then IsVowel = 2 ElseIf LCase(Left(sString, 2)) = "wi" Then IsVowel = 2 ElseIf LCase(Left(sString, 2)) = "we" Then IsVowel = 2 ElseIf LCase(Left(sString, 1)) = "a" Then IsVowel = 1 ElseIf LCase(Left(sString, 1)) = "u" Then IsVowel = 1 ElseIf LCase(Left(sString, 1)) = "i" Then IsVowel = 1 ElseIf LCase(Left(sString, 1)) = "e" Then IsVowel = 1 ElseIf LCase(Left(sString, 1)) = "o" Then IsVowel = 1 Else IsVowel = 0 End If End Function