conscode.bas

VB编写的手机短信源码

Attribute VB_Name = "CnvCode"
'*/-------------------------------------------------------------
'*/模 块 名:ConScode
'*/功    能:SMS 解码，编码函数
'*/-------------------------------------------------------------

Option Explicit

'*/-------------------------------------------------------------
'函数 ：将电话话码或短信中心号码进行编码
'参数 ：文本
'返回 ：字符串
'*/-------------------------------------------------------------
Public Function TeltoPDU(ByVal numb As String) As String
  Dim s As Integer
  Dim ma As String, ta As String, A As String, B As String
  s = 1
  ma = ""
  While (s <= Len(numb))
    ta = Mid(numb, s, 2)
    A = Mid(ta, 1, 1)
    B = Mid(ta, 2, 1)
    If B = "" Then B = "F"
    ma = ma & B & A
    s = s + 2
  Wend
  TeltoPDU = ma
End Function

'*/-------------------------------------------------------------
'*/函 数 名:GBChr2UCS
'*/功    能:UNICODE中文转为 16bit UCS2码
'*/返 回 值:字符
'*/参    数:msg      指定的中文字符
'*/-------------------------------------------------------------
Public Function GBChr2UCS(msg As String) As String
    Dim i As Integer
    For i = 1 To Len(msg)
        GBChr2UCS = GBChr2UCS & IIf(Len(Hex(AscW(Mid(msg, i, 1)))) = 2, "00" & Hex(AscW(Mid(msg, i, 1))), Hex(AscW(Mid(msg, i, 1))))
    Next i
    GBChr2UCS = IIf(Len(Hex(LenB(msg))) = 2, Hex(LenB(msg)), "0" & Hex(LenB(msg))) & GBChr2UCS
End Function

'*/-------------------------------------------------------------
'*/函 数 名:ChcekGB
'*/功    能:检测所含字符中的汉字数
'*/-------------------------------------------------------------
Public Function ChcekGB(strGB As String) As Integer
    Dim i As Integer
    For i = 0 To Len(strGB) - 1
       If Asc(Mid(strGB, i + 1, 1)) < 0 Then
          ChcekGB = ChcekGB + 1
       End If
    Next
End Function

'*/-------------------------------------------------------------
'函数 将十进制转换成2位16进制
'参数 ：文本
'返回 ：字符串
'*/-------------------------------------------------------------
Public Function Dec2Hex(ByVal he As Integer) As String
  Dim y As String
    
  y = Hex(he)
  If Len(y) = 1 Then
      y = "0" & y
  End If
  Dec2Hex = y
End Function

'*/-------------------------------------------------------------
'*/函 数 名:Bin2Dec
'*/功    能:二进制转十进制
'*/返 回 值:字符
'*/参    数:bina
'*/-------------------------------------------------------------
Public Function Bin2Dec(bina) As String
    Dim binN As String, digit As String
    Dim i As Integer, decim As Integer
    binN = StrReverse(bina)
    For i = 0 To Len(bina)
        digit = Mid(binN, i + 1, 1)
        decim = decim + Val(digit) * 2 ^ i
    Next i
    Bin2Dec = decim
End Function

'*/-------------------------------------------------------------
'*/函 数 名:Bin2Hex
'*/功    能:二进制转十六进制
'*/返 回 值:字符
'*/参    数:sBin
'*/-------------------------------------------------------------
Public Function Bin2Hex(ByVal sBin As String) As String
    Dim i As Integer
    Dim nDec As Long
    sBin = String(4 - Len(sBin) Mod 4, "0") & sBin 'Add zero to complete Byte
    For i = 1 To Len(sBin)
        nDec = nDec + CInt(Mid(sBin, Len(sBin) - i + 1, 1)) * 2 ^ (i - 1)
    Next i
    Bin2Hex = Hex(nDec)
    If Len(Bin2Hex) Mod 2 = 1 Then Bin2Hex = "0" & Bin2Hex
