'MacroName:Latin2Hebrew
'MacroDescription:Automatically untransliterate a field with Latin characters into Hebrew characters
'Macro created by: Joel Hahn, Niles Public Library District
'Macro last modified: 1 September 2021

Option Explicit
Option Compare Binary

Declare Function TransHebrew(sField As String, nWhichTable As Integer) As String
Declare Function TransHebrewNoVowels(sField As String, nWhichTable As Integer) As String

Sub Main
   Dim sField As String
   Dim bool As Integer
   Dim response As Integer
   Dim sTranslit As String
   Dim i As Integer
   Dim CharacterSet As Integer
   Dim IncludeVowels As Integer
   Dim sLang As String

'Set the default transliteration table selection
CharacterSet = 0 'Hebrew
' 0 = Hebrew
' 1 = Yiddish

'Set whether to include vowel points
IncludeVowels = 0
' 0 = Omit vowel points
' 1 = Include vowel points

   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

   Dim CharSets(2) As String
   CharSets(0) = "Hebrew"
   CharSets(1) = "Yiddish"

   Begin Dialog newdlg 181, 55, "Transliteration Options"
      OkButton  35, 40, 50, 14
      CancelButton  95, 40, 50, 14
      Text  3, 3, 177, 10, "Please select the LC Hebrew transliteration table to use:"
      DropListBox  42, 11, 98, 42, CharSets(), .Langs
      CheckBox  49, 26, 80, 10, "Include vowel points", .VowelPoints
   End Dialog

   Dim CharSelect As newdlg
   CharSelect.Langs = CharacterSet
   CharSelect.VowelPoints = IncludeVowels
   response = Dialog(CharSelect)
   If response = 0 Then
     Exit Sub
   End If
   CharacterSet = CharSelect.Langs
   IncludeVowels = CharSelect.VowelPoints

   bool = CS.GetFieldLine(CS.CursorRow, sField)
   If InStr(sField, "Data contains non-latin script") Then
     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

   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

   Select Case CharacterSet
      Case 0
         If IncludeVowels = 1 Then
           sTranslit = sTranslit &  TransHebrew(sField, CharacterSet)
         Else
           sTranslit = sTranslit &  TransHebrewNoVowels(sField, CharacterSet)
         End If
      Case 1
         sTranslit = sTranslit &  TransHebrew(sField, CharacterSet)
      Case Else
         Exit Sub
      End Select

   bool = CS.AddFieldLine(CS.CursorRow, sTranslit)

   CS.SendKeys "%ekl", -1

End Sub

'################################################################################

