'MacroName:Latin2Greek 'MacroDescription:Automatically untransliterate a field with Latin characters into Greek characters 'Macro created by: Joel Hahn, Niles Public Library District 'Macro last modified: 3 October 2021 Option Explicit Option Compare Binary Declare Function TransGreek(sField As String, nWhichTable As Integer, nChangeDigits As Integer) As String Declare Function TransGreekAlphaNumbers(sDigits, nDecimalPosition) As String Declare Function NewTransGreekAlphaNumbers(sDigits 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 ChangeDigits As Integer Dim sLang As String 'Set the default transliteration table selection CharacterSet = 0 'Modern Greek ' 0 = Modern Greek ' 1 = Classical Greek 'Set the default transliteration of numbers ChangeDigits = 0 ' 0 = Leave digits as digits ' 1 = Change Latin digits to Greek alphanumeric digits Dim CS As Object Set CS = CreateObject("Connex.Client") 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) = "Modern Greek" CharSets(1) = "Classical Greek" Begin Dialog newdlg 181, 57, "Transliteration Options" OkButton 34, 40, 50, 14 CancelButton 94, 40, 50, 14 Text 3, 3, 177, 10, "Please select the LC Greek transliteration table to use:" DropListBox 42, 11, 98, 42, CharSets(), .Langs CheckBox 6, 26, 170, 10, "Change Latin digits to Greek alphanumeric digits", .AlphaNumbers End Dialog Dim CharSelect As newdlg CharSelect.Langs = CharacterSet CharSelect.AlphaNumbers = ChangeDigits response = Dialog(CharSelect) If response = 0 Then Exit Sub End If CharacterSet = CharSelect.Langs ChangeDigits = CharSelect.AlphaNumbers 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, 1 sTranslit = sTranslit & TransGreek(sField, CharacterSet, ChangeDigits) Case Else Exit Sub End Select bool = CS.AddFieldLine(CS.CursorRow, sTranslit) CS.SendKeys "%ekl", -1 End Sub '################################################################################ Function TransGreek(sField As String, nWhichTable As Integer, nChangeDigits 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(" !@#$%^&*()[]{};:.,/?\=+-" & Chr(34), Mid(sField, i, 1)) Then 'If Mid(sField, i, 1) <> Chr(223) And Mid(sField, i+1, 2) <> " " & Chr(223) Then sNewField = sNewField & Mid(sField, i, 1) 'End If ElseIf InStr("0123456789", Mid(sField, i, 1)) Then If nChangeDigits = 1 Then place = i + 1 Do While Mid(sField, place, 1) Like "[0-9]" place = place + 1 Loop sDigits = Mid(sField, i, place - i) nDigitsAdded = 0 sNewField = sNewField & NewTransGreekAlphaNumbers(sDigits, nWhichTable) i = i + Len(sDigits) - 1 Else sNewField = sNewField & Mid(sField, i, 1) End If ElseIf Mid(sField, i, 1) = ";" Then sNewField = sNewField & "·" ElseIf Mid(sField, i, 1) = "?" Then sNewField = sNewField & ";" ElseIf Mid(sField, i, 1) = Chr(34) Then If Mid(sField, i-1, 1) = " " Then sNewField = sNewField & "«" ElseIf Mid(sField, i+1, 1) = " " Then sNewField = sNewField & "»" Else sNewField = sNewField & Mid(sField, i, 1) End If ElseIf Mid(sField, i, 1) = "A" Then sNewField = sNewField & "Α" ElseIf Mid(sField, i, 1) = "B" Then If nWhichTable = 1 Then sNewField = sNewField & "Β" Else If LCase(Mid(sField, i+1, 1)) = "p" And Mid(sField, i-1, 1) = " " Then sNewField = sNewField & "Μ" sNewField = sNewField & "π" i = i + 1 : j = j + 1 ElseIf nWhichTable = 0 And Mid(sField, i-1, 1) = " " Then sNewField = sNewField & "Μ" sNewField = sNewField & "π" j = j + 1 Else sNewField = sNewField & "∎" End If End If ElseIf Mid(sField, i, 1) = "V" Then sNewField = sNewField & "Β" ElseIf Mid(sField, i, 1) = "G" Then sNewField = sNewField & "Γ" ElseIf Mid(sField, i, 1) = "D" Then If (LCase(Mid(sField, i+1, 1)) = "t" Or Mid(sField, i+1, 1) = Chr(246)) And Mid(sField, i-1, 1) = " " Then sNewField = sNewField & "Ν" sNewField = sNewField & "τ" i = i + 1 : j = j + 1 ElseIf Mid(sField, i+1, 1) = Chr(246) Then sNewField = sNewField & "∎" i = i + 1 Else sNewField = sNewField & "Δ" End If ElseIf Mid(sField, i, 1) = "E" Then If Mid(sField, i+1, 1) = Chr(229) Then sNewField = sNewField & "Η" i = i + 1 Else sNewField = sNewField & "Ε" End If ElseIf Mid(sField, i, 1) = "Z" Then sNewField = sNewField & "Ζ" ElseIf Mid(sField, i, 1) = "I" Then sNewField = sNewField & "Ι" ElseIf Mid(sField, i, 1) = "K" Then sNewField = sNewField & "Κ" ElseIf Mid(sField, i, 1) = "L" Then sNewField = sNewField & "Λ" ElseIf Mid(sField, i, 1) = "M" Then sNewField = sNewField & "Μ" ElseIf Mid(sField, i, 1) = "N" Then sNewField = sNewField & "Ν" ElseIf Mid(sField, i, 1) = "X" Then sNewField = sNewField & "Ξ" ElseIf Mid(sField, i, 1) = "O" Then If Mid(sField, i+1, 1) = Chr(229) Then sNewField = sNewField & "Ω" i = i + 1 Else sNewField = sNewField & "Ο" End If ElseIf Mid(sField, i, 1) = "P" Then If LCase(Mid(sField, i+1, 1)) = "h" Then sNewField = sNewField & "Φ" i = i + 1 ElseIf LCase(Mid(sField, i+1, 1)) = "s" Then sNewField = sNewField & "Ψ" i = i + 1 Else sNewField = sNewField & "Π" End If ElseIf Mid(sField, i, 1) = "R" Then If LCase(Mid(sField, i+1, 1)) = "h" Then ''sNewField = sNewField & " ̔Ρ" 'LC used a non-spacing character instead of the proper spacing character, so the MARC-valid character always displays wrong unless it's applied to a space 'sNewField = sNewField & "∎Ρ" 'Because of this, display a fill character before the and make the cataloger deal with it. sNewField = sNewField & "Ῥ" 'OCLC AskQC instructs that the diacritic follow the character it affects, in order to best preserve MARC8 compatibility i = i + 1 Else sNewField = sNewField & "Ρ" End If ElseIf Mid(sField, i, 1) = "S" Then sNewField = sNewField & "Σ" ElseIf Mid(sField, i, 1) = "T" Then If LCase(Mid(sField, i+1, 1)) = "h" Then sNewField = sNewField & "Θ" i = i + 1 Else sNewField = sNewField & "Τ" End If ElseIf Mid(sField, i, 1) = "Y" Then sNewField = sNewField & "Υ" ElseIf Mid(sField, i, 1) = "U" Then If InStr("aeio", LCase(Mid(sField, i-1, 1))) Then sNewField = sNewField & "Υ" Else sNewField = sNewField & "∎" End If ElseIf Mid(sField, i, 1) = "C" Then If LCase(Mid(sField, i+1, 1)) = "h" Then sNewField = sNewField & "Χ" i = i + 1 Else sNewField = sNewField & "∎" End If ElseIf Mid(sField, i, 1) = "H" Then ''sNewField = sNewField & "̔" ' Rough breathing mark; current character vanishes at start of word, so macro currently does not add this character 'sNewField = sNewField & "∎" If Mid(sField, i+1, 1) Like "[a-z]" Then Mid(sField, i+1, 1) = UCase(Mid(sField, i+1, 1)) End If If LCase(Mid(sField, i+2, 1)) = "ai" Then sNewField = sNewField & "Αἱ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 2)) = "au" Then sNewField = sNewField & "Αὑ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 2)) = "ae" And Mid(sField, i+3, 1) = Chr(229) Then sNewField = sNewField & "Αἡ" i = i + 3 ElseIf Mid(sField, i+1, 1) = "A" Then sNewField = sNewField & "Ἁ" i = i + 1 ElseIf Mid(sField, i+1, 1) = "E" And Mid(sField, i+2, 1) = Chr(229) And LCase(Mid(sField, i+3, 1)) = "u" Then sNewField = sNewField & "Ηὑ" i = i + 3 ElseIf Mid(sField, i+1, 1) = "E" And Mid(sField, i+2, 1) = Chr(229) Then sNewField = sNewField & "Ἡ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 2)) = "eu" Then sNewField = sNewField & "Εὑ" i = i + 2 ElseIf Mid(sField, i+1, 1) = "E" Then sNewField = sNewField & "Ἑ" i = i + 1 ElseIf Mid(sField, i+1, 1) = "I" Then sNewField = sNewField & "Ἱ" i = i + 1 ElseIf Mid(sField, i+1, 1) = "O" And Mid(sField, i+2, 1) = Chr(229) And LCase(Mid(sField, i+3, 1)) = "u" Then sNewField = sNewField & "Ωὑ" i = i + 3 ElseIf Mid(sField, i+1, 1) = "O" And Mid(sField, i+2, 1) = Chr(229) Then sNewField = sNewField & "Ὡ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 2)) = "oe" And Mid(sField, i+3, 1) = Chr(229) Then sNewField = sNewField & "Οἡ" i = i + 3 ElseIf LCase(Mid(sField, i+1, 2)) = "oi" Then sNewField = sNewField & "Ωἱ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 2)) = "ou" Then sNewField = sNewField & "Ωὑ" i = i + 2 ElseIf Mid(sField, i+1, 1) = "O" Then sNewField = sNewField & "Ὁ" i = i + 1 ElseIf LCase(Mid(sField, i+1, 2)) = "ui" Then sNewField = sNewField & "Υἱ" i = i + 2 ElseIf Mid(sField, i+1, 1) = "U" Then sNewField = sNewField & "∎̔" i = i + 1 ElseIf Mid(sField, i+1, 1) = "Y" Then sNewField = sNewField & "Ὑ" i = i + 1 Else sNewField = sNewField & "∎" End If ElseIf Mid(sField, i, 1) = "a" Then sNewField = sNewField & "α" ElseIf Mid(sField, i, 1) = "b" Then If nWhichTable = 1 Then sNewField = sNewField & "β" Else If LCase(Mid(sField, i+1, 1)) = "p" And Mid(sField, i-1, 1) = " " Then sNewField = sNewField & "μ" sNewField = sNewField & "π" i = i + 1 : j = j + 1 ElseIf nWhichTable = 0 And Mid(sField, i-1, 1) = " " Then sNewField = sNewField & "μ" sNewField = sNewField & "π" j = j + 1 Else sNewField = sNewField & "∎" End If End If ElseIf Mid(sField, i, 1) = "v" Then sNewField = sNewField & "β" ElseIf Mid(sField, i, 1) = "g" Then sNewField = sNewField & "γ" ElseIf Mid(sField, i, 1) = "d" Then If (LCase(Mid(sField, i+1, 1)) = "t" Or Mid(sField, i+1, 1) = Chr(246)) And Mid(sField, i-1, 1) = " " Then sNewField = sNewField & "ν" sNewField = sNewField & "τ" i = i + 1 : j = j + 1 ElseIf Mid(sField, i+1, 1) = Chr(246) Then sNewField = sNewField & "∎" i = i + 1 Else sNewField = sNewField & "δ" End If ElseIf Mid(sField, i, 1) = "e" Then If Mid(sField, i+1, 1) = Chr(229) Then sNewField = sNewField & "η" i = i + 1 Else sNewField = sNewField & "ε" End If ElseIf Mid(sField, i, 1) = "z" Then sNewField = sNewField & "ζ" ElseIf Mid(sField, i, 1) = "i" Then sNewField = sNewField & "ι" ElseIf Mid(sField, i, 1) = "k" Then sNewField = sNewField & "κ" ElseIf Mid(sField, i, 1) = "l" Then sNewField = sNewField & "λ" ElseIf Mid(sField, i, 1) = "m" Then sNewField = sNewField & "μ" ElseIf Mid(sField, i, 1) = "n" Then If (Mid(sField, i+1, 1) <> "" And InStr("gkx", LCase(Mid(sField, i+1, 1)))) Or LCase(Mid(sField, i+1, 2)) = "ch" Then sNewField = sNewField & "γ" Else sNewField = sNewField & "ν" End If ElseIf Mid(sField, i, 1) = "x" Then sNewField = sNewField & "ξ" ElseIf Mid(sField, i, 1) = "o" Then If Mid(sField, i+1, 1) = Chr(229) Then sNewField = sNewField & "ω" i = i + 1 Else sNewField = sNewField & "ο" End If ElseIf Mid(sField, i, 1) = "p" Then If LCase(Mid(sField, i+1, 1)) = "h" Then sNewField = sNewField & "φ" i = i + 1 ElseIf LCase(Mid(sField, i+1, 1)) = "s" Then sNewField = sNewField & "ψ" i = i + 1 Else sNewField = sNewField & "π" End If ElseIf Mid(sField, i, 1) = "r" Then If LCase(Mid(sField, i+1, 1)) = "h" Then ''sNewField = sNewField & " ̔ρ" 'LC used a non-spacing character instead of the proper spacing character, so the MARC-valid character always displays wrong unless it's applied to a space 'sNewField = sNewField & "∎ρ" 'Because of this, display a fill character and make the cataloger deal with it. sNewField = sNewField & "ῥ" 'OCLC AskQC instructs that the diacritic follow the character it affects, in order to best preserve MARC8 compatibility i = i + 1 Else sNewField = sNewField & "ρ" End If ElseIf Mid(sField, i, 1) = "s" Then If Mid(sField, i+1, 1) Like "[a-z]" Then sNewField = sNewField & "σ" Else sNewField = sNewField & "ς" End If ElseIf Mid(sField, i, 1) = "t" Then If LCase(Mid(sField, i+1, 1)) = "h" Then sNewField = sNewField & "θ" i = i + 1 Else sNewField = sNewField & "τ" End If ElseIf Mid(sField, i, 1) = "y" Then sNewField = sNewField & "υ" ElseIf Mid(sField, i, 1) = "u" Then If InStr("aeio", LCase(Mid(sField, i-1, 1))) Then sNewField = sNewField & "υ" Else sNewField = sNewField & "∎" End If ElseIf Mid(sField, i, 1) = "c" Then If LCase(Mid(sField, i+1, 1)) = "h" Then sNewField = sNewField & "χ" i = i + 1 Else sNewField = sNewField & "∎" End If ElseIf Mid(sField, i, 1) = "h" Then 'sNewField = sNewField & " ̔" ' Rough breathing mark; applying it to a space makes it appear at the start of a word, but not in the right place If LCase(Mid(sField, i+1, 2)) = "ai" Then sNewField = sNewField & "αἱ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 2)) = "au" Then sNewField = sNewField & "αὑ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 2)) = "ae" And Mid(sField, i+2, 1) = Chr(229) Then sNewField = sNewField & "αἡ" i = i + 3 ElseIf LCase(Mid(sField, i+1, 1)) = "a" Then sNewField = sNewField & "ἁ" i = i + 1 ElseIf LCase(Mid(sField, i+1, 1)) = "e" And Mid(sField, i+2, 1) = Chr(229) And LCase(Mid(sField, i+3, 1)) = "u" Then sNewField = sNewField & "ηὑ" i = i + 3 ElseIf LCase(Mid(sField, i+1, 1)) = "e" And Mid(sField, i+2, 1) = Chr(229) Then sNewField = sNewField & "ἡ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 2)) = "eu" Then sNewField = sNewField & "εὑ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 1)) = "e" Then sNewField = sNewField & "ἑ" i = i + 1 ElseIf LCase(Mid(sField, i+1, 1)) = "i" Then sNewField = sNewField & "ἱ" i = i + 1 ElseIf LCase(Mid(sField, i+1, 1)) = "o" And Mid(sField, i+2, 1) = Chr(229) And LCase(Mid(sField, i+3, 1)) = "u" Then sNewField = sNewField & "ωὑ" i = i + 3 ElseIf LCase(Mid(sField, i+1, 1)) = "o" And Mid(sField, i+2, 1) = Chr(229) Then sNewField = sNewField & "ὡ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 2)) = "oe" And Mid(sField, i+3, 1) = Chr(229) Then sNewField = sNewField & "οἡ" i = i + 3 ElseIf LCase(Mid(sField, i+1, 2) = "oi") Then sNewField = sNewField & "ωἱ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 2) = "ou") Then sNewField = sNewField & "ωὑ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 1)) = "o" Then sNewField = sNewField & "ὁ" i = i + 1 ElseIf LCase(Mid(sField, i+1, 2)) = "ui" Then sNewField = sNewField & "υἱ" i = i + 2 ElseIf LCase(Mid(sField, i+1, 1)) = "u" Then sNewField = sNewField & "∎̔" i = i + 1 ElseIf LCase(Mid(sField, i+1, 1)) = "y" Then sNewField = sNewField & "ὑ" i = i + 1 Else sNewField = sNewField & "∎" End If Else sNewField = sNewField & "∎" End If i = i + 1 End If Loop While i <= Len(sField) TransGreek = sNewField End Function '################################################################################ Function TransGreekAlphaNumbers(sDigit, nDecimalPosition) As String Select Case nDecimalPosition Case 1 'Ones digit If sDigit = "1" Then TransGreekAlphaNumbers = "α" ElseIf sDigit = "2" Then TransGreekAlphaNumbers = "β" ElseIf sDigit = "3" Then TransGreekAlphaNumbers = "γ" ElseIf sDigit = "4" Then TransGreekAlphaNumbers = "δ" ElseIf sDigit = "5" Then TransGreekAlphaNumbers = "ε" ElseIf sDigit = "6" Then TransGreekAlphaNumbers = "ς" ElseIf sDigit = "7" Then TransGreekAlphaNumbers = "ζ" ElseIf sDigit = "8" Then TransGreekAlphaNumbers = "η" ElseIf sDigit = "9" Then TransGreekAlphaNumbers = "θ" Else TransGreekAlphaNumbers = "" End If Case 2 ' Tens digits If sDigit = "1" Then TransGreekAlphaNumbers = "ι" ElseIf sDigit = "2" Then TransGreekAlphaNumbers = "κ" ElseIf sDigit = "3" Then TransGreekAlphaNumbers = "λ" ElseIf sDigit = "4" Then TransGreekAlphaNumbers = "μ" ElseIf sDigit = "5" Then TransGreekAlphaNumbers = "ν" ElseIf sDigit = "6" Then TransGreekAlphaNumbers = "ξ" ElseIf sDigit = "7" Then TransGreekAlphaNumbers = "ο" ElseIf sDigit = "8" Then TransGreekAlphaNumbers = "π" ElseIf sDigit = "9" Then TransGreekAlphaNumbers = "ϟ" Else TransGreekAlphaNumbers = "" End If Case 3 'Hundreds digit If sDigit = "1" Then TransGreekAlphaNumbers = "ρ" ElseIf sDigit = "2" Then TransGreekAlphaNumbers = "σ" ElseIf sDigit = "3" Then TransGreekAlphaNumbers = "τ" ElseIf sDigit = "4" Then TransGreekAlphaNumbers = "υ" ElseIf sDigit = "5" Then TransGreekAlphaNumbers = "φ" ElseIf sDigit = "6" Then TransGreekAlphaNumbers = "χ" ElseIf sDigit = "7" Then TransGreekAlphaNumbers = "ψ" ElseIf sDigit = "8" Then TransGreekAlphaNumbers = "ω" ElseIf sDigit = "9" Then TransGreekAlphaNumbers = "ϡ" 'Character is not in Arial Unicode MS Else TransGreekAlphaNumbers = "" End If Case 4 'Thousands digit If sDigit = "1" Then TransGreekAlphaNumbers = "α" ElseIf sDigit = "2" Then TransGreekAlphaNumbers = "β" ElseIf sDigit = "3" Then TransGreekAlphaNumbers = "γ" ElseIf sDigit = "4" Then TransGreekAlphaNumbers = "δ" ElseIf sDigit = "5" Then TransGreekAlphaNumbers = "ε" ElseIf sDigit = "6" Then TransGreekAlphaNumbers = "ς" ElseIf sDigit = "7" Then TransGreekAlphaNumbers = "ζ" ElseIf sDigit = "8" Then TransGreekAlphaNumbers = "η" ElseIf sDigit = "9" Then TransGreekAlphaNumbers = "θ" Else TransGreekAlphaNumbers = "" End If Case 5 'Ten-thousands digit If sDigit = "1" Then TransGreekAlphaNumbers = "ι" ElseIf sDigit = "2" Then TransGreekAlphaNumbers = "κ" ElseIf sDigit = "3" Then TransGreekAlphaNumbers = "λ" ElseIf sDigit = "4" Then TransGreekAlphaNumbers = "μ" ElseIf sDigit = "5" Then TransGreekAlphaNumbers = "ν" ElseIf sDigit = "6" Then TransGreekAlphaNumbers = "ξ" ElseIf sDigit = "7" Then TransGreekAlphaNumbers = "ο" ElseIf sDigit = "8" Then TransGreekAlphaNumbers = "π" ElseIf sDigit = "9" Then TransGreekAlphaNumbers = "ϟ" Else TransGreekAlphaNumbers = "" End If Case 6 'Hundred-thousands digit If sDigit = "1" Then TransGreekAlphaNumbers = "ρ" ElseIf sDigit = "2" Then TransGreekAlphaNumbers = "σ" ElseIf sDigit = "3" Then TransGreekAlphaNumbers = "τ" ElseIf sDigit = "4" Then TransGreekAlphaNumbers = "υ" ElseIf sDigit = "5" Then TransGreekAlphaNumbers = "φ" ElseIf sDigit = "6" Then TransGreekAlphaNumbers = "χ" ElseIf sDigit = "7" Then TransGreekAlphaNumbers = "ψ" ElseIf sDigit = "8" Then TransGreekAlphaNumbers = "ω" ElseIf sDigit = "9" Then TransGreekAlphaNumbers = "ϡ" Else TransGreekAlphaNumbers = "" End If Case Else TransGreekAlphaNumbers = "∎" End Select End Function '################################################################################ Function NewTransGreekAlphaNumbers(sDigits As String, nWhichTable As Integer) As String Dim nDecimalPosition as Integer Dim nDigitsRemaining As Integer Dim sDigit as String Dim sNewDigits As String nDigitsRemaining = Len(sDigits) nDecimalPosition = 1 Do sDigit = Mid(sDigits, nDigitsRemaining, 1) Select Case nDecimalPosition Case 1 'Ones digit If sDigit = "1" Then sNewDigits = "α" ElseIf sDigit = "2" Then sNewDigits = "β" ElseIf sDigit = "3" Then sNewDigits = "γ" ElseIf sDigit = "4" Then sNewDigits = "δ" ElseIf sDigit = "5" Then sNewDigits = "ε" ElseIf sDigit = "6" Then sNewDigits = "ς" ElseIf sDigit = "7" Then sNewDigits = "ζ" ElseIf sDigit = "8" Then sNewDigits = "η" ElseIf sDigit = "9" Then sNewDigits = "θ" Else sNewDigits = "" End If Case 2 ' Tens digits If sDigit = "1" Then sNewDigits = "ι" & sNewDigits ElseIf sDigit = "2" Then sNewDigits = "κ" & sNewDigits ElseIf sDigit = "3" Then sNewDigits = "λ" & sNewDigits ElseIf sDigit = "4" Then sNewDigits = "μ" & sNewDigits ElseIf sDigit = "5" Then sNewDigits = "ν" & sNewDigits ElseIf sDigit = "6" Then sNewDigits = "ξ" & sNewDigits ElseIf sDigit = "7" Then sNewDigits = "ο" & sNewDigits ElseIf sDigit = "8" Then sNewDigits = "π" & sNewDigits ElseIf sDigit = "9" Then If nWhichTable = 1 Then sNewDigits = "ϙ" & sNewDigits Else sNewDigits = "ϟ" & sNewDigits End If Else sNewDigits = sNewDigits & "" End If Case 3 'Hundreds digit If sDigit = "1" Then sNewDigits = "ρ" & sNewDigits ElseIf sDigit = "2" Then sNewDigits = "σ" & sNewDigits ElseIf sDigit = "3" Then sNewDigits = "τ" & sNewDigits ElseIf sDigit = "4" Then sNewDigits = "υ" & sNewDigits ElseIf sDigit = "5" Then sNewDigits = "φ" & sNewDigits ElseIf sDigit = "6" Then sNewDigits = "χ" & sNewDigits ElseIf sDigit = "7" Then sNewDigits = "ψ" & sNewDigits ElseIf sDigit = "8" Then sNewDigits = "ω" & sNewDigits ElseIf sDigit = "9" Then sNewDigits = "ϡ" & sNewDigits 'Character is not in Arial Unicode MS Else sNewDigits = sNewDigits & "" End If Case 4 'Thousands digit If sDigit = "1" Then sNewDigits = "α" & sNewDigits ElseIf sDigit = "2" Then sNewDigits = "β" & sNewDigits ElseIf sDigit = "3" Then sNewDigits = "γ" & sNewDigits ElseIf sDigit = "4" Then sNewDigits = "δ" & sNewDigits ElseIf sDigit = "5" Then sNewDigits = "ε" & sNewDigits ElseIf sDigit = "6" Then sNewDigits = "ς" & sNewDigits ElseIf sDigit = "7" Then sNewDigits = "ζ" & sNewDigits ElseIf sDigit = "8" Then sNewDigits = "η" & sNewDigits ElseIf sDigit = "9" Then sNewDigits = "θ" & sNewDigits Else sNewDigits = sNewDigits & "" End If Case 5 'Ten-thousands digit If sDigit = "1" Then sNewDigits = "ι" & sNewDigits ElseIf sDigit = "2" Then sNewDigits = "κ" & sNewDigits ElseIf sDigit = "3" Then sNewDigits = "λ" & sNewDigits ElseIf sDigit = "4" Then sNewDigits = "μ" & sNewDigits ElseIf sDigit = "5" Then sNewDigits = "ν" & sNewDigits ElseIf sDigit = "6" Then sNewDigits = "ξ" & sNewDigits ElseIf sDigit = "7" Then sNewDigits = "ο" & sNewDigits ElseIf sDigit = "8" Then sNewDigits = "π" & sNewDigits ElseIf sDigit = "9" Then sNewDigits = "ϟ" & sNewDigits Else sNewDigits = "" End If Case 6 'Hundred-thousands digit If sDigit = "1" Then sNewDigits = "ρ" & sNewDigits ElseIf sDigit = "2" Then sNewDigits = "σ" & sNewDigits ElseIf sDigit = "3" Then sNewDigits = "τ" & sNewDigits ElseIf sDigit = "4" Then sNewDigits = "υ" & sNewDigits ElseIf sDigit = "5" Then sNewDigits = "φ" & sNewDigits ElseIf sDigit = "6" Then sNewDigits = "χ" & sNewDigits ElseIf sDigit = "7" Then sNewDigits = "ψ" & sNewDigits ElseIf sDigit = "8" Then sNewDigits = "ω" & sNewDigits ElseIf sDigit = "9" Then sNewDigits = "ϡ" & sNewDigits Else sNewDigits = sNewDigits & "" End If Case Else sNewDigits = sNewDigits & "∎" End Select nDecimalPosition = nDecimalPosition + 1 nDigitsRemaining = nDigitsRemaining - 1 Loop While nDigitsRemaining > 0 If Len(sDigits) < 4 Then sNewDigits = sNewDigits & "ʹ" ElseIf Len(sDigits) >= 4 Then sNewDigits = "͵" & sNewDigits End If NewTransGreekAlphaNumbers = sNewDigits End Function '################################################################################