短信PDU编码类,可以用COMM连MODEM可以方便的发短信.

2022-07-15 80酷酷网 80kuku.com

　　编码

网上有很多利用COM口连接手机,利用手机MODEM,使用AT指令发送短信，介绍PDU编码的原理很多，写一个现成的类出来，给有需要的人参考和使用。

SMSPDUClass.cls

Option Explicit

'保持属性值的局部变量
Private mvarSMSCLen As Integer '局部复制
Private mvarSMSCType As String '局部复制
Private mvarSMSC As String '局部复制
Private mvarMsgHead As Integer '局部复制
Private mvarTPMR As Integer '局部复制
Private mvarDestPhoneNumLen As Integer '局部复制
Private mvarDestPhoneNumType As String '局部复制
Private mvarDestPhoneNum As String '局部复制
Private mvarTPPID As Integer '局部复制
Private mvarTPDSC As Integer '局部复制
Private mvarTPVP As Integer '局部复制
Private mvarMSGLen As Integer '局部复制
Private mvarMSGContent As String '局部复制
Private mvarPDULen As Integer '局部复制
Private mvarPDU As String '局部复制
'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent ValidResult[(arg1, arg2, ... , argn)]
Public Event ValidResult(ByVal ErrorCode As Integer, ByVal ErrorString As String)

Public Function genPDU(Optional ByVal SMSContent As String, _
Optional ByVal DestNo As String, _
Optional ByVal ServiceNo As String) As String

'mvarSMSCLen = 0
'mvarSMSCType = ""
'mvarSMSC = ""
'mvarMsgHead = 11
'mvarTPMR = 0
'mvarDestPhoneNumLen = 0
'mvarDestPhoneNumType = ""
'mvarDestPhoneNum = ""
'mvarTPPID = 0
'mvarTPDSC = 8
'mvarTPVP = 0
'mvarMSGLen = 0
'mvarMSGContent = ""
'mvarPDULen = 0
'mvarPDU = ""

    If Len(SMSContent) > 0 Then
        mvarMSGContent = SMSContent

    End If

    If Len(DestNo) > 0 Then
        mvarDestPhoneNum = DestNo

    End If




    If Len(ServiceNo) > 0 Then
        mvarSMSC = ServiceNo
        If Len(mvarSMSC) > 14 Then
            RaiseEvent ValidResult(7, "SMSC Error!")
            mvarSMSC = "+8613800769500"
        End If
        If Len(mvarSMSC) < 11 Then
            RaiseEvent ValidResult(7, "SMSC Error!")
            mvarSMSC = "+8613800769500"
        End If
        mvarSMSC = "+86" & Right(mvarSMSC, 11)

    End If

    If Len(mvarDestPhoneNum) = 0 Then
        genPDU = ""
        RaiseEvent ValidResult(3, "DestPhoneNumber is null!")

        Exit Function
    End If

    If mvarTPDSC <> 0 And mvarTPDSC <> 8 Then
        genPDU = ""
        RaiseEvent ValidResult(5, "TP-DCS Error!")

        Exit Function
    End If

    Dim ServiceNumPDU As String
    Dim DestPhoneNumPDU As String
    ServiceNumPDU = mvarSMSC
    DestPhoneNumPDU = mvarDestPhoneNum

' msg.DestPhoneNumType 被叫号码类型。有+86时候为"91"，否则为"81"

    If Len(mvarSMSC) > 0 Then
        FormatPhoneNum ServiceNumPDU, mvarSMSCType
        mvarSMSCLen = Len(ServiceNumPDU & mvarSMSCType) / 2 '短信息中心地址长度。（短信息中心号码类型 + 短信息中心号码长度 /2 的十六进制表示）

    End If

    mvarDestPhoneNumLen = FormatPhoneNum(DestPhoneNumPDU, mvarDestPhoneNumType) ''被叫号码长度。被叫号码长度的十六进制表示。
'
    If Len(mvarMSGContent) > 70 Then
        mvarMSGContent = Left(mvarMSGContent, 70)

    End If

'    mvarMSGLen = Len(mvarMSGContent)

    Dim SMSText As String
    SMSText = mvarMSGContent

'
SMSText = GB2Unicode(SMSText) '把汉字符转化为UNICODE的HEX编码字符串
'

