frmreceive.frm

VB开发的手机短信接收发送管理程序

VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form FrmReceive 
   Caption         =   "短信发送接收程序"
   ClientHeight    =   7980
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7275
   Icon            =   "FrmReceive.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   7980
   ScaleWidth      =   7275
   StartUpPosition =   3  '窗口缺省
   Begin VB.Timer Timer1 
      Interval        =   1000
      Left            =   600
      Top             =   120
   End
   Begin VB.TextBox txtStatus 
      BackColor       =   &H80000004&
      Height          =   7695
      Left            =   0
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   0
      Top             =   0
      Width           =   7215
   End
   Begin MSCommLib.MSComm G18 
      Left            =   120
      Top             =   240
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      DTREnable       =   -1  'True
   End
End
Attribute VB_Name = "FrmReceive"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Cn As New ADODB.Connection
Private tb_SQ As New ADODB.Recordset
Dim rdCallHandset As New ADODB.Recordset
Dim mycount As Integer
Dim StrMain As String
Dim Timeint As Integer
Private Declare Function APIBeep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Sub cmdClr_Click()
    txtStatus.Text = ""
End Sub

Private Sub cmdStop_Click()
    End
End Sub

Private Sub Command1_Click()
    'SMSSendToUser_G18 "您好！您购买的PC200A型挖掘机（编号：66888），已到付款日期，请于12月11日到中国建设银行进行第4次付款！。", "13833160150"
End Sub
Private Sub Timer1_Timer()
   Dim StrReceive As String
    Dim SmsStart As Integer
    Dim SmsLen As Integer
    Dim SMSStr As String
    Dim Startpostion As Integer
    On Error GoTo ErrorHandler
    '接收G18短信
    RefreshSendQueue
    Timeint = Timeint + 1
    If Timeint > 300 Then
      'SetNOCnmi
      ' rec_G18_SMS True
       SetNoInt
       Timeint = 0
    End If
    StrReceive = G18.Input
    StrMain = StrMain & StrReceive
    If Len(StrMain) > 60 Then
    '//判断是否是状态报告
      'PubStatus StrMain
      Startpostion = InStr(1, StrMain, "+CDS")
      Debug.Print StrMain
        If Startpostion <> 0 And Len(Mid(StrMain, Startpostion + 1)) >= 79 Then
           RpTrac StrMain
           PubStatus "收到状态报告内容：" & Mid(StrMain, Startpostion)
           SetNoInt
           StrMain = ""
           ShowForm
        Else
         If InStr(1, StrMain, "+CMT") <> 0 Then
            SmsStart = InStr(1, StrMain, "089168")
            '<Gjr030824Modi>
            '当前出现089168位于字符串开头的情况，判断起始非0是不对的，那样调用Mid函数时将提示“Error #5 无效的过程调用或参数”。
            'If SmsStart > 0 Then
            If SmsStart > 4 Then
                SmsLen = CInt(Trim(Mid(StrMain, SmsStart - 5, 3)))
                If Len(Trim(Mid(StrMain, SmsStart, 58 + (SmsLen - 20) * 2))) >= (58 + (SmsLen - 20) * 2) Then
                    '//发送AT+CNMA 到G18模块以保证其状态'0,2,0,0,0'
                    SetNoInt
                    Timeint = 0
                    '//解释入库
                     Debug.Print Now & StrMain
                     SMSTrac StrMain
                     Debug.Print Asc(Trim(Mid(Mid(StrMain, SmsStart), (58 + (SmsLen - 20) * 2) + 1)))
                     'If Asc(Trim(Mid(Mid(StrMain, SmsStart), (58 + (SmsLen - 20) * 2) + 1))) <> 13 Then
                     '  PubStatus Mid(Mid(StrMain, SmsStart), (58 + (SmsLen - 20) * 2) + 1)
                     'End If
                    StrMain = ""
                    ShowForm
                End If
            Else
                
                'PubStatus "短信长度非法:" & StrMain, False, True
                StrMain = ""
                SetNoInt
            End If
            '<Gjr030824Modi>
        End If
     End If
   End If
    '整点报告程序运行状态
    Exit Sub
'错误处理
ErrorHandler:
   If Err.Number = 70 Then
      Resume Next
    Else
      PubStatus "公有变量strMain的值：" & StrMain
      PubStatus "Error #" & CStr(Err.Number) & " " & Err.Description, True
      SetNoInt
     StrMain = ""
   End If
End Sub

Private Sub Form_Load()
  On Error GoTo aa
    Cn.ConnectionTimeout = 200
    Cn.CommandTimeout = 200
    Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\database\data.mdb;Persist Security Info=False;Jet OLEDB:Database Password=ljglzx"
    G18.CommPort = 2
    G18.Settings = "9600,n,8,1"
    G18.PortOpen = True
    SMSReceive_G18
    PubDelay (1000)
    G18.Output = "at+cnmi=0,2,0,1,0" & Chr(13)
    PubDelay (1000)
    Timer1.Enabled = True
    addicon
    Me.Hide
    Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
    SaveSetting appname:="smssend", section:="sendopen", Key:="yesno", setting:="yes"
 Exit Sub
