Attribute VB_Name = "modStr"
' -------------------------------------------------------------------------------
'
'   AVStoDVD - by MrC
'   File: modStr.bas
'   Purpose: General utility string-related function
'
' -------------------------------------------------------------------------------


Option Explicit
Option Compare Binary
Option Base 0

Public Enum KnownCodePage
    CP_UNKNOWN = -1
    CP_ACP = 0
    CP_OEMCP = 1
    CP_MACCP = 2
    CP_THREAD_ACP = 3
    CP_SYMBOL = 42
    '   ARABIC
    CP_AWIN = 101   ' Bidi Windows codepage
    CP_709 = 102    ' MS-DOS Arabic Support CP 709
    CP_720 = 103    ' MS-DOS Arabic Support CP 720
    CP_A708 = 104   ' ASMO 708
    CP_A449 = 105   ' ASMO 449+
    CP_TARB = 106   ' MS Transparent Arabic
    CP_NAE = 107    ' Nafitha Enhanced Arabic Char Set
    CP_V4 = 108     ' Nafitha v 4.0
    CP_MA2 = 109    ' Mussaed Al Arabi (MA/2) CP 786
    CP_I864 = 110   ' IBM Arabic Supplement CP 864
    CP_A437 = 111   ' Ansi 437 codepage
    CP_AMAC = 112   ' Macintosh Code Page
    '   HEBREW
    CP_HWIN = 201   ' Bidi Windows codepage
    CP_862I = 202   ' IBM Hebrew Supplement CP 862
    CP_7BIT = 203   ' IBM Hebrew Supplement CP 862 Folded
    CP_ISO = 204    ' ISO Hebrew 8859-8 Character Set
    CP_H437 = 205   ' Ansi 437 codepage
    CP_HMAC = 206   ' Macintosh Code Page
    '   CODE PAGES
    CP_OEM_437 = 437
    CP_ARABICDOS = 708
    CP_DOS720 = 720
    CP_DOS737 = 737
    CP_DOS775 = 775
    CP_IBM850 = 850
    CP_IBM852 = 852
    CP_DOS861 = 861
    CP_DOS862 = 862
    CP_IBM866 = 866
    CP_DOS869 = 869
    CP_THAI = 874
    CP_EBCDIC = 875
    CP_JAPAN = 932
    CP_CHINA = 936
    CP_KOREA = 949
    CP_TAIWAN = 950
    '   UNICODE
    CP_UNICODELITTLE = 1200
    CP_UNICODEBIG = 1201
    '   CODE PAGES
    CP_EASTEUROPE = 1250
    CP_RUSSIAN = 1251
    CP_WESTEUROPE = 1252
    CP_GREEK = 1253
    CP_TURKISH = 1254
    CP_HEBREW = 1255
    CP_ARABIC = 1256
    CP_BALTIC = 1257
    CP_VIETNAMESE = 1258
    '   KOREAN
    CP_JOHAB = 1361
    '   MAC
    CP_MAC_ROMAN = 10000
    CP_MAC_JAPAN = 10001
    CP_MAC_ARABIC = 10004
    CP_MAC_GREEK = 10006
    CP_MAC_CYRILLIC = 10007
    CP_MAC_LATIN2 = 10029
    CP_MAC_TURKISH = 10081
    '   CODE PAGES
    CP_CHINESECNS = 20000
    CP_CHINESEETEN = 20002
    CP_IA5WEST = 20105
    CP_IA5GERMAN = 20106
    CP_IA5SWEDISH = 20107
    CP_IA5NORWEGIAN = 20108
    CP_ASCII = 20127
    CP_RUSSIANKOI8R = 20866
    CP_RUSSIANKOI8U = 21866
    CP_ISOLATIN1 = 28591
    CP_ISOEASTEUROPE = 28592
    CP_ISOTURKISH = 28593
    CP_ISOBALTIC = 28594
    CP_ISORUSSIAN = 28595
    CP_ISOARABIC = 28596
    CP_ISOGREEK = 28597
    CP_ISOHEBREW = 28598
    CP_ISOTURKISH2 = 28599
    CP_ISOLATIN9 = 28605
    CP_HEBREWLOG = 38598
    CP_USER = 50000
    CP_AUTOALL = 50001
    CP_JAPANNHK = 50220
    CP_JAPANESC = 50221
    CP_JAPANISO = 50222
    CP_KOREAISO = 50225
    CP_TAIWANISO = 50227
    CP_CHINAISO = 50229
    CP_AUTOJAPAN = 50932
    CP_AUTOCHINA = 50936
    CP_AUTOKOREA = 50949
    CP_AUTOTAIWAN = 50950
    CP_AUTORUSSIAN = 51251
    CP_AUTOGREEK = 51253
    CP_AUTOARABIC = 51256
    CP_JAPANEUC = 51932
    CP_CHINAEUC = 51936
    CP_KOREAEUC = 51949
    CP_TAIWANEUC = 51950
    CP_CHINAHZ = 52936
    CP_GB18030 = 54936
    '   UNICODE
    CP_UTF7 = 65000
    CP_UTF8 = 65001
