3
\$\begingroup\$

This working macro converts Hindi Devanagari proprietary font to Unicode font. It reads the conversion table from a tab delimited file, and converts one by one by finding all matches and then does some ligature shifting.

I don't know how efficient it is and how much time and resources it uses. Feel free to tell me if something like "bad coding style" comes to your notice, and alternative method of doing this.

Header #def part is not much used in this final macro, but used in debugging, so I retained it here. You can't run it without the conversion table file and without the text in the said font.

I'm using Windows8-32 bit, MS Office 2010, Word.

#If VBA7 Then
    Public Declare PtrSafe Function MessageBoxU Lib "user32" Alias "MessageBoxW" _
                                    (ByVal hwnd As LongPtr, _
                                     ByVal lpText As LongPtr, _
                                     ByVal lpCaption As LongPtr, _
                                     ByVal wType As Long) As Long
    'Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                                    (Destination As Any, _
                                     Source As Any, _
                                     ByVal Length As LongPtr)
    'Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
                                    (Destination As Any, _
                                     Source As Any, _
                                     ByVal Length As Long)
#Else
    Public Declare Function MessageBoxU Lib "user32" Alias "MessageBoxW" _
                            (ByVal hwnd As Long, _
                             ByVal lpText As Long, _
                             ByVal lpCaption As Long, _
                             ByVal wType As Long) As Long
    'Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                                    (Destination As Any, _
                                     Source As Any, _
                                     ByVal Length As Long)
    'Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
                                    (Destination As Any, _
                                     Source As Any, _
                                     ByVal Length As Long)
