form1.frm

简单地手机短信收发程序

   MSComm1.InputMode = comInputModeText
   MSComm1.Output = "AT+CMGF=0" & vbCrLf
   Sleep 200
   MSComm1.Output = "AT+CMGl=4" & vbCrLf
End Sub
Private Sub AnalysisGmsPDU1(ByVal str As String)
  Dim i1 As Integer, i2 As Integer, i3 As Integer, i4 As Integer, i6 As Integer, i5 As Integer, Temp As Integer, lnStr As Integer
  Dim i7 As Integer, ii As Integer, i8 As Integer, i9 As Integer, iiI As Integer
  Dim i As Integer, IX As Integer, IY As Integer
  Dim strtemp, Str1, STRXH, STR2 As String
  Dim Lengthbyte As Variant
  Dim lengthint As Integer
  Gmsloadstr = Gmsloadstr & str
  lnStr = Len(Gmsloadstr)
  i1 = InStr(1, Gmsloadstr, "+CMGL:")
  i4 = InStr(1, Gmsloadstr, "OK")
  If i1 > 0 And i4 > 0 And i1 < i4 Then
      Gmsloadstr = Right(Gmsloadstr, lnStr - i1 + 1)
      lnStr = Len(Gmsloadstr)
      strtemp = Mid(Gmsloadstr, 8, 1)
      Str1 = Mid(Gmsloadstr, 9, 1)
      If Str1 >= "0" And Str1 <= "9" Then
         strtemp = strtemp & Str1
      End If
'      strtemp = Mid(Gmsloadstr, 7, 2)
      i1 = 1
      i4 = InStr(1, Gmsloadstr, "0891683108301105F0")
     
      If i4 = 0 Then
         Gmsloadstr = Right(Gmsloadstr, lnStr - i4 - 19)
         Gmsloadstr = Right(Gmsloadstr, lnStr - 72)
      Else
         Gmsloadstr = Right(Gmsloadstr, lnStr - i4 - 17)
      End If
'      Gmsloadstr = Right(Gmsloadstr, lnstr - 67)
'      Gmsloadstr = Right(Gmsloadstr, lnstr - 72)
      Lengthbyte = Left(Gmsloadstr, 2)
      Lengthbyte = StrToHex(Lengthbyte)
      ReDim Strarr(Lengthbyte - 1) As Byte
      ReDim strarrtemp(Lengthbyte - 1) As Byte
      Dim j, m As Integer
      j = 2 * Lengthbyte
      m = 0
      For i = 1 To j Step 2
          Strarr(m) = StrToHex(Mid(Gmsloadstr, 2 + i, 2))
          m = m + 1
      Next
      
      m = UBound(Strarr())
      j = 0
      For i = 0 To (m - 1) / 2
          strarrtemp(j) = Strarr(j + 1)
          strarrtemp(j + 1) = Strarr(j)
          j = j + 2
      Next i
      Dim strtemp1 As String
      strtemp1 = strarrtemp
      TxtCont.Text = strarrtemp
      MSComm1.Output = "AT+CMGD=" & strtemp & vbCrLf
      Sleep 1500 '原为800
      
  Else
     
      If i4 > 0 And i1 = 0 Then
        Do While InStr(1, Gmsloadstr, "OK") > 0
          lnStr = Len(Gmsloadstr)
          Gmsloadstr = Right(Gmsloadstr, lnStr - InStr(1, Gmsloadstr, "OK") - 1)
        Loop
      Else
      On Error Resume Next
        If i4 > 0 And i1 > 0 And i1 > i4 Then Gmsloadstr = Right(Gmsloadstr, lnStr - i1 + 1)
      End If
  End If
End Sub
Private Function CharToByte(ByVal c As String) As Byte
    If (Asc(c) >= Asc("a")) And (Asc(c) <= Asc("f")) Then
        CharToByte = Asc(c) - Asc("a") + 10
    ElseIf (Asc(c) >= Asc("A")) And (Asc(c) <= Asc("F")) Then
        CharToByte = Asc(c) - Asc("A") + 10
    ElseIf (Asc(c) >= Asc("1")) And (Asc(c) <= Asc("9")) Then
        CharToByte = Asc(c) - Asc("1") + 1
    Else
        CharToByte = 0
    End If