End Function

'*/-------------------------------------------------------------
'*/函 数 名:Dec2Bin
'*/功    能:十进制转二进制函数
'*/返 回 值:字符
'*/参    数:decim
'*/-------------------------------------------------------------
Public Function Dec2Bin(decim, flag As Boolean) As String
    Dim number As Integer
    number = Val(decim)

    Do Until number = 0
       If number Mod 2 <> 0 Then
          Dec2Bin = Dec2Bin & "1"
       Else
          Dec2Bin = Dec2Bin & "0"
       End If
       number = number \ 2
    Loop
    Dec2Bin = StrReverse(Dec2Bin)

    If Len(Dec2Bin) < 8 Then
       Dec2Bin = IIf(flag, String(8 - Len(Dec2Bin), "0") & Dec2Bin, IIf(Len(Dec2Bin) <> 7, "0" & Dec2Bin, Dec2Bin))
    End If
    
End Function

'*/-------------------------------------------------------------
'*/函 数 名:Hex2Dec
'*/功    能:十六进制制转十进制函数
'*/返 回 值:字符
'*/参    数:dhex
'*/-------------------------------------------------------------
Public Function Hex2Dec(dhex) As String
  Dim length As Integer, i As Integer, number As Integer
  Dim c As String
    length = Len(dhex)
    Hex2Dec = 0
    For i = 1 To length
      c = Mid(dhex, i, 1)
      If c = "0" Then
          number = 0
      ElseIf c = "1" Then
          number = 1
      ElseIf c = "2" Then
          number = 2
      ElseIf c = "3" Then
          number = 3
      ElseIf c = "4" Then
          number = 4
      ElseIf c = "5" Then
          number = 5
      ElseIf c = "6" Then
          number = 6
      ElseIf c = "7" Then
          number = 7
      ElseIf c = "8" Then
          number = 8
      ElseIf c = "9" Then
          number = 9
      ElseIf c = "A" Then
          number = 10
      ElseIf c = "B" Then
          number = 11
      ElseIf c = "C" Then
          number = 12
      ElseIf c = "D" Then
          number = 13
      ElseIf c = "E" Then
          number = 14
      ElseIf c = "F" Then
          number = 15
      End If
      Hex2Dec = Hex2Dec + number * (16 ^ (length - i))
    Next i
End Function

'*/-------------------------------------------------------------
'*/函 数 名:Encode7bit
'*/功    能:7bit 英文编码
'*/返 回 值:字符  UDL+UD
'*/参    数:Msgtxt    英文短信内容
'*/-------------------------------------------------------------
Public Function Encode7bit(ByVal Msgtxt As String) As String
    Dim i As Integer, l As Integer, s As Integer
    Dim sTemp As String, sTemp1 As String, UD_data As String
    Dim UDL_length As String

    For i = 1 To Len(Msgtxt)
        sTemp1 = Dec2Bin(AscW(Mid(Msgtxt, i, 1)), False)
        sTemp = sTemp1 & sTemp
    Next
    If Len(Msgtxt) > 1 Then
        l = Len(sTemp)
        s = l - 7
        UD_data = Bin2Hex(Mid(sTemp, s, 8))
        Do Until s <= 8
            s = s - 8
            UD_data = UD_data & Bin2Hex(Mid(sTemp, s, 8))
        Loop
        UD_data = UD_data & Bin2Hex(Mid(sTemp, 1, s - 1))
    Else
        UD_data = Bin2Hex(sTemp)
    End If
    UDL_length = Hex(Len(Msgtxt))   '用户数据长度 UDL
    If Len(UDL_length) = 1 Then
            UDL_length = "0" & UDL_length
    End If
    Encode7bit = UDL_length & UD_data
End Function

