myvbdll.cls

PC机与GSM短信模块串口通信

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