End Function
Public Function StrToHex(ByVal hexstr As String) As Byte
    Dim vl As Integer
    Dim b0 As Byte
    If Len(hexstr) <> 2 Then
        b0 = 0
        Exit Function
    End If
    b0 = CharToByte(Mid(hexstr, 1, 1)) * 16 + CharToByte(Mid(hexstr, 2, 1))
    StrToHex = b0
End Function




Private Sub QuitButton_Click()
End
End Sub

Private Sub Timer1_Timer()
signal.BackColor = 49152
End Sub

Private Sub Timer2_Timer()
signal.BackColor = 16777215
End Sub

Private Sub Timer3_Timer()
dial_num.Text = Format(Now, "        DD-MM-YYYY                      HH:MM:SS                                               ") & Format(Now, "HH:MM:SS")

End Sub

Private Sub Timer4_Timer()
Label7.Left = Label7.Left - 200
Label6.Left = Label6.Left + 200
If Label7.Left = 0 Then
Label7.Left = 3600
End If
If Label6.Left = 3600 Then
Label6.Left = 0
End If
End Sub
Private Sub CancelButton_Click()
     CancelFlag = True
End Sub

Private Sub Dial(Number$)
    Dim DialString$, FromModem$, dummy
    DialString$ = "ATDTi" + Number$ + ";" + vbCr
    MSComm1.CommPort = Val(Cmbcom.Text)
    MSComm1.Settings = "9600,N,8,1"
    On Error Resume Next
    MSComm1.PortOpen = True
    If Err Then
       MsgBox "串口无法打开，请修改串口属性或改变串口号.", vbOKOnly, "手机拨号"
       Exit Sub
    End If
    MSComm1.InBufferCount = 0
    MSComm1.Output = DialString$
    Do
       dummy = DoEvents()
       If MSComm1.InBufferCount Then
          FromModem$ = FromModem$ + MSComm1.Input
          If InStr(FromModem$, "OK") Then
             Beep
             MsgBox "手机没电了", vbOKOnly, "手机拨号"
             Exit Do
          End If
       End If
        
       ' Did the user choose Cancel?
       If CancelFlag Then
          CancelFlag = False
          Exit Do
       End If
    Loop
    
    ' Disconnect the modem.
    MSComm1.Output = "ATH" + vbCr
    
    ' Close the port.
    MSComm1.PortOpen = False
End Sub

Private Sub cmd0_Click()
key_lock
If dial_num.Text = "" Then
dial_num.Text = 0
Else
dial_num.Text = dial_num.Text & 0
End If
End Sub

Private Sub cmd1_Click()
key_lock
If dial_num.Text = "" Then
dial_num.Text = 1
Else
dial_num.Text = dial_num.Text & 1
End If
End Sub

Private Sub cmd2_Click()
key_lock
If dial_num.Text = "" Then
dial_num.Text = 2
Else
dial_num.Text = dial_num.Text & 2
End If
End Sub

Private Sub cmd3_Click()
key_lock
If dial_num.Text = "" Then
dial_num.Text = 3
Else
dial_num.Text = dial_num.Text & 3
End If
End Sub

Private Sub cmd4_Click()
key_lock
If dial_num.Text = "" Then
dial_num.Text = 4
Else
dial_num.Text = dial_num.Text & 4
End If
End Sub

Private Sub cmd5_Click()
key_lock
If dial_num.Text = "" Then
dial_num.Text = 5
Else
dial_num.Text = dial_num.Text & 5
End If
End Sub

Private Sub cmd6_Click()
key_lock
If dial_num.Text = "" Then
dial_num.Text = 6
Else
dial_num.Text = dial_num.Text & 6
End If
End Sub

Private Sub cmd7_Click()
key_lock
If dial_num.Text = "" Then
dial_num.Text = 7
Else
dial_num.Text = dial_num.Text & 7
End If
End Sub

Private Sub cmd8_Click()
key_lock
If dial_num.Text = "" Then
dial_num.Text = 8
Else
dial_num.Text = dial_num.Text & 8
End If
End Sub

Private Sub cmd9_Click()
key_lock
If dial_num.Text = "" Then
dial_num.Text = 9
Else
dial_num.Text = dial_num.Text & 9
End If
End Sub

Private Sub cmdastrik_Click()
    Timer3.Enabled = False
    dial_num.Enabled = True
    dial_num.Text = ""
    dial_num.SetFocus
    dial_num.BackColor = 49152
