form1.frm

用MODEM来发短信

Sleep (1600)
TxString = MSComm1.Input
Dim atext() As String
'Text8.SelText = TxString
atext = Split(TxString, Chr(13) & Chr(10))
'Text8.Text = atext(4)
If Len(atext(4)) < 15 Then
   Text4.SelText = "无未读新信息，请等待！" & vbCrLf
Else
  For i = 2 To (UBound(atext) - 1) / 2 - 1
  Sleep (100)
  Text8.Text = atext(i * 2)
  
SuperSMS1.ConPDU Text8.Text, P, D, T, TXT, 1, E
'Text4.Text = smsalltext
'获得解析后的数据
Text4.SelText = "电话号码：" & P & vbCrLf _
& "日期：" & D & vbCrLf _
& "时间：" & T & vbCrLf _
& "内容：" & TXT & vbCrLf _
& "错误代码：" & E & vbCrLf
'Text4.SelText = TxString
Next i
End If

OpenOnComm
End Sub

Private Sub Command6_Click()
CloseOnComm
MSComm1.Output = "at+cmgf=0" & Chr(13) & Chr(10)
Sleep (600)
MSComm1.Output = "at+cmgl=4" & Chr(13) & Chr(10)

Sleep (3800)
Dim smsalltext As String
smsalltext = MSComm1.Input
Dim atext() As String
Dim i As Integer
atext = Split(smsalltext, Chr(13) & Chr(10))
Dim j As Integer

If Len(atext(4)) < 15 Then
  Text4.SelText = "内存为空，无短信" & vbCrLf
Else
For j = 2 To (UBound(atext) - 1) / 2 - 1
 Sleep (100)
Text8.Text = atext(j * 2)
SuperSMS1.ConPDU Text8.Text, P, D, T, TXT, 1, E

'Text4.Text = smsalltext
'获得解析后的数据
Text4.SelText = "电话号码：" & P & vbCrLf _
& "日期：" & D & vbCrLf _
& "时间：" & T & vbCrLf _
& "内容：" & TXT & vbCrLf _
& "错误代码：" & E & vbCrLf
Next j
End If
OpenOnComm
End Sub
Sub Conv()

SuperSMS1.SMS_Phone = Text9.Text
SuperSMS1.SMS_CSCA = Text1.Text
SuperSMS1.SMS_STXT = Text3.Text
Text5.Text = SuperSMS1.SMS_SMain
'Text8.Text = SuperSMS1.ANSIText(Text7.Text)
Text6.Text = SuperSMS1.SMS_SLen
End Sub

Private Sub Command5_Click()
Text4.Text = ""
End Sub



Private Sub Command7_Click()
CloseOnComm


MSComm1.Output = "at+cmgd=" & Text7.Text & vbCrLf
Dim deltext As String
Delay 1
deltext = MSComm1.Input
If InStr(deltext, "OK") <> 0 Then
   Text4.SelText = "删除短信" & Text7.Text & "成功" & vbCrLf
   deltext = ""
Else
   Text4.SelText = "删除短信" & Text7.Text & "失败，请重新检查" & vbCrLf
    deltext = ""
End If
OpenOnComm
End Sub


Private Sub combo2_dropdown()

Dim SCom As Integer
  Dim hKey As Long, ret As Long, lenData As Long, typeData As Long
    Dim Name As String, lenName As Long
    Dim idx As Integer, j As Integer
    Dim SSCom(0 To 50) As String
    ret = RegOpenKey(HKEY_LOCAL_MACHINE, "HARDWARE\DEVICEMAP\SERIALCOMM", hKey)
   ' If ret <> 0 Then Exit Sub
   ' SCom = ret
    ret = 0
    idx = 0
    Dim s As String
    Dim SArr() As String
    
    
    While ret = 0
        lenName = 256
        Name = String(256, Chr(0))
        ret = RegEnumValueAsAny(hKey, idx, Name, lenName, ByVal 0, typeData, _
                                ByVal vbNullString, lenData)
        If ret <> 0 Then
            RegCloseKey hKey
          '  Exit Sub
        End If
        
        lenName = Len(Name)
    
        s = String(lenData, Chr(0))
        RegEnumValueAsAny hKey, idx, Name, lenName, ByVal 0, typeData, ByVal s, lenData

        s = Left(s, InStr(s, Chr(0)) - 1)

        'Debug.Print s
      
      '  Text1.SelText = s
        SSCom(idx) = s
        DoEvents
        
        idx = idx + 1
        SCom = idx
    Wend
    RegCloseKey hKey
    
