frmstart.frm

通过Modem传输数据 通过Modem传输数据 通过Modem传输数据

Attribute VB_Exposed = False
Const prex = "0891"
Const midx = "11000D91"
Const sufx = "0008FF"

Dim mOK As String
Dim mErr As String
Dim mResult As String, txtOut As String, sData As String
Dim doit As Boolean, MsgArrive As Boolean

Private Sub fresh_Click()
    LstState.AddItem "完成..."
End Sub

Private Sub chkDebug_Click()
    picDebug.Visible = chkDebug.Value
End Sub

Private Sub cmdConnect_Click()
    On Error GoTo p1
    If Me.cmdConnect.Caption = "连接" Then
        If Len(Me.cmbPorts.Text) = 0 Then MsgBox "请选择一个可用的端口...": cmbPorts.SetFocus: Exit Sub
        cmdConnect.Caption = "断开"
        setStatus "正在连接..."
        MSComm1.RThreshold = 1
        MSComm1.InputLen = 0
        MSComm1.Settings = cmbBaudrate.Text & ",N,8,1"
        MSComm1.DTREnable = True
        MSComm1.InBufferSize = 32
        MSComm1.OutBufferSize = 0
        MSComm1.CommPort = cmbPorts.Text
        MSComm1.RTSEnable = True
        DoEvents
        MSComm1.PortOpen = True
        DoEvents
        setStatus "连接到端口号: " & cmbPorts.Text
        DoEvents
        FrameInfo.Enabled = True
        cmdRead.Enabled = True
        cmdSend.Enabled = True
        
        setStatus "获取手机状态...."
        
        getMobileInfo
        setStatus "已经成功连接到COM" & cmbPorts.Text
    ElseIf Me.cmdConnect.Caption = "断开" Then
        cmdConnect.Caption = "连接"
        MSComm1.PortOpen = False
        FrameInfo.Enabled = False
        lblDevType.Caption = ""
        lblManufacturer.Caption = ""
        lblProvider.Caption = ""
        cmdRead.Enabled = False
        cmdSend.Enabled = False
        setStatus "连接已经断开"
        LstState.Clear
    End If
    Exit Sub
p1:
    MsgBox "连接失败,请检查端口和连接后重试", vbExclamation, "提示"
    End
End Sub

Function getProvider(ByVal s As String)
    s1 = ""
    If Len(s) > 0 Then
        p = InStr(s, Chr(34))
        s1 = Mid(s, p + 1)
        p1 = InStr(s1, Chr(34))
        If p1 > 0 Then
            s1 = Mid(s1, 1, p1 - 1)
        End If
    End If
    getProvider = s1
End Function

Function getManufacturer(ByVal s As String)
    s1 = ""
    If Len(s) > 0 Then
        s1 = Mid(s, 11)
        p = InStr(s1, Chr(13))
        If p = 0 Then p = InStr(s1, Chr(10))
        If p > 0 Then
            s1 = Mid(s1, 1, p - 1)
        End If
    End If
    getManufacturer = s1
End Function

Function getDevType(ByVal s As String)
    s1 = ""
    If Len(s) > 0 Then
        s1 = Mid(s, 7)
        p = InStr(s1, Chr(10))
        If p = 0 Then p = InStr(s1, Chr(13))
        If p > 0 Then
            s1 = Mid(s1, 1, p)
        End If
    End If
    getDevType = s1
End Function

Function getScsa(ByVal s As String)
    s1 = ""
    If Len(s) > 0 Then
        p = InStr(s, Chr(34))
        s1 = Mid(s, p + 1)
        p1 = InStr(s1, Chr(34))
        If p > 0 Then
            s1 = Mid(s1, 1, p1 - 1)
        End If
    End If
    getScsa = s1
End Function

