VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 2  'vbComplexBound
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "myVBDll"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Option Base 0
Private Declare Function BitAnd Lib "MyVCdll.dll" (ByVal nFirstNum As Long, ByVal nSecondNum As Long) As Long
Private Declare Function BitLeftShift Lib "MyVCdll.dll" (ByVal nFirstNum As Long, ByVal nSecondNum As Integer) As Long
Private Declare Function BitRightShift Lib "MyVCdll.dll" (ByVal nFirstNum As Long, ByVal nSecondNum As Integer) As Long
Public Function vbBitAnd(ByVal nFirstNum As Long, ByVal nSecondNum As Long) As Long
    vbBitAnd = BitAnd(nFirstNum, nSecondNum)
End Function
Public Function vbBitLeftShift(ByVal nFirstNum As Long, ByVal nSecondNum As Integer) As Long
    vbBitLeftShift = BitLeftShift(nFirstNum, nSecondNum)
End Function
Public Function vbBitRightShift(ByVal nFirstNum As Long, ByVal nSecondNum As Integer) As Long
    vbBitRightShift = BitRightShift(nFirstNum, nSecondNum)
End Function
'7-bit解碼
'strInput: 源編碼串
'返回: 目標字符串
Public Function Decode7BitASC(ByVal strInput As String) As String
    Dim iTmp    As Integer
    Dim iSrc()  As Integer
    Dim iDst()  As Integer
    Dim idxSrc      As Long      '源字符串的計數值
    Dim idxDst      As Long      '目標解碼串的計數值
    Dim idxByte     As Long      '當前正在處理的組內字節的序號，范圍是0-6
    Dim iLeft       As Long      '上一字節殘余的數據
    Dim nD          As Long
    Dim blReturn        As Boolean
    Dim strMyString()   As String
    Dim strOutput       As String
    On Error Resume Next
    blReturn = String2Array(strInput, " ", nD, strMyString(), True)
    ReDim iSrc(0 To nD)
    ReDim iDst(0 To nD * 2)
    For idxSrc = 0 To nD - 1
        iSrc(idxSrc) = Hex2Dec(strMyString(idxSrc))
    Next idxSrc
    '計數值初始化
    idxSrc = 0
    idxDst = 0
    '組內字節序號和殘余數據初始化
    idxByte = 0
    iLeft = 0
    '將源數據每7個字節分為一組，解壓縮成8個字節
    '循環該處理過程，直至源數據被處理完
    '如果分組不到7字節，也能正確處理
    While idxSrc < nD
        '將源字節右邊部分與殘余數據相加，去掉最高位，得到一個目標解碼字節
        iTmp = BitLeftShift(iSrc(idxSrc), idxByte)
        iTmp = iTmp Or iLeft
        iDst(idxDst) = iTmp And &H7F
        '將該字節剩下的左邊部分，作為殘余數據保存起來
        iLeft = BitRightShift(iSrc(idxSrc), (7 - idxByte))
        '修改目標串的指針和計數值
        idxDst = idxDst + 1
        '修改字節計數值
        idxByte = idxByte + 1
        '到了一組的最后一個字節
        If idxByte = 7 Then
            '額外得到一個目標解碼字節
            iDst(idxDst) = iLeft
            '修改目標串的指針和計數值
            idxDst = idxDst + 1
            '組內字節序號和殘余數據初始化
            idxByte = 0
            iLeft = 0
        End If
        '修改源串的指針和計數值
        idxSrc = idxSrc + 1
    Wend
    For idxSrc = 0 To idxDst - 1
        strOutput = strOutput & Chr(iDst(idxSrc))
    Next idxSrc
    Decode7BitASC = strOutput