'
    mvarMSGLen = Len(SMSText) \ 2

    If Len(mvarSMSC) = 0 Then
        mvarSMSCLen = 0
        mvarPDU = Int2HexStr(mvarSMSCLen) & Int2HexStr(mvarMsgHead) & Int2HexStr(mvarTPMR) & Int2HexStr(mvarDestPhoneNumLen) & mvarDestPhoneNumType & DestPhoneNumPDU & _
                    Int2HexStr(mvarTPPID) & Int2HexStr(mvarTPDSC) & Int2HexStr(mvarTPVP) & Int2HexStr(mvarMSGLen) & SMSText

mvarPDULen = Len(mvarPDU) / 2 - 1

    Else
        mvarPDU = Int2HexStr(mvarSMSCLen) & mvarSMSCType & ServiceNumPDU & Int2HexStr(mvarMsgHead) & Int2HexStr(mvarTPMR) & Int2HexStr(mvarDestPhoneNumLen) & mvarDestPhoneNumType & DestPhoneNumPDU & _
                    Int2HexStr(mvarTPPID) & Int2HexStr(mvarTPDSC) & Int2HexStr(mvarTPVP) & Int2HexStr(mvarMSGLen) & SMSText

        mvarPDULen = Len(mvarPDU) / 2 - 9   'PDU字符串长度
    End If

genPDU = mvarPDU

End Function

'Public Property Let PDU(ByVal vData As String)
''向属性指派值时使用，位于赋值语句的左边。
''Syntax: X.PDU = 5
' mvarPDU = vData
'End Property

Public Property Get PDU() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.PDU

    Call genPDU

    PDU = mvarPDU
End Property

'Public Property Let PDULen(ByVal vData As Integer)
''向属性指派值时使用，位于赋值语句的左边。
''Syntax: X.PDULen = 5
' mvarPDULen = vData
'End Property

Public Property Get PDULen() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.PDULen
PDULen = mvarPDULen
End Property

