sms.ctl

COM短信猫开发源码

VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.UserControl Sms 
   ClientHeight    =   1080
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1200
   ScaleHeight     =   1080
   ScaleWidth      =   1200
   Begin MSCommLib.MSComm MSComm 
      Left            =   120
      Top             =   120
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      DTREnable       =   -1  'True
   End
End
Attribute VB_Name = "Sms"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'保持属性值的局部变量
Private mvarCom As Integer '局部复制
Private mvarBaudRate As Long  '局部复制
Private mvarCSCA As String  '局部复制
Private pCsca As String
'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent OnSms[(arg1, arg2, ... , argn)]
Public Event OnRcvSms(ByVal Msg As String, ByVal Sim As String, ByVal Time As String)
Public Event OnSendResult(ByVal Sim As String, ByVal Msg As String, ByVal SendFlag As Boolean)
Const prex = "0891"
Const midx8 = "11000881"
 Const midx11 = "11000D91"

Const sufx = "000800"
Private Declare Sub Sleep Lib "kernel32.dll" ( _
            ByVal dwMilliseconds As Long)
Dim PreSim As String '前一次发送的手机号
Dim PreMsg As String '前一次发送的内容

Dim SendSuccessCount As Integer
Dim SendFailedCount As Integer
Dim ReceiveCount As Integer
Dim WorkFlag As Boolean
Dim ReceiveData As String
Dim SendSuccess As Integer '-1等待；0失败；1成功
Dim ReceiveSuccess As Integer '-1等待；0失败；1成功



Public Function Ini() As Boolean
 Ini = SmsInit(Com, Str(mvarBaudRate) & ",n,8,1")
End Function


Public Function Send(ByVal Sim As String, ByVal Msg As String)
Dim pdu, psmsc, pnum, pmsg As String
    Send = False
    If WorkFlag = False Or SendSuccess = -1 Then Exit Function
    Dim leng As String

    Dim length As Integer

    length = Len(Msg)

    length = 2 * length

    leng = Hex(length)

    If length < 16 Then leng = "0" & leng


    pnum = Trim(telc(Sim))

    pmsg = Trim(ascg(Msg))
Dim simlen As Integer
simlen = Len(Sim)
If simlen = 8 Then
    pdu = prex & pCsca & midx8 & pnum & sufx & leng & pmsg
    Else
    pdu = prex & pCsca & midx11 & pnum & sufx & leng & pmsg
    End If
    If MSComm.PortOpen Then
        Sleep 10
        MSComm.Output = "AT+CMGF=0" + vbCr
        Sleep 1000
        MSComm.Output = "AT+CMGS=" & Str(15 + length) + vbCr
        Sleep 1000
        MSComm.Output = pdu & Chr$(26) & vbCr
        Sleep 100
        SendSuccess = -1
        PreSim = Sim
        PreMsg = Msg
        Send = True
    End If

End Function

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


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


Public Property Let Csca(ByVal vData As String)
 mvarCSCA = vData
 pCsca = Trim(telc(vData))
End Property


Public Property Get Csca() As String
Csca = mvarCSCA
End Property

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


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


Private Function SmsInit(Port As Integer, setstr As String) As Boolean
    SmsInit = False
    If SmsOpen(Port, setstr) = False Then Exit Function
    WorkFlag = True
    SendSuccessCount = 0
    SendFailedCount = 0
    ReceiveCount = 0
    ReceiveData = ""
    SendSuccess = 0
    ReceiveSuccess = 0
    SmsInit = True
End Function

Public Sub CloseSms()
MSComm.PortOpen = False
WorkFlag = False
End Sub


Function SmsOpen(Port As Integer, Setings As String) As Integer     '被opensms_click 调用

On Error GoTo ErrHandle
    SmsOpen = False
    If MSComm.PortOpen Then MSComm.PortOpen = False
    MSComm.CommPort = Port
    MSComm.Settings = Setings
    MSComm.PortOpen = True
    
    If MSComm.PortOpen Then
        SmsOpen = True
        MSComm.Output = "ATE0" + Chr(13) + Chr(10)
        MSComm.RThreshold = 1
        MSComm.Output = "AT+CMGF=0" + Chr(13) + Chr(10)
        MSComm.Output = "AT+CSMP=4,167,0,8" + Chr(13) + Chr(10)
'上边两行语句作为联机是初始化用的命令
    End If
    
Exit Function
ErrHandle:
   MsgBox "错误：  " + Str(Err.Number) + Chr(13) + Chr(10) + Err.Description, vbOKOnly & vbCritical, App.Title
End Function



Private Function chg(rmsg As String) As String

Dim tep As String

Dim temp As String

Dim i As Integer

Dim b As Integer

tep = rmsg

i = Len(tep)

