form1.frm

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

                Next i
            Else
                strTmp = MSComm1.Input
                txtReceived.Text = txtReceived.Text & strTmp
                
                blTmp = GetDataFromCommPort(strTmp, strATData, strGetInfo)
                n_CaptionCount = 0
                Me.Caption = strGetInfo
                SetTrayTip Me.Caption
                If g_blIsNewCallIn Then
                    g_blIsNewCallIn = False
                    blNeedPlayMusic = True
                    iWhichMusic = 1
                    strTmp = vbCrLf & "来电时间：" & Format(Now, "YYYY年MM月DD日 HH:MM:SS") & vbCrLf
                    txtReceived.Text = txtReceived.Text & strTmp
                End If
                If g_blIsNewSMSIn Then
                    g_blIsNewSMSIn = False
                    blNeedPlayMusic = True
                    iWhichMusic = 2
                End If
                
                If blNeedPlayMusic Then
                    blNeedPlayMusic = False
                    iMusicPlayTimes = 1
                    '----- 判断当前窗口是否是活动窗口 -----
                    If Me.hWnd <> GetForegroundWindow() Then Me.SetFocus
                
                    If iWhichMusic = 2 Then
                        MMCNewSMS.FileName = App.Path & "\" & cmbSMSMelody.Text & ".wav" ' 水乡.wav"
                        If Me.WindowState = vbMinimized Then tmrICONSms.Enabled = True
                    ElseIf iWhichMusic = 1 Then
                        MMCNewSMS.FileName = App.Path & "\" & cmbCallMelody.Text & ".wav" ' ringin.wav"
                        tmrICONCall.Enabled = True
                    End If
                    
                    If MMCNewSMS.Mode = mciModeNotOpen Then MMCNewSMS.Command = "Open"
                    If g_nCountPlaySnd = 0 Then
                        MMCNewSMS.Command = "Play"
                    Else
                        If MMCNewSMS.Mode = mciModePlay Then
                            g_nCountPlaySnd = iMusicPlayTimes
                        Else
                            g_nCountPlaySnd = g_nCountPlaySnd + 1
                            If g_nCountPlaySnd > iMusicPlayTimes Then g_nCountPlaySnd = iMusicPlayTimes
                            MMCNewSMS.Command = "Close"
                            MMCNewSMS.Command = "Open"
                            MMCNewSMS.Command = "Play"
                        End If
                    End If
                End If
                If g_blIsEndCall Then
                    g_blIsEndCall = False
                    tmrICONCall.Enabled = False
                    MMCNewSMS.Command = "Close"
                End If
            End If
        
        '''''''''''''''''''''''''''''''''''''''
        Case comEventBreak
            n_CaptionCount = 0
            Me.Caption = "Modem发出中断信号，希望计算机能等候，请稍候."
            SetTrayTip Me.Caption
'            MSComm1.DTREnable = Not MSComm1.DTREnable
'            DoEvents
'            MSComm1.DTREnable = Not MSComm1.DTREnable
'            MSComm1.Break = True
'            DoEvents
'            MSComm1.Break = False
            MSComm1.PortOpen = False
            MSComm1.PortOpen = True
        Case comEvCTS
            n_CaptionCount = 0
            If MSComm1.CTSHolding = True Then 'Modem表示计算机可以发送数据
                Me.Caption = "Modem能够接收计算机数据"
                SetTrayTip Me.Caption
            Else 'Modem无法响应计算机数据，可能缓冲区不够
                Me.Caption = "Modem请求计算机暂时不要发送数据"
                SetTrayTip Me.Caption
                MSComm1.DTREnable = Not MSComm1.DTREnable
                DoEvents
                MSComm1.DTREnable = Not MSComm1.DTREnable
            End If
        Case comEvDSR
            n_CaptionCount = 0
            If MSComm1.DSRHolding = True Then '当Modem收到计算机已经就绪，Modem表示自己也就绪
                Me.Caption = "Modem可以给计算机发送数据"
                SetTrayTip Me.Caption
            Else '在计算机发出DTR信号后，Modem可能还没有就绪
                Me.Caption = "Modem还没有初始化完毕"
                SetTrayTip Me.Caption
            End If
        Case comEventFrame
            MSComm1.PortOpen = False
            MSComm1.PortOpen = True
        Case comEvRing
            n_CaptionCount = 0
            Me.Caption = "检测到振铃变化"
            SetTrayTip Me.Caption
        Case comEvCD
            n_CaptionCount = 0
            Me.Caption = "检测到载波变化"
            SetTrayTip Me.Caption
        Case Else
            MsgBox MSComm1.CommEvent
'            MSComm1.RTSEnable = Not MSComm1.RTSEnable
'            DoEvents
'            MSComm1.RTSEnable = Not MSComm1.RTSEnable
            'MSComm1.PortOpen = False
            'MSComm1.PortOpen = True
    End Select

End Sub

'功能： 生成PDU串
'输入： 短信息内容、目标手机号码、[可选的短信服务中心号码]
'输出： 生成的PDU串
'返回： 整个字串的长度
'
Private Function GetPDU(ByVal SMSText As String, _
                        ByVal DestNo As String, _
                        ByRef PDUString As String, _
                        Optional ByVal ServiceNo As String) As Long
    On Error GoTo ErrorPDU
    Dim i As Integer
    Dim iAsc As Integer
    Dim iLen As Integer
    Dim strTmp As String
    Dim strTmp2 As String
    Dim strDest As String
    Dim strChar As String
    Dim blIsEmptyService As Boolean
    
    For i = 1 To Len(DestNo)
        strChar = Mid(DestNo, i, 1)
        iAsc = Asc(strChar)
        If iAsc > 57 Or iAsc < 48 Then Exit Function
    Next i
    
    If Len(DestNo) = 14 Then
        If Left(DestNo, 3) = "+86" Then
            DestNo = Right(DestNo, 11)
        Else
            Exit Function
        End If
    End If
    
    If Len(DestNo) <> 11 Or SMSText = "" Then Exit Function
    
    Dim objDll As New myVBDll
    
    DestNo = DestNo & "F"
    
    If ServiceNo = "" Then
        strTmp = "0001000D9168"
        blIsEmptyService = True
    Else
        blIsEmptyService = False
        strTmp = "089168"
        If Len(ServiceNo) = 14 Then
            If Left(ServiceNo, 3) = "+86" Then
                ServiceNo = Right(ServiceNo, 11)
            Else
                Exit Function
            End If
        End If
        
        For i = 1 To Len(ServiceNo)
            strChar = Mid(ServiceNo, i, 1)
            iAsc = Asc(strChar)
            If iAsc > 57 Or iAsc < 48 Then Exit Function
        Next i
        ServiceNo = ServiceNo & "F"
        
        strDest = ""
        For i = 1 To 12 Step 2
            strTmp2 = Mid(ServiceNo, i, 2)
            strDest = strDest & Right(strTmp2, 1) & Left(strTmp2, 1)
        Next i
        strTmp = strTmp & strDest & "11000D9168"

    End If
    strDest = ""
    For i = 1 To 12 Step 2
        strTmp2 = Mid(DestNo, i, 2)
        strDest = strDest & Right(strTmp2, 1) & Left(strTmp2, 1)
    Next i
    strTmp = strTmp & strDest
    strTmp = strTmp & "000800"
    
    
    SMSText = objDll.GB2Unicode(SMSText)
    iLen = Len(SMSText) \ 2
    strChar = Hex(iLen)
    If Len(strChar) < 2 Then strChar = "0" & strChar
    strTmp = strTmp & strChar & SMSText
    
    Set objDll = Nothing
    PDUString = strTmp
    If blIsEmptyService Then
        GetPDU = Len(strTmp) / 2 - 1
    Else
        GetPDU = Len(strTmp) / 2 - 9
    End If
    Exit Function
ErrorPDU:
    Set objDll = Nothing
    GetPDU = 0
    PDUString = ""
    MsgBox "Error:" & Err & "." & vbCrLf & Err.Description
End Function

Private Sub Timer1_Timer()
    Timer1.Enabled = False
    Call ContinueSend
End Sub

Private Sub tmrClock_Timer()
    Dim dtNow As Date
    Dim dtSet As Date
    
    If chkClock.Value = vbChecked Then
        dtNow = Format(Now, "HH:MM")
        dtSet = Format(txtClock.Text, "HH:MM")
        If dtNow = dtSet Then
            MMCNewSMS.FileName = App.Path & "\" & cmbCallMelody.Text & ".wav"
            If MMCNewSMS.Mode = mciModeNotOpen Then MMCNewSMS.Command = "Open"
            If g_nCountPlaySnd = 0 Then
                MMCNewSMS.Command = "Play"
            Else
                If MMCNewSMS.Mode = mciModePlay Then
                    g_nCountPlaySnd = 5
                Else
                    g_nCountPlaySnd = g_nCountPlaySnd + 1
                    If g_nCountPlaySnd > 5 Then g_nCountPlaySnd = 5
                    MMCNewSMS.Command = "Close"
                    MMCNewSMS.Command = "Open"
                    MMCNewSMS.Command = "Play"
                End If
            End If
        End If
    Else
        If MMCNewSMS.Mode = mciModePlay Then
            MMCNewSMS.Command = "Close"
        End If
    End If
    
    n_CaptionCount = n_CaptionCount + 1
    If n_CaptionCount > 5 Then
        n_CaptionCount = 0
        Me.Caption = "PDUSMS"
        SetTrayTip Me.Caption
    End If
End Sub

Private Sub tmrICONCall_Timer()
    Static blStaTmp As Boolean
    
    If blStaTmp Then
        If Me.WindowState = vbMinimized Then SetTrayIcon LoadPicture(App.Path & "\Cellsc.ico")
        blStaTmp = False
    Else
        If Me.WindowState = vbMinimized Then SetTrayIcon LoadPicture(App.Path & "\Cellscr.ico")
        blStaTmp = True
    End If
End Sub

Private Sub tmrICONSms_Timer()
    Static blStaTmp As Boolean
    
    If blStaTmp Then
        If Me.WindowState = vbMinimized Then SetTrayIcon LoadPicture(App.Path & "\Cellss.ico")
        blStaTmp = False
    Else
        If Me.WindowState = vbMinimized Then SetTrayIcon LoadPicture(App.Path & "\Cellssr.ico")
        blStaTmp = True
    End If
        
End Sub

Private Sub tmrTask_Timer()
    tmrTask.Enabled = ScanTaskA
End Sub

Private Sub txtDestNO_GotFocus()
    txtDestNO.SelStart = 0
    txtDestNO.SelLength = Len(txtDestNO.Text)
End Sub

Private Sub txtDestNO_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        KeyAscii = 0
        Call cmdGenerate_Click
    End If
End Sub

Private Sub txtReceived_Change()

    txtReceived.SelStart = Len(txtReceived.Text)

End Sub

Private Sub txtSMS_Change()

    lblLeftBytes.Caption = "剩余字数：" & 70 - Len(txtSMS)

End Sub

Private Sub txtSMS_GotFocus()
    txtSMS.SelStart = 0
    txtSMS.SelLength = Len(txtSMS.Text)
End Sub

Private Sub txtSMS_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        KeyAscii = 0
        Call cmdGenerate_Click
    End If
    If Len(txtSMS) > 160 Then KeyAscii = 0
End Sub

'Private Sub txtUnicode_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
'
'    If Button = vbRightButton Then
'        PopupMenu mnuRichTxRtClick
'    End If
'End Sub

Private Function ScanTaskA() As Boolean

    Dim nTmp As Long
    
On Error Resume Next
    
ContinueScan:
    
    '======= 取出命令标志数组 =======
    nTmp = ary_nCommandFlag(i_ScanPtr)
    
    '======= 察看标志是否等于1 =======
    If (n_TaskWord And nTmp) <> 0 Then
        
        '------- 如果有任务存在，则准备执行之 -------
'        tmrTimedout.Enabled = False
        
        '------- 任务执行的条件是串口打开，而且没有正在进行的接收任务 -------
        If MSComm1.PortOpen = True Then 'And Not bl_IsReceiving Then
            
            '------- 将任务命令下发 -------
            MSComm1.Output = ary_strTask(i_ScanPtr)
'            If i_ScanPtr = 15 Then MSComm2.Output = "R1" & vbCrLf
        Else
            
            '------- 如果执行的条件不满足，则保留权利，等待下次会话 -------
            ScanTaskA = True
            Exit Function
        End If
        
        '----------------------------------------------
        '    如果程序能够执行到此处，说明该任务已经完成
        '那么将该任务的标志删除
        '----------------------------------------------
        n_TaskWord = (n_TaskWord And (Not nTmp))
        
        '------------------------------------------------------------------
        '    因为一个会话只能执行一个任务，因此扫描指针回零，退出当前会话，
        '等待下次会话，重新扫描
        '------------------------------------------------------------------
        i_ScanPtr = 0
        ScanTaskA = True
        Exit Function
    End If
    
    '======= 没有捕获任务，将扫描指针前移一个位置 =======
    i_ScanPtr = i_ScanPtr + 1
    
    '------- 如果扫描了整个队列也没有发现任务 -------
    If i_ScanPtr >= 16 Then
        
        '------- 结束扫描，等待外部触发 -------
        i_ScanPtr = 0
'        tmrTimedout.Enabled = True
        ScanTaskA = False
    Else
    
        '------- 否则的话，继续扫描 -------
        GoTo ContinueScan
    End If
End Function