Public Property Let MSGContent(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.MSGContent = 5
    mvarMSGContent = vData
    mvarMSGLen = Len(vData) * 2

End Property

Public Property Get MSGContent() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.MSGContent
MSGContent = mvarMSGContent
End Property

'Public Property Let MSGLen(ByVal vData As String)
''向属性指派值时使用，位于赋值语句的左边。
''Syntax: X.MSGLen = 5
' mvarMSGLen = vData
'End Property

Public Property Get MSGLen() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.MSGLen
MSGLen = mvarMSGLen
End Property

Public Property Let TPVP(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.TPVP = 5
    If vData >= 0 And vData < 256 Then
        mvarTPVP = vData

    Else
        RaiseEvent ValidResult(6, "TP-VP Error!")
    End If
End Property

Public Property Get TPVP() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.TPVP
TPVP = mvarTPVP
End Property

Public Property Let TPDCS(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.TPDSC = 5
    If vData >= 0 And vData < 256 Then
        mvarTPDSC = vData
    Else
        RaiseEvent ValidResult(5, "TP-DCS Error!")
    End If
End Property

Public Property Get TPDCS() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.TPDSC
TPDCS = mvarTPDSC
End Property

Public Property Let TPPID(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.TPPID = 5
    If vData >= 0 And vData < 256 Then
        mvarTPPID = vData
    Else
        RaiseEvent ValidResult(4, "TP-PID Error!")
    End If
End Property

Public Property Get TPPID() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.TPPID
TPPID = mvarTPPID
End Property

Public Property Let DestPhoneNum(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.DestPhoneNum = 5
    If Len(vData) = 0 Then
        RaiseEvent ValidResult(3, "DestPhoneNumber is null!")
    Else
        mvarDestPhoneNum = vData
        mvarDestPhoneNumLen = FormatPhoneNum(vData, mvarDestPhoneNumType)
    End If
End Property

Public Property Get DestPhoneNum() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.DestPhoneNum

DestPhoneNum = mvarDestPhoneNum

End Property

'Public Property Let DestPhoneNumType(ByVal vData As String)
''向属性指派值时使用，位于赋值语句的左边。
''Syntax: X.DestPhoneNumType = 5
'    mvarDestPhoneNumType = vData
'End Property
'
'
Public Property Get DestPhoneNumType() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.DestPhoneNumType
    If Len(mvarDestPhoneNum) = 0 Then
        mvarDestPhoneNumType = "FF"
    Else
        Dim str As String
        str = mvarDestPhoneNum
        FormatPhoneNum str, mvarDestPhoneNumType

    End If
    DestPhoneNumType = mvarDestPhoneNumType
End Property

'Public Property Let DestPhoneNumLen(ByVal vData As String)
''向属性指派值时使用，位于赋值语句的左边。
''Syntax: X.DestPhoneNumLen = 5
'    mvarDestPhoneNumLen = vData
'End Property
'
'
Public Property Get DestPhoneNumLen() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.DestPhoneNumLen
    If Len(DestPhoneNum) = 0 Then
        mvarDestPhoneNumLen = 0
    Else
        Dim str As String
        str = DestPhoneNum
        mvarDestPhoneNumLen = FormatPhoneNum(str, mvarDestPhoneNumType)
    End If
    DestPhoneNumLen = mvarDestPhoneNumLen
End Property

Public Property Let TPMR(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.TPMR = 5
    If vData >= 0 And vData < 256 Then
        mvarTPMR = vData

    Else
        RaiseEvent ValidResult(2, "TP-MR Error!")

    End If
End Property

Public Property Get TPMR() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.TPMR
TPMR = mvarTPMR
End Property

Public Property Let MsgHead(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.MsgHead = 5
    If vData >= 0 And vData < 256 Then
        mvarMsgHead = vData
    Else
        RaiseEvent ValidResult(1, "MsgHead Error!")


    End If
End Property

Public Property Get MsgHead() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.MsgHead
MsgHead = mvarMsgHead
End Property

Public Property Let SMSC(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.SMSC = 5

    If Len(vData) = 0 Then
        mvarSMSCLen = 0
        mvarSMSC = vData
    Else
        If Len(vData) > 14 Then
            RaiseEvent ValidResult(7, "SMSC Error!")
            vData = "+8613800769500"
        End If
        If Len(vData) < 11 Then
            RaiseEvent ValidResult(7, "SMSC Error!")
            vData = "+8613800769500"
        End If
        vData = "+86" & Right(vData, 11)
        mvarSMSC = vData
        mvarSMSCLen = FormatPhoneNum(vData, mvarSMSCType) / 2
    End If

End Property

Public Property Get SMSC() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.SMSC
SMSC = mvarSMSC
End Property

'Public Property Let SMSCType(ByVal vData As String)
''向属性指派值时使用，位于赋值语句的左边。
''Syntax: X.SMSCType = 5
' mvarSMSCType = vData
'End Property

Public Property Get SMSCType() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.SMSCType
    If Len(SMSC) = 0 Then
        mvarSMSCType = "FF"
    Else
        Dim str As String
        str = SMSC
        FormatPhoneNum str, mvarSMSCType
    End If
    SMSCType = mvarSMSCType
End Property

'Public Property Let SMSCLen(ByVal vData As String)
''向属性指派值时使用，位于赋值语句的左边。
''Syntax: X.SMSCLen = 5
'    mvarSMSCLen = vData
'End Property
'
'
Public Property Get SMSCLen() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.SMSCLen
    If Len(SMSC) = 0 Then
        mvarSMSCLen = 0

    Else
        Dim str As String
        str = SMSC
        FormatPhoneNum str, mvarSMSCType
        mvarSMSCLen = Len(mvarSMSCType & str) / 2

    End If
    SMSCLen = mvarSMSCLen
End Property

Private Sub Class_Initialize()

mvarSMSCLen = 0
mvarSMSCType = ""
mvarSMSC = ""
mvarMsgHead = 17
mvarTPMR = 0
mvarDestPhoneNumLen = 0
mvarDestPhoneNumType = ""
mvarDestPhoneNum = ""
mvarTPPID = 0
mvarTPDSC = 8
mvarTPVP = 255
mvarMSGLen = 0
mvarMSGContent = ""
mvarPDULen = 0
mvarPDU = ""

'    Msg.MsgHead = "11"   '文件头字节 (header byte, 是一种 bitmask) 。这里 11 指正常地发送短信息。
'    Msg.TPMR = "00"         '信息参考号。（ TP-MR ）
'    Msg.TPPID = "00"    '‘一般都是 00 ，表示点到点的标准短信
'    Msg.TPVP = "FF"   '‘有效期 (TP-VP), 短信的有效时间 ,00或FF表示有效
'    Msg.TPDSC = "08"    '用户信息编码方式 (TP-DCS) , 7-bit 编码（ 08 ： UCS2 编码汉字一般为08）


End Sub

Private Function Int2HexStr(ByVal arg0 As Integer) As String
    Dim strChar As String
    strChar = ""

    strChar = Hex(arg0)
    If Len(strChar) < 2 Then strChar = "0" & strChar
    Int2HexStr = strChar
End Function

'由于位置上略有处理，实际号码应为： 8613805515500( 字母 F 意指长度减 1),
'这是作者所在地 GSM 短信息中心的号码。 ( 号码处理方法为 , 如果为 +86 开始 , 将 + 号去掉 ,
'然后判断是否为偶数 , 不是在末尾补 F, 然后将奇数位和偶数位互换 )

Public Function FormatPhoneNum(ByRef phoneNum As String, ByRef tonNpiFlag As String) As Integer
    Dim i As Integer
    Dim iAsc As Integer
    Dim strChar As String

'        If Len(phoneNum) = 14 Then
'            If Left(phoneNum, 3) = "+86" Then
'                phoneNum = Right(phoneNum, 11)
'            Else
'                If Len(phoneNum) <> 11 Then
'                    FormatSMSC = 0
'                    Exit Function
'                End If
'            End If
'        End If
        If Len(phoneNum) <= 0 Then
            FormatPhoneNum = 0
            Exit Function
        End If
             If Left(phoneNum, 3) = "+86" Then
                phoneNum = Right(phoneNum, 13)
                tonNpiFlag = "91"
            Else
'                If Len(phoneNum) <> 11 Then
'                    FormatSMSC = 0
'                    Exit Function
'                End If
                tonNpiFlag = "81"
            End If



        For i = 1 To Len(phoneNum)
            strChar = Mid(phoneNum, i, 1)
            iAsc = Asc(strChar)
            If iAsc > 57 Or iAsc < 48 Then
                FormatPhoneNum = 0
                Exit Function
            End If
        Next i
        If Len(phoneNum) Mod 2 <> 0 Then
            phoneNum = phoneNum & "F"
        End If

        Dim strTmp2, strTmp1 As String
        strTmp1 = ""
        For i = 1 To Len(phoneNum) Step 2
            strTmp2 = Mid(phoneNum, i, 2)
            strTmp1 = strTmp1 & Right(strTmp2, 1) & Left(strTmp2, 1)
        Next i
        phoneNum = strTmp1
    FormatPhoneNum = Len(phoneNum) - 1
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
    RaiseEvent ValidResult(Err.Number, Err.Description)

    GB2Unicode = ""
End Function

使用方法：

Dim sms1 As New SMSPDUClass

    sms1.DestPhoneNum = "13922992078"
    sms1.SMSC = "+861380076950011"
    sms1.MSGContent = "aa"

SendSms sms1.pdu,sms1.pduleni

Public Function SendSms(ByVal strSMSPdu As String, ByVal SMSLen As Integer) As Boolean
    With MSComm1
        If .PortOpen = True Then
'            Debug.Print Now()
            If SMSLen > 5 Then
                .Output = "AT+CMGF=0" & vbCr
                .Output = "AT+CMGS=" & SMSLen & vbCr
            Else
                SendSms = False
                Exit Function
            End If

            If Len(strSMSPdu) = 0 Then
                SendSms = False
                Exit Function
            End If
'            Debug.Print Now()

            Dim i As Long
            For i = 0 To 10000 Step 1
                DoEvents
                DoEvents
                DoEvents
                DoEvents
                DoEvents
                DoEvents
                DoEvents
                DoEvents
                DoEvents
                DoEvents
                DoEvents
                DoEvents
                DoEvents

            Next
'            Debug.Print Now()

            .Output = strSMSPdu & Chr(26)
            SendSms = True
'             Debug.Print Now()
        Else

                SendSms = False
                Exit Function
        End If

End With
End Function