Sub getMobileInfo()
    Dim st As Boolean
    txtOut = ""
    st = sendIt("AT", "OK", "ERROR")
    If st = True Then
        'Everything OK
    Else
        'Not Connected
        MsgBox "没有发现手机"
        End
    End If
    
    txtOut = ""
    st = sendIt("ATI", "OK", "ERROR")
    If st = True Then
        lblDevType.Caption = getDevType(txtOut)
    Else
        lblDevType.Caption = ""
    End If
    
    txtOut = ""
    
    st = sendIt("AT+CGMI", "OK", "ERROR")
    If st = True Then
        lblManufacturer.Caption = getManufacturer(txtOut)
    Else
        lblManufacturer.Caption = ""
    End If
    txtOut = ""

    st = sendIt("AT+COPS?", "OK", "ERROR")
    If st = True Then
        lblProvider.Caption = getProvider(txtOut)
    Else
        lblProvider.Caption = ""
    End If
    
    st = sendIt("AT+CNMI=?", "OK", "ERROR")
    If st = True Then
        st = sendIt("AT+CNMI?", "OK", "ERROR")
        If st = True Then
            st = sendIt("AT+CNMI=2,1", "OK", "ERROR")
            If st = True Then
            'OK
            End If
        End If
    End If
End Sub

Private Sub ListComPorts()
    Dim i As Integer
    
    Me.cmbPorts.Clear
    setStatus "获取可用计算机端口..."
    For i = 1 To 16
        If COMAvailable(i) Then
            Me.cmbPorts.AddItem i
            'setStatus "COM " & i & " 找到"
        End If
    Next
    Me.cmbPorts.ListIndex = 0
    setStatus "获取可用计算机端口成功"
End Sub

Sub setStatus(ByVal s As String)
    StatusMsg.Panels(3).Text = "" & s
End Sub

Function sendIt(ByVal s As String, ByVal ok As String, ByVal eror As String, Optional ByVal TOut = 2) As Boolean
    mOK = ok
    mErr = eror
    LstState.AddItem "正在发送..." & s
    MSComm1.Output = s & Chr(13)
    Dim p As Double, p1 As Double, p2 As Double
    p = 0.0001 * TOut
    p2 = 0#
    doit = False
    sData = ""
    Dim dt1 As Date, dt2 As Date
    dt1 = Now
    s1 = ""
    While doit = False
        dt2 = Now
        p1 = (dt2 - dt1)
        'p2 = p1 * 10000#
        If p1 >= p Then
            doit = True
            sendIt = False
            Exit Function
        'ElseIf p2 Mod 10 = 0 Then
        '    s1 = s1 & "-"
        '    If Len(s1) > 20 Then s1 = "-"
        '    setStatus s1
        '    DoEvents
        End If
        DoEvents
    Wend
    sendIt = True
End Function

Private Function SendSMS(csca As String, phnum As String, Msg As String) As Boolean
    Dim what As Boolean
    Dim pduText As String, pSmsc As String, pNum As String, pMsg As String
    Dim nTime As Date
    Dim i As Integer, nLength As Integer
    Dim commandLength As Integer
    Dim dd As String
    Dim strPdu As String, OneWord As String
    Dim Temp1 As String, Temp2 As String
    
    strPdu = ""
    nLength = Len(Msg)           '所要转换的所有字符长度
    For i = 1 To nLength
        OneWord = Mid(Msg, i, 1) '取其中一个字符
        dd = Hex(AscW(OneWord))  '转换成Unicode码
        If Len(dd) = 4 Then      '长度不够时补足4位，即2个八位组
            strPdu = strPdu + dd
        Else
            If Len(dd) = 2 Then
                strPdu = strPdu + "00" + dd
            Else
                strPdu = strPdu + "000" + dd
            End If
        End If
    Next i                        'strPdu中的内容就是要传递的信息PDU码
    
    Temp1 = Hex(Len(strPdu) / 2)  'strPdu中的内容就是要传递的信息PDU码
    If Len(Temp1) = 1 Then
        Temp2 = "0" + Temp1
    Else
        Temp2 = Temp1
    End If                                   'temp2为数据PDU长度
    commandLength = (Len(strPdu)) / 2 + 15   '发送PDU总长度．用于AT+CMGS
    
    pSmsc = Trim(telc(csca))
    pNum = Trim(telc(phnum))

    pduText = prex & pSmsc & midx & pNum & sufx & Temp2 & strPdu '全部的PDU数据
    what = sendIt("AT+CMGS=" + CStr(commandLength) + vbCrLf, ">", "ERROR")
    Delay (3)
    If what = True Then
        what = sendIt(Trim(pduText) & Chr(26), "OK", "ERROR")
    End If
    
    SendSMS = what
