smscmd.bas

VB编写的手机短信源码

Attribute VB_Name = "SMScmd"
Option Explicit

'从接收到的数据中提取出信息PUD码数据
Public Function GetMsgPDU(ByVal sMsg As String) As String
  Dim temp As String, sMsgLen As Integer, LenTemp As Integer
  sMsgLen = Len(sMsg)
  LenTemp = InStr(sMsg, "08") - 1
  temp = Right(sMsg, sMsgLen - LenTemp)
  LenTemp = InStr(temp, vbCrLf) - 1
  temp = Left(temp, LenTemp)
  GetMsgPDU = temp
End Function

'-------------------------------------------
'函数名 ：ReadNEWsms
'功能   ：读取新到短信的数据
'参数   ：从COM返回的新短信通知
'返回   ：字符串
'-------------------------------------------
Public Function ReadNewSMS(ByVal MsgCode As String) As String
  Dim StoreType As String, StoreID As String
  Dim strCOM32 As String, temp As String

  temp = Right(MsgCode, Len(MsgCode) - 10)
  StoreType = Mid(temp, 1, 2)
  StoreID = Val(Trim(Mid(temp, InStr(temp, ",") + 1, 3)))
  
  Call SendAT("AT+CPMS=" & Chr(34) & StoreType & Chr(34) & vbCr, 20)
  strCOM32 = SendAT("AT+CMGR=" & StoreID & vbCr, 5)
  If InStr(strCOM32, "+CMGR") > 0 And InStr(strCOM32, "OK") > 0 Then
    ReadNewSMS = GetMsgPDU(strCOM32)
  End If
End Function

'-------------------------------------------
'函数名 ：SendSMS
'功能   ：发送短信（使用卡中的短信中心）
'参数   ：接收号码，短信内容
'返回   ：布尔
'-------------------------------------------
Public Function SendSMS(ByVal Tel As String, ByVal MsgText As String) As Boolean
  Dim sendPDU1 As String, sendPDU2 As String, sUD As String
  Dim Re_SMSinfo As String, tempstr As String

  sendPDU2 = "0018"
  If ChcekGB(MsgText) > 0 Then
    sUD = GBChr2UCS(MsgText)
    sendPDU2 = "0008"  '中文免提
  Else
    sUD = Encode7bit(MsgText)
    sendPDU2 = "0000"  '英文免提
  End If
  tempstr = "001100" & Dec2Hex(Len(Tel)) & "81" & TeltoPDU(Tel) & sendPDU2 & "A7" & sUD
  Call SendAT("AT+CMGS=" & CStr((Len(tempstr) - 2) / 2), 5)
  Pause 0.3
  Re_SMSinfo = SendAT(tempstr & Chr(26), 5)
  If (InStr(Re_SMSinfo, "+CMGS") > 0 And InStr(Re_SMSinfo, "OK") > 0) Then  '发送成功
    SendSMS = True
  End If
  If (InStr(Re_SMSinfo, "ERROR") > 0 Or Left(Re_SMSinfo, 2) = "超时") Then  '发送失败
    SendSMS = False
  End If
End Function

'-------------------------------------------
'函数名 ：ReadSMS
'功能   ：读取短信的数据
'参数   ：短信息ID
'返回   ：字符串
'-------------------------------------------
Public Function ReadSMS(ByVal indexID) As String
  ReadSMS = SendAT("AT+CMGR=" & indexID, 20)
End Function

'-------------------------------------------
'函数名 ：DelSMS
'功能   ：删除短信
'参数   ：短信息ID
'返回   ：字符串
'-------------------------------------------
Public Sub DelSMS(indexID)
  Call SendAT("AT+CMGD=" & indexID, 5)
End Sub

'***********************************************
'函数 ：获取信息发送方短信中心号
'参数 ：信息编码字符串
'返回 ：信息发送方短信中心号 （字符串）
'***********************************************
Public Function GetMsgSCA(ByVal sMsg As String) As String
  Dim strSCA As String
  Dim SCAtemp As String, NumArr(30) As String, i As Integer
  Dim scaLen As Integer
    scaLen = Hex2Dec(Left(sMsg, 2))         '中心号长度
    strSCA = Mid(sMsg, 5, (scaLen) * 2)     '短信中心数据
    For i = 1 To (scaLen - 1) * 2 Step 2
        NumArr(i) = Mid(strSCA, i, 2)
        SCAtemp = SCAtemp & StrReverse(NumArr(i)) 'StrReverse功能是颠倒字符串
    Next i
    SCAtemp = Right(Replace(SCAtemp, "F", ""), (scaLen - 1) * 2) '去掉短信中心尾部的"F"
    GetMsgSCA = SCAtemp
End Function

