form1.frm

通过串口收发短信工具

     CancelFlag = True
End Sub
'******************************************************************************
'函数名:    Dial
'功能:      拨打对方电话
'输入:      Number               字符
'返回       无
'记录:  日期        作者            注释
'       2004-2-10   高卫东          编制设计
'******************************************************************************
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$ = "13930130270" 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

'******************************************************************************
'函数名:    AnalysisGmsPDU
'功能:      PDU方式读短信
'输入:      str      内容           字符
'
'返回       无
'记录:  日期        作者            注释
'       2004-2-10   高卫东          编制设计
'******************************************************************************
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 Timer5_Timer()
 Read_message
End Sub

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