'*/-------------------------------------------------------------
'*/函 数 名:inString
'*/功    能:指定一字符串在另一字符串中最先出现的位置
'*/         功能和VB自带的InStr 函数一样，请参阅
'*/返 回 值:Variant (Long)
'*/参    数:aString      必要参数。接受搜索的字符串表达式。
'*/         bString      必要参数。被搜索的字符串表达式。
'*/         Skip
'*/-------------------------------------------------------------
Function inString(aString, bString, Optional Skip = 0)
    Dim i As Integer
    For i = 1 To Len(bString)
        If Mid(bString, i, Len(aString)) = aString Then
           If Skip = 0 Then
              inString = i
              Exit Function
           Else
              Skip = Skip - 1
           End If
        End If
    Next
    inString = 0
End Function

'*/-------------------------------------------------------------
'*/函 数 名:Split
'*/功    能:返回一个下标从零开始的一维数组，它包含指定数目的子字符串。
'*/         兼容VB的自带函数
'*/返 回 值:变体
'*/参    数:sIn      指定的字符
'*/         sDel     替换为的字符
'*/-------------------------------------------------------------
Public Function SplitStr(sIn, sDel) As Variant
  Dim i As Integer, X As Integer, s As Integer, t As Integer
  i = 1: s = 1: t = 1: X = 1
  ReDim tArr(1 To X) As Variant
        
  If InStr(1, sIn, sDel) <> 0 Then
    Do
      ReDim Preserve tArr(1 To X) As Variant
      tArr(i) = Mid(sIn, t, InStr(s, sIn, sDel) - t)
      t = InStr(s, sIn, sDel) + Len(sDel)
      s = t
      If tArr(i) <> "" Then i = i + 1
      X = X + 1
    Loop Until InStr(s, sIn, sDel) = 0
    ReDim Preserve tArr(1 To X) As Variant
    tArr(i) = Mid(sIn, t, Len(sIn) - t + 1)
  Else
    tArr(1) = sIn
  End If
  SplitStr = tArr
End Function

'*/-------------------------------------------------------------
'*/函 数 名:UCS2GBChr
'*/功    能:16 bit UCS2码转为UNICODE中文
'*/返 回 值:字符
'*/参    数:msg      指定的16 bit UCS2码
'*/-------------------------------------------------------------
Public Function UCS2GBChr(msg As String, stepi As Integer) As String
  Dim i As Integer
  For i = 1 To Len(msg) Step stepi
    UCS2GBChr = UCS2GBChr & ChrW("&H" & Mid(msg, i, stepi))
  Next i
End Function

'*/-------------------------------------------------------------
'*/函 数 名:Decode7bit
'*/功    能:7bit 码解码为英文
'*/返 回 值:英文字符
'*/参    数:PduString      指定的7bit码
'*/-------------------------------------------------------------
Public Function Decode7bit(PduString As String) As String
  Dim i As Long, c As Long, c1 As Long
  Dim Binaries(255, 1) As String, temp As String, strFormated As String
  Dim p1 As String, p2 As String
   
  For i = 0 To Len(PduString) - 2 Step 2
    c = c + 1
    c1 = c1 + 1
    temp = Mid(PduString, i + 1, 2)
    temp = Val("&H" & temp)    'HEX2DEC(temp)
    temp = Dec2Bin(temp, True)
    Binaries(c, 0) = Mid(temp, 1, c1)
    Binaries(c, 1) = Mid(temp, c1 + 1, Len(temp) - c1)
    If c1 = 7 Then
      c = c + 1
      c1 = 0
    End If
  Next i
  For i = 1 To c
    p1 = Binaries(i, 1)
    p2 = Binaries(i - 1, 0)
    p1 = p1 & p2
    Select Case Bin2Dec(p1)
      Case 24
      Case 25
      Case 20
      Case 19
      Case 22
      Case 10
      Case Else
        If Bin2Dec(p1) = 0 Then
          strFormated = strFormated & "@"
        Else
          strFormated = strFormated & ChrW(Bin2Dec(p1))
        End If
    End Select
  Next i
  Decode7bit = strFormated
End Function