End Enum
 
Const MB_PRECOMPOSED = &H1
Const MB_COMPOSITE = &H2
Const MB_USEGLYPHCHARS = &H4
Const MB_ERR_INVALID_CHARS = &H8
 
Const WC_DEFAULTCHECK = &H100                ' check for default char
Const WC_COMPOSITECHECK = &H200              ' convert composite to precomposed
Const WC_DISCARDNS = &H10                    ' discard non-spacing chars
Const WC_SEPCHARS = &H20                     ' generate separate chars
Const WC_DEFAULTCHAR = &H40                  ' replace with default char
 
Declare Function GetACP Lib "KERNEL32" () As Long
Declare Function lstrlenW Lib "KERNEL32" (ByVal pStr As Long) As Long
Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal OleStr As Long, ByVal bLen As Long) As Long
Declare Function SysAllocStringLen Lib "oleaut32" (ByVal OleStr As Long, ByVal bLen As Long) As Long
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 cchMultiByte As Long, ByVal lpDefaultChar As Long, lpUsedDefaultChar As Long) As Long
Declare Function MultiByteToWideChar Lib "KERNEL32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long

Declare Sub PutMem4 Lib "msvbvm60" (Destination As Any, value As Any)
Declare Sub RtlMoveMemory Lib "KERNEL32" (pDst As Any, pSrc As Any, ByVal bLen As Long)


' Return DefaultValue if Str is empty
Public Function DefaultStr(Str As String, DefaultValue As String)

    If Str = "" Then
        DefaultStr = DefaultValue
    Else
        DefaultStr = Str
    End If

End Function


' Remove a char from beginning and end of a string
Public Function RemoveCharBegEnd(Str As String, Char As String, Optional Char2 As String) As String

    Dim Flag As Boolean
    
    On Error GoTo Err_Handling
    
    RemoveCharBegEnd = Str
    If RemoveCharBegEnd <> "" Then
        Do Until Flag = True
            If Left(RemoveCharBegEnd, 1) = Char Then
                RemoveCharBegEnd = Right(RemoveCharBegEnd, Len(RemoveCharBegEnd) - 1)
            End If
            If RemoveCharBegEnd = "" Then Exit Function
            If Left(RemoveCharBegEnd, 1) = Char2 Then
                RemoveCharBegEnd = Right(RemoveCharBegEnd, Len(RemoveCharBegEnd) - 1)
            End If
            If RemoveCharBegEnd = "" Then Exit Function
            If Right(RemoveCharBegEnd, 1) = Char Then
                RemoveCharBegEnd = Left(RemoveCharBegEnd, Len(RemoveCharBegEnd) - 1)
            End If
            If RemoveCharBegEnd = "" Then Exit Function
            If Right(RemoveCharBegEnd, 1) = Char2 Then
                RemoveCharBegEnd = Left(RemoveCharBegEnd, Len(RemoveCharBegEnd) - 1)
            End If
            If RemoveCharBegEnd = "" Then Exit Function
            If Left(RemoveCharBegEnd, 1) <> Char And Left(RemoveCharBegEnd, 1) <> Char2 And Right(RemoveCharBegEnd, 1) <> Char And Right(RemoveCharBegEnd, 1) <> Char2 Then
                Flag = True
            End If
        Loop
    End If
    
    Exit Function
    