Combo2.Clear
Dim i As Integer
For i = 0 To SCom - 2
Combo2.AddItem SSCom(i), i
'Combo7.AddItem "com2", 1
Next
End Sub
Private Sub Command8_Click()
'On Error Resume Next
CloseOnComm

If InStr(Command8.Caption, "关闭串口") <> 0 Then
   MSComm1.PortOpen = False
   Command8.Caption = "打开串口"
   Command7.Enabled = False
   Command6.Enabled = False
   Command4.Enabled = False
   Command1.Enabled = False
   Command9.Enabled = False
   Command10.Enabled = False
   Command2.Enabled = False
   Command11.Enabled = False
   Label5.Enabled = False
   
 Else
 
  MSComm1.PortOpen = 1
  Command8.Caption = "关闭串口"
'  If flag2 = True Then
 MSComm1.Output = "at" & vbCrLf
Dim attext
Sleep (800)
attext = MSComm1.Input
If InStr(attext, "OK") <> 0 Then
  Command2.Enabled = True
    Command7.Enabled = True
   Command6.Enabled = True
   Command4.Enabled = True
   Command1.Enabled = True
   Command9.Enabled = True
   Command10.Enabled = True
   Command11.Enabled = True
   Label5.Enabled = True
   Text4.SelText = "设备已经连接！" & vbCrLf
   
  Else
   Text4.SelText = "串口无反应，请检查！" & vbCrLf
  
 End If
End If
OpenOnComm
End Sub



Private Sub Command9_Click()
CloseOnComm
Dim TxString As String
Dim i As Integer

MSComm1.Output = "at+cmgf=0" & vbCrLf
Sleep (600)
MSComm1.Output = "at+cmgl=1" & Chr(13) & Chr(10)
Sleep (3600)
TxString = MSComm1.Input
Dim atext() As String
'Text8.SelText = TxString
atext = Split(TxString, Chr(13) & Chr(10))
'Text8.Text = atext(4)
If Len(atext(4)) < 15 Then
   Text4.SelText = "无已读信息，请检查！" & vbCrLf
Else
  For i = 2 To (UBound(atext) - 1) / 2 - 1
 Sleep (100)
  Text8.Text = atext(i * 2)
  
SuperSMS1.ConPDU Text8.Text, P, D, T, TXT, 1, E
'Text4.Text = smsalltext
'获得解析后的数据
Text4.SelText = "电话号码：" & P & vbCrLf _
& "日期：" & D & vbCrLf _
& "时间：" & T & vbCrLf _
& "内容：" & TXT & vbCrLf _
& "错误代码：" & E & vbCrLf
'Text4.SelText = TxString
Next i
End If
OpenOnComm
End Sub

