' 撰寫人：Devil(璉璉)  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

Public Enum enuAddKind
   Front = 0
   Back = 1
End Enum

Private Const BufferString = 256

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