Err_Handling:
RemoveCharBegEnd = Str

End Function


' Remove part (Str) of a string
Public Function RemoveStr(FullStr As String, Str As String) As String

    On Error GoTo Err_Handling
        
    If InStr(1, FullStr, Str) <> 0 Then
        RemoveStr = Mid(FullStr, 1, InStr(1, FullStr, Str) - 1) & _
                    Mid(FullStr, InStr(1, FullStr, Str) + Len(Str), Len(FullStr) - InStr(1, FullStr, Str) + Len(Str))
    End If
    If RemoveStr = "" Then
        RemoveStr = FullStr
    End If
    
    Exit Function
    
Err_Handling:
RemoveStr = FullStr

End Function


'Input: String containing null terminator (Chr(0))
'Returns: all character before the null terminator
Public Function StripNull(ByVal InString As String) As String

    Dim iNull As Integer
    
    If Len(InString) > 0 Then
        iNull = InStr(InString, vbNullChar)
        Select Case iNull
        Case 0
            StripNull = InString
        Case 1
            StripNull = ""
        Case Else
           StripNull = Left$(InString, iNull - 1)
       End Select
    End If

End Function


'Input: String containing double null terminator (Chr(0) + Chr(0))
'Returns: all character before the double null terminator
Public Function StripNullEnd(ByRef InString As String) As String
     
    Dim iNull As Integer
     
    ' Remove double null terminator
    iNull = InStr(1, InString, Chr(0) & Chr(0))
    If iNull > 0 Then
        StripNullEnd = Left$(InString, iNull - 1)
    Else
        StripNullEnd = InString
    End If
    
End Function


' Return a time in seconds in hours:minutes:seconds.milliseconds format
Public Function VisualTime(ByVal DurationSeconds As Single, Optional ShortFormat As Boolean, Optional Add_ms As Boolean) As String

    Dim TimeSplit() As String
    Dim ms As Integer
    
    VisualTime = Format(Int(DurationSeconds) / 24 / 3600, "hh.nn.ss")
    TimeSplit = Split(VisualTime, ".")
    If Round(DurationSeconds - Int(DurationSeconds), 3) = 1 Then
        TimeSplit(2) = TimeSplit(2) + 1
        ms = 0
    Else
        ms = Round(DurationSeconds - Int(DurationSeconds), 3) * 1000
    End If
    If ShortFormat = False Then
        If ms > 500 Then
            TimeSplit(2) = Format(Val(TimeSplit(2)) + 1, "00")
        End If
        If Val(TimeSplit(0)) > 0 Then
            VisualTime = Val(TimeSplit(0)) & ":" & TimeSplit(1) & ":" & TimeSplit(2) & " hours"
        ElseIf Val(TimeSplit(1)) > 0 Then
            VisualTime = Val(TimeSplit(1)) & ":" & TimeSplit(2) & " minutes"
        Else
            VisualTime = Val(TimeSplit(2)) & " seconds"
        End If
    Else
        If Add_ms = False Then
            If ms > 500 Then
                TimeSplit(2) = Format(Val(TimeSplit(2)) + 1, "00")
            End If
            VisualTime = TimeSplit(0) & ":" & TimeSplit(1) & ":" & TimeSplit(2)
        Else
            VisualTime = TimeSplit(0) & ":" & TimeSplit(1) & ":" & TimeSplit(2) & "." & PadLeft(ms, "0", 3)
        End If
    End If
   
