form1.frm

通过串口收发短信工具

    Do
        tm2 = Now - tm1
        DoEvents
        If tm2 * v1 > sec Then Exit Do
    Loop Until stopDelay
End Sub

'******************************************************************************
'函数名:    GsmSendMessage
'功能:      PDU方式发送短信
'输入:      strtemp               字符
'返回       无
'记录:  日期        作者            注释
'       2004-2-10   高卫东          编制设计
'******************************************************************************
 Private Sub GsmSendMessage(ByVal strtemp As String)
'    MSComm1.CommPort = Val(Cmbcom.Text)
    If MSComm1.PortOpen = False Then MSComm1.PortOpen = True
    MSComm1.InputMode = comInputModeText
    IntLen = Len(strtemp) / 2 - 1
    MSComm1.Output = "AT+CMGF=0" & vbCrLf
    Delay 0.5 '原为1.5
    MSComm1.Output = "AT+CMGS=" & IntLen & vbCrLf
    Delay 0.5  '原为0.5
    MSComm1.Output = strtemp & Chr(26)
    Delay 2 '原为2.0
End Sub
'******************************************************************************
'函数名:    GsmSendMessageEnglish
'功能:      TXT方式发送短信
'输入:      strtemp               字符
'返回       无
'记录:  日期        作者            注释
'       2004-2-10   高卫东          编制设计
'******************************************************************************
 Private Sub GsmSendMessageEnglish(ByVal strtemp As String)
'    MSComm1.CommPort = Val(Cmbcom.Text)
    If MSComm1.PortOpen = False Then MSComm1.PortOpen = True
    MSComm1.InputMode = comInputModeText
    MSComm1.Output = "AT+CMGF=1" & vbCrLf
    Delay 0.5 '原为1.5
    MSComm1.Output = "AT+CMGS=" & Trim(TxtPhone.Text) & vbCrLf
    Delay 0.5  '原为0.5
    MSComm1.Output = strtemp & Chr(26)
    Delay 2 '原为2.0
End Sub

'******************************************************************************
'函数名:    Proccess
'功能:      TXT方式发送短信
'输入:      strTel   电话号码           字符
'           strSend  发送内容           字符
'返回       无
'记录:  日期        作者            注释
'       2004-2-10   高卫东          编制设计
'******************************************************************************
Private Sub Proccess(ByVal strTel As String, ByVal strSend As String)
    Dim strtemp, strtemp1, strtemp2, strtemp3, Temp, temp1, temp2 As String
    Dim strbyte As Byte
    Dim i As Integer
    Dim bytSource() As Byte
    Dim lngCount As Long
    strtemp = strTel
    strtemp = strtemp & "FFFFFFFFFFFF"
    strtemp = Left(strtemp, 12)
    For i = 1 To 12 Step 2
     strtemp1 = Mid(strtemp, i, 2)
     strtemp2 = strtemp2 & Right(strtemp1, 1) & Left(strtemp1, 1)
    Next i
    strSendText = "0011000B81" & strtemp2 & "0008AA"
    If Check2.Value = vbChecked Then
       bytSource = strSend
    Else
       bytSource = TxtCont.Text
    End If
    i = UBound(bytSource) + 1
    IntLen = Right("00" & Hex(i), 2)
    strtemp = Right("00" & Hex(UBound(bytSource) + 1), 2)
    strtemp3 = ""
    For i = 0 To UBound(bytSource) Step 2
        Temp = Right("00" & Hex(bytSource(i)), 2)
        temp1 = Right("00" & Hex(bytSource(i + 1)), 2)
        temp2 = temp1 & Temp
        strtemp3 = strtemp3 & temp2
    Next i
    
    strSendText = strSendText & strtemp & strtemp3

End Sub


Private Sub Check2_Click()
  If Check2.Value = vbChecked Then
     Frame2.Visible = True
     Label13.Visible = True
  Else
     Frame2.Visible = False
     Label13.Visible = False
  End If
End Sub

Private Sub Cmbcom_Change()
  If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
  MSComm1.CommPort = Val(Cmbcom.Text)
End Sub

Private Sub Cmbcom_Click()
  If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
  MSComm1.CommPort = Val(Cmbcom.Text)
End Sub

