frmmain.frm

使用modem实现的来电显示程序,可以用参考串口编程

End Sub

Private Sub SetTip(txt As String, Optional TipColor As Long = &HFFFF, _
                   Optional Scroll As Boolean = True)
Dim i   As Integer
Tip = txt
If txt <> "" Then
i = 48 - LenB(StrConv(txt, vbFromUnicode))
i = Fix(i / 2)
lblTip = IIf(Scroll, Space(i) & txt & Space(i), txt)
lblTip.ForeColor = TipColor
Timer1.Enabled = Scroll
If WindowState = 1 Then Caption = txt
Else
    lblTip = ""
End If
End Sub
Private Sub ReSetTip(txt As String, Optional lbWidth As Long = 48)
Dim i   As Integer
If Timer1.Enabled Then
    i = lbWidth - LenB(StrConv(txt, vbFromUnicode))
    i = Fix(i / 2)
End If
lblTip = Space(i) & txt & Space(i)
End Sub

Private Sub brDay_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then
        QueryCID brDay
    End If
End Sub


Private Sub brNext_Click()
    brDay = FormatDateAPI(DateAdd("d", 1, brDay), True)
    QueryCID brDay
End Sub

Private Sub brPrev_Click()
    brDay = FormatDateAPI(DateAdd("d", -1, brDay), True)
    
    QueryCID brDay
End Sub
Private Sub brToday_Click()
    brDay = FormatDateAPI(Now, True)
    QueryCID brDay
End Sub
Private Sub btn5_Click()
    WindowState = 1     '最小化
End Sub
Private Sub btnClose_Click()
On Error Resume Next
        comm.PortOpen = False
        Unload Me
End Sub

Private Sub btnMdm_Click()
    btnRcd.Value = 0
    btnMdm.Value = 1
    RcvText.Visible = True
End Sub

Private Sub btnPull_Click()
    If btnPull.Value Then
        imgTitle.Visible = True
        Height = 3870 - 405
        shpBorder.Height = 231
        lblTip.Top = 211
        ReSetTip Tip
    Else
        imgTitle.Visible = False
        Height = 825 - 405
        shpBorder.Height = 28
        lblTip.Top = 8
        ReSetTip Tip, 40
    End If
End Sub

Private Sub btnRcd_Click()
    btnRcd.Value = 1
    btnMdm.Value = 0
    RcvText.Visible = False
End Sub

Private Sub cboMODEM_Click()
On Error Resume Next
Dim enmKey()    As String