End Function


' Pad the left side of a string with a character
Public Function PadLeft(ByVal InString As String, ByVal PadChar As String, TargetLength As Long) As String

    On Error GoTo Err_Handling
    
    If Len(InString) < TargetLength Then
        PadLeft = String(TargetLength - Len(InString), PadChar) & InString
    Else
        PadLeft = InString
    End If
    
    Exit Function
    
Err_Handling:
PadLeft = InString

End Function


' Left Trim a string until TrimChar is found
Public Function StrTrimLeft(StrOrig As String, TrimChar As String)
    
    On Error GoTo Err_Handling
    
    If StrOrig <> "" And TrimChar <> "" And InStr(1, StrOrig, TrimChar) <> 0 Then
        StrTrimLeft = StrOrig
        Do Until Right(StrTrimLeft, 1) = TrimChar
            StrTrimLeft = Left(StrTrimLeft, Len(StrTrimLeft) - 1)
        Loop
        StrTrimLeft = Left(StrTrimLeft, Len(StrTrimLeft) - 1)
    End If
    Exit Function
    
Err_Handling:
StrTrimLeft = ""

End Function


' Right Trim a string until TrimChar is found
Function StrTrimRight(StrOrig As String, TrimChar As String) As String

    On Error GoTo Err_Handling
    
    If StrOrig <> "" And TrimChar <> "" And InStr(1, StrOrig, TrimChar) <> 0 Then
        StrTrimRight = StrOrig
        Do Until Left(StrTrimRight, 1) = TrimChar
            StrTrimRight = Right(StrTrimRight, Len(StrTrimRight) - 1)
        Loop
        StrTrimRight = Right(StrTrimRight, Len(StrTrimRight) - 1)
    End If
    
    Exit Function
    
Err_Handling:
StrTrimRight = ""

End Function


' Returns a 6 chars String representing the hexadecimal value of a number
Public Function CHex(ByVal Number As Long) As String

    Dim SixCharString As String
    
    SixCharString = String(6 - Len(Hex(Number)), "0") & Hex(Number)
    CHex = Right(SixCharString, 2) & Mid(SixCharString, 3, 2) & Left(SixCharString, 2)
    
End Function


' Remove reserved/special chars from string
'   \  -> chr(92)
'   /  -> chr(47)
'   :  -> chr(58)
'   *  -> chr(42)
'   ?  -> chr(63)
'   "  -> chr(34)
'   <  -> chr(60)
'   >  -> chr(62)
'   |  -> chr(124)
'   CR -> chr(13)
'   LF -> chr(10)
Public Function RemoveSpecialChars(StrOrig As String) As String

    Dim jj As Integer
  
    On Error GoTo Err_Handling
    
    For jj = 1 To Len(StrOrig)
        Select Case Asc(Mid(StrOrig, jj, 1))
        Case 10, 13, 34, 42, 47, 58, 60, 62, 63, 92, 124
            RemoveSpecialChars = RemoveSpecialChars & ""
        Case Else
            RemoveSpecialChars = RemoveSpecialChars & Mid(StrOrig, jj, 1)
        End Select
    Next jj
    
    Exit Function

Err_Handling:
RemoveSpecialChars = ""

End Function
 
 
 ' Convert a C wchar* to a Visual Basic string
Public Function bStr(ptr As Long) As String
  
  Dim l As Long

  l = lstrlenW(ptr)
  bStr = String$(l, vbNullChar)

  RtlMoveMemory ByVal StrPtr(bStr), ByVal ptr, l * 2

End Function


' Return system Code Page
Public Function GetCodePage() As Long

    GetCodePage = GetACP
    
End Function