End Function
'7-bit編碼
'strInput: 源字符串
'iArrayRtn: 目標編碼數組
Public Function Encode7BitASC(ByVal strInput As String) As String
    Dim idxSrc      As Long      '源字符串的計數值
    Dim idxDst      As Long      '目標編碼串的計數值
    Dim idxChar     As Long      '當前正在處理的組內字符字節的序號，范圍是0-7
    Dim iLeft       As Long      '上一字節殘余的數據
    Dim nSrcLength  As Long      '源字符串長度
    Dim iTmp        As Integer
    Dim iSrc()      As Integer
    Dim i           As Integer
    Dim iArrayRtn() As Integer
    On Error Resume Next
    idxSrc = 0
    idxDst = 0
    nSrcLength = Len(strInput)
    ReDim iSrc(0 To nSrcLength)
    ReDim iArrayRtn(0 To nSrcLength)
    For i = 1 To nSrcLength
        iSrc(i - 1) = AscB(Mid(strInput, i, 1))
    Next i
    '將源串每8個字節分為一組，壓縮成7個字節
    '循環該處理過程，直至源串被處理完
    '如果分組不到8字節，也能正確處理
    For idxSrc = 0 To nSrcLength
        '取源字符串的計數值的最低3位
        idxChar = idxSrc And 7
        '處理源串的每個字節
        If idxChar = 0 Then
            '組內第一個字節，只是保存起來，待處理下一個字節時使用
            iLeft = iSrc(idxSrc)
        Else
        '組內其它字節，將其右邊部分與殘余數據相加，得到一個目標編碼字節
            iTmp = BitLeftShift(iSrc(idxSrc), (8 - idxChar))
            DoEvents
            iTmp = BitAnd(iTmp, &HFF)
            iTmp = iTmp Or iLeft
            If iTmp <> 0 Then
                iArrayRtn(idxDst) = iTmp
                '修改目標串的指針和計數值 idxDst++;
                idxDst = idxDst + 1
            End If
            '將該字節剩下的左邊部分，作為殘余數據保存起來
            iLeft = BitRightShift(iSrc(idxSrc), idxChar)
        End If
    Next idxSrc
    Dim nTmp As Long
    Dim strTmp As String
    Encode7BitASC = ""
    For nTmp = 0 To idxDst
        strTmp = Hex(iArrayRtn(nTmp))
        If Len(strTmp) < 2 Then strTmp = "0" & strTmp
    Next nTmp
    Encode7BitASC = Trim(strTmp)
End Function
Public Function ASCII2Char(ByVal strAsc As String) As String
    Dim i       As Integer
    Dim j       As Integer
    Dim strTmp  As String
    Dim strTmpA As String
    Dim strTmpB As String
    On Error Resume Next
    j = Len(strAsc)
    strTmpB = ""
    For i = 1 To j
        strTmpA = Mid(strAsc, i, 1)
        If strTmpA <> " " Then strTmpB = strTmpB & strTmpA
    Next i
    j = Len(strTmpB)
    strTmp = ""
    For i = 1 To j Step 2
        strTmpA = Mid(strTmpB, i, 2)
        strTmp = strTmp & ChrB(Hex2Dec(strTmpA))
    Next i
    ASCII2Char = strTmp
End Function
Public Function CharToAscii(ByVal strChar As String) As String
    Dim iAsc As Integer
    Dim n1      As Long
    Dim n2      As Long
    Dim strTmp  As String
    Dim strTmp1 As String
    Dim strTmp2 As String
    On Error Resume Next
    n1 = LenB(strChar)
    strTmp = ""
    For n2 = 1 To n1
        iAsc = AscB(MidB(strChar, n2, 1))
        If iAsc <> 0 Then
            strTmp1 = Hex(iAsc)
            If Len(strTmp1) < 2 Then strTmp1 = "0" & strTmp1
            strTmp = strTmp & strTmp1 & " "
        End If
    Next n2
    CharToAscii = Trim(strTmp)
End Function
Public Function Hex2Dec(ByVal strInput As String) As Long
    Dim i       As Integer
    Dim j       As Integer
    Dim iLen    As Integer
    Dim iTmp    As Integer
    Dim nRet    As Long
    Dim strTmp  As String
    On Error Resume Next
    If strInput <> "" Then
        iLen = Len(strInput)
        nRet = 0
        For i = 1 To iLen
            iTmp = Asc(Mid(strInput, i, 1))
            If iTmp >= 48 And iTmp <= 57 Then               '"0" = 48, "9" = 57
                nRet = nRet + (iTmp - 48) * 16 ^ (iLen - i)
            ElseIf iTmp >= 65 And iTmp <= 70 Then           '"A" = 65, "F" = 70
                nRet = nRet + (iTmp - 55) * 16 ^ (iLen - i)
            ElseIf iTmp >= 97 And iTmp <= 102 Then          '"a" = 97, "f" = 102
                nRet = nRet + (iTmp - 87) * 16 ^ (iLen - i)
            Else
                nRet = 0
                Exit For
            End If
        Next i
    End If
    Hex2Dec = nRet
