VB Caller ID Source Code
Option Explicit
'Private Variables
Public fo As FileSystemObject
Public db As Database
Public wrk As Workspace
Public rs As Recordset
Public idx As Index
Public m_stDataPath As String
Public bEcho As Boolean 'public echo flag for com
Public bOK As Boolean
Public bRing As Boolean
Public bError As Boolean
Public iRingTime As Single
'Private Constants
Private Const DefDataPath = "C:\"
Private Sub Form_Load()
'retrieve last window location
Me.Top = GetSetting(App.Title, "Window", "Top", Me.Top)
Me.Left = GetSetting(App.Title, "Window", "Left", Me.Left)
'retrieve last port settings
Comm1.Settings = GetSetting(App.Title, "Properties", "Settings", Comm1.Settings)
Comm1.CommPort = GetSetting(App.Title, "Properties", "CommPort", Comm1.CommPort)
Comm1.Handshaking = GetSetting(App.Title, "Properties", "Handshaking", Comm1.Handshaking)
bEcho = GetSetting(App.Title, "Properties", "Echo", False)
m_stDataPath = GetSetting(App.Title, "Properties", "DataPath", DefDataPath)
frmLineInfo.CallName.Text = ""
frmLineInfo.Number.Text = ""
frmLineInfo.DateTime.Text = ""
OpenDataBase
End Sub
Private Sub Connect_Click()
If (Connect.Caption = "&Connect") Then ' This menu item will open or close the com port
On Error GoTo 0
If Not Comm1.PortOpen Then ' Open the comm port if not already open
Comm1.PortOpen = True
End If
If Not Comm1.PortOpen Then ' if there is a problem opening the port
MsgBox "Cannot open comm port " & Comm1.CommPort ' display an error first
End ' bail out of the program
End If
' Initialize communications and update app UI
Comm1.DTREnable = True
Comm1.RTSEnable = True
Comm1.RThreshold = 1 ' Generate a receive event on every character received
Comm1.InputLen = 1 ' Read the receive buffer 1 char at a time
bOK = False
bError = False
Comm1.Output = vbCr + "ATZ" + vbCr ' Reset modem
Wait
If bOK Then
bOK = False
bError = False
Comm1.Output = "AT#CID=1" + vbCr 'Turn on caller id events
Wait
If bError Then
MsgBox "Port " + Comm1.CommPort + ": Modem not Caller ID enabled"
Comm1.PortOpen = False ' Close the port and update app UI
Connect.Caption = "&Connect" ' Change the menu to reflect opposite of port status
ElseIf bOK Then
Connect.Caption = "Dis&connect" ' Change the menu to reflect opposite of port status
End If
Else
MsgBox "Port " + Str(Comm1.CommPort) + " not responding"
Comm1.DTREnable = False
Comm1.RTSEnable = False
Comm1.PortOpen = False ' Close the port and update app UI
Connect.Caption = "&Connect" ' Change the menu to reflect opposite of port status
End If
Else
Comm1.DTREnable = False
Comm1.RTSEnable = False
Comm1.PortOpen = False ' Close the port and update app UI
Connect.Caption = "&Connect" ' Change the menu to reflect opposite of port status
End If
End Sub
Private Sub ProcessEvent(stEvent As String)
Dim stNumber As String
ModemEvents.AddItem stEvent 'Add Modem event to event listbox
Select Case stEvent
Case "OK"
bOK = True
Case "ERROR"
bError = True
Case "RING"
If bRing = False Then
frmLineInfo.DateTime.Text = Now
bRing = True
End If
iRingTime = Timer
Case Else
Select Case Left(stEvent, 4)
Case "TIME"
Case "DATE"
Case "NMBR"
stNumber = Mid(stEvent, 8)
If Len(stNumber) = 10 Then
frmLineInfo.Number.Text = "(" + Left(stNumber, 3) + ") " + Mid(stNumber, 4, 3) + "-" + Right(stNumber, 4)
Else
frmLineInfo.Number.Text = stNumber
End If
Case "NAME"
frmLineInfo.CallName.Text = Mid(stEvent, 8)
End Select
End Select
End Sub
Private Sub ClearEvents_Click()
ModemEvents.Clear
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub comm1_OnComm()
Static stEvent As String 'storage for an Modem event
Dim stComChar As String * 1 'temporary storage for received comm port data
Select Case Comm1.CommEvent
Case comEvReceive ' Received RThreshold # of chars.
Do
stComChar = Comm1.Input 'read 1 character .Inputlen = 1
Select Case stComChar
Case vbLf 'Ignore linefeeds
Case vbCr 'The CR indicates the end of the Receive String
If Len(stEvent) > 0 Then
ProcessEvent stEvent 'Process the Modem event
stEvent = ""
End If
Case Else
stEvent = stEvent + stComChar 'Save everything between CR's
End Select
Loop While Comm1.InBufferCount 'Loop until all characters in receive buffer are processed
'----------------------------------------------------------------------------------------------
'The following communication events are ignored.
'In normal operation they will never fire.
'----------------------------------------------------------------------------------------------
'Case comBreak ' A Break was received.
'Case comCDTO ' CD (RLSD) Timeout.
'Case comCTSTO ' CTS Timeout.
'Case comDSRTO ' DSR Timeout.
'Case comFrame ' Framing Error
'Case comOverrun ' Data Lost.
'Case comRxOver ' Receive buffer overflow.
'Case comRxParity ' Parity Error.
'Case comTxFull ' Transmit buffer full.
'Case comEvCD ' Change in the CD line.
'Case comEvCTS ' Change in the CTS line.
'Case comEvDSR ' Change in the DSR line.
'Case comEvRing ' Change in the Ring Indicator.
'Case comEvSend ' chars in send buffer
'----------------------------------------------------------------------------------------------
End Select
End Sub
Private Sub Wait()
Dim Start
Start = Timer
Do While Timer < Start + 2
DoEvents
If bOK Then
Exit Sub
End If
If bError Then
Exit Sub
End If
Loop
End Sub
Private Sub Exit_Click()
Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
If Comm1.PortOpen Then
Comm1.PortOpen = False
End If
If (Me.WindowState = vbNormal) Then
SaveSetting App.Title, "Window", "Top", Me.Top
SaveSetting App.Title, "Window", "Left", Me.Left
End If
SaveSetting App.Title, "Properties", "DataPath", m_stDataPath
CloseDatabase
End Sub
Private Sub Properties_Click()
Load frmProperties
frmProperties.Show
End Sub
Private Sub OpenDataBase()
Set fo = New FileSystemObject
Set wrk = CreateWorkspace("", "admin", "", dbUseJet)
If Not fo.FileExists(m_stDataPath & "callerid.mdb") Then
Set db = wrk.CreateDatabase(m_stDataPath & "callerid.mdb", dbLangGeneral)
CreatePhoneDB
Else
Set db = wrk.OpenDataBase(m_stDataPath & "callerid.mdb")
End If
Set rs = db.OpenRecordset("PhoneCalls", dbOpenTable)
End Sub
Private Sub CloseDatabase()
db.Close
wrk.Close
Set db = Nothing
Set wrk = Nothing
Set fo = Nothing
End Sub
Private Sub AddRecord()
Dim lID As Long
Select Case Len(frmLineInfo.Number.Text)
Case 0
frmLineInfo.Number.Text = "No Number"
Case 1
Select Case frmLineInfo.Number.Text
Case "O"
frmLineInfo.Number.Text = "Unavailable"
frmLineInfo.CallName.Text = "Unavailable"
Case "P"
frmLineInfo.Number.Text = "Blocked"
frmLineInfo.CallName.Text = "Blocked"
End Select
End Select
Select Case Len(frmLineInfo.CallName.Text)
Case 0
frmLineInfo.CallName.Text = "-"
Case 1
Select Case frmLineInfo.CallName.Text
Case "O"
frmLineInfo.CallName.Text = "Unavailable"
Case "P"
frmLineInfo.CallName.Text = "Blocked"
End Select
End Select
With rs
If (.RecordCount > 0) Then
.MoveLast
lID = .Fields("id") + 1
Else
lID = 1
End If
.AddNew
.Fields("id") = lID
.Fields("datetime") = Now
.Fields("number") = frmLineInfo.Number.Text
.Fields("name") = frmLineInfo.CallName.Text
.Update
End With
End Sub
Private Function CreatePhoneDB() As Recordset
Dim tbl As TableDef
Set tbl = db.CreateTableDef("PhoneCalls")
With tbl
.Fields.Append .CreateField("id", dbLong, 4)
.Fields.Append .CreateField("datetime", dbDate, 4)
.Fields.Append .CreateField("number", dbText, 20)
.Fields.Append .CreateField("name", dbText, 20)
db.TableDefs.Append tbl
End With
Set db = wrk.OpenDataBase(m_stDataPath & "callerid.mdb")
Set tbl = db!phonecalls
Set idx = tbl.CreateIndex("DateTime")
idx.Fields.Append idx.CreateField("datetime")
tbl.Indexes.Append idx
End Function
Private Sub Report_Click()
Load frmReport
frmReport.Show
End Sub
Private Sub Timer1_Timer()
If bRing Then
If Timer < iRingTime Then
iRingTime = Timer
ElseIf Timer > iRingTime + 8 Then
AddRecord
bRing = False
lbCallList.AddItem frmLineInfo.DateTime.Text + " " + frmLineInfo.Number.Text + " " + frmLineInfo.CallName.Text, 0
frmLineInfo.Number.Text = ""
frmLineInfo.CallName.Text = ""
frmLineInfo.DateTime.Text = ""
End If
End If
End Sub