'++++++++++++++++++++++++++++++++++++++++
'取得MODEM关联的串口号
    '先查找 System\CurrentControlSet\Services\Class\Modem\000X\MatchingDeviceId"
    '针对内置型MODEM
    MatchingDeviceId = ReadKey_String(mKey & sKey(cboMODEM.ListIndex + 1) & "\MatchingDeviceId")
    If MatchingDeviceId = "" Then
        '外置型MODEM的关联串口放在此处 System\CurrentControlSet\Services\Class\Modem\000X\AttachTo
        PORTNAME = ReadKey_String(mKey & sKey(cboMODEM.ListIndex + 1) & "\AttachedTo")
    Else
        'MatchingDeviceId 一般格式为 Serenum\RSS0272
        '再到 Enum\ MatchingDeviceId \ 找出配置
        EnumMainKey "Enum\" & MatchingDeviceId & "\", enmKey
        PORTNAME = ReadKey_String("Enum\" & MatchingDeviceId & "\" & enmKey(1) & "\" & "PORTNAME")
        If PORTNAME = "" Or UCase(Left(PORTNAME, 3)) <> "COM" Then
            PORTNAME = ReadKey_String(mKey & sKey(cboMODEM.ListIndex + 1) & "\AttachedTo")
        End If
    End If
    'PORTNAME 格式为 COM1 ~ COM4
    If PORTNAME = "" Or UCase(Left(PORTNAME, 3)) <> "COM" Then
        'MODEM配置出错！！！
        SetTip "MODEM配置错误！！！", &HFF
        Power.Enabled = False: Exit Sub
    End If
'++++++++++++++++++++++++++++++++++++++++
'取得激活来电显示命令
    EnableCallerID = ReadKey_String(mKey & sKey(cboMODEM.ListIndex + 1) & "\EnableCallerID\1")
    If EnableCallerID = "" Or UCase(Left(EnableCallerID, 2)) <> "AT" Then
        SetTip "不支持来电显示！！！", &HFF
        Power.Enabled = False: Exit Sub
    End If
    If InStr(EnableCallerID, "<cr>") Then
        EnableCallerID = Mid(EnableCallerID, 1, InStr(EnableCallerID, "<cr>") - 1)
    End If
    If InStr(EnableCallerID, Chr(13)) = 0 Then
        EnableCallerID = EnableCallerID & Chr(13)
    End If
'++++++++++++++++++++++++++++++++++++++++
'取得MODEM初始化的命令
    InitSetting = ReadKey_String(mKey & sKey(cboMODEM.ListIndex + 1) & "\Settings\Init\1")
    If InStr(InitSetting, "<cr>") Then
        InitSetting = Mid(InitSetting, 1, InStr(InitSetting, "<cr>") - 1)
    End If
    If InStr(InitSetting, Chr(13)) = 0 Then
        InitSetting = InitSetting & Chr(13)
    End If
'++++++++++++++++++++++++++++++++++++++++
SetTip "", &HFFFF00, False
Dim bDCB()     As Byte
    bDCB = ReadKey_Binary(mKey & sKey(cboMODEM.ListIndex + 1) & "\DCB")
    CopyMemory tDCB, bDCB(0), Len(tDCB)
'-----------------------------------------
    Power.Enabled = True
    Power.Value = 1
    Power_Click
    'lblModem = "串口:" & sCOMM & _
            "   激活来电显示命令:" & EnableCallerID
End Sub
Private Sub comm_OnComm()
Dim rs      As Variant  '串口接收数据
    Select Case comm.CommEvent
        Case comEvSend
            'rs = Comm.Output
            'If Sys.hwndDebug Then lstSave.Add rs
        Case comEvReceive   ' 数据接收处理
            On Error Resume Next
            rs = comm.Input
            ShowString rs
            rs = UCase(rs)
            If Len(InBuf) = 0 Then
                If InStr(rs, "D") Then
                    InBuf = Mid(rs, InStr(rs, "D"))     '判断来电显示的起始字符 D  (Date)
                ElseIf InStr(rs, "T") Then
                    InBuf = Mid(rs, InStr(rs, "T"))     '判断来电显示的起始字符 T  (Time)
                ElseIf InStr(rs, "N") Then
                    InBuf = Mid(rs, InStr(rs, "N"))     '判断来电显示的起始字符 N  (NMBR)
                End If
                ReceiveExplain
            Else
                InBuf = InBuf & rs
                ReceiveExplain
            End If
        Case comEvCD
            '确保程序运行过程中，MODEM复位时发射EnableCallerID命令
            If comm.CDHolding Then
                comm.Output = EnableCallerID
                Do While comm.OutBufferCount
                Loop
                Dim s As String
                s = comm.Input
            End If
    End Select
End Sub
Sub ReceiveExplain()
'接收数据判断
Dim ks      As String
On Error Resume Next

    If Len(InBuf) >= 4 And InStr(InBuf, Chr(13)) > 0 Then
        If Left(InBuf, 4) = "DATE" And InStr(InBuf, Chr(13)) > 0 Then
            InBuf = Mid(InBuf, InStr(InBuf, "DATE") + 7)
            ks = Mid(InBuf, 1, InStr(InBuf, Chr(13)) - 1)
            rDate = Format(Now, "yyyy") & SDATE & Left(ks, 2) & SDATE & Right(ks, 2)
            InBuf = Mid(InBuf, InStr(InBuf, Chr(13)) + 2)
        End If
        If Left(InBuf, 4) = "TIME" And InStr(InBuf, Chr(13)) > 0 Then
            InBuf = Mid(InBuf, InStr(InBuf, "TIME") + 7)
            ks = Mid(InBuf, 1, InStr(InBuf, Chr(13)) - 1)
            rTime = Left(ks, 2) & STIME & Right(ks, 2)
            InBuf = Mid(InBuf, InStr(InBuf, Chr(13)) + 2)
        End If
        If Left(InBuf, 4) = "NMBR" And InStr(InBuf, Chr(13)) > 0 Then
            InBuf = Mid(InBuf, InStr(InBuf, "NMBR") + 7)
            rCallerID = Mid(InBuf, 1, InStr(InBuf, Chr(13)) - 1)
            lstCID.AddItem Format(lstCID.ListCount + 1, "000.") & "[" & rDate & " " & rTime & "] " & rCallerID
            SetTip "[" & rDate & " " & rTime & "] " & rCallerID, &HFFFF00, False
            WriteCID rDate & " " & rTime, rCallerID
            InBuf = ""
        End If
        If Len(InBuf) < 4 Then
            If Left(InBuf, 1) <> "D" And Left(InBuf, 1) <> "T" And Left(InBuf, 1) <> "N" Then
                InBuf = ""
            End If
        Else
            If Left(InBuf, 4) <> "DATE" And Left(InBuf, 4) <> "TIME" And Left(InBuf, 4) <> "NMBR" Then InBuf = ""
        End If
    End If
Exit Sub
CrcError:
    InBuf = ""
End Sub
'显示调试信息
'输出窗口 RcvText
Private Sub ShowString(ByVal Data As String)
On Error GoTo Handler
Const MAXTERMSIZE = 6400
Dim TermSize    As Long
Dim i           As Integer
Dim hwndOutput  As Long
Const WM_GETTEXTLENGTH = &HE
Const EM_SETSEL = &HB1
Const EM_REPLACESEL = &HC2

    '1、确定文本不太长
    hwndOutput = RcvText.hwnd
    TermSize = SendMessage(hwndOutput, WM_GETTEXTLENGTH, 0, 0)  '取出文本 ANSI 长度
    If TermSize > MAXTERMSIZE Then
        RcvText.Text = Mid$(RcvText, 3200)
        TermSize = SendMessage(hwndOutput, WM_GETTEXTLENGTH, 0, 0)
    End If
    '2、过滤/处理 BACKSPACE.
    Do
       i = InStr(Data, Chr$(8))
       If i Then
          If i = 1 Then
            Data = Mid$(Data, i + 1)
          Else
            Data = Left$(Data, i - 2) & Mid$(Data, i + 1)
          End If
       End If
    Loop While i
    '3、去掉换行符
    Do
        i = InStr(Data, Chr$(10))
        If i Then
            Data = Left$(Data, i - 1) & Mid$(Data, i + 1)
        End If
    Loop While i
    
    '4、确定所有回车都带有换行符
    i = 1
    Do
        i = InStr(i, Data, Chr$(13))
        If i Then
            Data = Left$(Data, i) & Chr$(10) & Mid$(Data, i + 1)
            i = i + 1
        End If
    Loop While i
    '5、输出到窗口
    'Dim TxStart As Long, TxEnd As Long
    'Dim TxS As Long
    'TxS = SendMessage(RcvText.hwnd, EM_GETSEL, 0, 0)
    'TxStart = TxS AND &HFFFF&
    'TxEnd = TxS \ &H10000
    'If TxStart <> TermSize Or TxEnd <> TermSize Then
    SendMessageVal hwndOutput, EM_SETSEL, TermSize, TermSize
    'End If
    SendMessageStr hwndOutput, EM_REPLACESEL, 0, Data
Exit Sub
Handler:
    Resume Next
End Sub

Private Sub Form_Load()
    
    SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
    InitParity
    btnPull_Click
    Show
    DoEvents
    SetTip "正在连接数据库...", &HFFFF00
    DoEvents
    On Error Resume Next
    'adoCn.Provider = "Microsoft.Jet.OLEDB.3.51"
    adoCn.CursorLocation = adUseClient
    adoCn.Open "DSN=CallerID;ODBC;"
    '不能找JET数据库支持
    If Err.Number = 3706 Then
        SetTip "不能找到数据库的JET支持..", &HFF&
        ShowString "不能找到数据库的JET支持.." & Chr(13)
        Set adoCn = Nothing
    Else
        SetTip "", &HFFFF00
    End If
    SDATE = GetLocaleString(LOCALE_SDATE)
    STIME = GetLocaleString(LOCALE_STIME)
    
    '枚举所有的MODEM配置
    EnumMainKey mKey, sKey
    For i = 1 To UBound(sKey)
        cboMODEM.AddItem ReadKey_String(mKey & sKey(i) & "\Model")
    Next i
    
    If cboMODEM.ListCount > 0 Then cboMODEM.ListIndex = 0

    btnClose.Value = 1
    btnPull_Click
    brToday_Click
End Sub
Public Function ScrollText(strText As String) As String
     strText = (Right$(strText, Len(strText) - 1)) & Left$(strText, 1)
     lblTip = strText
End Function
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
     ReleaseCapture
     'SendMessage hwnd, &H202, 0, 0
     SendMessage hwnd, &H112, &HF012, 0
End Sub
Private Sub Form_Resize()
    If WindowState = 0 Then
        Caption = "来电显示器"
    ElseIf WindowState = 1 Then
        Caption = Tip
    End If
End Sub
Private Sub imgTitle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form_MouseDown Button, Shift, X, Y
End Sub
Private Sub lblTip_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form_MouseDown Button, Shift, X, Y
End Sub
Private Sub Power_Click()
On Error Resume Next
    If Power.Value Then

        If comm.PortOpen = True Then comm.PortOpen = False
        comm.Settings = tDCB.BaudRate & "," & PARITY(tDCB.PARITY) & "," & _
                        tDCB.ByteSize & "," & (tDCB.StopBits / 2 + 1)
        comm.CommPort = Val(Mid(PORTNAME, 4))
        comm.PortOpen = True
        If Err.Number = 8002 Then
            SetTip "MODEM安装不正确!...", &HFF
            ShowString Now & Chr(13)
            ShowString Tip & Chr(13)
            ShowString "1、可能MODEM没有正确连接。" & Chr(13)
            Power.Value = 0
        ElseIf Err.Number = 8005 Then
            SetTip "不能打开MODEM!...", &HFF
            ShowString Now & Chr(13)
            ShowString Tip & Chr(13)
            ShowString "1、可能有其它应用（如上网)占用。" & Chr(13)
            Power.Value = 0
        End If
        If Power.Value Then
        '+++++++++++++++++++++++++++
            '初始化MODEM
            If InitSetting <> "" Then CommOutput InitSetting
            '让MODEM一直不接听
            CommOutput "ats0=0" & Chr(13)
            '激活来电显示
            CommOutput EnableCallerID
        End If
    Else
        comm.PortOpen = False
    End If
End Sub
Private Sub RcvText_KeyPress(KeyAscii As Integer)
    If comm.PortOpen Then
        comm.Output = Chr$(KeyAscii)
    End If
    KeyAscii = 0
End Sub
Private Sub Timer1_Timer()
     If Tip <> "" Then ScrollText lblTip
End Sub