moddatachangefun.bas

手机短信开发

Attribute VB_Name = "modFun"
Option Explicit


'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
''        strTmp = strTmp & strTmp
'    Next nTmp
'
'    Encode7BitASC = Trim(strTmp)
'
'End Function

'//将UNICODE转换中文

Public Function Unicode2AscII(ByVal s As String) As String
    On Error Resume Next
    Dim i As Integer
    Dim R As String
    For i = 1 To Len(s) Step 4
        R = R + ChrB("&H" & Mid(s, i + 2, 2)) & ChrB("&H" & Mid(s, i, 2))
    Next
    Unicode2AscII = R
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