form1.frm

VB编写的实现手机短信收发程序源码演示!

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   4605
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6480
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   12
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   ScaleHeight     =   4605
   ScaleWidth      =   6480
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox MsgIndex 
      Height          =   360
      Left            =   2760
      TabIndex        =   7
      Text            =   "0"
      Top             =   2280
      Width           =   1455
   End
   Begin VB.CommandButton Command1 
      Caption         =   "接收"
      Height          =   495
      Left            =   3600
      TabIndex        =   6
      Top             =   3480
      Width           =   1935
   End
   Begin MSComctlLib.StatusBar Status 
      Align           =   2  'Align Bottom
      Height          =   375
      Left            =   0
      TabIndex        =   5
      Top             =   4230
      Width           =   6480
      _ExtentX        =   11430
      _ExtentY        =   661
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   5
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Object.Width           =   2293
            MinWidth        =   2293
            Text            =   "发送状态："
            TextSave        =   "发送状态："
         EndProperty
         BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Object.Width           =   2117
            MinWidth        =   2117
         EndProperty
         BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Object.Width           =   2293
            MinWidth        =   2293
            Text            =   "成功次数："
            TextSave        =   "成功次数："
         EndProperty
         BeginProperty Panel4 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
         BeginProperty Panel5 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
      EndProperty
   End
   Begin VB.CommandButton Send 
      Caption         =   "发送"
      Height          =   495
      Left            =   1320
      TabIndex        =   4
      Top             =   3480
      Width           =   2055
   End
   Begin VB.TextBox SendMsg 
      Height          =   855
      Left            =   2760
      MultiLine       =   -1  'True
      TabIndex        =   3
      Top             =   1080
      Width           =   2775
   End
   Begin VB.TextBox MobileTel 
      Height          =   495
      Left            =   2760
      TabIndex        =   1
      Text            =   "13"
      Top             =   360
      Width           =   2775
   End
   Begin MSCommLib.MSComm MSComm1 
      Left            =   120
      Top             =   480
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      CommPort        =   3
      DTREnable       =   -1  'True
   End
   Begin VB.Label Label3 
      Caption         =   "短信接收索引号"
      Height          =   375
      Left            =   720
      TabIndex        =   8
      Top             =   2280
      Width           =   1695
   End
   Begin VB.Label Label2 
      Caption         =   "短信息内容："
      Height          =   375
      Left            =   720
      TabIndex        =   2
      Top             =   1200
      Width           =   1575
   End
   Begin VB.Label Label1 
      Caption         =   "对方手机号："
      Height          =   375
      Left            =   720
      TabIndex        =   0
      Top             =   360
      Width           =   1695
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

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成功

Private Sub Command1_Click()
    RequestRecMsg MsgIndex.Text
End Sub



Private Sub Form_Load()

    SmsInit 3, "9600,n,8,1"

End Sub
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
Private Function SmsSend(MoblieID As String, TxtMessage As String) As Boolean    '被timer1_timer调用
    Dim TxtMsg As String

    SmsSend = False
    If WorkFlag = False Or SendSuccess = -1 Then Exit Function
    '编码
    TxtMsg = Encode(TxtMessage)
    If MSComm1.PortOpen Then
        MSComm1.Output = "AT+CMGS=" + Chr(34) + MoblieID + Chr(34) + Chr(13)  '送出短信目的号码
        MSComm1.Output = TxtMsg + Chr(26)   '送出已编码后的短信内容
        SendSuccess = -1
        SmsSend = True
    End If
End Function

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

On Error GoTo ErrHandle
    SmsOpen = False
    If MSComm1.PortOpen Then MSComm1.PortOpen = False
    MSComm1.CommPort = Port
    MSComm1.Settings = Setings
    MSComm1.PortOpen = True
    
    If MSComm1.PortOpen Then
        SmsOpen = True
        MSComm1.Output = "ATE0" + Chr(13) + Chr(10)
        MSComm1.RThreshold = 1
        MSComm1.Output = "AT+CMGF=1" + Chr(13) + Chr(10)
        MSComm1.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 Sub MSComm1_OnComm()

    Dim buffer As String
    Dim i As Integer, j As Integer
    Dim NextFlag As Boolean

    ReceiveData = ReceiveData + MSComm1.Input
    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 And j < i And 14 >= Len(ReceiveData) - j Then '最前的数据为发送返回结果
            If SendSuccess = -1 Then
                buffer = Mid(ReceiveData, j, 14)
                If InStr(buffer, "OK") > 0 Then
                    SendSuccess = 1
                    SendSuccessCount = SendSuccessCount + 1
                Else
                    SendSuccess = 0
                    SendFailedCount = SendFailedCount + 1
                End If
            End If
            ReceiveData = Mid(ReceiveData, j + 14)
            NextFlag = True
        Else
            If i > 0 Then
                j = InStr(ReceiveData, Chr(13) + Chr(10) + "OK")
                If j > 0 Then
                    buffer = Mid(ReceiveData, i, j - i)
                    ReceiveSuccess = 0
                    If Analyze(buffer) Then
                        ReceiveSuccess = 1 '接收成功
                        ReceiveCount = ReceiveCount + 1
                    End If
                    ReceiveData = Mid(ReceiveData, j + 3)
                    NextFlag = True
                End If
            End If
        End If
    Loop While NextFlag

End Sub
Function Analyze(RecMsg As String) As Boolean
 Dim tel As String, msg As String, time As String
    Analyze = AnalyzeRecMsg(buffer, tel, msg, time)
    If Analyze = True Then
    '用户处理
        MobileTel.Text = tel
        SendMsg.Text = msg
       ' Label1.Caption = time
    End If
End Function
Private Sub Send_Click()
    Success = -1
    If Len(MobileTel.Text) < 11 Or Len(MobileTel.Text) > 12 Then
        MsgBox "请输入正确的手机号"
        Exit Sub
    End If
    If Len(SendMsg.Text) < 1 Or Len(SendMsg.Text) > 80 Then
        MsgBox "必须信息或输入的信息不能超过80"
        Exit Sub
    End If
    Status.Panels(2).Text = "正发送..."
    SmsSend MobileTel.Text, SendMsg.Text
End Sub
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
    MSComm1.Output = "AT+CSDH=1" + Chr(13) + Chr(10)
    MSComm1.Output = "AT+CMGR=" + MsgIndex + Chr(13) + Chr(10)
End Function
Private Function RequestDelMsg(MsgIndex As String)
    MSComm1.Output = "AT+CMGD=" + MsgIndex + Chr(13) + Chr(10)
End Function