End Function
Public Function GB2Unicode(ByVal strGB As String) As String
    Dim byteA()         As Byte
    Dim i               As Integer
    Dim strTmpUnicode   As String
    Dim strA            As String
    Dim strB            As String
    On Error GoTo ErrorUnicode
    i = LenB(strGB)
    ReDim byteA(1 To i)
    For i = 1 To LenB(strGB)
        strA = MidB(strGB, i, 1)
        byteA(i) = AscB(strA)
    Next i
    '此時已經將strGB轉換為Unicode編碼，保存在數組byteA()中。
    '下面需要調整順序并以字符串的形式返回
    strTmpUnicode = ""
    For i = 1 To UBound(byteA) Step 2
        strA = Hex(byteA(i))
        If Len(strA) < 2 Then strA = "0" & strA
        strB = Hex(byteA(i + 1))
        If Len(strB) < 2 Then strB = "0" & strB
        strTmpUnicode = strTmpUnicode & strB & strA
    Next i
    GB2Unicode = strTmpUnicode
    Exit Function
ErrorUnicode:
    MsgBox "錯誤：" & Err & "." & vbCrLf & Err.Description
    GB2Unicode = ""
End Function
Public Function Unicode2GB(ByVal strUnicode As String) As String
    Dim byteA()     As Byte
    Dim i           As Integer
    Dim strTmp      As String
    Dim strTmpGB    As String
    On Error GoTo ErrUnicode2GB
    i = Len(strUnicode) / 2
    ReDim byteA(1 To i)
    For i = 1 To Len(strUnicode) / 2 Step 2
        strTmp = Mid(strUnicode, i * 2 - 1, 2)
        strTmp = Hex2Dec(strTmp)
        byteA(i + 1) = strTmp
        strTmp = Mid(strUnicode, i * 2 + 1, 2)
        strTmp = Hex2Dec(strTmp)
        byteA(i) = strTmp
    Next i
    strTmpGB = ""
    For i = 1 To UBound(byteA)
        strTmp = byteA(i)
        strTmpGB = strTmpGB & ChrB(strTmp)
    Next i
    Unicode2GB = strTmpGB
    Exit Function
ErrUnicode2GB:
    MsgBox "Err=" & Err.Number & ",原因：" & Err.Description
    Unicode2GB = ""
End Function
'此函數是將一個字符串中以charRef為分隔符的元素保存到數組MyStr()中
'參數：
'YourStr：  待分隔的字符串
'charRef：  分隔符號
'isNormal： 如果為假，則表示分隔符可能由多個空格組成，例如Tab符號。
'nD：       返回值，表示有多少個元素
'MyStr()：  返回值，保存分隔后的各個元素。
Public Function String2Array(ByVal YourStr As String, ByVal charRef As String, ByRef nD As Long, ByRef MyStr() As String, ByVal isNormal As Boolean) As Boolean
    Dim i           As Long
    Dim j           As Long
    Dim nUBound     As Long
    Dim iAsc        As Integer
    Dim strChar     As String
    Dim strTmp      As String
    Dim aryTr()     As String
    On Error GoTo ErrorDecode
    strChar = ""
    YourStr = Trim(YourStr)     '首先去掉字符串兩邊的空格
    nUBound = 1
    j = 0
    ReDim aryTr(1 To nUBound)
    If Not isNormal Then
        For i = 1 To Len(YourStr)
            strTmp = Mid(YourStr, i, 1)
            iAsc = Asc(strTmp)
            If iAsc > 122 Or iAsc < 33 Then
                strChar = Mid(YourStr, i - j, j)
                If strChar <> "" Then
                    aryTr(nUBound) = strChar
                    nUBound = nUBound + 1
                    ReDim Preserve aryTr(1 To nUBound)
                End If
                strChar = ""
                j = 0
            Else
                j = j + 1
                If i = Len(YourStr) Then
                    strChar = Mid(YourStr, i - j + 1, j)
                    aryTr(nUBound) = strChar
                End If
            End If
        Next i
        nD = nUBound
        ReDim MyStr(0 To nUBound - 1)
        For i = 1 To nUBound
            MyStr(i - 1) = aryTr(i)
        Next i
        String2Array = True
    Else
        For i = 1 To Len(YourStr)
            strTmp = Mid(YourStr, i, 1)
            If strTmp = charRef Then
                strChar = Mid(YourStr, i - j, j)
                If strChar <> "" Then
                    aryTr(nUBound) = strChar
                    nUBound = nUBound + 1
                    ReDim Preserve aryTr(1 To nUBound)
                End If
                strChar = ""
                j = 0
            Else
                j = j + 1
                If i = Len(YourStr) Then
                    strChar = Mid(YourStr, i - j + 1, j)
                    aryTr(nUBound) = strChar
                End If
            End If
        Next i
        nD = nUBound
        ReDim MyStr(0 To nUBound - 1)
        For i = 1 To nUBound
            MyStr(i - 1) = aryTr(i)
        Next i
        String2Array = True
    End If
    Exit Function