Function TransHebrew(sField As String, nWhichTable As Integer) As String
  Dim i As Long
  Dim j As Long
  Dim k As Integer
  Dim place As Integer
  Dim sDigits As String
  Dim nDigitsAdded
  Dim nTransDigit, nTransDigits
  Dim sNewField As String
  Dim sTempTranslit As String
  sNewField = ""
  sTempTranslit = ""

  i = 6
  Do
    If Mid(sField, i, 1) = Chr(223) Then
      sNewField = sNewField & "ǂ" & Mid(sField, i+1, 1)
      i = i + 2

    Else
       If InStr(" !@#$%^&*()[]{};:.,/?\=+", Mid(sField, i, 1)) Then
          sNewField = sNewField & Mid(sField, i, 1)
        ElseIf InStr("0123456789", Mid(sField, i, 1)) Then
          sNewField = sNewField & Mid(sField, i, 1)

       ElseIf Mid(sField, i, 1) = "-" Then
         If LCase(Mid(sField, i-1, 1)) Like "[a-z]" Or LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
           'sNewField = sNewField & "־"
         Else
           sNewField = sNewField & Mid(sField, i, 1)
         End If
       ElseIf Mid(sField, i, 1) = "'" Then
         sNewField = sNewField & "׳"
       ElseIf Mid(sField, i, 1) = Chr(34) Then
         sNewField = sNewField & "״"
       ElseIf Mid(sField, i, 1) = Chr(167) Then
         'Don't transliterate; just used as a break between consonants that might be digraphs but aren't in this case

       ElseIf Mid(sField, i, 1) = Chr(174) Then
         sNewField = sNewField & "א"
       ElseIf LCase(Mid(sField, i, 1)) = "a" Then
         If LCase(Mid(sField, i+1, 1)) = "i" and nWhichTable = 0 Then
           sNewField = sNewField & "ַי"
           i = i + 1
         ElseIf LCase(Mid(sField, i+1, 1)) = "y" And nWhichTable = 1 Then
           sNewField = sNewField & "ײַ"
           i = i + 1
         Else
           If nWhichTable = 1 Then
             sNewField = sNewField & "א"
           ElseIf i = 6 or Mid(sField, i-1, 1) = " " Then
             sNewField = sNewField & "אַ"
           Else
             sNewField = sNewField & "ַ"   '(or ֲ or ָ)
           End If
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "b" Then
         If nWhichTable = 1 Then
           sNewField = sNewField & "ב"
         Else
           sNewField = sNewField & "בּ"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "v" Then
         If Mid(sField, i+1, 1) = Chr(242) Then
           If i = 6 or Mid(sField, i-1, 1) = " " Then
             sNewField = sNewField & "װ"
           Else
             sNewField = sNewField & "ו"
           End If
           i = i + 1
         Else
           sNewField = sNewField & "ב"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "g" Then
         sNewField = sNewField & "ג"
       ElseIf LCase(Mid(sField, i, 1)) = "d" Then
         sNewField = sNewField & "ד"
       ElseIf LCase(Mid(sField, i, 1)) = "z" Then
         sNewField = sNewField & "ז"
       ElseIf LCase(Mid(sField, i, 1)) = "h" Then
         If Mid(sField, i+1, 1) = Chr(242) Then
           sNewField = sNewField & "ח"
           i = i + 1
         Else
           sNewField = sNewField & "ה"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "t" Then
         If Mid(sField, i+1, 1) = Chr(242) Then
           sNewField = sNewField & "]"
           i = i + 1
         ElseIf LCase(Mid(sField, i+1, 1)) = "s" Then
           If LCase(Mid(sField, i+2, 1)) Like "[a-z]" Then
             sNewField = sNewField & "צ"
             i = i + 1
           Else
             sNewField = sNewField & "ץ"
             i = i + 1
           End If
         Else
           If nWhichTable = 1 Then
             sNewField = sNewField & "תּ"
           Else
             sNewField = sNewField & "ת"
           End If
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "y" Then
         sNewField = sNewField & "י"
       ElseIf LCase(Mid(sField, i, 1)) = "k" Then
         If LCase(Mid(sField, i+1, 1)) = "h" Then
           If LCase(Mid(sField, i+2, 1)) Like "[a-z]" Then
             sNewField = sNewField & "כ"
             i = i + 1
           Else
             sNewField = sNewField & "ך"
             i = i + 1
           End If
         Else
           If Mid(sField, i+1, 1) = Chr(242) Then
             sNewField = sNewField & "ק"
             i = i + 1
           Else
             If LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
               sNewField = sNewField & "כ"
             Else
               sNewField = sNewField & "ך"
             End If
             sNewField = sNewField & "ּ"
           End If
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "l" Then
         sNewField = sNewField & "ל"
       ElseIf LCase(Mid(sField, i, 1)) = "m" Then
         If LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
           sNewField = sNewField & "מ"
         Else
           sNewField = sNewField & "ם"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "n" Then
         If LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
           sNewField = sNewField & "נ"
         Else
           sNewField = sNewField & "ן"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "s" Then
         If Mid(sField, i+1, 1) = Chr(226) Then
           sNewField = sNewField & "שֹ"
           i = i + 1
         ElseIf nWhichTable = 1 And Mid(sField, i+1, 1) = Chr(225) Then
           sNewField = sNewField & "ת"
           i = i + 1
         ElseIf nWhichTable = 0 And Mid(sField, i+1, 1) = Chr(225) Then
           sNewField = sNewField & "ס"
           i = i + 1
         ElseIf LCase(Mid(sField, i+1, 1)) = "h" Then
           sNewField = sNewField & "שׁ"
           i = i + 1
         Else
           sNewField = sNewField & "ס"
         End If
       ElseIf Mid(sField, i, 1) = Chr(176) Then
         sNewField = sNewField & "ע"
       ElseIf LCase(Mid(sField, i, 1)) = "f" Then
         If LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
           sNewField = sNewField & "פ"
         Else
           sNewField = sNewField & "ף"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "p" Then
         If LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
           sNewField = sNewField & "פ"
         Else
           sNewField = sNewField & "ף"
         End If
         sNewField = sNewField & "ּ"
       ElseIf LCase(Mid(sField, i, 1)) = "r" Then
         sNewField = sNewField & "ר"
       ElseIf LCase(Mid(sField, i, 1)) = "u" Then
         If nWhichTable = 1 Then
           sNewField = sNewField & "ו"  '(Or א & ו)
         ElseIf i = 6 or Mid(sField, i-1, 1) = " " Then
            sNewField = sNewField & "אֻ"
         Else
           sNewField = sNewField & "ֻ"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "e" Then
         If nWhichTable = 1 Then
           If LCase(Mid(sField, i+1, 1)) = "y" Then
             sNewField = sNewField & "ײ"  '(Or א & ײ)
             i = i + 1
           Else
             sNewField = sNewField & "ע"  '(Or א & י)
           End If
         ElseIf i = 6 or Mid(sField, i-1, 1) = " " Then
            sNewField = sNewField & "אֶ"
         Else
           sNewField = sNewField & "ֶ"  '(Or &#x05B0, &#x05B1, &#x05B5, &#x05B5 & &#x05D9, or &#x05B6 & &#x05D9)
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "i" Then
         If nWhichTable = 1 Then
            sNewField = sNewField & "י"
         ElseIf i = 6 or Mid(sField, i-1, 1) = " " Then
            sNewField = sNewField & "אִ"
         Else
            sNewField = sNewField & "ִ"  '(or ִ & י)
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "o" Then
         If LCase(Mid(sField, i+1, 1)) = "y" And nWhichTable = 1 Then
            sNewField = sNewField & "ױ"
            i = i + 1
         ElseIf nWhichTable = 1 Then
            sNewField = sNewField & "א"
         ElseIf i = 6 or Mid(sField, i-1, 1) = " " Then
            sNewField = sNewField & "אֹ"
         Else
           sNewField = sNewField & "ֹ"     '(or &#x05B3 or &#x05B8)
         End If

       Else
         sNewField = sNewField & "∎"
       End If
       i = i + 1
    End If
  Loop While i <= Len(sField)
  
  TransHebrew = sNewField
