smstest.frm

一个pc通过串口连接手机发送短信的测试程序

    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

Public Function teldec(num As String) As String  '收短信手机号码解码

  Dim tl As Integer
  Dim ltem, rtem, ttem As String
  Dim ti As Integer
      
  ttem = ""
  tl = Len(num)
  
  For ti = 1 To tl Step 2
    ltem = Mid(num, ti, 1)
    rtem = Mid(num, ti + 1, 1)
    ttem = ttem & rtem & ltem
  Next ti
  If Right(ttem, 1) = "F" Then
      ttem = Mid(ttem, 1, tl - 1)
  End If
  teldec = ttem
End Function

    


Function pdu_send(ByVal csca As String, ByVal num As String, ByVal msg As String) As String   'pdu编码和短信发送
 Dim pdu, psmsc, pnum, pmsg As String
  Dim leng As String
  Dim Length As Integer
Const prex = "0891"
Const midx = "11000D91"
Const sufx = "000800"
  Length = Len(msg)
  Length = 2 * Length
  leng = Hex(Length)
  If Length < 16 Then leng = "0" & leng
  psmsc = Trim(telc(csca))
  pnum = Trim(telc(num))
  pmsg = Trim(ascg(msg))
  pdu = prex & psmsc & midx & pnum & sufx & leng & pmsg
  
  '----------------------------------------------------
  
      
    If connect_status = True Then
       sleep (1)
       MSComm1.Output = "AT+CMGF=0" + vbCr
       sleep (1) '''''
       MSComm1.Output = "AT+CMGS=" & Str(15 + Length) + vbCr
       sleep (3)
       MSComm1.Output = pdu & Chr$(26)
       sleep (4)
       pdu_send = "1" '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''需增加检测环节
    MsgBox "已发送 " + MSComm1.Input
    Else
    pdu_send = "0"
    MsgBox "串口未打开 "
    End If


End Function


Function pdu_decode(pdu_in As String, ByRef smsc_num As String, ByRef from_num As String, ByRef from_time As String, ByRef msg As String) As Integer   'pdu解码
Dim pdul, from_numl, msgl As Integer
Dim pdu As String

pdu = pdu_in
smsc_num = ""
from_num = ""
from_time = "'"
msg = ""

pdul = Len(pdu)

smscl = CInt(Val("&H" & Left(pdu, 2)))
smsc_num = teldec(Mid(pdu, 5, 2 * smscl - 2))
If Mid(pdu, 3, 2) = "91" Then
  smsc_num = "+" & smsc_num
End If

pdul = pdul - 2 * smscl - 2
pdu = Mid(pdu, 2 * smscl + 3, pdul)

from_numl = CInt(Val("&H" & Mid(pdu, 3, 2)))
If (from_numl Mod 2) <> 0 Then
  from_numl = from_numl + 1
End If
from_num = teldec(Mid(pdu, 7, from_numl))
If Left(from_num, 2) = "86" Then
  from_num = Right(from_num, Len(from_num) - 2)
End If

pdul = pdul - from_numl - 10
pdu = Mid(pdu, (from_numl + 11), pdul)

from_time = teldec(Left(pdu, 12))

pdul = pdul - 14
pdu = Mid(pdu, 15, pdul)

msgl = CInt(Val("&H" & Left(pdu, 2)))
If (pdul - 2) = msgl * 2 Then
  msg = chg(Mid(pdu, 3, pdul - 2))
  pdu_decode = 1
Else
  pdu_decode = 0
End If

End Function





    '因为手机同一时间只能处理一件事情，因此这个函数只负责发送短信，关于短信发送成功与否以及阅读短信的部分集中在一起处理。判断手机短信发送成功与否主要由AT+CMGS命令执行以后的返回码来决定（可参见前文的AT指令介绍部分）。

    '为了防止手机因过于繁忙而出错，这里采取了一定的方法让手机有充分的时间处理发送和接收及删除等操作。Sleep()函数正是为此而设计的，在发送及删除操作后都会让程序暂停一秒，这样就不至于使得手机过于繁忙。

    Public Function sleep(tt As Integer) As Integer
       For r = 0 To tt
        For i = 1 To 100
          For j = 1 To 10000
            k = j
            Next j
            Next i
          Next r
          sleep = 1

    End Function





Private Sub find_sms_in_Click()  '启用接收中断提醒功能
    If connect_status = False Then
    MsgBox "请先连接串口！"
    Exit Sub
  End If
  If find_sms_in.Value = 1 Then

    MSComm1.Output = "AT+CNMI=1,1,0,2,1" + Chr(13) + Chr(10)

   Else

     MSComm1.Output = "AT+CNMI=0,0,0,0,1" + Chr(13) + Chr(10)

   End If
    
End Sub

Private Sub com_connect_Click()    '打开串口
 Dim resp As String
 Dim outstring As String
 
 
 'If SmsOpen(2, "19200,n,8,1") = True Then
  If SmsOpen(CInt(com_num.Text), com_set.Text) = True Then

        MSComm1.Output = "ATE0" + Chr(13) + Chr(10) '关闭回显
         sleep (3)
        resp = MSComm1.Input
        MSComm1.Output = "AT" + Chr(13) + Chr(10) '测试连接正常
         sleep (3)
        resp = MSComm1.Input
        If resp = (Chr(13) + Chr(10) + "OK" + Chr(13) + Chr(10)) Then
           MsgBox "串口成功连接!"
           connect_status = True
           MSComm1.RThreshold = 1 '开串口接收中断
             sleep (10)
           
           MSComm1.Output = "AT+CPMS = ""MT"", ""MT"", ""MT""" + Chr(13) + Chr(10) '短消息接受后存在手机上??
           sleep (3)
           Exit Sub
        End If
  End If
  MsgBox "串口连接失败!"
End Sub


Function SmsOpen(Port As Integer, Setings As String) As Integer     '串口初始化

On Error GoTo ErrHandle
    SmsOpen = False
    If MSComm1.PortOpen Then MSComm1.PortOpen = False
    MSComm1.CommPort = Port
    MSComm1.Settings = Setings
    MSComm1.InBufferSize = 10000
    MSComm1.InputMode = comInputModeText  '
    MSComm1.InBufferCount = 0  '清除接收缓冲区
    MSComm1.OutBufferCount = 0 '清除发送缓冲区
    MSComm1.RThreshold = 0     '关串口接收中断
    
    MSComm1.PortOpen = True
  
    If MSComm1.PortOpen Then
        SmsOpen = True
    End If
Exit Function
ErrHandle:
   MsgBox "错误：  " + Str(Err.Number) + Chr(13) + Chr(10) + Err.Description, _
          vbOKOnly + vbCritical, App.Title
End Function


Private Sub com_disconnect_Click()    '关闭串口
     If MSComm1.PortOpen = True Then
         MSComm1.PortOpen = False
     End If
         
      MsgBox "端口已关闭"
      connect_status = False
End Sub




Private Sub Form_Load()
 


 connect_status = False
 find_sms_in.Value = 0


End Sub


Private Sub MSComm1_OnComm()   '有通讯事件发生(接受数据)
Dim dd As String

Select Case MSComm1.CommEvent

Case comEvReceive '...有接受事件发生
  'MSComm1.RThreshold = 0 '关串口接收中断
  sleep (3)
  dd = MSComm1.Input
'  sms_receive.Text = sms_receive.Text & dd & vbCrLf
  
  'at_receive_temp = at_receive_temp + MSComm1.Input
  at_receive_temp = at_receive_temp + dd
  
       If InStr(at_receive_temp, "OK" & vbCrLf) <> 0 Or InStr(at_receive_temp, "ERROR" & vbCrLf) <> 0 Or InStr(at_receive_temp, vbCrLf & "+CMTI: """) <> 0 Then '收完后
                
                at_receive = at_receive_temp
                com_out.Text = at_receive
                at_receive_ready = 1
                at_receive_temp = ""
                com_receive_output (at_receive)
                                
            End If
  
          
            
  'MSComm1.RThreshold = 1 '开串口接收中断'''''