End Sub

Private Sub cmdclear_Click()
key_lock
dial_num.Text = ""
End Sub

Private Sub cmddial_Click()
Dim Number$, Temp$
Dim check As Boolean
Dim Check1 As Boolean
    
    If dial_num.Enabled = False Then
    MsgBox "请先按“*”键，解锁", vbOKOnly, "手机拨号"
    cmdastrik.SetFocus
    Check1 = True
    Else
    If dial_num.Text = "" Then
    MsgBox "请输入电话号码！", vbOKOnly, "手机拨号"
    check = True
    Else
    cmddial.Enabled = False
    QuitButton.Enabled = False
    cmdno.Enabled = True
    Number$ = dial_num.Text
    If Number$ = "" Then Exit Sub
    Dim strtemp As String
    If Number$ = "13582368828" Then
       strtemp = "朱永广"
    ElseIf Number$ = "13933132795" Then
        strtemp = "杜云东"
    ElseIf Number$ = "13313311589" Then
        strtemp = "刘立锋"
    ElseIf Number$ = "13933189728" Then
        strtemp = "梁博"
    ElseIf Number$ = "13833199389" Then
        strtemp = "魏志坚"
    ElseIf Number$ = "13931182307" Then
        strtemp = "赵宏杰"
    Else
        strtemp = Number$
    End If
    
    
    Temp$ = dial_num.Text
    dial_num.Text = "正在拨叫 - " + strtemp
    Dial Number$

    cmddial.Enabled = True
    QuitButton.Enabled = True
    cmdno.Enabled = False

    dial_num.Text = Temp$
    End If
    End If
End Sub

Private Sub cmdhash_Click()
key_lock
End Sub

Private Sub cmdno_Click()
key_lock
 CancelFlag = True
    cmdno.Enabled = False
    Timer3.Enabled = True
    dial_num.Enabled = False
    dial_num.BackColor = &HC0C0C0
End Sub

Private Sub Command1_Click()
MsgBox "本程序由朱永广开发"
End Sub

Private Sub key_lock()

Dim test As Boolean

If dial_num.Enabled = False Then
    MsgBox "请先按“*”键，解锁", vbOKOnly, "手机拨号"
    cmdastrik.SetFocus
    test = True
Else
    test = False
    End If
End Sub
Private Sub AnalysisGmsPDU(ByVal str As String)
   Dim i  As Integer, j As Integer, n As Integer
   Dim i1 As Integer, i2 As Integer, i3 As Integer, i4 As Integer
   Dim TempStr As String, lnStr As Long, Str1 As String
   Dim PduStr As String
   
   'On Error Resume Next
   i1 = InStr(1, Gmsloadstr, "+CMGL:")
   i2 = InStr(1, Gmsloadstr, "+CSQ:")
   If i1 > 0 Or i2 > 0 Then   'i1 和 i2不可能同时是 1
      If i2 = 0 Then
         While i1 > 0
            lnStr = Len(Gmsloadstr)
            Gmsloadstr = Right(Gmsloadstr, lnStr - i1 + 1)
            '判断短消息的INDEX
            i3 = InStr(1, Gmsloadstr, ",")
            Str1 = Mid(Gmsloadstr, i3 - 1, 1)
            TempStr = Mid(Gmsloadstr, i3 - 2, 1)
            If TempStr >= "0" And TempStr <= "9" Then
               Str1 = TempStr & Str1
            End If       'str1 是短消息编号
            
            '判断短消息是否读过
            TempStr = Mid(Gmsloadstr, i3 + 1, 1)