aa:
  PubStatus "程序出现错误" & Err.Description & Err.Number
  End
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SaveSetting appname:="smssend", section:="sendopen", Key:="yesno", setting:="no"
    PubStatus "系统正常关闭"
    Cn.Close
    G18.PortOpen = False
    End
End Sub

'//////////////////////////////////////////////////////////////
'刷新发送队列SendQueue表，每执行一次发送一条优先级最高的短信。
'//////////////////////////////////////////////////////////////
Private Sub RefreshSendQueue()
    'On Error Resume Next
    Dim tb_SQ As New ADODB.Recordset
    Dim SendSIMNum As String
    Dim SendContent As String
    Dim tempSendTime As Date
    Dim tempSendTime_1 As Double
    Dim Admi As String
    With tb_SQ
        .Open "select * from SendQueue where 发送标志='已发'", Cn, adOpenDynamic, adLockOptimistic
       Do Until .EOF
         If Now - .Fields!发送时间 > 5 / 24 / 60 Then
          .Fields!发送标志 = "超时"
          .Update
         End If
         .MoveNext
       Loop
       .Close
    End With
    tempSendTime = #1/1/2000 12:00:01 AM#
    tb_SQ.Open "select * from SendQueue where 发送标志='待发'", Cn, adOpenDynamic, adLockOptimistic
      If Not tb_SQ.EOF Then
        SendSIMNum = tb_SQ.Fields!手机号
        SendContent = LTrim(RTrim(tb_SQ.Fields!发送内容))
        
        If SMSSendToUser_G18(SendContent, SendSIMNum) = True Then
            tb_SQ.Fields!发送标志 = "已发"
            tb_SQ.Fields!发送时间 = Now
            PubStatus "发送内容：" & SendContent
            PubStatus "向用户" & SendSIMNum & "发送短信成功。"
        Else
            PubStatus "发送内容：" & SendContent
            tb_SQ.Fields!发送标志 = "失败"
            tb_SQ.Fields!发送时间 = Now
            PubStatus "向用户" & SendSIMNum & "发送短信失败。"
        End If
        tb_SQ.Update
      End If
    tb_SQ.Close
    Set tb_SQ = Nothing
End Sub

'//////////////////////////////////////////////////////
'发送中文短消息，发送参数(发送的中文内容，对方手机号)
'//////////////////////////////////////////////////////
Private Function SMSSendToUser_G18(ByVal vSendStr As String, ByVal vSIMnumber As String) As Boolean
    Dim I As Integer
    Dim Sendstr As String
    Dim StrLength As Integer
    Dim Temp_timer As Long
    Dim InputStr_L As String
    Dim InputStr_S As String
    Dim OutStr As String
    Dim SendLength As String
    Dim SIMID As String
    Dim SendWeither As Boolean
    SMSSendToUser_G18 = False
    Dim j As Integer
    '检验参数合法性
    'G18.Output = "at+cnmi=0,0,0,0,0" & Chr(13)
   If Not SMSParameterValidityTest(vSendStr, vSIMnumber) Then
      PubStatus "参数不合法"
      Exit Function
    End If
    
    '清空接收和发送缓冲区
    ClrSMSInputOutputBuffer
 'For i = 0 To 2
    '判断模块是否正常工作
'   If Not testGSM() Then
 '    PubStatus "模块工作不正常"
 '   Else
 '     Exit For
 '   End If
'  Next i
'  If i > 2 Then
'    Exit Function
'  End If
    '##################################
    'Gjr030617.
    '暂免去信号强度测试。
    
    '测试信号强度是否达到要求
    'If GSMStrengthTest_G18 < 10 Then
    '    PubStatus "信号强度不足"
    '    Exit Function
    'End If
    '##################################
    
    '将输入的汉字字符串转化为Unicode代码，并在最后补"0000"
aa:
  Sendstr = ""
    For I = 1 To Len(vSendStr)
        Sendstr = Sendstr & Right("0000" & Hex(AscW(Mid(vSendStr, I, 1))), 4)
    Next
    Sendstr = Sendstr & "0000"
    
    '计算发送内容长度
    StrLength = Len(Sendstr) / 2
    
    For I = 1 To 3
    
        '清空接收发送缓冲区
        G18.InBufferCount = 0
        G18.OutBufferCount = 0
        
        '发送"CMGS"命令
        OutStr = "AT+CMGS= " & (15 + StrLength) & Chr(13)
        Debug.Print OutStr
        G18.Output = OutStr
        
        SendWeither = False
        Temp_timer = Timer
        Do While Timer < Temp_timer + 2
            Call PubDelay(500)
            InputStr_S = G18.Input
            If Len(InputStr_S) <> 0 Then
                InputStr_L = InputStr_L + InputStr_S
                If InStr(InputStr_L, "> ") <> 0 Then
                    SendWeither = True
                    Exit Do
                Else
                    SendWeither = False
                End If
            End If
        Loop
        
        '收到字符"> "后退出For语句
        If SendWeither = True Then Exit For
    Next
    If SendWeither = False Then
       PubStatus "没有收到>"
      Exit Function
    End If
    'PubDelay (1000)
    '计算发送字符串压缩以前的长度
    If Len(Hex(StrLength + Int(StrLength / 7))) = 1 Then
        SendLength = "0" & Hex(StrLength + Int(StrLength / 7))