b = i / 4

If i = b * 4 Then

    b = b - 1

                  tep = Left(tep, b * 4)

Else

           tep = Left(tep, b * 4)

End If

chg = ""

For i = 1 To b

 temp = "&H" & Mid(tep, (i - 1) * 4 + 1, 4)

     chg = chg & ChrW(CInt(Val(temp)))

Next i


End Function

Private Function telc(num As String) As String

Dim tl As Integer

Dim ltem, rtem, ttem As String

Dim ti As Integer

ttem = ""

tl = Len(num)

'If tl <> 11 And tl <> 13 Then
'
'    MsgBox "wrong number." & tl
'
'    Exit Function
'
'End If

If tl = 11 Then

    tl = tl + 2

    num = "86" & num

End If

For ti = 1 To tl Step 2

  ltem = Mid(num, ti, 1)

  rtem = Mid(num, ti + 1, 1)

  If ti = tl Then rtem = "F"

  ttem = ttem & rtem & ltem

Next ti

telc = ttem

End Function


Private Function ascg(smsg As String) As String

Dim si, sb As Integer

Dim stmp As Integer

Dim stemp As String

sb = Len(smsg)

ascg = ""

For si = 1 To sb

    stmp = AscW(Mid(smsg, si, 1))

    If Abs(stmp) < 127 Then

        stemp = "00" & Hex(stmp)

    Else

        stemp = Hex(stmp)

    End If

    ascg = ascg & stemp

Next si

ascg = Trim(ascg)

End Function



Private Function Analyze(ByVal RecMsg As String, ByRef Tel As String, ByRef Msg As String, ByRef Time As String) As Boolean
 Dim Tel As String, Msg As String, Time As String
    Analyze = AnalyzeRecMsg(buffer, Tel, Msg, Time)
End Function
'
'Private Function Encode(TxtMessage As String) As String
'    Dim High As String, Low As String, OneWord As String
'    Dim i As Integer
'    For i = 1 To Len(TxtMessage)        '将短信息转化为编码
'        OneWord = Mid(TxtMessage, i, 1)
'        Low = Hex(AscB(MidB(OneWord, 1, 1)))
'        High = Hex(AscB(MidB(OneWord, 2, 1)))
'        If Len(High) = 1 Then High = "0" + High
'        If Len(Low) = 1 Then Low = "0" + Low
'        Encode = Encode + High + Low     '得到的编码
'    Next i
'End Function
'Private Function Decode(EncodeMessage As String) As String
'    Dim Word(2) As Byte
'    Dim ascii As String
'    Dim temp As String
'    Dim j As Integer, Pos As Integer
'    Pos = 1
'    j = 1
'    Do
'        If j >= Len(EncodeMessage) Then
'            Exit Function
'        End If
'        ascii = Mid(EncodeMessage, j, 2)
'        j = j + 2
'
'        Word(Pos) = Val("&H" + ascii)
'        Pos = Pos - 1
'        If Pos < 0 Then
'            temp = Word
'            Decode = Decode + Left(temp, 1)
'            Pos = 1
'        End If
'    Loop
'End Function
'Private Function GetBPNumber(RecDecodeMsg As String) As String
'    Dim i As Integer
'    Dim Start As Boolean
'    Dim OneWord As String
'    GetBPNumber = ""
'    Start = False
'    For i = 1 To Len(RecDecodeMsg)
'        OneWord = Mid(RecDecodeMsg, i, 1)
'        If OneWord >= "0" And OneWord <= "9" Then
'            Start = True
'            GetBPNumber = GetBPNumber + OneWord
'        Else
'            If Start = False Then
'                If OneWord <> " " Then Exit Function
'            Else
'                If OneWord = " " Then
'                   Do
'                    i = i + 1
'                    OneWord = Mid(RecDecodeMsg, i, 1)
'                   Loop While OneWord = " " And i < Len(RecDecodeMsg)
'                End If
'                RecDecodeMsg = Mid(RecDecodeMsg, i)
'                Exit Function
'            End If
'        End If
'    Next i
'End Function
Private Function AnalyzeRecMsg(ByVal RecMsg As String, ByRef MobileNumber As String, ByRef Msg As String, ByRef MsgTime As String) As Boolean
    Dim i As Integer, j As Integer
    Dim AnalyzeMsg As String
    Dim length As Integer
    AnalyzeRecMsg = False
    i = InStr(RecMsg, "+CMGR:")
    If i < 1 Then Exit Function
    AnalyzeMsg = Mid(RecMsg, i + 6)
    i = InStr(AnalyzeMsg, Chr(34) + "+86")
    If i < 1 Then Exit Function
    j = InStr(i + 1, AnalyzeMsg, Chr(34))
    If j < i Then Exit Function
    MobileNumber = Mid(AnalyzeMsg, i + 4, j - i - 4)
    AnalyzeMsg = Mid(AnalyzeMsg, j)
    i = InStr(AnalyzeMsg, ",")
    If i < 1 Then Exit Function
    i = InStr(i, AnalyzeMsg, ",")
    If i < 1 Then Exit Function
    i = InStr(i, AnalyzeMsg, Chr(34))
    If i < 1 Then Exit Function
    j = InStr(i + 1, AnalyzeMsg, Chr(34))
    If j < i Then Exit Function
    MsgTime = Mid(AnalyzeMsg, i + 1, j - i - 4)
    AnalyzeMsg = Mid(AnalyzeMsg, j)
    i = InStr(AnalyzeMsg, Chr(13) + Chr(10))
    If i < 1 Then Exit Function
    j = InStrRev(AnalyzeMsg, ",", i)
    If j < 1 Then Exit Function
    length = Val(Mid(AnalyzeMsg, j + 1, i - j - 1))
    
    j = InStr(i + 2, AnalyzeMsg, Chr(13) + Chr(10))
    If j < 1 Then Exit Function
    Msg = Mid(AnalyzeMsg, i + 2, j - i - 2)
    If Len(Msg) > length Then
        Msg = Decode(Msg)
    End If
    AnalyzeRecMsg = True
