myvbdll.cls

这是一个通过手机串口实现短信发送的实例

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