Case Else
  MsgBox "串口通信出错"

End Select
End Sub

Private Sub send_at_Click()   '发送at命令

  If connect_status = False Then
    MsgBox "请先连接串口！"
    Exit Sub
  End If

  MSComm1.InBufferCount = 0  '清除接收缓冲区
  MSComm1.Output = Trim(com_in.Text) + Chr(13) + Chr(10)
End Sub

Private Sub sms_del_Click()

  If connect_status = False Then
    MsgBox "请先连接串口！"
    Exit Sub
  End If

    MSComm1.Output = "AT+CMGD=" + del_index.Text + Chr(13) + Chr(10)
    sleep (3)
    MsgBox "短信删除成功！"
    MSComm1.InBufferCount = 0  '清除接收缓冲区
    MSComm1.Output = "AT+CMGL=1" + Chr(13) + Chr(10)
    
End Sub

Private Sub sms_get_Click()


  If connect_status = False Then
    MsgBox "请先连接串口！"
    Exit Sub
  End If
  
  at_receive_ready = 0
  at_receive = ""

  MSComm1.InBufferCount = 0  '清除接收缓冲区
  MSComm1.Output = "AT+CMGL=1" + Chr(13) + Chr(10)


End Sub


Private Sub com_receive_output(ByVal at_receive As String)
  Dim at_head As String
  Dim at_tail As String
  Dim sms(5) As String
  
 Dim smsc_num As String
 Dim from_num As String
 Dim from_time As String
 Dim msg As String
   
  If InStr(at_receive, "+CMTI: ""MT"",") > 0 Then '收到新信息提醒,直接查询新信息
    'Call sms_get_Click
    MSComm1.InBufferCount = 0  '清除接收缓冲区
    MSComm1.Output = "AT+CMGL=0" + Chr(13) + Chr(10)
  End If
  
  If InStr(at_receive, "+CMGL:") > 0 And InStr(at_receive, "OK" & vbCrLf) Then '接收到短消息
    at_tail = at_receive
    'sms_receive.Text = ""
       
    Do Until (at_tail = "OK" & vbCrLf)
    at_head = StrHead(at_tail, vbCrLf)
    If InStr(at_head, "+CMGL:") Then
           sms(1) = Mid(at_head, 7, InStr(at_head, ",") - 7)
           at_head = StrHead(at_tail, vbCrLf)
           If pdu_decode(at_head, smsc_num, from_num, from_time, msg) = 1 Then
                   sms(2) = smsc_num
                   sms(3) = from_num
                   sms(4) = from_time
                   sms(5) = msg
            End If
            sms_receive.Text = sms(1) + "," + sms(2) + "," + sms(3) + "," + sms(4) + "," + sms(5) + vbCrLf + sms_receive.Text
   End If
   Loop
   End If
End Sub




Private Sub smssend_Click()  '发送一条信息
   Dim smsccc, numb, smsmsg As String
   Dim result As Boolean
    smsccc = Trim(smsc.Text)
    numb = Trim(tonumber.Text)
    smsmsg = Trim(sms_send.Text)
   result = pdu_send(smsccc, numb, smsmsg)

End Sub

Public Function StrHead(ss As String, ByVal c As String) As String
    Dim i As Long
    
    i = InStr(ss, c)
    If i > 0 Then
        StrHead = Mid(ss, 1, i - 1)
        ss = Mid(ss, i + Len(c))
    Else
        StrHead = ss
        ss = ""
    End If
End Function