form1.frm

这是一个通过手机串口实现短信发送的实例

      AutoSize        =   -1  'True
      Caption         =   "服务中心(&N):"
      Height          =   180
      Left            =   120
      TabIndex        =   1
      Top             =   120
      Width           =   1080
   End
   Begin VB.Menu mnuSystem 
      Caption         =   "文件(&F)"
      Begin VB.Menu mnuSystemQuit 
         Caption         =   "退出(&X)"
      End
   End
   Begin VB.Menu mnuTray 
      Caption         =   "Popup"
      Visible         =   0   'False
      Begin VB.Menu mnuTrayRestore 
         Caption         =   "恢复(&R)"
      End
      Begin VB.Menu mnuTrayMinimize 
         Caption         =   "最小化(&N)"
      End
      Begin VB.Menu mnuTraySep 
         Caption         =   "-"
      End
      Begin VB.Menu mnuTrayClose 
         Caption         =   "关闭(&C)"
      End
   End
   Begin VB.Menu mnuListRtClick 
      Caption         =   "ListPopup"
      Visible         =   0   'False
      Begin VB.Menu mnuListRtClickShow 
         Caption         =   "显示(&S)"
      End
      Begin VB.Menu mnuListRtClickCopy 
         Caption         =   "复制(&C)"
      End
      Begin VB.Menu mnuListRtClickReply 
         Caption         =   "回复(&R)"
      End
      Begin VB.Menu mnuListRtClickDelList 
         Caption         =   "从列表删除(&L)"
      End
      Begin VB.Menu mnuListRtClickDel 
         Caption         =   "删除(&D)"
      End
      Begin VB.Menu mnuListRtClickSep1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuListRtClickDelAll 
         Caption         =   "全部删除(&A)"
      End
   End
   Begin VB.Menu mnuRichTxRtClick 
      Caption         =   "RichTxtClick"
      Visible         =   0   'False
      Begin VB.Menu mnuRichTxRtClickCut 
         Caption         =   "剪切(&X)"
      End
      Begin VB.Menu mnuRichTxRtClickCopy 
         Caption         =   "复制(&C)"
      End
      Begin VB.Menu mnuRichTxRtClickPaste 
         Caption         =   "粘贴(&V)"
      End
      Begin VB.Menu mnuRichTxRtClickDel 
         Caption         =   "删除(&D)"
      End
      Begin VB.Menu mnuRichTxRtClickSep1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuRichTxRtClickSelectAll 
         Caption         =   "全选(&A)"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'
'Private Declare Function TextToSms Lib "SMSDLL.dll" (ByVal csc As String, ByVal ToNum As String, ByVal smsnr As String, ByVal flash As Integer, ByVal reportit As Integer, ByRef i_SMSLen As Integer, ByVal retSms As String) As Integer
'Private Declare Function SmsToText Lib "SMSDLL.dll" (ByVal sms As String, ByVal csca As String, ByRef caca_len, ByVal ToNum As String, ByRef ToNum_len As Integer, ByVal sendtime As String, ByRef time_len As Integer, ByVal smsnr As String) As Integer
'

'关于握手

'在这儿，请使用如下命令串的设置，否则，
'当计算机控制Modem重启后，计算机与 Modem
'不能正常通信！同时，将计算机的握手协议
'设置成RTS握手。

'       at + ifc = 0,2; &w

'格式说明：
'       AT + IFC = <DCE by DTE>, <DTE by DCE>

'DCE by DTE有如下值：
'0：表示 None
'1：表示 Xon/Xoff local circuit 103(不支持)
'2：表示 RTS
'3：表示 Xon/Xoff global on circuit 103(不支持)

'DTE by DCE:
'0: None
'1: Xon/Xoff circuit 104(Not supported)
'2: CTS

Public LastState As Integer

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010&
Private Const SC_RESTORE = &HF120&
Private Const SC_SIZE = &HF000&

Dim i_TotalLen As Integer
Dim i_SMSLen As Integer
Dim str_SMSPDU As String ' * 400
Dim obj_ArySMSList() As SMSDef
Dim n_CaptionCount As Long
Dim ary_strTask()       As String
Dim i_ScanPtr       As Integer
Dim i_PtrSave       As Integer
Dim n_TaskWord      As Long
Dim ary_nCommandFlag(0 To 31)               As Long