' Return true if Extended ASCII chars are found
Public Function HasExtendedChars(StrOrig As String) As Boolean

    Dim jj As Integer
    
    On Error GoTo Err_Handling
    
    For jj = 1 To Len(StrOrig)
        If Asc(Mid(StrOrig, jj, 1)) > 127 Then
            HasExtendedChars = True
            Exit For
        End If
    Next jj

    Exit Function

Err_Handling:
HasExtendedChars = False

End Function

 
' Converts a UTF-8 byte array to a Unicode string
Public Function sUTF8toUni(bySrc() As Byte) As String

    Dim lBytes As Long, lNC As Long, lRet As Long

    lBytes = UBound(bySrc) - LBound(bySrc) + 1
    lNC = lBytes
    sUTF8toUni = String$(lNC, Chr(0))
    lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(bySrc(LBound(bySrc))), lBytes, StrPtr(sUTF8toUni), lNC)
    sUTF8toUni = Left$(sUTF8toUni, lRet)

End Function


' Convert a UTF8 text file into a ANSI text file
Public Function UTF8FiletoANSIFile(sUTF8FilePathname As String, sANSIFilePathname As String, Optional bSRT As Boolean) As Boolean

    Dim iFile As Integer
    Dim bData() As Byte
    Dim sData As String
    Dim lSize As Long
    Dim jj As Long

    On Error GoTo Err_Handling
    
    ' Get the incoming data size
    lSize = FileLen(sUTF8FilePathname)
    If lSize > 0 Then
        ReDim bData(0 To lSize - 1)

        ' Read the existing UTF-8 file
        iFile = FreeFile()
        Open sUTF8FilePathname For Binary As #iFile
            Get #iFile, , bData
        Close #iFile

        ' Convert all the data to Unicode (all VB Strings are Unicode)
        sData = sUTF8toUni(bData)
        
        ' Handle SRT subs output
        If bSRT = True Then
            For jj = 1 To Len(sData)
                If Mid(sData, jj, 1) = "1" Then
                    Exit For
                End If
            Next jj
            sData = Right(sData, Len(sData) - jj + 1)
        End If
    End If

    ' Now write it all out to the ANSI file
    If sData <> "" Then
        iFile = FreeFile()
        Open sANSIFilePathname For Output As #iFile
            Print #iFile, sData
        Close iFile
        If Dir(sANSIFilePathname) <> "" Then
            UTF8FiletoANSIFile = True
        End If
    End If
    
    Exit Function
    
Err_Handling:
UTF8FiletoANSIFile = False
    
End Function


' Output a ANSI string to a UTF8 text file
Public Sub sANSItoUTF8File(Str As String, PathnameSave As String)
   
    Dim fso, MyFile
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set MyFile = fso.CreateTextFile(PathnameSave, True, True)
    MyFile.WriteLine (Str)
    MyFile.Close

End Sub


' Output a ANSI string to a ANSI text file
Public Function STRtoANSIFile(Str As String, PathnameSave As String) As Boolean
   
    Dim NumFile As Integer
    
    On Error GoTo Err_Handling
    
    NumFile = FreeFile
    Open PathnameSave For Output As #NumFile
        Print #NumFile, Str
    Close #NumFile
    
    If Dir(PathnameSave) <> "" Then STRtoANSIFile = True
    
    Exit Function
    
Err_Handling:
STRtoANSIFile = False

End Function


' Convert a long digit representing a color into RGB string
Public Function LongtoRGB(lColor As Long) As String

    LongtoRGB = (lColor And 255) & "," & (Int(lColor / 256) And 255) & "," & (Int(lColor / 65536) And 255)
    
End Function