Private Sub Text4_KeyPress(KeyAscii As Integer)
On Error Resume Next
MSComm1.Output = Chr(KeyAscii)
End Sub
Private Sub Form_Load()
    On Error Resume Next
   MSComm1.PortOpen = False
    MSComm1.CommPort = 1
    MSComm1.InputMode = comInputModeText
     MSComm1.Settings = "57600,N,8,1"
     'MSComm1.InBufferCount = 1
     MSComm1.InBufferSize = 30240
    MSComm1.InputLen = 0    '设置每次从串口缓冲区取的字节为全部
    MSComm1.PortOpen = True '打开串口
    Command8.Caption = "关闭串口"
    'Command8.Value = 0
    Combo1.Text = "57600"
    'CloseOnComm
    MSComm1.Output = "at" & Chr(13) & Chr(10)
    Sleep (800)
    'Text4.Text = StrConv (MSComm1.Input, vbUnicode)
    Dim aafirst As String
    aafirst = MSComm1.Input
    If InStr(aafirst, "OK") = 0 Then
    MsgBox ("AT不通，请检查mode是否连接成功！")
    'Command8.Caption = "打开串口"
    Command1.Enabled = 0
    Command4.Enabled = 0
    Command6.Enabled = 0
    Command7.Enabled = 0
    Command9.Enabled = 0
    Command10.Enabled = 0
     Command2.Enabled = 0
     Command11.Enabled = 0
     Label5.Enabled = 0
    Else
    aafirst = ""
    Text4.SelText = "设备已经连接成功，请测试！" & vbCrLf
    
   ' Command8.Caption = "关闭串口"
      Command1.Enabled = 1
    Command4.Enabled = 1
    Command6.Enabled = 1
    Command7.Enabled = 1
    Command2.Enabled = 1
    Command9.Enabled = 1
    Command10.Enabled = 1
    Command11.Enabled = 1
    Label5.Enabled = 1
    MSComm1.Output = "at+cnmi=1,1,0,0,1" & vbCrLf
    End If
    Delay 1
    aafirst = MSComm1.Input
    'inData = ""
   OpenOnComm
Open "DataLink.txt" For Append As #1
  
Close #1
End Sub
Private Sub Command1_Click()
On Local Error Resume Next
Command1.Enabled = False
Command2.Enabled = False
Command7.Enabled = False
Command11.Enabled = False
Command4.Enabled = False
Command9.Enabled = False
Command6.Enabled = False
Command10.Enabled = False

 CloseOnComm
 Dim stt1 'As String
 
 Dim atext() As String
