'MacroName:Hebrew2Latin 'MacroDescription:Automatically transliterate a field with Hebrew characters into Latin characters 'Macro created by: Joel Hahn, Niles Public Library District 'Last modified: 12 September 2021 Declare Function TransHebrew(sChar As String, sNextChar As String, nPos As Variant) As String Declare Function IsHebrewChar(sNCR) As Integer Global arrChars() As Variant Option Explicit Sub Main Dim bool as Integer Dim sField As String Dim CharacterSet As Integer Dim nHasHebrew as integer Dim sLang As String Dim NewField As String Dim i, j, a Dim response As Integer Dim sHex As String Dim nHex As Long Dim TempChar As String Dim place3 as Integer Dim place As Integer Dim sBCR As String 'Set the default transliteration table selection CharacterSet = 0 'Hebrew ' 0 = Hebrew ' 1 = Yiddish Dim CS As Object Set CS = CreateObject("Connex.Client") ReDim arrChars(0) Select Case CS.ItemType Case -1, 5 To 13, 15 To 16, 21 To 25 MsgBox "Not viewing a MARC record. Exiting..." & CStr(CS.ItemType) Exit Sub End Select Dim CharSets(2) As String CharSets(0) = "Hebrew" CharSets(1) = "Yiddish" bool = CS.GetFixedField("Lang", sLang) Select Case sLang Case "heb" CharacterSet = 0 Case "yid" CharacterSet = 1 Case Else Begin Dialog newdlg 183, 50, "Transliteration Options" OkButton 35, 27, 50, 14 CancelButton 95, 27, 50, 14 Text 3, 3, 177, 10, "Please select the LC Hebrew transliteration table to use:" DropListBox 42, 11, 98, 42, CharSets(), .Langs End Dialog Dim CharSelect As newdlg CharSelect.Langs = CharacterSet response = Dialog(CharSelect) If response = 0 Then Exit Sub End If CharacterSet = CharSelect.Langs End Select bool = CS.GetFieldLineUnicode(CS.CursorRow, sField) NewField = Left(sField, 5) sField = Mid(sField, 6) i = 1 : nHasHebrew = 0 Do While i <= Len(sField) - 7 a = Mid(sField, i, 8) If IsHebrewChar(Mid(sField, i, 6)) Then nHasHebrew = 1 Exit Do End If i = i + 1 Loop If nHasHebrew = 0 Then MsgBox "Field contains no Hebrew characters. Exiting..." Exit Sub End If 'Break up vernacular field into 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 'Delimiter NewField = NewField & Chr(223) Case &H0590 To &H05FF, &HFB1E 'Hebrew character If i < UBound(arrChars) Then TempChar = TransHebrew(arrChars(i), arrChars(i+1), i) If CharacterSet = 0 And arrChars(i) = "א" Then If Right(NewField, 1) = " " Or Len(NewField) = 5 Then If arrChars(i+1) = "ֵ" Or arrChars(i+1) = "ֶ" Or arrChars(i+1) = "ֱ"Then TempChar = "e" i = i + 1 ElseIf arrChars(i+1) = "ִ" And arrChars(i+2) = "י" Then TempChar = "i" i = i + 2 ElseIf arrChars(i+1) = "ִ" Then TempChar = "i" i = i + 1 ElseIf arrChars(i+1) = "ֹ" Or arrChars(i+1) = "ֳ" Then TempChar = "o" i = i + 1 ElseIf arrChars(i+1) = "ֻ" Then TempChar = "u" i = i + 1 Else TempChar = "a" End If End If ElseIf CharacterSet = 1 And arrChars(i) = "א" Then If arrChars(i+1) = "ו" Then TempChar = "u" i = i + 1 ElseIf arrChars(i+1) = "ױ" Then TempChar = "oy" i = i + 1 ElseIf arrChars(i+1) = "י" Then TempChar = "i" i = i + 1 ElseIf arrChars(i+1) = "ײ" And arrChars(i+2) = "ַ" Then TempChar = "ay" i = i + 2 ElseIf arrChars(i+1) = "ײ" Then TempChar = "ey" i = i + 1 ElseIf arrChars(i+1) = "ָ" Then TempChar = "o" i = i + 1 Else TempChar = "a" End If ElseIf CharacterSet = 1 And arrChars(i) = "ע" Then TempChar = "e" ElseIf CharacterSet = 1 And arrChars(i) = "ב" Then TempChar = "b" ElseIf CharacterSet = 1 And arrChars(i) = "ו" Then If arrChars(i+1) = "ּ" Then TempChar = Chr(252) i = i + 1 Else TempChar = "u" End If ElseIf CharacterSet = 0 And arrChars(i) = "ב" And arrChars(i+1) = "ּ" Then TempChar = "b" ElseIf CharacterSet = 0 And arrChars(i) = "ו" Then If arrChars(i+1) = "ֹ" Then TempChar = "o" i = i + 1 ElseIf arrChars(i+1) = "ּ" Then TempChar = "u" i = i + 1 End If ElseIf CharacterSet = 1 And arrChars(i) = "י" And arrChars(i+1) = "ִ" Then i = i + 1 ElseIf CharacterSet = 1 And arrChars(i) = "ת" Then If arrChars(i+1) = "ּ" Then i = i + 1 Else TempChar = "s" & Chr(225) End If ElseIf CharacterSet = 0 And arrChars(i) = "ת" And arrChars(i+1) = "ּ" Then i = i + 1 ElseIf arrChars(i) = "ך" Or arrChars(i) = "כ" Then If arrChars(i+1) = "ּ" Then TempChar = "k" i = i + 1 End If ElseIf arrChars(i) = "ף" Or arrChars(i) = "פ" Then If arrChars(i+1) = "ּ" Then TempChar = "p" i = i + 1 End If ElseIf arrChars(i) = "ש" Then If arrChars(i+1) = "ֹ" Then TempChar = "s" & Chr(226) i = i + 1 ElseIf arrChars(i+1) = "ׁ" Then TempChar = "sh" i = i + 1 End If ElseIf CharacterSet = 0 And (arrChars(i) = "ִ" Or arrChars(i) = "ֵ" Or arrChars(i) = "ֶ") Then If arrChars(i+1) = "י" Then i = i + 1 End If ElseIf CharacterSet = 0 And arrChars(i) = "ַ" Then If arrChars(i+1) = "י" Then TempChar = "ai" i = i + 1 End If ElseIf CharacterSet = 0 And arrChars(i) = "ײ" Then If arrChars(i+1) = "ַ" Or arrChars(i+1) = "̲" Then TempChar = "ay" i = i + 1 End If End If Else TempChar = TransHebrew(arrChars(i), "&H0000;", i) End If NewField = NewField + TempChar Case Else 'Non-Hebrew Unicode character NewField = NewField & Chr(252) End Select Else If arrChars(i) = Chr(171) or arrChars(i) = Chr(187) Then 'Convert angle-quotation marks; assume plus/minus sign is actually an angle-quotation mark, due to using the same ASCII code point NewField = NewField & Chr(34) Else NewField = NewField & arrChars(i) End If End If i = i + 1 Loop If Mid(NewField, 6, 1) Like "[a-z]" Then Mid(NewField, 6, 1) = UCase(Mid(NewField, 6, 1)) Else If Mid(NewField, 7, 1) Like "[a-z]" Then Mid(NewField, 7, 1) = UCase(Mid(NewField, 7, 1)) End If End If bool = CS.AddFieldLine(CS.CursorRow + 1, NewField) CS.CursorRow = CS.CursorRow -1 CS.SendKeys "%ekl", -1 End Sub '############################################################################## Function IsHebrewChar(sNCR) As Integer Dim b b = Mid(sNCR, 1, 6) If Len(sNCR) = 6 And (Mid(sNCR, 1, 6) Like "&[#]x05[9A-F]") Then IsHebrewChar = 1 Else IsHebrewChar = 0 End If End Function Function TransHebrew(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 sHex = Mid(sChar, 4, Len(sChar) - 2) nHex = Val("&H" & sHex) sNextHex = Mid(sNextChar, 4, Len(sNextChar) - 1) nNextHex = Val("&H" & sNextHex) Select Case nHex Case &H05D0 TransHebrew = Chr(174) Case &H05D1 TransHebrew = "v" Case &H05D2 TransHebrew = "g" Case &H05D3 TransHebrew = "d" Case &H05D4 TransHebrew = "h" Case &H05D5 TransHebrew = "v" & Chr(242) Case &H05D6 TransHebrew = "z" Case &H05D7 TransHebrew = "h" & Chr(242) Case &H05D8 TransHebrew = "t" & Chr(242) Case &H05D9 TransHebrew = "y" Case &H05DA, &H05DB TransHebrew = "kh" Case &H05DC TransHebrew = "l" Case &H05DD, &H05DE TransHebrew = "m" Case &H05DF, &H05E0 TransHebrew = "n" Case &H05E1 TransHebrew = "s" Case &H05E2 TransHebrew = Chr(176) Case &H05E3, &H05E4 TransHebrew = "f" Case &H05E5, &H05E6 TransHebrew = "ts" Case &H05E7 TransHebrew = "k" & Chr(242) Case &H05E8 TransHebrew = "r" Case &H05E9 TransHebrew = "sh" Case &H05EA TransHebrew = "t" Case &H05F0 TransHebrew = "v" & Chr(242) Case &H05F1 TransHebrew = "oy" Case &H05F2 TransHebrew = "ey" Case &H05B0 TransHebrew = "e" Case &H05B1 TransHebrew = "e" Case &H05B2 TransHebrew = "a" Case &H05B3 TransHebrew = "o" Case &H05B4 TransHebrew = "i" Case &H05B5 TransHebrew = "e" Case &H05B6 TransHebrew = "e" Case &H05B7 TransHebrew = "a" Case &H05B8 TransHebrew = "a" 'a or o Case &H05B9 TransHebrew = "o" '(point Holam / Sin Dot) - see Shin (5E9) on exceptions table Case &H05BB TransHebrew = "u" 'Case &H05BC ' TransHebrew = "" '(point Dagesh & Mapiq) - see exceptions table Case &H05BF TransHebrew = "" '(point Rafe) 'Case &H05C1 ' TransHebrew = "" '(Right Shin Dot) - see Shin (5E9) on exceptions table Case &HFB1E TransHebrew = "" '(Judeo-Spanish Varika) Case &H05BE TransHebrew = "-" Case &H05F3 TransHebrew = "'" Case &H05F4 TransHebrew = Chr(34) Case Else TransHebrew = Chr(252) End Select End Function '################################################################################