' 發展單位：水海科技系統研發驗證工作室
' 撰寫人：鄭子璉(Tzu-Lien, Cheng, 璉璉) ，成大水利博肄，微軟最有價值專家
' Web: http://tlcheng.no-ip.com/TLCheng/ E-Mail: qvb3377@ms5.hinet.net
' --------------------------------------------------------------------------------------

Private Declare Function CopyPointer2String Lib "kernel32" Alias "lstrcpyA" (ByVal NewString As String, ByVal hPointerString As Long) As Long
Public Declare Function StringToPointer Lib "kernel32" Alias "lstrcpyA" (ByVal NewString As Long, ByVal OldString As String) As Long

' 字元碼
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpWideCharStr As Any, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, lpWideCharStr As Any, ByVal cchWideChar As Long) As Long

Public Enum enuAddKind
   Front = 0
   Back = 1
End Enum

' 字元碼
Public Enum enuCodePage
   CP_ACP = 0  '  default to ANSI code page
   CP_OEMCP = 1  '  default to OEM  code page
   CP_MACCP = 2
   CP_THREAD_ACP = 3
   CP_SYMBOL = 42
   CP_GB2312 = 936
   CP_Big5 = 950
   CP_Unicode = 1200
   CP_ANSI = 1252
   CP_UTF7 = 65000
   CP_UTF8 = 65001
   
   WC_COMPOSITECHECK = &H200       '  convert composite to precomposed
   WC_DISCARDNS = &H10        '  discard non-spacing chars
   WC_DEFAULTCHAR = &H40        '  replace w/ default char
   WC_SEPCHARS = &H20        '  generate separate chars

   MB_COMPOSITE = &H2         '  use composite chars
   MB_PRECOMPOSED = &H1         '  use precomposed chars
   MB_USEGLYPHCHARS = &H4         '  use glyph chars, not ctrl chars
End Enum

Private Const BufferString = 256

Public Function myMultiByteToWideChar(ByVal lpString As String, Optional ByVal CodePageFlags As enuCodePage = CP_UTF8) As String
   Dim cbWChar As Long, strBytes() As Byte
   ReDim tBytes(0) As Byte
   
   strBytes = lpString & Chr(0)
   cbWChar = MultiByteToWideChar(CodePageFlags, 0, strBytes(0), -1, tBytes(0), 0)
   
   ReDim tBytes((cbWChar - 1) * 2 - 1) As Byte
   summy = MultiByteToWideChar(CodePageFlags, 0, strBytes(0), -1, tBytes(0), cbWChar - 1)
   
   myMultiByteToWideChar = tBytes
End Function

Public Function myWideCharToMultiByte(ByVal lpString As Variant, Optional ByVal wFlags As enuCodePage = CP_UTF8)
   ' 測試 UniCode 轉 UTF-8, Byte陣列長未確實運算
   Dim cbByte As Long, strBytes() As Byte
   
   cbByte = Len(lpString) * 4
   ReDim tBytes(cbByte - 1) As Byte
   
   strBytes = lpString
   summy = WideCharToMultiByte(wFlags, 0, strBytes(0), Len(lpString), tBytes(0), cbByte, 0, 0)
   ReDim Preserve tBytes(summy - 1) As Byte
   
   myWideCharToMultiByte = tBytes
End Function

Public Function myStrComp(ByVal String1 As String, ByVal String2 As String) As Long

myStrComp = StrComp(String1, String2)

If myStrComp <> 0 Then
   len1 = String1
   len2 = String2
   
   If len1 < len2 Then
      tLen = Len(len1)
   Else
      tLen = Len(len2)
   End If
   
   myStrComp = tLen + 1
   
   For i = 1 To tLen
      If Mid(String1, i, 1) <> Mid(String2, i, 1) Then
         myStrComp = i
         Exit For
      End If
   Next i
End If

End Function

Public Function myFormat(ByVal Expression, ByVal Formatted As String)