End Function

'################################################################################

Function TransHebrewNoVowels(sField As String, nWhichTable As Integer) As String
  Dim i As Long
  Dim j As Long
  Dim k As Integer
  Dim place As Integer
  Dim sDigits As String
  Dim nDigitsAdded
  Dim nTransDigit, nTransDigits
  Dim sNewField As String
  Dim sTempTranslit As String
  sNewField = ""
  sTempTranslit = ""

  i = 6
  Do
    If Mid(sField, i, 1) = Chr(223) Then
      sNewField = sNewField & "&#x01C2;" & 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 InStr("0123456789", Mid(sField, i, 1)) Then
          sNewField = sNewField & Mid(sField, i, 1)

       ElseIf Mid(sField, i, 1) = "-" Then
         If LCase(Mid(sField, i-1, 1)) Like "[a-z]" Or LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
           'sNewField = sNewField & "&#x05BE;"
         Else
           sNewField = sNewField & Mid(sField, i, 1)
         End If
       ElseIf Mid(sField, i, 1) = "'" Then
         sNewField = sNewField & "&#x05F3;"
       ElseIf Mid(sField, i, 1) = Chr(34) Then
         sNewField = sNewField & "&#x05F4;"
       ElseIf Mid(sField, i, 1) = Chr(167) Then
         'Don't transliterate; just used as a break between consonants that might be digraphs but aren't in this case

       ElseIf Mid(sField, i, 1) = Chr(174) Then
         sNewField = sNewField & "&#x05D0;"
       ElseIf LCase(Mid(sField, i, 1)) = "a" Then
         If LCase(Mid(sField, i+1, 1)) = "i" and nWhichTable = 0 Then
           'Skip vowel points
           i = i + 1
         ElseIf LCase(Mid(sField, i+1, 1)) = "y" And nWhichTable = 1 Then
           'Skip vowel points
           i = i + 1
         Else
           If nWhichTable = 1 Then
             'Skip vowel points
           ElseIf i = 6 or Mid(sField, i-1, 1) = " " Then
             'Skip vowel points
           Else
             'Skip vowel points
           End If
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "b" Then
         'If nWhichTable = 1 Then
           sNewField = sNewField & "&#x05D1;"
         'Else
         '  sNewField = sNewField & "&#x05D1;&#x05BC;"
         'End If
       ElseIf LCase(Mid(sField, i, 1)) = "v" Then
         If Mid(sField, i+1, 1) = Chr(242) Then
           If i = 6 or Mid(sField, i-1, 1) = " " or Mid(sField, i+1, 1) = " " Then
             sNewField = sNewField & "&#x05D5;"
           Else
             sNewField = sNewField & "&#x05F0;"
           End If
           i = i + 1
         Else
           sNewField = sNewField & "&#x05D1;"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "g" Then
         sNewField = sNewField & "&#x05D2;"
       ElseIf LCase(Mid(sField, i, 1)) = "d" Then
         sNewField = sNewField & "&#x05D3;"
       ElseIf LCase(Mid(sField, i, 1)) = "z" Then
         sNewField = sNewField & "&#x05D6;"
       ElseIf LCase(Mid(sField, i, 1)) = "h" Then
         If Mid(sField, i+1, 1) = Chr(242) Then
           sNewField = sNewField & "&#x05D7;"
           i = i + 1
         Else
           sNewField = sNewField & "&#x05D4;"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "t" Then
         If Mid(sField, i+1, 1) = Chr(242) Then
           sNewField = sNewField & "&#x05D8;"
           i = i + 1
         ElseIf LCase(Mid(sField, i+1, 1)) = "s" Then
           If LCase(Mid(sField, i+2, 1)) Like "[a-z]" Then
             sNewField = sNewField & "&#x05E6;"
             i = i + 1
           Else
             sNewField = sNewField & "&#x05E5;"
             i = i + 1
           End If
         Else
           'If nWhichTable = 1 Then
           '  sNewField = sNewField & "&#x05EA;&#x05BC;"
           'Else
             sNewField = sNewField & "&#x05EA;"
           'End If
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "y" Then
         sNewField = sNewField & "&#x05D9;"
         If LCase(Mid(sField, i-1, 1)) Like "[aeiou]" And LCase(Mid(sField, i+1, 1)) = "i" Then
           sNewField = sNewField & "&#x05D9;"
           i = i + 1
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "k" Then
         If LCase(Mid(sField, i+1, 1)) = "h" Then
           If LCase(Mid(sField, i+2, 1)) Like "[a-z]" Then
             sNewField = sNewField & "&#x05DB;"
             i = i + 1
           Else
             sNewField = sNewField & "&#x05DA;"
             i = i + 1
           End If
         Else
           If Mid(sField, i+1, 1) = Chr(242) Then
             sNewField = sNewField & "&#x05E7;"
             i = i + 1
           Else
             If LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
               sNewField = sNewField & "&#x05DB;"
             Else
               sNewField = sNewField & "&#x05DA;"
             End If
             'sNewField = sNewField & "&#x05BC;"
           End If
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "l" Then
         sNewField = sNewField & "&#x05DC;"
       ElseIf LCase(Mid(sField, i, 1)) = "m" Then
         If LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
           sNewField = sNewField & "&#x05DE;"
         Else
           sNewField = sNewField & "&#x05DD;"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "n" Then
         If LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
           sNewField = sNewField & "&#x05E0;"
         Else
           sNewField = sNewField & "&#x05DF;"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "s" Then
         If Mid(sField, i+1, 1) = Chr(226) Then
           sNewField = sNewField & "&#x05E9;" '&#x05B9;"
           i = i + 1
         ElseIf nWhichTable = 1 And Mid(sField, i+1, 1) = Chr(225) Then
           sNewField = sNewField & "&#x05EA;"
           i = i + 1
         ElseIf nWhichTable = 0 And Mid(sField, i+1, 1) = Chr(225) Then
           sNewField = sNewField & "&#x05E1;"
           i = i + 1
         ElseIf LCase(Mid(sField, i+1, 1)) = "h" Then
           sNewField = sNewField & "&#x05E9;" '&#x05C1;"
           i = i + 1
         Else
           sNewField = sNewField & "&#x05E1;"
         End If
       ElseIf Mid(sField, i, 1) = Chr(176) Then
         sNewField = sNewField & "&#x05E2;"
       ElseIf LCase(Mid(sField, i, 1)) = "f" Then
         If LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
           sNewField = sNewField & "&#x05E4;"
         Else
           sNewField = sNewField & "&#x05E3;"
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "p" Then
         If LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
           sNewField = sNewField & "&#x05E4;"
         Else
           sNewField = sNewField & "&#x05E3;"
         End If
         'sNewField = sNewField & "&#x05BC;"
       ElseIf LCase(Mid(sField, i, 1)) = "r" Then
         sNewField = sNewField & "&#x05E8;"
       ElseIf LCase(Mid(sField, i, 1)) = "u" Then
         If nWhichTable = 1 Then
           'Skip vowel points 'sNewField = sNewField & "&#x05D5;"  'seems to be acceptable when using "plene" spelling for omitting vowel points
         ElseIf i = 6 or Mid(sField, i-1, 1) = " " Then
            'Skip vowel points
         Else
           'Skip vowel points
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "e" Then
         If nWhichTable = 1 Then
           If LCase(Mid(sField, i+1, 1)) = "y" Then
             sNewField = sNewField & "&#x05F2;"  '(Or &#x05D0; & &#x05F2;)
             i = i + 1
           Else
             sNewField = sNewField & "&#x05E2;"  '(Or &#x05D0; & &#x05D9;)
           End If
         ElseIf i = 6 or Mid(sField, i-1, 1) = " " Then
            'Skip vowel points 'sNewField = sNewField & "&#x05D9;" 'seems to be acceptable when using "plene" spelling for omitting vowel points '"&#x05D0;&#x05B6;"
         Else
           'Skip vowel points
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "i" Then
         If nWhichTable = 1 Then
            'Skip vowel points 'sNewField = sNewField & "&#x05D9;" 'seems to be acceptable when using "plene" spelling for omitting vowel points
         ElseIf i = 6 or Mid(sField, i-1, 1) = " " Then
            sNewField = sNewField & "&#x05D0;&#x05B4;"
         Else
            'Skip vowel points
         End If
       ElseIf LCase(Mid(sField, i, 1)) = "o" Then
         If LCase(Mid(sField, i+1, 1)) = "y" And nWhichTable = 1 Then
            'Skip vowel points
            i = i + 1
         ElseIf nWhichTable = 1 Then
            'Skip vowel points
         ElseIf i = 6 or Mid(sField, i-1, 1) = " " Then
            'Skip vowel points
         Else
           'Skip vowel points 'sNewField = sNewField & "&#x05B9;" 'seems to be acceptable when using "plene" spelling for omitting vowel points
         End If

       Else
         sNewField = sNewField & "&#x220E;"
       End If
       i = i + 1 : j = j + 1
    End If
  Loop While i <= Len(sField)
  
  TransHebrewNoVowels = sNewField
End Function

'################################################################################