#End If
'Converting to UTF-8
'http://www.di-mgt.com.au/howto-convert-vba-unicode-to-utf8.html
''' WinApi function that maps a UTF-16 (wide character) string to a new character string
'Private Declare Function WideCharToMultiByte Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As Long, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As Long, _
    ByVal cbMultiByte As Long, _
    ByVal lpDefaultChar As Long, _
    ByVal lpUsedDefaultChar As Long) As Long

' CodePage constant for UTF-8
'Private Const CP_UTF8 = 65001
'https://msdn.microsoft.com/en-us/library/windows/desktop/dd317756%28v=vs.85%29.aspx?f=255&MSPPError=-2147217396
'CodePage constant for devnagari
'Private Const CP_UTF8 = 57002

Sub Universal_Converter_v1.0()
'
' Universal_Converter
'
' Proprietary fonts to Unicode font Converter Macro for MS Word
' First Release: Version 1.0, 24 December 2015.
'
' Only selected font is changed to Unicode.
' Hence, ensure that the font of the text you intend to convert, has been set to that font.
' If there are more than one font that you intend to convert, please run the macro many times, each time selecting one font for conversion

    'Name of the source properietary font to be converted to target, must be exactly as displayed in ms word FONT box
    oFontFrom = "Kruti Dev 010"
    'oFontFrom = "Ankit"

    'Name of the target font to which source is to be converted, must be exactly as displayed in ms word FONT box
    oFontTo = "Arial Unicode MS"

    'All Unicode codes of letters that combine with other letters into one single entity are stored for matching and keeping letters separated.
    Dim arrMaatraasCode
    arrMaatraasCode = Array(2366, 2367, 2368, 2369, 2370, 2371, 2372, 2375, 2376, 2377, 2379, 2380, 2306, 2373, 2305, 2307, 2381, 2364)
    'aa i ee u oo ri rri e ai au o ou bindu, e, chandrabindu, visarg, halant, nuqta

    'This converts above codes to letters and puts them in a single variable
    Dim arrMaatraas(17) As String
    strMaatraasAll = " "
    For arrIndex = 0 To UBound(arrMaatraasCode)
        arrMaatraas(arrIndex) = ChrW(arrMaatraasCode(arrIndex))
        strMaatraasAll = strMaatraasAll & arrMaatraas(arrIndex) & " "
    Next arrIndex

    'to prevent matraas and samyuktakshars from merging, yet not give a word break
    'a of sinhala, dec code 3845
    strFiller = ChrW(3845)
    strHalant = ChrW(2381)
    strChhoti_i = ChrW(2367)
    ' bindu, anuswara, dec code 2306, also to be moved forward if immediately with chhoti i
    strBindu = ChrW(2306)
    strR = ChrW(2352)

    'Define font conversion table
    Dim arrIndexMax As Integer
    Const arrIndexMax1 = 1024

    Dim arrInCode(arrIndexMax1) As Integer
    Dim arrFromChar(arrIndexMax1) As String
    Dim arrToChar(arrIndexMax1) As String

    '0: No, 1: yes, Change accordingly if you want to create the output conversion table or not, helps in debugging
    CreateCSVTable = 1
    'subroutine reads conversion table from disk file and optionally creates only applicable values to another CSV disk file
    ReadConversionTable arrInCode, arrFromChar, arrToChar, arrIndexMax, strMaatraasAll, strFiller, CreateCSVTable, oFontFrom, oFontTo

    If arrIndexMax < 0 Then
        MsgBox "No valid data found in conversion table file. Aborting!"
        End
    End If

    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting

    With Selection.Find.Font
         .Name = oFontFrom
         '.Size = 10
         '.Bold = False
         '.Italic = True
         '.Color = wdColorRed
    End With

    Application.ScreenUpdating = True
    'Application.ScreenUpdating = False 'stops word file displaying changes. If you like to see each letter getting converted, make it "true", or comment it
    For arrIndex = 0 To arrIndexMax
        If (arrInCode(arrIndex) >= 1) And (arrInCode(arrIndex) <= 4) Then
            ReplaceText1 arrFromChar(arrIndex), arrToChar(arrIndex)
        End If
    Next arrIndex

    Shift_chhotii_i strFiller, strHalant, strChhoti_i, strBindu

    Shift_half_r strFiller, strHalant, strR

    ReplaceText1 strFiller, ""

    'change all other input font text to output font text
    'following lines copied from internet
    Selection.HomeKey Unit:=wdStory
    Dim rngStory As Range
    For Each rngStory In ActiveDocument.StoryRanges
        With rngStory.Find
            'Do not find or replace anything
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchCase = True
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Font.Name = oFontFrom
            .Replacement.Font.Name = oFontTo
        End With

        rngStory.Find.Execute Replace:=wdReplaceAll
    Next rngStory

    Application.ScreenUpdating = True 'the word file restarts displaying changes done
End Sub ' Universal Converter subroutine
Sub ReadConversionTable(ByRef arrInCode() As Integer, _
    ByRef arrFromChar() As String, _
    ByRef arrToChar() As String, _
    ByRef arrIndexMax As Integer, _
    ByVal strMaatraasAll As String, _
    ByVal strFiller As String, _
    ByVal CreateCSVTable As Integer, _
    ByVal oFontFrom As String, _
    ByVal oFontTo As String)
'
' ReadConversionTable Macro
'
' reads conversion table from a tab delimited file and optionallly creates another csv file having only applicable values
' http://blogs.technet.com/b/heyscriptingguy/archive/2007/03/23/how-can-i-parse-a-tab-delimited-file-and-then-save-that-as-a-comma-separated-values-file.aspx

    oFontFrom1 = oFontFrom
    Select Case oFontFrom
    Case "Ankit"
        'Ankit's charmap is exactly same as Kruti Dev 010
        oFontFrom1 = "Kruti Dev 010"
    Case "Kruti Dev 016"
        'Kruti Dev 016's charmap is almost similar to that of Kruti Dev 010
        oFontFrom1 = "Kruti Dev 010"
    End Select

    'change to reflect the location of conversion table files in your hard disk
    oPath = "E:\lang\fr\"
    oInFontFile = oPath & oFontFrom1 & "_to_" & oFontTo & ".txt"
    'open conversion table file as read only
    Const flagReadOnly = 1
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFileIn = objFSO.OpenTextFile(oInFontFile, flagReadOnly)

    'create output file storing conversion table with filler.
    If CreateCSVTable = 1 Then
        oOutFontFile = oPath & oFontFrom1 & "_to_" & oFontTo & "_out.txt"
        '0: Don't overwrite, 1: Do overwrite file on disk, if already exists
        flagOverwrite = 1
        '1: make output file unicode
        flagUnicode = 1

        Set objFileOut = objFSO.CreateTextFile(oOutFontFile, flagOverwrite, flagUnicode)
        objFileOut.WriteLine Chr(34) & "SlNo" & Chr(34) & "," & Chr(34) & "Code" & Chr(34) & "," & Chr(34) & "FromChar" & Chr(34) & "," & Chr(34) & "ToChar" & Chr(34)
    End If

    arrIndex = -1
    Do Until objFileIn.AtEndOfStream
        strLine = objFileIn.ReadLine

        'blank line, hence skipped
        If Len(strLine) = 0 Then
            GoTo ContinueUntilLoop1
        End If

        'the input read from the file is split by TABs into different fields
        arrFields = Split(strLine, vbTab)

        'only these codes (first field of input) is to converted, hence rest skipped
        If arrFields(0) < 1 Or arrFields(0) > 4 Then
            GoTo ContinueUntilLoop1
        End If

        'this set of conversion stays at this index in arrays
        arrIndex = arrIndex + 1
        arrInCode(arrIndex) = arrFields(0)
        'function InsertFiller adds Filler to keep letters separate
        arrFromChar(arrIndex) = InsertFiller(arrFields(1), strMaatraasAll, strFiller)
        arrToChar(arrIndex) = InsertFiller(arrFields(2), strMaatraasAll, strFiller)

        If CreateCSVTable = 1 Then
            objFileOut.WriteLine arrIndex & "," & arrInCode(arrIndex) & "," & Chr(34) & arrFromChar(arrIndex) & Chr(34) & "," & Chr(34) & arrToChar(arrIndex) & Chr(34)
        End If

ContinueUntilLoop1:
    Loop
    'Now, this has maximum value of index up to which there are valid values in the conversion array
    arrIndexMax = arrIndex

    objFileIn.Close
    If CreateCSVTable = 1 Then
        objFileOut.Close
    End If
End Sub 'ReadConversionTable
Function InsertFiller(ByVal inStr1 As String, ByVal strMaatraasAll As String, ByVal strFiller As String) As String
'
' InsertFiller
'
' adds strFiller to keep letters separate

    ' functino UTF8_Decode converts corrupted unicode text to utf-8 which is otherwise stored as ANSI-2354-4 etc.
    oStr1 = UTF8_Decode(inStr1)
    oStr2 = ""
    For i = 1 To Len(oStr1)
        oChar = Mid(oStr1, i, 1)
        'filler is added before each maatra
        oStr2 = oStr2 & IIf(InStr(1, strMaatraasAll, oChar, 1) > 0, strFiller, "") & oChar
    Next i

    InsertFiller = oStr2
End Function 'InsertFiller
Function UTF8_Decode(ByVal sStr As String)
'
' UTF8_Decode
'
' taken from http://p2p.wrox.com/vbscript/29099-unicode-utf-8-system-text-utf8encoding-vba.html
' converts corrupted unicode text to utf-8 which is otherwise stored as ANSI-2354-4 etc.
'
    Dim l As Long, sUTF8 As String, iChar As Integer, iChar2 As Integer
    For l = 1 To Len(sStr)
        iChar = Asc(Mid(sStr, l, 1))
        If iChar > 127 Then
            If Not iChar And 32 Then ' 2 chars
            iChar2 = Asc(Mid(sStr, l + 1, 1))
            sUTF8 = sUTF8 & ChrW$(((31 And iChar) * 64 + (63 And iChar2)))
            l = l + 1
        Else
            Dim iChar3 As Integer
            iChar2 = Asc(Mid(sStr, l + 1, 1))
            iChar3 = Asc(Mid(sStr, l + 2, 1))
            sUTF8 = sUTF8 & ChrW$(((iChar And 15) * 16 * 256) + ((iChar2 And 63) * 64) + (iChar3 And 63))
            l = l + 2
        End If
            Else
            sUTF8 = sUTF8 & Chr$(iChar)
        End If
    Next l
    UTF8_Decode = sUTF8
End Function 'UTF8_Decode
Sub ReplaceText1(ByVal oText As String, ByVal oReplacementText As String)
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .Text = oText
        .Replacement.Text = oReplacementText

        'search only in Kruti Dev 010
        .Format = True
        .MatchCase = True
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWholeWord = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        'simple text search
        .MatchWildcards = False
    End With

    Selection.Find.Execute Replace:=wdReplaceAll
End Sub 'ReplaceText1
Sub Shift_chhotii_i(ByVal strFiller As String, ByVal strHalant As String, ByVal strChhoti_i As String, ByVal strBindu As String)
'chhoti i  to be moved forwards, dec code 2367

    lenFiller = Len(strFiller)
    lenHalant = Len(strHalant)
    strFillerHalant = strFiller & strHalant
    lenFillerHalant = Len(strFillerHalant)
    strSearchChhoti_i1 = strFiller & strChhoti_i
    lenSearchChhoti_i1 = Len(strSearchChhoti_i1)
    strSearchBindu1 = strFiller & strBindu
    lenSearchBindu1 = Len(strSearchBindu1)

    Selection.HomeKey Unit:=wdStory
    Dim oRange As Range
    Set oRange = ActiveDocument.Range
    With Selection.Find
        .ClearFormatting
        .Text = strSearchChhoti_i1

        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

        Do While .Execute
            Selection.MoveEnd Unit:=wdWord, Count:=1
            strMemText = Selection.Range.Text
            lenSelection = Len(strMemText)

            If Mid(strMemText, lenSearchChhoti_i1 + 1, lenSearchBindu1) = strSearchBindu1 Then
                lenSearched1 = lenSearchChhoti_i1 + lenSearchBindu1
            Else
                lenSearched1 = lenSearchChhoti_i1
            End If

            lenMid = 0
            Do While (Mid(strMemText, lenSearched1 + lenMid + 3, lenHalant) = strHalant)
                lenMid = lenMid + 1 + lenFillerHalant
            Loop
            Selection.Range.Text = Mid(strMemText, lenSearched1 + 1, lenMid + 1) & _
                                Left(strMemText, lenSearched1) & _
                                Right(strMemText, lenSelection - lenSearched1 - lenMid - 1)
            Selection.MoveStart Unit:=wdCharacter, Count:=lenMid + lenSearched1
        Loop
    End With
End Sub 'Shift_chhotii_i
Sub Shift_half_r(ByVal strFiller As String, ByVal strHalant As String, ByVal strR As String)
'half r to be moved backwards, dec code 2352, followed by halant

    lenFiller = Len(strFiller)
    lenHalant = Len(strHalant)
    strFillerHalant = strFiller & strHalant
    lenFillerHalant = Len(strFillerHalant)
    strSearched = strR & strFillerHalant
    lenSearched = Len(strSearched)

    Selection.HomeKey Unit:=wdStory
    Dim oRange As Range
    Set oRange = ActiveDocument.Range
    With Selection.Find
        .ClearFormatting
        .Text = strSearched

        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

        Do While .Execute
            Selection.MoveStart Unit:=wdWord, Count:=-1
            strMemText = Selection.Range.Text
            lenSelection = Len(strMemText)
            lenMid = 0

            Do While (Mid(strMemText, lenSelection - 1 - lenMid - lenSearched, lenFiller) = strFiller)
                lenMid = lenMid + lenFiller + 1
            Loop

            Do While (Mid(strMemText, lenSelection - 1 - lenMid - lenSearched, lenHalant) = strHalant)
                lenMid = lenMid + lenFillerHalant + 1
            Loop

            Selection.Range.Text = Left(strMemText, lenSelection - lenSearched - 1 - lenMid) & _
                                    Right(strMemText, lenSearched) & _
                                    Mid(strMemText, lenSelection - lenSearched - lenMid, lenMid + 1)
            Selection.MoveStart Unit:=wdCharacter, Count:=lenSelection
        Loop
    End With
End Sub 'Shift_half_r
\$\endgroup\$
3
\$\begingroup\$

It's not clear why you would need to p/invoke the native MessageBoxU function, given you're not using it anywhere, correctly preferring the language's own MsgBox wrapper.

Remove all the dead/commented-out code if you're not using it - otherwise is obscures the intent of the code.

As far as I know, Universal_Converter_v1.0 is only a valid VBA identifier if you surround it with [SquareBrackets], because the dot is a special character that cannot legally be part of an identifier. Version numbers don't belong in names either, and Upper_Snake_Case looks very strange when everything in the language's standard libraries is in PascalCase.

What happens when you make a minor change to that procedure, you increment the minor version digit and update all call sites accordingly? That's ...madness!

A good reason to refactor/rename would be to make the procedure's name start with a verb: UniversalConverter looks more like a name for a class than one for a procedure; keep nouns for types, and use verbs for procedures.

This looks confusing:

Dim arrIndexMax As Integer
Const arrIndexMax1 = 1024

Why would one be a constant and the other a variable? Avoid numeric suffixes in identifiers, they quickly make a maintenance nightmare.

Where's Option Explicit? Looks like you're using variables that aren't declared anywhere - that's another maintenance nightmare waiting to happen.

You're not consistently using Hungarian notation, some of the prefixes you use seem completely arbitrary and meaningless. I like lenXxx for a variable that's holding the length of a string because it tells the reader what the variable is used for, but strXxx and oRange (boy that one is funny! Say it 3 times out loud if you're not sure why!) have prefixes that stand for a type, and that's wrong.

The code could use some vertical whitespace between procedures and functions, it would feel less monolithic.

Functions Mid, Str, Chr, ChrW, Left and Right return a Variant, which incurs an implicit type conversion. Use the "stringly-typed" Mid$, Str$, Chr$, ChrW$, Left$ and Right$ versions instead, which return an actual String. It's not clear why you're only sometimes using them.

VBA has too many loop constructs; Do While...Loop is there only to please the fans of Do...Loop - a more succinct construct would be While...Wend.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.