Public Function IsUTF8(ByRef Text As String, Optional ByVal lngReadSize As Long = 2048) As Boolean

    Dim bytArray() As Byte, lngArraySize As Long, lngBytes As Long, lngPos As Long, lngUTF8 As Long
    
    lngArraySize = LenB(Text)
    If lngArraySize Then
        If lngReadSize > 0 Then
            ' see if we take the entire string or just a part of it
            If lngReadSize > lngArraySize Then
                ' take everything
                lngReadSize = lngArraySize
                bytArray = Text
            Else
                ' take just the part of it
                bytArray = LeftB$(Text, lngReadSize)
            End If
            ' now keep going until we have gone through the entire buffer
            Do While lngPos < lngReadSize
                ' the code here is just standard UTF-8 decoding
                If bytArray(lngPos) < &H80 Then
                    lngPos = lngPos + 1
                ElseIf bytArray(lngPos) < &HC0 Then
                    Exit Function
                ElseIf (bytArray(lngPos) >= &HC0) And (bytArray(lngPos) <= &HFD) Then
                    If (bytArray(lngPos) And &HFC) = &HFC Then
                        lngBytes = 5
                    ElseIf (bytArray(lngPos) And &HF8) = &HF8 Then
                        lngBytes = 4
                    ElseIf (bytArray(lngPos) And &HF0) = &HF0 Then
                        lngBytes = 3
                    ElseIf (bytArray(lngPos) And &HE0) = &HE0 Then
                        lngBytes = 2
                    ElseIf (bytArray(lngPos) And &HC0) = &HC0 Then
                        lngBytes = 1
                    End If
                    For lngPos = (lngPos + 1) To (lngPos + lngBytes)
                        If Not ((bytArray(lngPos) >= &H80) And (bytArray(lngPos) <= &HBF)) Then
                            Exit Function
                        ElseIf lngPos >= lngReadSize Then
                            Exit Do
                        End If
                    Next lngPos
                    'lngUTF8 = lngUTF8 + 1
                Else
                    lngPos = lngPos + 1
                End If
            Loop
            IsUTF8 = True 'lngUTF8 > 0
        End If
    End If
    
End Function


Public Function UTF16toUTF8(ByRef Text As String) As String
    
    Dim lngBufferLen As Long, lngBufferPtr As Long, lngTextLen As Long, strBuffer As String, TextOut As String
    
    ' first check text length
    lngTextLen = Len(Text)
    If lngTextLen Then
        ' calculate maximum output size
        lngBufferLen = lngTextLen * 4
        ' create the buffer string to hold output data
        lngBufferPtr = SysAllocStringByteLen(0, lngBufferLen)
        PutMem4 ByVal VarPtr(strBuffer), ByVal lngBufferPtr
        ' convert to UTF-8
        lngBufferLen = WideCharToMultiByte(CP_UTF8, 0&, StrPtr(Text), lngTextLen, lngBufferPtr, lngBufferLen, 0&, ByVal 0&)
        ' output as is best fit
        If lngBufferLen > 0 Then
            TextOut = LeftB$(strBuffer, lngBufferLen)
        Else
            TextOut = vbNullString
        End If
        ' clean buffer
        strBuffer = vbNullString
    Else
        TextOut = vbNullString
    End If
    UTF16toUTF8 = TextOut

End Function


Public Function UTF8toUTF16(ByRef Text As String) As String
    
    Dim lngBufferLen As Long, lngBufferPtr As Long, lngTextLen As Long, strBuffer As String, TextOut As String
    
    ' first check text length
    lngTextLen = LenB(Text)
    If lngTextLen Then
        ' calculate maximum output size
        lngBufferLen = lngTextLen * 2
        ' create the buffer string to hold output data
        lngBufferPtr = SysAllocStringByteLen(0, lngBufferLen)
        PutMem4 ByVal VarPtr(strBuffer), ByVal lngBufferPtr
        ' convert from UTF-8
        lngBufferLen = MultiByteToWideChar(CP_UTF8, 0&, StrPtr(Text), lngTextLen, lngBufferPtr, lngBufferLen)
        ' output as is best fit
        If lngBufferLen > 0 Then
            TextOut = Left$(strBuffer, lngBufferLen)
        Else
            TextOut = vbNullString
        End If
        ' clean buffer
        strBuffer = vbNullString
    Else
        TextOut = vbNullString
    End If
    UTF8toUTF16 = TextOut