'*/-------------------------------------------------------------
'*/函 数 名:GetMsgPhone
'*/功    能:提取发件人(DA)号码
'*/返 回 值:字符
'*/参    数:msg      指定的16 bit UCS2码
'*/-------------------------------------------------------------
Public Function GetMsgPhone(ByVal sMsg As String) As String
    On Error Resume Next
    Dim CSAlen As Integer         '短信中心长度
    Dim MessageType As String     '信息类型
    Dim TelLen As String          '电话号码长度
    Dim Tel As String             '电话号码
    Dim i As Integer, TELcode As String, TELtemp As String
    MessageType = Mid(sMsg, 19, 2)  '获取信息类型
    CSAlen = CLng(Left(sMsg, 2))    '发送方中心号长度
    TELcode = Mid(sMsg, CSAlen * 2 + 3, Len(sMsg) - (CSAlen * 2 + 2))
    If MessageType = "06" Or MessageType = "02" Then
        TELcode = Mid(TELcode, 5, Len(TELcode) - 2)
    Else
        TELcode = Mid(TELcode, 3, Len(TELcode) - 2)
    End If
    TelLen = Val("&H" & Mid(TELcode, 1, 2))
    If TelLen Mod 2 <> 0 Then
       TelLen = TelLen + 1
    End If
    For i = 0 To TelLen - 2 Step 2
        TELtemp = Mid(TELcode, i + 5, 2)
        TELtemp = StrReverse(TELtemp)
        Tel = Tel & TELtemp
    Next i
    Tel = Right(Replace(Tel, "F", ""), TelLen)
    GetMsgPhone = IIf(Len(Tel) = 0, "", Tel)
End Function

'*/-------------------------------------------------------------
'*/函 数 名:GetMsgTime
'*/功    能:提取发件时间 SCTS
'*/返 回 值:字符
'*/参    数:sMsg      指定的16 bit UCS2码
'*/-------------------------------------------------------------
Public Function GetMsgTime(ByVal sMsg As String) As String
  Dim TimeTemp(14) As String
  Dim strPDU As String
  Dim scaLen As Integer       '短信中心长度
  Dim TelLen As Integer      '时间数据长度
  Dim MsgType As String       '信息类型
  Dim i As Integer
    MsgType = Mid(sMsg, 19, 2)
    If MsgType = "06" Or MsgType = "02" Then '状态报告
       GetMsgTime = ""
    Else
        scaLen = Hex2Dec(Left(sMsg, 2))   '获取短信中心长度
        strPDU = Mid(sMsg, 3 + scaLen * 2 + 2, Len(sMsg) - (scaLen * 2))  '提取短信中心之后+2的数据
        TelLen = Val("&H" & Mid(strPDU, 1, 2))   '获取发送方号码长度
        If TelLen Mod 2 <> 0 Then                '判断长度是否偶数
           TelLen = TelLen + 1
        End If
        strPDU = Mid(strPDU, TelLen + 9, Len(strPDU) - TelLen + 2)
        For i = 0 To 14 Step 2
            TimeTemp(i) = StrReverse(Mid(strPDU, i + 1, 2))
        Next i
        GetMsgTime = TimeTemp(0) & "/" & TimeTemp(2) & "/" & TimeTemp(4) & " - " & TimeTemp(6) & ":" & TimeTemp(8) & ":" & TimeTemp(10)
   End If
End Function

'***********************************************
'函数 ：获取短信内容
'参数 ：信息编码字符串
'返回 ：信息文本内容 字符串
'***********************************************
Public Function GetMsgText(ByVal sMsg As String) As String
    Dim MsgLen As Integer, scaLen As Integer
    Dim PhoneLen As Integer, LenTemp As Integer
    Dim msg As String, smsType As String
    Dim Code As Long, i As Integer
    msg = ""
    scaLen = Hex2Dec(Left(sMsg, 2))
    PhoneLen = Hex2Dec(Mid(sMsg, (scaLen + 2) * 2 + 1, 2))
    If PhoneLen Mod 2 = 0 Then
      smsType = Mid(sMsg, (scaLen + 6) * 2 + PhoneLen - 1, 2)
    Else
      smsType = Mid(sMsg, (scaLen + 6) * 2 + PhoneLen, 2)
    End If
    LenTemp = (scaLen + 6 + 7) * 2 + PhoneLen + 2 '信息长度数据开始位置
    If LenTemp Mod 2 = 0 Then LenTemp = LenTemp - 1
    
    If smsType = "08" Then
        MsgLen = Hex2Dec(Mid(sMsg, LenTemp, 2))
        Debug.Print "Msg.nnn= " & LenTemp
        Debug.Print "Msg.Len= " & MsgLen
        For i = 1 To MsgLen / 2
            Code = Hex2Dec(Mid(sMsg, i * 4 + LenTemp - 2, 4))
            msg = msg + ChrW(Code)
        Next i
    ElseIf smsType = "00" Then
        MsgLen = Hex2Dec(Mid(sMsg, LenTemp, 2))
        MsgLen = MsgLen - (Int(MsgLen / 8))
        msg = ConvToStr(Mid(sMsg, LenTemp + 2, MsgLen * 2))
    Else
    End If
    GetMsgText = msg
End Function

'***********************************************
'函数 ：信息编码转换成字符串
'参数 ：信息编码
'返回 ：字符串
'***********************************************
Public Function ConvToStr(ByVal msg As String) As String
  Dim MsgLen As Integer
  Dim result As Integer
  Dim i, X, y, z As Integer
  Dim temp As Long
    
  ConvToStr = ""
  X = 0
  MsgLen = Len(msg) / 2
  For i = 0 To MsgLen - 1
    y = i Mod 7
    temp = Hex2Dec(Mid(msg, i * 2 + 1, 2))
    result = temp Mod 2 ^ (7 - y)
    result = result * 2 ^ (y) + X
    X = Int(temp / (2 ^ (7 - y)))
    ConvToStr = ConvToStr & Chr(result)
    If y = 6 Then
      ConvToStr = ConvToStr & Chr(X)
      X = 0
    End If
  Next i
End Function