'MacroName:Urdu2Latin 'MacroDescription:Automatically transliterate Urdu characters into Latin characters 'Macro written by: Joel Hahn, Niles Public Library District 'Macro last modified: 15 December 2011 Declare Function TransUrdu(sChar As String, sNextChar As String, nPos As Variant) As String 'Declare Function GetWord(nPos, nStart, nStop) As String Declare Function IsArabicChar(sNCR) As Integer Global arrChars() Option Explicit Sub Main Dim CharacterSet As Integer Dim bool as Integer Dim sField As String Dim nHasArabic as integer Dim NewField As String Dim i, a Dim sHex As String Dim nHex As Long Dim sNextHex As String Dim nNextHex As Long Dim s2NextHex As String Dim n2NextHex As Long Dim TempChar As String Dim place3 as Integer Dim place As Integer Dim sBCR As String Dim sLang As String 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.GetFixedField("Lang", sLang) Select Case sLang 'Case "hin" ' CharacterSet = 0 'Case "mar" ' CharacterSet = 1 'Case "pra", "san" ' CharacterSet = 2 Case Else 'Set the default transliteration table selection CharacterSet = 0 End Select bool = CS.GetFieldLineUnicode(CS.CursorRow, sField) NewField = Left(sField, 5) sField = Mid(sField, 6) i = 1 : nHasArabic = 0 Do While i <= Len(sField) - 7 a = Mid(sField, i, 8) If IsArabicChar(Mid(sField, i, 6)) Then nHasArabic = 1 Exit Do End If i = i + 1 Loop If nHasArabic = 0 Then MsgBox "Field contains no Urdu characters. Exiting..." Exit Sub End If 'Break up Urdu 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 &H0601 To &H06FF Select Case CharacterSet Case 0 'Urdu If i < UBound(arrChars) Then If Len(arrChars(i+1)) > 1 Then sNextHex = Mid(arrChars(i+1), 4, Len(arrChars(i+1)) - 2) nNextHex = Val("&H" & sNextHex) Else nNextHex = Val("&H" & Asc(arrChars(i+1))) End If TempChar = TransUrdu(arrChars(i), arrChars(i+1), i) If arrChars(i + 1) = "ّ" Then TempChar = TempChar & TempChar i = i + 1 End If If arrChars(i) = "ا" And arrChars(i+1) = "و" Then TempChar = "u" i = i + 1 ElseIf arrChars(i) = "ا" And arrChars(i+1) = "ل" Then If i + 1 < UBound(arrChars) Then If Len(arrChars(i+2)) > 1 Then s2NextHex = Mid(arrChars(i+2), 4, Len(arrChars(i+2)) - 2) n2NextHex = Val("&H" & s2NextHex) Else n2NextHex = Val("&H" & s2NextHex) End If Select Case n2NextHex Case &H0631 TempChar = "ar-" Case &H062F TempChar = "ad-" Case &H0630 TempChar = "az" & Chr(246) & "-" Case &H062A TempChar = "at-" Case &H062B TempChar = "as" & Chr(246) & "-" Case &H0646 TempChar = "an-" Case &H0644 TempChar = "al-" Case &H0637 TempChar = "at" & Chr(243) & "-" Case &H0638 TempChar = "az" & Chr(242) & "-" Case &H0635 TempChar = "as" & Chr(242) & "-" Case &H0636 TempChar = "az" & Chr(243) & "-" Case &H0633 TempChar = "as-" Case &H0634 TempChar = "ash-" Case &H0632 TempChar = "az-" Case Else TempChar = "al-" End Select i = i + 1 End If End If Else 'TempChar = Chr(252) TempChar = TransUrdu(arrChars(i), arrChars(i+1), i) End If End Select NewField = NewField + TempChar Case Else NewField = NewField & Chr(252) 'non-Urdu 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 (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) ) 'ǂ") '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 bool = CS.AddFieldLine(CS.CursorRow + 1, NewField) CS.CursorRow = CS.CursorRow -1 CS.SendKeys "%ekl", -1 End Sub '############################################################################## Function TransUrdu(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 IsConsonant = 0 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 &H0627 TempTranslit = "" Case &H0628 TempTranslit = "b" Case &H067E TempTranslit = "p" Case &H062A TempTranslit = "t" Case &H0670, &H067F TempTranslit = "t" & Chr(242) 'T-dot-below Case &H062B TempTranslit = "s" & Chr(246) 'S-underscore Case &H062C TempTranslit = "j" Case &H0686 TempTranslit = "c" Case &H062D TempTranslit = "h" & Chr(242) 'H-dot-below Case &H062E TempTranslit = "k" & Chr(246) & "h" & Chr(246) 'KH-underscore Case &H062F TempTranslit = "d" Case &H0688, &H068C, &H0690 TempTranslit = "d" & Chr(242) 'D-dot-below Case &H0630 TempTranslit = "z" & Chr(246) 'Z-underscore Case &H0631 TempTranslit = "r" Case &H0691, &H0697, &H0699 TempTranslit = "r" & Chr(242) 'R-dot-below Case &H0632 TempTranslit = "z" Case &H0698 TempTranslit = "zh" Case &H0633 TempTranslit = "s" Case &H0634 TempTranslit = "sh" Case &H0635 TempTranslit = "s" & Chr(242) 'S-dot-below Case &H0636 TempTranslit = "z" & Chr(243) 'Z-double-dot-below Case &H0637 TempTranslit = "t" & Chr(243) 'T-double-dot-below Case &H0638 TempTranslit = "z" & Chr(242) 'Z-dot-below Case &H0639 TempTranslit = Chr(176) 'Ain Case &H063A TempTranslit = "g" & Chr(246) & "h" & Chr(246) 'GH-underscore Case &H0641 TempTranslit = "f" Case &H0642 TempTranslit = "q" Case &H06A9 TempTranslit = "k" Case &H06AF TempTranslit = "g" Case &H0644 TempTranslit = "l" Case &H0645 TempTranslit = "m" Case &H0646 TempTranslit = "n" Case &H06BA TempTranslit = "n" & Chr(246) 'N-underscore Case &H0648 TempTranslit = "v" Case &H06C1 TempTranslit = "h" & Chr(242) 'H-dot below Case &H0647, &H06BE TempTranslit = "h" Case &H0629, &H06C3 TempTranslit = "t" Case &H0649, &H064A, &H06CC TempTranslit = "y" Case &H06D2 TempTranslit = "y" Case &H0622 TempTranslit = "a" & Chr(229) 'A-macron 'TempTranslit = Chr(176) & "a" & Chr(229) 'Ain + A-macron Case &H0623, &H0624, &H0626 TempTranslit = Chr(174) 'Hamza/alif 'Punctuation & Numbers Case &H060C, &H066C TempTranslit = "," Case &H090D 'Date separator TempTranslit = "" Case &H061B TempTranslit = ";" Case &H061E 'Triple dot punctuation mark TempTranslit = "" Case &H061F TempTranslit = "?" Case &H066A TempTranslit = "%" Case &H066B, &H06D4 TempTranslit = "." Case &H06F0, &H0660 TempTranslit = "0" Case &H06F1, &H0661 TempTranslit = "1" Case &H06F2, &H0662 TempTranslit = "2" Case &H06F3, &H0663 TempTranslit = "3" Case &H06F4, &H0664 TempTranslit = "4" Case &H06F5, &H0665 TempTranslit = "5" Case &H06F6, &H0666 TempTranslit = "6" Case &H06F7, &H0667 TempTranslit = "7" Case &H06F8, &H0668 TempTranslit = "8" Case &H06F9, &H0669 TempTranslit = "9" Case Else 'Unknown/non-Hindi character TempTranslit= Chr(252) ' Select Case nNextHex ' Case &H1112 ' TempTranslit = "lkʻ" ' arrChars(nPos + 1) = "�" ' End Select End Select 'If IsConsonant = 1 Then ' If nNextHex = &H093C And UBound(arrChars) > nPos + 1 Then ' sNextHex = Mid(arrChars(nPos+2), 4, Len(arrChars(nPos+2)) - 1) ' nNextHex = Val("&H" & sNextHex) ' End If ' Select Case nNextHex ' Case &H093E To &H094C, &H0962 ' 'Do nothing; vowel follows ' Case &H094D ' 'Do nothing; consonant ligature follows ' Case Else ' 'Add the implicit "a" ' TempTranslit = TempTranslit & "a" ' End Select 'End If TransUrdu = TempTranslit End Function '############################################################################## 'Function GetWord(nPos, nStart, nStop) As String ' Dim i ' Dim sTempWord As String ' sTempWord = "" ' i = nStart ' Do While i <= nStop ' sTempWord = sTempWord & arrChars(nPos + i) ' i = i + 1 ' Loop ' GetWord = sTempWord 'End Function '############################################################################## Function IsArabicChar(sNCR) As Integer Dim b b = Mid(sNCR, 1, 6) If Len(sNCR) = 6 And (Mid(sNCR, 1, 6) Like "&[#]x06[0-9A-F]") Then IsArabicChar = 1 Else IsArabicChar = 0 End If End Function