Private Sub Cmbfs_Click()
 Dim strtemp, strtext As String
 strtemp = Trim(Txtsjhm.Text)
 strtext = "**50000" & Trim(Cmbbdz.Text) & "55031006"
 If Cmbyg.Text = "是" Then
    strtext = strtext & "6f0d"
 Else
    strtext = strtext & "700d"
 End If
 Proccess strtemp, strtext
 GsmSendMessage strSendText
' Timer6.Enabled = True
 End Sub

Private Sub CmdRead_Click()
Read_message
End Sub

Private Sub Cmdsend_Click()
 Dim strtemp, strtext As String
 strtemp = Trim(TxtPhone.Text)
 strtext = Trim(TxtCont.Text)
 GsmSendMessageEnglish strtext
End Sub

Private Sub Command2_Click()
TxtCont.Text = ""
If Check1.Value = 1 Then
   If MSComm1.PortOpen = False Then MSComm1.PortOpen = True
   MSComm1.InputMode = comInputModeText
   MSComm1.Output = "AT+CMGF=1" & vbCrLf
   Sleep 200
   MSComm1.Output = "AT+CMGl=ALL" & vbCrLf
Else
 Read_message
End If
End Sub

Private Sub cmdsendc_Click()
 Dim strtemp, strtext As String
 strtemp = Trim(TxtPhone.Text)
 strtext = Trim(TxtCont.Text)
 Proccess strtemp, strtext
 GsmSendMessage strSendText
End Sub

Private Sub Cmdtz_Click()
End
End Sub

Private Sub Command8_Click()
   Timer5.Enabled = True
End Sub

Private Sub Commandr_Click()
TxtCont.Text = ""
If Check1.Value = 1 Then
   If MSComm1.PortOpen = False Then MSComm1.PortOpen = True
   MSComm1.InputMode = comInputModeText
   MSComm1.Output = "AT+CMGF=1" & vbCrLf
   Sleep 200
   MSComm1.Output = "AT+CMGl=ALL" & vbCrLf
Else
 Read_message
End If
End Sub

Private Sub Form_Activate()
cmdastrik.SetFocus
End Sub


Private Sub Form_Load()
 Dim str As String
 SkinSet Me, "手机控制中心"
 dial_num.Text = Format(Now, "DD-MM-YYYY                   HH:MM:SS") & Format(Now, "HH:MM:SS")
 Cmbyg.ListIndex = 0
 Cmbbdz.ListIndex = 0
End Sub

Private Sub Form_Unload(Cancel As Integer)
If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
Unload FrmTmp
End
End Sub

Private Sub Image1_Click()

End Sub

Private Sub imgBtnClose_Click()
 Unload Me
End Sub

Private Sub Label5_Click()
cmdsendc_Click
End Sub

Private Sub Label9_Click()
CmdRead_Click
End Sub

Private Sub Lbltypecall_Click()
Cmdsend_Click
End Sub

Private Sub MSComm1_OnComm()
 Dim by As Variant
 Dim n1 As Integer, n2 As Integer
 by = MSComm1.Input
 Dim i As Integer
 i = InStr(by, "+CMTI:")
 If i > 0 Then
    If Check2.Value = vbChecked Then
      Commandr_Click
    Else
      CmdRead_Click
    End If
    Exit Sub
 End If
 If Check2.Value = vbChecked Then
    Txt485.Text = Txt485.Text & CStr(by)
    Txt485.SelStart = Len(Txt485.Text)
 Else
    TxtCom.Text = TxtCom.Text & CStr(by)
    TxtCom.SelStart = Len(TxtCom.Text)
 End If
 Gmsloadstr = Gmsloadstr & by
 
 n1 = InStr(1, Gmsloadstr, vbCrLf & "OK" & vbCrLf)
 n2 = InStr(1, Gmsloadstr, vbCrLf & "ERROR" & vbCrLf)

 If n2 > 0 Then Debug.Print "ERRORERROR-------------" & n2
 
 If n1 > 0 Then
    Debug.Print "OKOKOKOKOK-----------------" & n1
   AnalysisGmsPDU Gmsloadstr
 End If
 
End Sub

Private Sub Read_message()
   If MSComm1.PortOpen = False Then MSComm1.PortOpen = True
   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()