''            If TempStr = "0" Then   '短消息没有被读过
               '得到发送方电话号码
               i4 = InStr(1, Gmsloadstr, vbCrLf)
               TempStr = Mid(Gmsloadstr, i4 + 22, 2)
               If TempStr = "0D" Then
                   TempStr = Mid(Gmsloadstr, i4 + 28, 12)
                   SbTelephone = ""
                   For i = 0 To 5 Step 1
                      For j = 2 To 1 Step -1
                         If Not (i = 5 And j = 1) Then SbTelephone = SbTelephone & Mid(TempStr, i * 2 + j, 1)
                      Next
                   Next
                   '判断是文本还是PDU方式
                   TempStr = Mid(Gmsloadstr, i4 + 42, 2)
                   If TempStr = "08" Then         'PDU
                        PduStr = Mid(Gmsloadstr, i4 + 58, 2)
                        n = CharToByte(Mid(PduStr, 1, 1)) * 16 + CharToByte(Mid(PduStr, 2, 1))
                        ReDim Strarr(n - 1) As Byte
                        j = 0
                        For i = 0 To (n - 1) * 2 Step 2
                           PduStr = Mid(Gmsloadstr, i4 + i + 60, 2)
                           Strarr(j) = StrToHex(PduStr)
                           j = j + 1
                        Next
                        Dim m As Integer
                        m = UBound(Strarr())
                        ReDim strarrtemp(m) As Byte
                        j = 0
                        For i = 0 To (m - 1) / 2
                            strarrtemp(j) = Strarr(j + 1)
                            strarrtemp(j + 1) = Strarr(j)
                            j = j + 2
                        Next i
                       TempStr = strarrtemp
                       If Check2.Value = vbChecked Then
                          Txt485.Text = Txt485.Text & "第" & Str1 & "条短信内容为:" & TempStr & vbCrLf
                          Txt485.Text = Txt485.Text & "发送方电话号码:" & SbTelephone
                          Txt485.SelStart = Len(Txt485.Text)
                       Else
                            TxtCont.Text = TxtCont.Text & "第" & Str1 & "条短信内容为:" & TempStr & vbCrLf
                            TxtCont.Text = TxtCont.Text & "发送方电话号码:" & SbTelephone
                            TxtCont.SelStart = Len(TxtCont.Text)
                       End If
                   End If
                   If TempStr = "00" Then        'TXT
                      PduStr = Mid(Gmsloadstr, i4 + 44, 12)
                      PduStr = Mid(Gmsloadstr, i4 + 58, 2)
                      n = CharToByte(Mid(PduStr, 1, 1)) * 16 + CharToByte(Mid(PduStr, 2, 1))
                      TempStr = Bit8ToBit7(Mid(Gmsloadstr, i4 + 60, n * 2))
                      If Check2.Value = vbChecked Then
                         Txt485.Text = Txt485.Text & "第" & Str1 & "条短信内容为:" & TempStr & vbCrLf
                         Txt485.Text = Txt485.Text & "发送方电话号码:" & SbTelephone
                         Txt485.SelStart = Len(Txt485.Text)
                      Else
                         TxtCont.Text = TxtCont.Text & "第" & Str1 & "条短信内容为:" & TempStr & vbCrLf
                         TxtCont.Text = TxtCont.Text & "发送方电话号码:" & SbTelephone
                         TxtCont.SelStart = Len(TxtCont.Text)
                      End If
                   End If
               End If
            MSComm1.Output = "AT+CMGD=" & Str1 & vbCrLf
            lnStr = Len(Gmsloadstr)
            Gmsloadstr = Right(Gmsloadstr, lnStr - 10)
            i1 = InStr(1, Gmsloadstr, "+CMGL:")
         Wend
         Gmsloadstr = ""
      End If
   Else
      Gmsloadstr = ""
   End If
End Sub
Public Function Bit8ToBit7(ByVal TempStr As String) As String
Dim TempByte() As Byte
Dim GetByte As Byte
Dim i As Integer, j As Integer, n As Integer, m As Integer, k As Integer
    If Trim(TempStr) = "" Then
       Bit8ToBit7 = ""
       Exit Function
    End If
    n = Len(TempStr) / 2
    ReDim TempByte(n - 1) As Byte
    For i = 1 To n
       TempByte(i - 1) = StrToHex(Mid(TempStr, (i - 1) * 2 + 1, 2))
    Next
    m = 0
    GetByte = 0
    For i = 0 To n - 1
       For j = 0 To 7
           k = TempByte(i) Mod 2
           TempByte(i) = TempByte(i) \ 2
           GetByte = GetByte \ 2 + k * 64
           m = m + 1
           If m = 7 Then
             Bit8ToBit7 = Bit8ToBit7 & Chr(GetByte)
             m = 0
             GetByte = 0
           End If
       Next
    Next
End Function


Private Sub Timer6_Timer()
 Txt485.Text = Txt485.Text & TxtCom.Text & vbCrLf
 Delay 5
 Txt485.Text = Txt485.Text & TxtCont.Text & vbCrLf
 Txt485.SelLength = Len(Txt485.Text)
 Txt485.SelStart = 0
End Sub