'MacroName:Syriac2Latin
'MacroDescription:Automatically transliterate a field with Syriac characters into Latin characters
'Macro written by: Joel Hahn, Niles Public Library District
'Macro last modified: 25 October 2013

Declare Function TransSyriac(sChar As String, sNextChar As String, nPos As Variant) As String
Declare Function IsSyriacChar(sNCR) As Integer

Global arrChars()
Option Explicit


Sub Main
   Dim bool as Integer
   Dim sField As String
   Dim nHasSyriac 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 sCurChar
   Dim sNextChar

   Dim CS As Object
   Set CS = CreateObject("Connex.Client")
   ReDim arrChars(0)

   bool = CS.GetFieldLineUnicode(CS.CursorRow, sField)

   NewField = Left(sField, 5)
   sField = Mid(sField, 6)

   i = 1 : nHasSyriac = 0
   Do While i <= Len(sField) - 7
     a = Mid(sField, i, 8)
     If IsSyriacChar(Mid(sField, i, 6)) Then
       nHasSyriac = 1
       Exit Do
     End If
     i = i + 1
   Loop
   If nHasSyriac = 0 Then
      MsgBox "Field contains no Syriac characters. Exiting..."
      Exit Sub
   End If

   'Break up Syriac 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 &H0000
               'Do nothing; character already processed
            Case &H200D To &H200F
               'Do nothing; Unicode formatting character
            Case &H01C2   'Delimiter
               NewField = NewField & Chr(223) 
            Case &H0700 To &H074F   'Syriac character
               sCurChar = arrChars(i)
               If i < UBound(arrChars) Then
                  sNextChar = arrChars(i+1)
               Else
                  sNextChar = "&#x0000;"
               End If
               TempChar = TransSyriac(sCurChar, sNextChar, i)
               NewField = NewField + TempChar
            Case Else   'Non-Syriac 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-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 (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
   place3 = 5
   Do While InStr(place3, NewField, Chr(223) ) '&#x01C2;")
     'place3 = InStr(place3, NewField, "&#x01C2;") + 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

   bool = CS.AddFieldLine(CS.CursorRow + 1, NewField)
   CS.CursorRow = CS.CursorRow -1
   CS.SendKeys "%ekl", -1
   
End Sub

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

Function IsSyriacChar(sNCR) As Integer
   Dim b
   b = Mid(sNCR, 1, 6)
   If Len(sNCR) = 6 And (Mid(sNCR, 1, 6) Like "&[#]x07[0-4]") Then
      IsSyriacChar = 1
   Else
      IsSyriacChar = 0
   End If
End Function

Function TransSyriac(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 &H0710, &H0711
      TransSyriac = Chr(174) 'Alaph
    Case &H0712, &H072D
      TransSyriac = "b"
    Case &H0713, &H0714, &H072E
      TransSyriac = "g"
    Case &H0715, &H0716, &H072F
      TransSyriac = "d"
    Case &H0717
      TransSyriac = "h"
    Case &H0718
      TransSyriac = "w"
      If nNextHex = &H073F Then
         TransSyriac = "o"
         arrChars(nPos + 1) = "&#x0000;"
      ElseIf nNextHex = &H073C Or nNextHex = &H073D Then
         TransSyriac = "u" & Chr(226)  'u-acute
         arrChars(nPos + 1) = "&#x0000;"
      End If
    Case &H0719
      TransSyriac = "z"
    Case &H071A
      TransSyriac = "h" & Chr(242)  'h-dot below
    Case &H071B, &H071C
      TransSyriac = "t" & Chr(242)  't-dot below
    Case &H071D
      TransSyriac = "y"
      If nNextHex = &H0736 Or nNextHex = &H0739 Then
         TransSyriac = "e" & Chr(226)  'e-acute
         arrChars(nPos + 1) = "&#x0000;"
      ElseIf nNextHex = &H073A Or nNextHex = &H073C Then
         TransSyriac = "i" & Chr(226)  'i-acute
         arrChars(nPos + 1) = "&#x0000;"
      End If
    Case &H071E
      TransSyriac = "yh"
    Case &H071F
      TransSyriac = "k"
    Case &H0720
      TransSyriac = "l"
    Case &H0721
      TransSyriac = "m"
    Case &H0722
      TransSyriac = "n"
    Case &H0723, &H0724
      TransSyriac = "s"
    Case &H0725
      TransSyriac = Chr(176) 'Ayin
    Case &H0726, &H0727
      TransSyriac = "p"
    Case &H0728
      TransSyriac = "s" & Chr(242)  's-dot below
    Case &H0729
      TransSyriac = "q"
    Case &H072A
      TransSyriac = "r"
    Case &H072B
      TransSyriac = "s" & Chr(233)
    Case &H072C
      TransSyriac = "t"

    Case &H0730 To &H0732
      TransSyriac = "a"
    Case &H0733 To &H0735
      TransSyriac = "a" & Chr(229)
    Case &H0736 To &H0739
      TransSyriac = "e"
      If nNextHex = &H071D Then
         TransSyriac = "e" & Chr(226)  'e-acute
         arrChars(nPos + 1) = "&#x0000;"
      End If
    Case &H073A, &H073B
      TransSyriac = "i"
      If nNextHex = &H071D Then
         TransSyriac = "i" & Chr(226)  'i-acute
         arrChars(nPos + 1) = "&#x0000;"
      End If
    Case &H073C
      TransSyriac = "iu"
      If nNextHex = &H0718 Then
         TransSyriac = "u" & Chr(226)  'u-acute
         arrChars(nPos + 1) = "&#x0000;"
      ElseIf nNextHex = &H071D Then
         TransSyriac = "i" & Chr(226)  'i-acute
         arrChars(nPos + 1) = "&#x0000;"
      End If
    Case &H073D To &H073E
      TransSyriac = "u"
      If nNextHex = &H0718 Then
         TransSyriac = "u" & Chr(226)  'u-acute
         arrChars(nPos + 1) = "&#x0000;"
      End If
    Case &H073F
      If nNextHex = &H0718 Then
         TransSyriac = "o"
         arrChars(nPos + 1) = "&#x0000;"
      End If
    Case &H0740 To &H074A
      TransSyriac = ""  'Skip; untransliterated diacritic
    
    Case &H0700, &H0701, &H0704, &H0709, &H070B To &H070F
      TransSyriac = ""  'Skip; untransliterated punctuation
    Case &H0702
      TransSyriac = ","
    Case &H0703
      TransSyriac = ":"
    Case &H070A
      TransSyriac = "."

    Case Else
      TransSyriac = Chr(252)
  End Select
End Function