Private Sub chkClock_Click()
    If chkClock.Value = vbChecked Then
        txtClock.Visible = True
        tmrClock.Enabled = True
    Else
        txtClock.Visible = False
        tmrClock.Enabled = False
    End If
End Sub

Private Sub chkPDUMode_Click()
    
    Dim iTmp As Integer
    
    On Error Resume Next
    If MSComm1.PortOpen = True Then
        If chkPDUMode.Value = vbChecked Then
            iTmp = 0
        Else
            iTmp = 1
        End If
        MSComm1.Output = "AT+CMGF=" & iTmp & vbCr
    End If
End Sub

Private Sub cmbBaud_Click()
    If MSComm1.PortOpen = True Then
        MSComm1.Settings = cmbBaud.Text
    End If
End Sub



Private Sub cmdAnalosys_Click()
    Dim nU As Long, n As Long
    Dim strReceived As String
    
On Error Resume Next
    
    strReceived = txtReceived.Text
    n_CaptionCount = 0
    Me.Caption = PickAllSMS(strReceived, obj_ArySMSList)
    SetTrayTip Me.Caption
    
    nU = UBound(obj_ArySMSList)
    If nU > 0 Then
        With lstSMS
            .Clear
            For n = 1 To nU
                .AddItem obj_ArySMSList(n).SmsIndex & "." & obj_ArySMSList(n).SourceNo
            Next n
            .ListIndex = 0
        End With
    End If

End Sub

Private Sub cmdClearReceived_Click()
    txtReceived.Text = ""
End Sub

Private Sub ContinueSend()
    On Error GoTo ErrorContinue
    With MSComm1
        If .PortOpen = True And str_SMSPDU <> "" Then
            .Output = str_SMSPDU & Chr(26)
            str_SMSPDU = ""
        End If
    End With
    
'    cmdContinue.Enabled = False
    Exit Sub
ErrorContinue:
    MsgBox "Error:" & Err & "." & vbCrLf & Err.Description
End Sub

Private Sub cmdCopy_Click()
    Clipboard.Clear
    Clipboard.SetText txtReceived.SelText ' txtUnicode.Text
End Sub

Private Sub cmdDelAll_Click()
    On Error Resume Next
    If MSComm1.PortOpen = True Then
        MSComm1.Output = "AT+CMGD=1,1" & vbCr
    End If
End Sub

Private Sub cmdExit_Click()
    Unload Me 'End
End Sub

Private Sub cmdGenerate_Click()
   '将信息编码成一条短消息
    Dim iRet As Integer
    Dim nRet As Long
    Dim iSplash As Integer
    Dim iReport As Integer
'    iSplash = CInt(chkSplash.Value)
'    iReport = CInt(chkReport.Value)
   
    If txtSMS.Text = "" Then
        MsgBox "请输入短消息内容"
        Exit Sub
    End If
    
'    If chkPDUMode.Value = vbUnchecked Then
'        MsgBox "请使用PDU模式！"
'        Exit Sub
'    End If
    nRet = GetPDU(txtSMS.Text, txtDestNO.Text, str_SMSPDU, cmbCSCA.Text) ' txtServiceNO.Text)
    Text4.Text = "短消息长度:" + CStr(nRet) & vbCrLf & "PDU内容:" & vbCrLf & str_SMSPDU
    i_TotalLen = nRet
    If nRet > 0 Then
        cmdSend.Enabled = True
        cmdSend.SetFocus
    End If
        
End Sub

Private Sub cmdReadAll_Click()
    If MSComm1.PortOpen = True Then
        txtReceived.Text = ""
        Call AddTask(n_TaskWord, ary_strTask, 16, 11, "AT+CMGF=1" & vbCr)
        Call AddTask(n_TaskWord, ary_strTask, 8, 12, "AT+CMGL=""ALL""" & vbCr)
        'MSComm1.Output = "AT+CMGL=""ALL""" & vbCr
    End If
    If tmrTask.Enabled = False Then tmrTask.Enabled = True
End Sub

Private Sub cmdSave_Click()
    Dim strFileName As String
    Dim strAppend As String
    
    strFileName = App.Path & "\SendReord.txt"
    
    strAppend = txtUnicode.Text
    
    Call SaveInfoToFile(strAppend, "RxSMS.txt")
    txtUnicode.BackColor = &HFFC0FF