End Function

Private Sub cmdRead_Click()
    Dim what As Boolean
    Dim nPos As Integer
    txtOut = ""
    what = sendIt("AT+CSCA?", "OK", "ERROR")
    If what = True Then
        txtCenterNumber.Text = getScsa(txtOut)
    End If
End Sub

Private Sub cmdSend_Click()
    If txtPhoneNumber.Text = "" Then
        MsgBox "请输入手机号码!", vbExclamation, "提示"
        Exit Sub
    End If
    
    If txtCenterNumber.Text = "" Then
        MsgBox "请输入信息中心号码!", vbExclamation, "提示"
        Exit Sub
    End If
    
    Dim what As Boolean
    Dim s As String
    what = sendIt("AT+CMGF=0", "OK", "ERROR")
    If what = True Then
        s = txtPhoneNumber.Text
        setStatus "发送消息到用户 " & s
        what = SendSMS(txtCenterNumber.Text, s, txtMsg.Text)
        If what = False Then GoTo p
        setStatus "发送..."
        DoEvents
    End If
    setStatus "发送消息成功!"
    Exit Sub
p:
    setStatus "发送消息失败!"
    MsgBox "发送消息失败...", vbExclamation, "提示"
End Sub

Private Sub Form_Load()
    ListComPorts
    cmbBaudrate.ListIndex = 1
End Sub

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

Private Sub MSComm1_OnComm()
    Dim strTemp As String, msgStr As String
    Dim nPos As Integer, nCount As Integer
    Dim what As Boolean
    LstState.AddItem "正在向端口发送数据....."
    MsgArrive = False
    If MSComm1.CommEvent = comEvReceive Then
        strTemp = MSComm1.Input
        sData = sData & strTemp
        If InStr(sData, "+CMTI") > 0 Then
            MsgArrive = True
            doit = True
        ElseIf InStr(sData, mOK) > 0 Then
            doit = True
        ElseIf InStr(sData, mErr) > 0 Then
            doit = True
        ElseIf InStr(sData, ">") > 0 Then
            doit = True
        End If
        'mResult = sData
        If Len(sData) > 0 Then
            LstState.AddItem "端口返回数据--> " & sData
        End If
        txtOut = sData

        If MsgArrive = True Then
            nPos = InStr(sData, "+CMTI")
            msgStr = Mid(sData, nPos)
            nPos = InStr(msgStr, ",")
            nCount = Trim(Val(Mid(sData, nPos + 1, 3)))
            what = sendIt("AT+CMGR=" & nCount, "OK", "ERROR")
            If what = True Then
                frmRx.txtMsgRecieve.Text = sData
                frmRx.Visible = True
            End If
        End If
    End If
End Sub

Private Sub txtCenterNumber_KeyPress(KeyAscii As Integer)
    If (Chr(KeyAscii) > "9" Or Chr(KeyAscii) < "0") And KeyAscii <> 8 Then
            KeyAscii = 0 '取消本次按键事件。
            Beep '提示输入错误
    End If
End Sub

Private Sub txtMsg_Change()
    txtMsg.MaxLength = 70
    LabText.Caption = "字数:" & Len(txtMsg.Text) & "/70"
End Sub

' Const LB_SETHORIZONTALEXTENT = &H194
' 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


'List1 为 ListBox 的名称
'Call SendMessage(List1.hwnd, LB_SETHORIZONTALEXTENT, _
'     水平卷动轴的宽度, ByVal 0&)' 特别注意：以上的水平卷动轴宽度的单位是 pixel(像素)。

Private Sub txtPhoneNumber_KeyPress(KeyAscii As Integer)
    If (Chr(KeyAscii) > "9" Or Chr(KeyAscii) < "0") And KeyAscii <> 8 Then
        KeyAscii = 0 '取消本次按键事件。
        Beep '提示输入错误
    End If
End Sub