End Function


Public Function ANSItoUTF16(ByRef bText() As Byte, Optional ByVal cPage As KnownCodePage = CP_UNKNOWN, Optional lFlags As Long) As Byte()
    
    Static tmpArr() As Byte, textStr As String
    Dim tmpLen As Long
    Dim textLen As Long
    Dim A As Long
    'Dim bText() As Byte
    'Dim jj As Integer
    'Dim sTextExt As String
    
    'bText() = sText
    If UBound(bText) > 0 Then
        ' set code page to a valid one
        If cPage = CP_UNKNOWN Then cPage = GetACP
        If cPage = CP_ACP Or cPage = CP_WESTEUROPE Then
            textLen = UBound(bText)
            tmpLen = textLen + textLen + 1
            If (Not tmpArr) = True Then ReDim Preserve tmpArr(tmpLen)
            If UBound(tmpArr) <> tmpLen Then ReDim Preserve tmpArr(tmpLen)
            For A = 0 To UBound(bText)
                tmpArr(A + A) = bText(A)
            Next A
        Else
            textStr = CStr(bText) & "|"
            textLen = LenB(textStr)
            tmpLen = textLen + textLen
            ReDim Preserve tmpArr(tmpLen + 1)
            ' get the new string to tmpArr
            tmpLen = MultiByteToWideChar(CLng(cPage), lFlags, ByVal StrPtr(textStr), -1, _
                                         ByVal VarPtr(tmpArr(0)), tmpLen)
            If tmpLen = 0 Then Exit Function
            tmpLen = tmpLen + tmpLen - 5
            'If tmpArr(tmpLen - 1) = 0 And tmpArr(tmpLen) = 0 Then tmpLen = tmpLen - 2
            If UBound(tmpArr) <> tmpLen Then ReDim Preserve tmpArr(tmpLen)
        End If
        ANSItoUTF16 = tmpArr
        'sTextExt = tmpArr
        '' return the result
        'For jj = 1 To Len(sTextExt) Step 2
        '    ANSItoUTF16 = ANSItoUTF16 & Mid(sTextExt, jj, 1)
        'Next jj
    End If

End Function


Public Function UTF16toANSI(ByRef Text() As Byte, Optional ByVal cPage As KnownCodePage = CP_UNKNOWN, Optional lFlags As Long) As Byte()
    
    Static tmpArr() As Byte
    Dim tmpLen As Long, textLen As Long, A As Long
    
    If (Not Text) = True Then Exit Function
    ' set code page to a valid one
    If cPage = CP_UNKNOWN Then cPage = GetACP
    If cPage = CP_ACP Or cPage = CP_WESTEUROPE Then
        textLen = UBound(Text)
        tmpLen = (textLen + 1) \ 2 - 1
        If (Not tmpArr) = True Then ReDim Preserve tmpArr(tmpLen)
        If UBound(tmpArr) <> tmpLen Then ReDim Preserve tmpArr(tmpLen)
        For A = 0 To tmpLen
            tmpArr(A) = Text(A + A)
        Next A
    Else
        textLen = (UBound(Text) + 1) \ 2
        ' at maximum ANSI can be four bytes per character in new Chinese encoding GB18030–2000
        tmpLen = textLen + textLen + textLen + textLen + 1
        ReDim Preserve tmpArr(tmpLen - 1)
        ' get the new string to tmpArr
        tmpLen = WideCharToMultiByte(CLng(cPage), lFlags, ByVal VarPtr(Text(0)), textLen, ByVal VarPtr(tmpArr(0)), _
                                     tmpLen, ByVal 0&, ByVal 0&)
        If tmpLen = 0 Then Exit Function
        ' a hopeless try to correct a weird error?
        ReDim Preserve tmpArr(tmpLen - 1)
    End If
    ' return the result
    UTF16toANSI = tmpArr
    
End Function