End Function
Private Function RequestRecMsg(MsgIndex As String) As Boolean
    RequestRecMsg = False
    If ReceiveSuccess = -1 Then Exit Function
    ReceiveSuccess = -1
    RequestRecMsg = True
    MSComm.Output = "AT+CSDH=1" + Chr(13) + Chr(10)
    MSComm.Output = "AT+CMGR=" + MsgIndex + Chr(13) + Chr(10)
End Function
Private Function RequestDelMsg(MsgIndex As String)
    MSComm.Output = "AT+CMGD=" + MsgIndex + Chr(13) + Chr(10)
End Function



Private Sub MSComm_OnComm()
    Dim buffer As String
    Dim i As Integer, j As Integer
    Dim NextFlag As Boolean
    Dim RcvTel As String
    Dim RcvTime As String
    Dim RcvMsg As String
    Dim RcvData As String
    RcvData = MSComm.Input
    Debug.Print RcvData
    If SendSuccess = -1 Then
        If InStr(RcvData, "OK") > 0 Then
                     SendSuccess = 1
                    SendSuccessCount = SendSuccessCount + 1
                    RaiseEvent OnSendResult(PreSim, PreMsg, True)
        Else
                    SendSuccess = 0
                    SendFailedCount = SendFailedCount + 1
                    RaiseEvent OnSendResult(PreSim, PreMsg, False)
        End If
    End If
     
    
    
'    Do
'        NextFlag = False
'        j = InStr(ReceiveData, "+CMS")
'        If j > 0 Then
'            ReceiveSuccess = 0
'        End If
'        i = InStr(ReceiveData, "+CMGR:")
'        j = InStr(ReceiveData, "+CMGS")
'        If j = 0 And i = 0 And Len(ReceiveData) > 8 Then '删除接收区中无用的数据
'            ReceiveData = Mid(ReceiveData, Len(ReceiveData) - 7)
'        End If
'        If j > 0 Then  '最前的数据为发送返回结果
'            If SendSuccess = -1 Then
'                buffer = Mid(ReceiveData, j, 14)
'                If InStr(buffer, "OK") > 0 Then
'                    SendSuccess = 1
'                    SendSuccessCount = SendSuccessCount + 1
'                    RaiseEvent OnSendResult(PreSim, PreMsg, True)
'                Else
'                    SendSuccess = 0
'                    SendFailedCount = SendFailedCount + 1
'                    RaiseEvent OnSendResult(PreSim, PreMsg, False)
'                End If
'            End If
'            ReceiveData = Mid(ReceiveData, j + 14)
'            NextFlag = True
'        End If
'
'            If i > 0 Then
'                j = InStr(ReceiveData, Chr(13) + Chr(10) + "OK")
'                If j > 0 Then
'                    buffer = Mid(ReceiveData, i, j - i)
'                    ReceiveSuccess = 0
'                    ReceiveData = Mid(ReceiveData, j + 3)
'                    RcvTel = RcvTime = RcvMsg = ""
'                    If Analyze(ReceiveData, RcvTel, RcvMsg, RcvTime) = True Then
'                        ReceiveSuccess = 1 '接收成功
'                        ReceiveCount = ReceiveCount + 1
'                        RaiseEvent OnRcvSms(RcvMsg, RcvTel, RcvTime)
'                    End If
'                    NextFlag = True
'                End If
'            End If
'
'    Loop While NextFlag

End Sub