Select Case VarType(Expression)
Case vbInteger, vbLong, vbSingle, vbDouble, vbVariant
   tStart = InStr(Formatted, "#")
   tLen = InStrContinue(Formatted, "#", tStart) - tStart
   If InStr(tStart + tLen, Formatted, ".") = tStart + tLen Then
      tDot = InStrContinue(Formatted, "#", tStart + tLen + 1) - tStart
      tFormat = "#." + String(tDot - tLen - 1, "0")
      tLen = tDot
   Else
      tFormat = "#"
   End If
   tmpVar = Format(Expression, tFormat)
   Mid(Formatted, tStart, tLen) = AddFormattoChar(tLen, tmpVar, " ", 0)
Case vbString
   tStart = InStr(Formatted, "\")
   tEnd = InStr(tStart + 1, Formatted, "\")
   tLen = tEnd - tStart + 1
   
   If MyLen(Expression) >= tLen Then
      Formatted = Left(Formatted, tStart - 1) & MyMid(Expression, 1, tLen) & Mid(Formatted, tEnd + 1)
   Else
      Formatted = Left(Formatted, tStart - 1) & Expression & Space(tLen - MyLen(Expression)) & Mid(Formatted, tEnd + 1)
   End If
Case Else
End Select
   
myFormat = Formatted

End Function

Public Function ByteToString(ByVal hByte, Optional ByVal AscII As Boolean = False) As String

ByteToString = hByte
If AscII Then
   ByteToString = StrConv(ByteToString, vbUnicode)
End If

End Function

Public Function StringToByte(ByVal hString As String, Optional ByVal AscII As Boolean = False)

Dim tByte() As Byte
If AscII Then
   tByte = StrConv(hString, vbFromUnicode)
Else
   tByte = hString
End If

StringToByte = tByte

End Function

Public Function myURLDecode(ByVal hString As String, Optional ByVal SpaceString As String = "%") As String

Dim tByte() As Byte
nCount = 0

i = 1
Do
   i = i + 1
   tStr = InstrString(hString, SpaceString, i)
   If Len(hString) >= 3 Then
      tStr = InstrString(tStr, "&")
   End If
   
   If tStr = "" Then
      Exit Do
   Else
      nCount = nCount + 1
      ReDim Preserve tByte(1 To nCount) As Byte
      tByte(nCount) = Val("&H" + Mid(tStr, 1, 2))
      
      If Len(tStr) = 3 Then
         nCount = nCount + 1
         ReDim Preserve tByte(1 To nCount) As Byte
      
         tByte(nCount) = Asc(Mid(tStr, 3, 1))
      End If
   
   End If
Loop

myURLDecode = ByteToString(tByte, True)


End Function

Public Function myQPCodeConvStr(ByVal hString As String, Optional ByVal SpaceString As String = "=") As String

i = 1

Do
   i = i + 1
   tStr = InstrString(hString, SpaceString, i)
   
   If tStr = "" Then
      Exit Do
   Else
      If Len(tStr) > 2 Then
         tStr2 = Mid(tStr, 3, 1)
         tHex = "&H" + Left(tStr, 2) + MyHex(Asc(tStr2), 2)
      Else
      
         tHex = "&H" + tStr
      
         If Val(tHex) > 127 Then
            i = i + 1
            tStr = InstrString(hString, SpaceString, i)
            tHex = tHex + tStr
         End If
      End If
      
      myQPCodeConvStr = myQPCodeConvStr + Chr(Val(tHex))
      
      If Len(tStr) > 3 Then
         myQPCodeConvStr = myQPCodeConvStr + Mid(tStr, 4)
      End If
      
   End If
Loop

End Function

Public Function myReplaceString(ByVal hString As String, ByVal hSource As String, ByVal hTarget As String) As String

tLenS = Len(hSource)
tLenT = Len(hTarget)

tChk = (tLenS = tLenT)
tLoc = 1

Do
   tLoc = InStr(tLoc, hString, hSource)
   If tLoc <> 0 Then
      If tChk Then
         Mid(hString, tLoc, tLenS) = hTarget
      Else
         hString = Left(hString, tLoc - 1) + hTarget + Mid(hString, tLoc + tLenS)
      End If
      tLoc = tLoc + tLenT
   Else
      Exit Do
   End If
Loop

myReplaceString = hString

End Function

Public Function MidAdvance(ByVal SourceString As String, ByVal StartString As String, ByVal EndString As String)

sn = InStr(SourceString, StartString) + 1
en = InStr(sn + 1, SourceString, EndString) - 1

If sn = 1 Or en = -1 Then
   MidAdvance = vbNullString
Else
   MidAdvance = Mid(SourceString, sn, en - sn + 1)
End If

End Function

Public Function PointerToString(hPointer As Long) As String

Dim tStr As String
tStr = String(BufferString, Chr$(0))
CopyPointer2String tStr, hPointer
PointerToString = Left(tStr, InStr(tStr, Chr$(0)) - 1)

End Function

Public Function AddFormattoChar(ByVal LenthofN, ByVal NChar As String, ByVal AddChar As String, Optional ByVal Kind As enuAddKind = Front)
 
If IsNull(NChar) Then
   TempC = ""
Else
   TempC = NChar
End If
 
Do Until MyLen(TempC) >= LenthofN
   
   If MyLen(AddChar) = 1 Then
      tLen = (LenthofN - MyLen(TempC))
      tAddChar = String(tLen, AddChar)
      
      Select Case Kind
      Case Is = Front
         TempC = tAddChar + TempC
      Case Is = Back
         TempC = TempC + tAddChar
      End Select
      
   Else
    
      Select Case Kind
      Case Is = Front
          TempC = AddChar + TempC
      Case Is = Back
          TempC = TempC + AddChar
      End Select
   End If
Loop

AddFormattoChar = TempC

End Function

Public Function MyLen(ByVal myString As String) As Long

MyLen = LenB(StrConv(myString, vbFromUnicode))

End Function

Public Function MyMid(ByVal myString As String, ByVal myStart, Optional ByVal myLength As Long = 0)

myChar = StrConv(myString, vbFromUnicode)
If myLength = 0 Then
   MyMid = StrConv(MidB(myChar, myStart), vbUnicode)
Else
   MyMid = StrConv(MidB(myChar, myStart, myLength), vbUnicode)
End If

End Function

Public Function InstrString(ByVal SourceString As String, Optional ByVal SpaceString As String = " ", Optional ByVal Number As Long = 1, Optional Continue As Boolean = False, Optional ChangeValue As Boolean = False)

' 輸入小於 0 傳回全部

Dim tmpLoc As Long, tmpGetNum As Long, tmpNextLoc As Long
Dim tString()

tmpLoc = 1
tmpGetNum = 0
spaceLen = Len(SpaceString)

Do
   tmpGetNum = tmpGetNum + 1
   ReDim Preserve tString(1 To tmpGetNum)
   
   If Continue Then
      tmpLoc = InStrContinue(SourceString, SpaceString, tmpLoc)
   End If
   
   tmpNextLoc = InStr(tmpLoc, SourceString, SpaceString)
   
   If tmpNextLoc = 0 Then
      If ChangeValue Then
         tString(tmpGetNum) = Val(Mid(SourceString, tmpLoc))
      Else
         tString(tmpGetNum) = Mid(SourceString, tmpLoc)
      End If
      Exit Do
   Else
      If ChangeValue Then
         tString(tmpGetNum) = Val(Mid(SourceString, tmpLoc, tmpNextLoc - tmpLoc))
      Else
         tString(tmpGetNum) = Mid(SourceString, tmpLoc, tmpNextLoc - tmpLoc)
      End If
      If tmpGetNum = Number Then
         Exit Do
      End If
      tmpLoc = tmpNextLoc + spaceLen
   End If
Loop

If Number > 0 Then
   If Number > tmpGetNum Then
      InstrString = ""
   Else
      InstrString = tString(Number)
   End If
   
   If ChangeValue Then
      InstrString = Val(InstrString)
   End If
Else
   If tString(tmpGetNum) = "" Then
      If tmpGetNum > 1 Then
         ReDim Preserve tString(1 To tmpGetNum - 1)
      End If
   End If
   InstrString = tString
End If

End Function

Public Function InStrContinue(ByVal SourceString As String, ByVal SpaceString As String, Optional ByVal Start As Long = 1)

Do
   tmpNextLoc = InStr(Start, SourceString, SpaceString)
   If tmpNextLoc <> Start Then
      Exit Do
   Else
      Start = Start + 1
   End If
Loop

InStrContinue = Start

End Function