Dim i As Integer
atext = Split(Text2.Text, ",")
'For i = 0 To UBound(atext)

 If Text1.Text <> "" Then
    MSComm1.Output = "at+csca=""" & Text1.Text & """" & Chr(13)
    Delay 2
    stt1 = MSComm1.Input
    If InStr(stt1, "OK") = 0 Then
     
       MsgBox "短信中心号码设置不成功，请检查！", vbOKOnly, "发送结果"
       Exit Sub
    End If
 End If
 Delay 1
 MSComm1.Output = "at+cmgf=1" & Chr(13)
 Sleep (600)  'wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
 Dim att 'As String
    att = MSComm1.Input
   ' Text4.Text = StrConv(att, vbUnicode)
    If InStr(att, "OK") <> 0 Then
       For i = 0 To UBound(atext)
         MSComm1.Output = "at+cmgs=""" & atext(i) & """" & Chr(13)
         Delay 2
         MSComm1.Output = Text3.Text & Chr(26)
         Sleep (3200)
    
         Dim stt 'As String
         stt = MSComm1.Input
         If InStr(stt, "+CMGS") <> 0 Then
            Text4.SelText = "发送给" & atext(i) & "成功！" & vbCrLf
         Else
            Text4.SelText = "发送给" & atext(i) & "失败，请检查！" & vbCrLf
         End If
         Sleep (100)
        Next i
        Text4.SelText = "发送完毕！" & vbCrLf
    Else
        MsgBox "短信模式设置不成功，请检查！", vbOKOnly, "发送结果"
    End If
Command1.Enabled = True
Command2.Enabled = True
Command7.Enabled = True
Command11.Enabled = True
Command4.Enabled = True
Command9.Enabled = True
Command6.Enabled = True
Command10.Enabled = True

 OpenOnComm
End Sub
Public Sub CloseOnComm()
MSComm1.RThreshold = 0
MSComm1.InputMode = comInputModeText

End Sub
Public Sub OpenOnComm()
MSComm1.RThreshold = 1
MSComm1.InputMode = comInputModeBinary

End Sub
Public Sub Delay(HowLong As Date)   '延时
   Dim temptime As Date
   temptime = DateAdd("s", HowLong, Now)
    While temptime > Now
        DoEvents '让 windows 去处理其他事
    Wend
End Sub

Private Sub Text1_Change()
Conv
End Sub

Private Sub Text2_Change()

Conv
End Sub

Private Sub Text3_Change()
Conv
End Sub



Private Sub MSComm1_OnComm() '串口中断
On Error Resume Next
Static bFlag As Boolean
Static Xbyte As Long
Select Case MSComm1.CommEvent   '选择事件
Case comEvReceive '接收到字符
     
        Dim InByte() As Byte '定义一个二进制指针放接收到的数据
        InByte = MSComm1.Input '数据转移到指针
        Dim temp As Long
        Dim temp1 As Long
        Dim temp2 As Long
        Dim j As Long
        Dim counttrue As Integer
        counttrue = 1
       
        
         For j = 0 To UBound(InByte) '循环到指针上标
          ''  If ifhex = 1 Then '16进制显示处理
        '  inData = inData & Hex(InByte(j)) & " " '取出一个字节换为16进制显示用

           ' Else:
                  If InByte(j) < 128 And bFlag = 0 Then
                    If InByte(j) = 13 Then
                    inData = inData & vbCr 'Lf
                    Else
                    inData = inData & Chr(InByte(j)) 'ascii码显示处理
                    
                    End If
                  Else '此时为一个中文的前半部
                     If bFlag Then '上次收到半个中文没处理
                     temp1 = Xbyte
                     temp2 = InByte(j)
                     temp = (temp1 * 256 + temp2) - 65536
                     inData = inData & Chr(temp)
                     bFlag = 0
                     Else
                        If j <> UBound(InByte) Then
                        temp1 = InByte(j)
                        temp2 = InByte(j + 1)
                        temp = (temp1 * 256 + temp2) - 65536
                        inData = inData & Chr(temp) ' & "(*" & temp & "*) "
                        j = j + 1 '此次中断收到最后一个字节是前半个中文
                        Else
                        
                        Xbyte = InByte(j) '保存该字节
                        bFlag = 1 '置标志
                        
                        End If
                     End If
                 ' End If
            End If
         
        ' counttrue = 1
        
    Next j

 DoEvents

   ' Delay 1
 ' flag2 = False
  If InStr(inData, "+CMTI:") <> 0 And counttrue = 1 Then
        
            Text4.SelText = "新短信，请接收！" & vbCrLf
           ' Delay 1
            counttrue = counttrue + 1
 End If


If Check1.Value And InStr(inData, "+CMT:") <> 0 Then
 CloseOnComm
 Delay 1
 inData = MSComm1.Input
 Dim atext() As String
 atext = Split(inData, Chr(13) & Chr(10))
 Text8.Text = atext(1)
 SuperSMS1.ConPDU Text8.Text, P, D, T, TXT, 1, E
'Text4.Text = smsalltext
'获得解析后的数据
Text4.SelText = "电话号码：" & P & vbCrLf _
& "日期：" & D & vbCrLf _
& "时间：" & T & vbCrLf _
& "内容：" & TXT & vbCrLf _
& "错误代码：" & E & vbCrLf
'保存到TEXT文档
Text8.Text = "电话号码：" & P & vbCrLf _
& "日期：" & D & vbCrLf _
& "时间：" & T & vbCrLf _
& "内容：" & TXT & vbCrLf _
& "错误代码：" & E & vbCrLf
Open "DataLink.txt" For Append As #1
   Print #1, Text8.Text
Close #1

Sleep (400)
MSComm1.Output = "at+cnma" & Chr(13) & Chr(10)
Sleep (600)
  inData = MSComm1.Input
 If InStr(inData, "OK") = 0 Then
    MSComm1.Output = "at+cnma" & Chr(13) & Chr(10)
    Sleep (400)
    inData = MSComm1.Input
 End If
  OpenOnComm
  

  
End If
 
  Text4.SelText = inData '将刚收到的字符串显示出来
    inData = ""
  Text4.SelStart = Len(Text4.Text) '光标置后
    

Case comEventRxOver '接收缓冲区满的处理
MsgBox "接收缓冲区满了！" '发出警告
End Select
End Sub