End Sub

Private Sub cmdSaveAll_Click()
    Dim nU As Long, n As Long
    Dim strSMS As String
    Dim smsTmp As SMSDef
    
On Error Resume Next
    
    nU = UBound(obj_ArySMSList)
    If nU > 0 Then
        strSMS = ""
        For n = 1 To nU
            smsTmp = obj_ArySMSList(n)
            strSMS = strSMS & smsTmp.SmsIndex & ". "
            strSMS = strSMS & Format(smsTmp.ReachDate, "YYYY-MM-DD") & " " & Format(smsTmp.ReachTime, "HH:MM:SS")
            strSMS = strSMS & vbTab & smsTmp.SourceNo & vbCrLf
            strSMS = strSMS & "-------------------------------------" & vbCrLf
            strSMS = strSMS & smsTmp.SmsMain
            If n < nU Then strSMS = strSMS & vbCrLf & "==========================================" & vbCrLf
        Next n
        
        Call SaveInfoToFile(strSMS, "RxSMS.txt")
    End If
        
End Sub

Private Sub cmdSend_Click()
    
    Dim strAppend As String
    
    On Error GoTo ErrorSend
    
   ' If chkPDUMode.Value = vbUnchecked Then
    '    MsgBox "目前所使用的模式不是PDU模式，请确认使用的是PDU模式才能正常发送，并被对方接收。"
     '   Exit Sub
   ' End If
'
    
    strAppend = Format(Now, "YYYY-MM-DD HH:MM:SS") & vbTab & txtDestNO.Text & vbCrLf & _
                "-----------------------------" & vbCrLf & txtSMS.Text
    
    Call SaveInfoToFile(strAppend)
    
    
    With MSComm1
        If .PortOpen = True And i_TotalLen > 5 Then
            Call AddTask(n_TaskWord, ary_strTask, 2, 14, "AT+CMGF=0" & vbCr)
            Call AddTask(n_TaskWord, ary_strTask, 1, 15, "AT+CMGS=" & i_TotalLen & vbCr)
            '.Output = "AT+CMGS=" & i_TotalLen & vbCr
        End If
    End With
    
    If tmrTask.Enabled = False Then tmrTask.Enabled = True
    Timer1.Enabled = True
    cmdSend.Enabled = False
    txtSMS.SetFocus
    Exit Sub

ErrorSend:
    MsgBox "Error:" & Err & "." & vbCrLf & Err.Description
End Sub

Private Sub cmdShutDown_Click()
    Dim strTmp As String
    
    On Error Resume Next
    If MSComm1.PortOpen = True Then
        If cmdShutDown.Caption = "关机(&U)" Then
            MSComm1.Output = "AT+CPOF" & vbCr '"AT+CFUN=0" & vbCr
            cmdShutDown.Caption = "开机(&U)"
'            MSComm1.RTSEnable = False
        Else
            MSComm1.Output = "AT+CFUN=1" & vbCr
            cmdShutDown.Caption = "关机(&U)"
'            MSComm1.RTSEnable = True
        End If
    End If
End Sub
Private Sub cmdSwitchPort_Click()

    On Error GoTo ErrorPort
    Dim strVerify As String
    If cmdSwitchPort.Caption = "打开(&O)" Then
        With MSComm1
            .CommPort = CmbPortName.ListIndex + 1
            .RThreshold = 1
            .SThreshold = 0
            .Handshaking = comNone
            
            
            .Settings = cmbBaud.Text & ",N,8,1"
            .PortOpen = True
            CmbPortName.Enabled = False
        End With
        cmdSwitchPort.Caption = "关闭(&O)"
    Else
        MSComm1.PortOpen = False
        CmbPortName.Enabled = True
        cmdSwitchPort.Caption = "打开(&O)"
    End If
    Exit Sub
ErrorPort:
    MsgBox "Error:" & Err & "." & Err.Description
    CmbPortName.Enabled = True
End Sub



Private Sub cmdUnicodeGB_Click()
    
On Error GoTo ErrorUnicode
    
    txtUnicode.Text = DecodeUnicode(Clipboard.GetText)
    n_CaptionCount = 0
    Me.Caption = "Ready"
    SetTrayTip Me.Caption
    
    Exit Sub