ErrorDecode:
    MsgBox Err.Number & ":" & Err.Description
    String2Array = False
End Function
Public Sub QuickSort(InputArray() As Double, LowPos As Integer, HighPos As Integer)
    Dim iPivot As Integer

    If LowPos < HighPos Then
        iPivot = PartitionA(InputArray, LowPos, HighPos)
        Call QuickSort(InputArray, LowPos, iPivot - 1)
        Call QuickSort(InputArray, iPivot + 1, HighPos)
    End If
End Sub
Private Sub Swap(InputArray() As Double, FirstPos As Integer, SecondPos As Integer)
    Dim dblTmp As Double
    dblTmp = InputArray(FirstPos)
    InputArray(FirstPos) = InputArray(SecondPos)
    InputArray(FirstPos) = dblTmp
End Sub
Private Function PartitionA(r() As Double, ByVal iB As Integer, ByVal iE As Integer) As Integer
    '//并返回基準記錄的位置
    Dim dblPivot As Double
    '===== 用區間的第1個記錄作為基準 =====
    dblPivot = r(iB)
    '===== { 從區間兩端交替向中間掃描，直至iB=iE為止 =====
    Do While (iB < iE)
        '----- pivot相當于在位置iB上 -----
        Do While (iB < iE And r(iE) >= dblPivot)
            '--- 從右向左掃描，查找第1個小于Pivot的記錄R(iE) ---
            iE = iE - 1
        Loop
        '----- 表示找到的R(iE) < dblPivot -----
        If (iB < iE) Then
            '--- 相當于交換R(ib)和R(ie)，交換后iB指針加1 ---
            r(iB) = r(iE)
            iB = iB + 1
        End If
        '----- Pivot相當于在位置iE上 -----
        Do While (iB < iE And r(iB) <= dblPivot)
            '--- 從左向右掃描，查找第1個大于Pivot的記錄R(iB) ---
            iB = iB + 1
        Loop
        '----- 表示找到了R(iB)，使R(iB) > Pivot -----
        If (iB < iE) Then
            '--- 相當于交換R(iB)和R(iE)，交換后iE指針減1 ---
            r(iE) = r(iB)
            iE = iE - 1
        End If
    Loop
    '===== 基準記錄已被最后定位 =====
    r(iB) = dblPivot
    PartitionA = iB
End Function
Private Function Partition(InputArray() As Double, LowPos As Integer, HighPos As Integer) As Integer
    Dim dblPivot As Double
    Dim iPos As Integer, iTmp As Integer
    Dim i As Integer, j As Integer
    iPos = LowPos
    dblPivot = InputArray(iPos)
    For i = LowPos + 1 To HighPos
        If InputArray(i) < dblPivot Then
            Call Swap(InputArray, iPos, i)
            iPos = iPos + 1
        End If
    Next i
    Call Swap(InputArray, LowPos, iPos)
    Partition = iPos
End Function