VERSION 5.00 Begin VB.Form frmMain BorderStyle = 1 'Fixed Single Caption = "Banking Interactive Voice Response System." ClientHeight = 4800 ClientLeft = 150 ClientTop = 540 ClientWidth = 7590 DrawMode = 15 'Merge Pen Not Icon = "frmMain.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 4800 ScaleMode = 0 'User ScaleWidth = 7590 StartUpPosition = 2 'CenterScreen Begin VB.PictureBox Picture1 Height = 1095 Left = 2760 Picture = "frmMain.frx":030A ScaleHeight = 1035 ScaleWidth = 1275 TabIndex = 13 Top = 120 Width = 1335 End Begin VB.Frame Frame1 Caption = "Message Information" Height = 2055 Left = 1200 TabIndex = 1 Top = 1320 Width = 3855 Begin VB.Label Label8 Caption = "Server" Height = 255 Left = 240 TabIndex = 15 Top = 1680 Width = 735 End Begin VB.Label lblServer BackColor = &H80000013& ForeColor = &H80000002& Height = 255 Left = 1080 TabIndex = 14 Top = 1680 Width = 2535 End Begin VB.Label lblTime Height = 255 Left = 1200 TabIndex = 9 Top = 1320 Width = 2055 End Begin VB.Label lblNumber Height = 495 Left = 1200 TabIndex = 8 Top = 720 Width = 2415 End Begin VB.Label lblName Height = 255 Left = 960 TabIndex = 7 Top = 240 Width = 2055 End Begin VB.Label Label4 Caption = "Time" Height = 255 Left = 240 TabIndex = 6 Top = 1320 Width = 615 End Begin VB.Label Label3 Caption = "Number" Height = 255 Left = 240 TabIndex = 5 Top = 720 Width = 615 End Begin VB.Label Label2 Caption = "Name" Height = 255 Left = 240 TabIndex = 4 Top = 240 Width = 615 End End Begin VB.Timer tmrUpdate Enabled = 0 'False Interval = 50 Left = 0 Top = 600 End Begin VB.Label Label10 Height = 495 Left = 4080 TabIndex = 17 Top = 3600 Width = 3375 End Begin VB.Label Label7 Caption = "Label7" Height = 495 Left = 3240 TabIndex = 16 Top = 2160 Width = 1215 End Begin VB.Image Image1 Height = 480 Left = 5640 Picture = "frmMain.frx":496C Top = 240 Width = 480 End Begin VB.Label Label6 BackColor = &H80000013& Caption = "USERS PHONE DIGIT INFO" ForeColor = &H8000000D& Height = 495 Left = 5280 TabIndex = 12 Top = 1560 Width = 2175 End Begin VB.Label Label5 Alignment = 2 'Center BackColor = &H80000013& Caption = "CALL STATE:" Height = 375 Left = 1320 TabIndex = 11 Top = 3720 Width = 2415 End Begin VB.Label Label9 Height = 375 Left = 5280 TabIndex = 10 Top = 2160 Width = 2175 End Begin VB.Label Label1 BackColor = &H00000000& Height = 135 Left = 6240 TabIndex = 3 Top = 120 Width = 1215 End Begin VB.Label lblNumMsg Alignment = 2 'Center BackColor = &H00000000& Caption = "IVRS" BeginProperty Font Name = "Terminal" Size = 18 Charset = 255 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H000000C0& Height = 495 Left = 6240 TabIndex = 2 Top = 240 Width = 1215 End Begin VB.Label lblTest BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 495 Left = 1320 TabIndex = 0 Top = 4200 Width = 3735 End Begin VB.Menu server Caption = "Server" Begin VB.Menu start Caption = "Start" End Begin VB.Menu stop Caption = "Stop" End End Begin VB.Menu settings Caption = "Settings" Begin VB.Menu modem Caption = "Modem" End Begin VB.Menu commport Caption = "CommPort" End End Begin VB.Menu utilities Caption = "Utilities" Begin VB.Menu outgoingcall Caption = "&Outgoing Call" Shortcut = ^O End Begin VB.Menu recordvoice Caption = "&Record Voice" Shortcut = ^R End Begin VB.Menu vbbalance Caption = "&Balance" Shortcut = ^B End End Begin VB.Menu help Caption = "Help" Begin VB.Menu aboutivrs Caption = "About IVRS" End Begin VB.Menu context Caption = "Context" End End End Attribute VB_Name = "frmMain" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '-------------------------------------------------------------------------------------- ' Copyright (C) 2009 '--------------------------------------------------------------------------------------- 'Project work of the following 3rd year students of BCA of Kashmir University. ' Gh Mehdi Mir ' Mehraj-ul-Shafi Bhat ' Sameer Ahmad Mir 'Project Guides 'Er.Manzoor Ahmad Chachoo. '------------------------------------------- 'Over view of this Application. '------------------------------------------- 'This Application named as IVRS waits for and answers incoming calls. It uses 'DirectSound to play out a recorded wellcome message, intractively asks the user to 'give the information like Account No. and Tpin etc. Based on this information Account Balance 'is fetched from the database and is played back to the user, who is on the other end 'of telephone 'Connection is established by using TAPI3.0 and sound is played by using DirectSound 'component of DirectX 8. Option Explicit Implements DirectXEvent8 'TAPI Stuff Const TAPI3_ALL_TAPI_EVENTS = _ TE_ACDGROUP Or _ TE_ADDRESS Or _ TE_AGENT Or _ TE_AGENTHANDLER Or _ TE_AGENTSESSION Or _ TE_CALLHUB Or _ TE_CALLINFOCHANGE Or _ TE_CALLMEDIA Or _ TE_CALLNOTIFICATION Or _ TE_CALLSTATE Or _ TE_DIGITEVENT Or _ TE_GENERATEEVENT Or _ TE_PRIVATE Or _ TE_QOSEVENT Or _ TE_QUEUE Or _ TE_REQUEST Or _ TE_TAPIOBJECT Public gobjTapi As TAPI 'We share this with dlgSetup Dim WithEvents gobjTapiWithEvents As TAPI Attribute gobjTapiWithEvents.VB_VarHelpID = -1 Dim gobjAddress As ITAddress Dim gobjReceivedCallInfo As ITCallInfo Dim glRegistrationToken As Long Dim gobjMediaControl As ITLegacyCallMediaControl 'DirectSound Stuff Dim ds As DirectSound8 'Our DirectSound object 'Our Play SoundBuffer, shared with dlgGreet Public dsBuffer As DirectSoundSecondaryBuffer8 'Ivrs App Stuff Dim strGreeting As String Dim m_device As Integer Dim gbSupportedCall As Boolean Dim m_messageCounter As Long Dim m_Answer As Boolean Dim m_bPlayBack As Boolean Dim m_oColl As Collection Dim m_curFile As Integer Dim m_bRemote As Boolean Dim m_secret As String Dim m_recGuid As String Dim m_playGuid As String Dim m_curRings As Integer 'Settings from the registry Public m_len As Integer 'Max message length in seconds, also set from dlgGreet Dim m_rings As Integer 'Number of rings to answer Dim m_toll As Integer 'Number of rings to answer when we have messages Dim m_code As Integer 'Remote access code for remote message play back Dim m_card As String 'Name of the selected voice card to use 'variables using for result checking Dim counter As Integer Dim s_account_no As String Dim i_account_no As Integer Dim s_tpin As String Dim i_tpin As Integer Dim lang As Integer Dim opt As Integer Dim year As Integer Dim i_language As Boolean Dim i_kash As Boolean Dim i_urdu As Boolean Dim i_engl As Boolean Dim tflag As Boolean Dim v_tpin As Boolean Dim i_accno As Boolean Dim b_playing As Boolean Dim i As Integer Dim b_bal As Boolean Dim v_bal As Boolean Dim dc As Boolean Private Sub GetSettings() m_card = GetSetting("VB-TAPI3", "Settings", "Card", "") End Sub Private Sub InitTAPI() 'Create the TAPI 3.0 object, initialize it and register for events If gobjTapi Is Nothing Then 'create the tapi object Set gobjTapi = New TAPI 'call Initialize before calling any other tapi function Call gobjTapi.Initialize 'set the EventFilter to accept all defined tapi events gobjTapi.EventFilter = TAPI3_ALL_TAPI_EVENTS 'register the outgoing interface (the one that will actually 'receive and process the events) Set gobjTapiWithEvents = gobjTapi End If End Sub 'The Server button has two states, On and Off. When turning On we register for 'TAPI events on the device selected in Setup and disable most of the 'buttons on the form. When turning Off we unregister for events. 'In either case we set our variables m_playGuid and m_recGuid to the 'appropriate device guids. Private Sub RegisterForNotification() 'If RegisterCallNotifications had been previously called, 'unregister here, before registering for the new address 'This is not a required step, a TAPI3 app can register for 'receiving call notifications on more than one address in 'the same time, but the app must be able to handle multiple 'calls on multiple addresses. 'This sample prefers to register on only one address at a time. If glRegistrationToken <> 0 Then Call gobjTapi.UnregisterNotifications(glRegistrationToken) glRegistrationToken = 0 End If 'Register (specify) media types for which you want to receive calls; 'only calls that have this media type will be offered to the app. 'The media types must be passed to RegisterCallNotifications 'bits in a "dword", which in VB is actually a "long". Dim fOwner As Boolean, fMonitor As Boolean Dim lMediaTypes As Long, lCallbackInstance As Long 'fOwner = True ensures that app receives incoming calls 'and their call state events fOwner = True fMonitor = False lMediaTypes = TAPIMEDIATYPE_AUDIO lCallbackInstance = 1 On Error Resume Next glRegistrationToken = gobjTapi.RegisterCallNotifications( _ gobjAddress, fMonitor, fOwner, lMediaTypes, lCallbackInstance) If Err.Number <> 0 Then Dim strMsg As String strMsg = "Registering for receiving calls failed." & Chr(13) & _ "If you have a data modem, replace it with a voice modem. " & _ "Quit the app and try again." MsgBox (strMsg) End If End Sub 'Show our Setup dialog Private Sub cmdSetup_Click() Screen.MousePointer = vbHourglass On Error GoTo ErrorOut: If gobjTapi Is Nothing Then InitTAPI End If dlgSetup.Show vbModal, Me ErrorOut: Screen.MousePointer = vbNormal End Sub 'cmdStop stops play back, it is called remotely via DTMF 3 Private Sub cmdStop_Click() If m_bPlayBack = True Then 'Just try to go beyond the index of files and we will stop m_curFile = m_oColl.Count + 10 If Not dsBuffer Is Nothing Then dsBuffer.stop Else m_bPlayBack = False Set m_oColl = Nothing m_curFile = 0 End If End If End Sub Private Sub Command1_Click() Dim retr As Integer retr = getBalance(1010, 33) End Sub Private Sub aboutivrs_Click() Form2.Show End Sub 'Center the form on the screen Private Sub Form_Load() App.HelpFile = "ivrs.CHM" 'Displays help by pressing F1 Me.Top = (Screen.Height / 2) - (Me.Height / 2) Me.Left = (Screen.Width / 2) - (Me.Width / 2) strGreeting = App.Path & "\messages\welcome.wav" i = 0 On Error Resume Next 'Directory probably exists, so an error is thrown ' MkDir App.Path & "\Messages" On Error GoTo 0 Err.Clear SetMsgLabel InitMVars End Sub 'Called on from load and each time we disconnect to reset our state Private Sub InitMVars() m_bPlayBack = False m_Answer = False m_bRemote = False m_secret = "" m_curRings = 0 s_account_no = "" s_tpin = "" i_language = True tflag = False i_kash = False v_tpin = False i_accno = False b_bal = False v_bal = False opt = 0 year = 0 i = 0 End Sub 'Populates the count of messages label Private Sub SetMsgLabel() Dim oColl As Collection Set oColl = GetMessages() lblNumMsg = "IVRS" Set oColl = Nothing End Sub 'We store the device we want by name in the registry, now we need to get an 'index to that device from the collection of ITAddress's we have Public Function GetDeviceByName(name As String, objCollAddresses As ITCollection) Dim lLoop As Long Dim objCrtAddress As ITAddress For lLoop = 1 To objCollAddresses.Count Set objCrtAddress = objCollAddresses.Item(lLoop) If objCrtAddress.AddressName = name Then ' we Found it! GetDeviceByName = lLoop Exit Function End If Next GetDeviceByName = -1 End Function 'Make sure TAPI is shutdown properly Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) 'Make sure that everything is stopped and reset before exiting. Set ds = Nothing Set dsBuffer = Nothing Set gDSC = Nothing Set gDSCB = Nothing 'disconnect the call: need to query its call control interface for this Dim objCallControl As ITBasicCallControl Set objCallControl = gobjReceivedCallInfo Set gobjMediaControl = Nothing Set gobjReceivedCallInfo = Nothing SetMsgLabel 'Set our count of messages label ClearLabels 'Clear the caller id labels 'objCallControl.Disconnect (DC_NORMAL) 'release the call control interface Set objCallControl = Nothing ' RegisterForNotification If Not gobjTapi Is Nothing Then If glRegistrationToken <> 0 Then Call gobjTapi.UnregisterNotifications(glRegistrationToken) End If 'Disconnect the call Disconnect gobjTapi.Shutdown End If End Sub ' In 3.0 we need to constantly query 'for Getting caller id when we get 'a ringing event and when we get our TE_CALLNOTIFCATION event. Private Sub GetCallerID(oCallInfo As ITCallInfo) Dim sAddress As String Dim sName As String On Error Resume Next sAddress = oCallInfo.CallInfoString(CIS_CALLERIDNUMBER) sName = oCallInfo.CallInfoString(CIS_CALLERIDNAME) lblNumber = sAddress lblName = sName 'Debug.Print sAddress & " " & sName Exit Sub End Sub 'The main TAPI event procedure. Comments in line Private Sub gobjTapiWithEvents_Event(ByVal TapiEvent As TAPI3Lib.TAPI_EVENT, ByVal pEvent As Object) Dim oCallInfo As ITCallInfo Dim j As Integer Select Case TapiEvent Case TE_CALLNOTIFICATION 'in the case of TE_CALLNOTIFICATION, pEvent contains 'an ITCallNotficationEvent interface, but since 'pEvent is declared as Object, we must specifically 'query for that interface Dim objCallNotificationEvent As ITCallNotificationEvent Set objCallNotificationEvent = pEvent 'Set caller id labels if this is our first notification of this call If (gobjReceivedCallInfo Is Nothing) Then lblName = "IVRS CALLER" lblNumber = "NO CLIP FACILITY ON THIS LINE" lblTime = TimeAsString DoEvents End If 'Case TE_CALLINFOCHANGE Set oCallInfo = objCallNotificationEvent.Call GetCallerID oCallInfo Set oCallInfo = Nothing 'decide if we can take this call: our ivrs project app only 'supports one call at a time, so if it already has a call, 'it will reject any other call that arrives in the same time. gbSupportedCall = True If Not (gobjReceivedCallInfo Is Nothing) Then 'We only support one call at a time! gbSupportedCall = False 'Note: objCallNotificationEvent.Call actually contains an 'ITCallInfo interface, but by assigning it to an ITBasicCallControl 'interface, we actually query for the interface "ITBasicCallControl" Dim objReceivedCallControl As ITBasicCallControl Set objReceivedCallControl = objCallNotificationEvent.Call 'Reject the not supported call by calling Disconnect 'Note: this second call will arrive only if the tsp (tapi service provider) 'supports more than 1 call per address. Dim code As DISCONNECT_CODE code = DC_REJECTED objReceivedCallControl.Disconnect (code) 'release all objects that are not needed any longer Set objReceivedCallControl = Nothing Set objCallNotificationEvent = Nothing Exit Sub End If 'query ITCallInfo interface for the new call, and store it Set gobjReceivedCallInfo = objCallNotificationEvent.Call Set gobjMediaControl = gobjReceivedCallInfo Set objCallNotificationEvent = Nothing Case TE_CALLINFOCHANGE Dim oCIC As ITCallInfoChangeEvent Set oCIC = pEvent If oCIC.Cause = CIC_CALLERID Then 'Try to get caller id info Set oCallInfo = oCIC.Call GetCallerID oCallInfo Set oCallInfo = Nothing End If Set oCIC = Nothing Case TE_CALLSTATE lblTest.Caption = "TE_CALLSTATE" 'for this type of event, the object pEvent must be 'queried for its ITCallStateEvent interface Dim objCallStateEvent As ITCallStateEvent Set objCallStateEvent = pEvent Dim State As CALL_STATE Dim objEventCallInfo As ITCallInfo 'extract the call object from pEvent (from its 'ITCallStateEvent interface) Set objEventCallInfo = objCallStateEvent.Call State = objCallStateEvent.State If State = CS_DISCONNECTED Then lblTest.Caption = "CS_DISCONNECTED" ' If Not gDSC Is Nothing Then ' StopRecording 'StopRecording will call disconnect for us ' Else Disconnect Dim objCollAddresses As ITCollection If gobjTapi Is Nothing Then InitTAPI End If GetSettings Set objCollAddresses = gobjTapi.Addresses m_device = GetDeviceByName(m_card, objCollAddresses) Dim strMsg If m_device = -1 Then strMsg = "Can not find selected device, choose Setup" On Error Resume Next 'GoTo ErrorOut: End If 'pick up the "N"-th address - the address on which 'you want to register for receiving calls Set gobjAddress = objCollAddresses.Item(m_device) Set objCollAddresses = Nothing 'no more needed, release RegisterForNotification 'Set our DirectSound device GUID's, if we have to record uncomment the next stat. ' m_recGuid = GetLegacyWaveIDAsDXDeviceGUID(m_device, "wave/in") strGreeting = App.Path & "\messages\welcome.wav" m_playGuid = GetLegacyWaveIDAsDXDeviceGUID(m_device, "wave/out") ' m_device = GetDeviceByName(m_card, objCollAddresses) ' RegisterForNotification ' End If End If strGreeting = App.Path & "\messages\welcome.wav" ' Set objCallStateEvent = Nothing Case TE_DIGITEVENT Dim oDigEvt As ITDigitDetectionEvent Set oDigEvt = pEvent Dim strDigit As String Dim strchar As String Dim strint As Integer strDigit = Chr(oDigEvt.Digit) strchar = strchar & strDigit strint = Val(strchar) lblTest.Caption = "Key Pressed on the Telephone: " & strDigit If (strDigit = "1" Or strDigit = "2" Or strDigit = "3") And i_language = True Then lang = Int(strDigit) Select Case lang Case 1 i_engl = True PlayFile App.Path & "\messages\continueeng.wav" PlayFile App.Path & "\messages\menu.wav" Label9.Caption = "Language Selected is English" i_language = False Case 2 i_urdu = True PlayFile App.Path & "\messages\urdu.wav" Label9.Caption = "Language Selected is URDU" i_language = False Case 3 i_kash = True PlayFile App.Path & "\messages\kashmiri.wav" Label9.Caption = "Language Selected is KASHMIRI" i_language = False Case Else PlayFile App.Path & "\messages\wrongdata.wav" End Select ElseIf (strDigit = "1" Or strDigit = "2" Or strDigit = "3" Or strDigit = "4" Or strDigit = "5") And i_engl = True Then opt = Int(strDigit) Select Case opt Case 1 'i_kash = False PlayFile App.Path & "\messages\askaccno.wav" Label9.Caption = "Account Balance Option Selected" & strDigit i_accno = True i_engl = False b_bal = True Case Else PlayFile App.Path & "\messages\wrongdata.wav" End Select ElseIf (strDigit = "0" Or strDigit = "1" Or strDigit = "2" Or strDigit = "3" Or strDigit = "4" Or strDigit = "5" Or strDigit = "6" Or strDigit = "7" Or strDigit = "8" Or strDigit = "9" Or strDigit = "#") And (i_accno = True) Then If (strDigit <> "#") Then s_account_no = s_account_no & strDigit Else tflag = True lblTest.Caption = "Account Number is" & s_account_no i_account_no = CInt(s_account_no) i_accno = False PlayFile App.Path & "\messages\tel_pin.wav" End If ElseIf (strDigit = "0" Or strDigit = "1" Or strDigit = "2" Or strDigit = "3" Or strDigit = "4" Or strDigit = "5" Or strDigit = "6" Or strDigit = "7" Or strDigit = "8" Or strDigit = "9" Or strDigit = "#") And (tflag = True) Then If (strDigit <> "#") Then s_tpin = s_tpin & strDigit Else tflag = False lblTest.Caption = "Telephonic Pin is" & s_tpin i_tpin = CInt(s_tpin) v_bal = True End If If (v_bal = True) Then dc = True Call getBalance(i_account_no, i_tpin) End If If (dc = True) Then Label9.Caption = " " Label10.Caption = " " Disconnect End If Else PlayFile App.Path & "\messages\wrongdata.wav" End If Set oDigEvt = Nothing Case TE_ADDRESS lblTest.Caption = "TE_ADDRESS" Dim oEvt As ITAddressEvent Set oEvt = pEvent If oEvt.Event = AE_RINGING Then ' We don't have to get Caller ID here! Dim oCollection As ITCollection Dim oAddress As ITAddress Set oAddress = oEvt.Address Set oCollection = oAddress.Calls If oCollection.Count > 0 Then Set oCallInfo = oCollection.Item(1) GetCallerID oCallInfo Set oCallInfo = Nothing End If Set oCollection = Nothing Set oAddress = Nothing 'Track the ring count and only answer if we have met the criteria we 'specified in Setup m_curRings = m_curRings + 1 If m_curRings >= m_rings Then m_Answer = True tmrUpdate.Enabled = True Else If m_curRings >= m_toll Then m_Answer = True tmrUpdate.Enabled = True End If End If End If Set oEvt = Nothing End Select Set pEvent = Nothing End Sub 'Answer the call and setup for DTMF detection events Private Sub Answer() Err.Clear If gobjReceivedCallInfo Is Nothing Then Exit Sub End If If Not (gobjReceivedCallInfo.CallState = CS_OFFERING) Then Exit Sub End If 'query ITBasicCallControl, the call control interface Dim objCallControl As ITBasicCallControl Set objCallControl = gobjReceivedCallInfo 'Answer objCallControl.Answer 'release the call control interface Set objCallControl = Nothing 'Start DTMF detection gobjMediaControl.DetectDigits LINEDIGITMODE_DTMF End Sub 'Disconnect a call. we sometimes try to disconnect a call that we 'haven't answered yet (a call comes in but is dropped before the app has 'answered. Other than tracking the state of whether or not we actually 'answered the call we just attempt that last in this sub Private Sub Disconnect() On Error GoTo ErrorOut: InitMVars If gobjReceivedCallInfo Is Nothing Then Exit Sub 'If we try to disconnect while we are working we fail Set ds = Nothing Set dsBuffer = Nothing Set gDSC = Nothing Set gDSCB = Nothing 'disconnect the call: need to query its call control interface for this Dim objCallControl As ITBasicCallControl Set objCallControl = gobjReceivedCallInfo Set gobjMediaControl = Nothing Set gobjReceivedCallInfo = Nothing SetMsgLabel 'Set our count of messages label ClearLabels 'Clear the caller id labels objCallControl.Disconnect (DC_NORMAL) 'release the call control interface Set objCallControl = Nothing RegisterForNotification Exit Sub ErrorOut: 'Normally get here when a caller hangs up before we answered Debug.Print "Disconnect " & Err.Description & " " & Err.Number Set objCallControl = Nothing RegisterForNotification Err.Clear End Sub 'Plays a given file, fairly self explanatory... Public Sub PlayFile(strGreeting As String) Dim dsBuf As DSBUFFERDESC On Error Resume Next 'GoTo ErrorOut: 'We can play out the speakers or through the phone device, which to use 'is determined in the cmdOn_Click method which sets m_playGuid 'it takes 3 seconds to execute the next two lines Set ds = gDX.DirectSoundCreate(m_playGuid) ds.SetCooperativeLevel Me.hWnd, DSSCL_PRIORITY 'Set the coop level 'Make sure we still can play when we lose window focus! dsBuf.lFlags = DSBCAPS_GLOBALFOCUS Or DSBCAPS_CTRLVOLUME Set dsBuffer = ds.CreateSoundBufferFromFile(strGreeting, dsBuf) ' tmrUpdate.Enabled = True dsBuffer.Play DSBPLAY_DEFAULT b_playing = True Exit Sub On Error Resume Next 'ErrorOut: If m_playGuid = vbNullString Then MsgBox "PlayFile Failed: " & Err.Description Else Me.Caption = "PlayFIle Failed: " & Err.Description End If SetMsgLabel End Sub 'Starts recording a file, initializes the DirectSound capture device 'and buffer and sets up events. Public Sub RecordFile() On Error GoTo ErrorOut: m_messageCounter = m_len Init m_recGuid 'Use the appropriate device guid set in cmdOn_Click SetEvents StartCapture Exit Sub ErrorOut: Debug.Print "Record File Error: " + Err.Description Disconnect End Sub 'Stop recording, either from a Disconnect event or we have reached the 'maximum message time set in Setup Public Sub StopRecording() Dim fName As String Err.Clear On Error Resume Next gDSCB.stop If Err.Number <> 0 Then Debug.Print "StopRecording: " & Err.Description On Error GoTo 0 'Resume normal error handling If m_recGuid <> vbNullString Then fName = lblTime & "," & lblName & "," & lblNumber & ".wav" 'We have the opportunity to get called a few times on disconnect 'verifing the file name works since we will have cleared the labels 'the first time through If Trim(fName) <> ",,.wav" Then SaveToFileAsStream App.Path + "\Messages\" & fName Else Exit Sub End If Else 'Recorded a new welcome greeting SaveToFileAsStream App.Path + "\Greet.wav" End If On Error Resume Next ClearEvents Set gDSC = Nothing Set gDSCB = Nothing On Error GoTo 0 Disconnect End Sub 'Answers the call and plays the greeting. The tmrUpdate_Timer sub gets enabled 'here so it can watch for the playing of the file to end. Private Sub IVRS_Start() Debug.Print "IVRS_Start: " & Now() Answer Debug.Print "Answer: " & Now() 'DoEvents PlayFile strGreeting Debug.Print "PlayFile: " & Now() tmrUpdate = True End Sub Private Sub modem_Click() If lblServer.Caption <> "Server ON" Then MsgBox "Start the Server first", vbExclamation, "IVRS" Else dlgSetup.Show (1) End If End Sub Private Sub outgoingcall_Click() Outgoing.Show vbModal End Sub Private Sub recordvoice_Click() dlgGreet.Show vbModal End Sub Private Sub start_Click() Dim strMsg As String Screen.MousePointer = vbHourglass ' If cmdOn.Caption = "&Start Server" Then If Not dsBuffer Is Nothing Then While (dsBuffer.GetStatus And DSBSTATUS_PLAYING) = _ DSBSTATUS_PLAYING DoEvents Wend dsBuffer.stop End If If b_playing = True Then 'Make sure we aren't playing files dsBuffer.stop Disconnect b_playing = False End If Dim objCollAddresses As ITCollection If gobjTapi Is Nothing Then InitTAPI End If GetSettings Set objCollAddresses = gobjTapi.Addresses m_device = GetDeviceByName(m_card, objCollAddresses) If m_device = -1 Then strMsg = "Can not find selected device, choose Setup" GoTo ErrorOut: End If 'pick up the "N"-th address - the address on which 'you want to register for receiving calls Set gobjAddress = objCollAddresses.Item(m_device) 'Set objCollAddresses = Nothing 'no more needed, release RegisterForNotification 'Set our DirectSound device GUID's ' m_recGuid = GetLegacyWaveIDAsDXDeviceGUID(m_device, "wave/in") m_playGuid = GetLegacyWaveIDAsDXDeviceGUID(m_device, "wave/out") lblServer.Caption = "Server ON" ErrorOut: Err.Clear Screen.MousePointer = vbNormal ' MsgBox strMsg End Sub Private Sub stop_Click() lblServer.Caption = "Server OFF" Screen.MousePointer = vbNormal dsBuffer.stop Disconnect b_playing = False End Sub 'Most of this timer routine polls for the status of the DirectSound buffer 'that is currently playing. As opposed to the recording where we used events 'for playing we just simply poll the status. This timer is also used to 'answer the incoming call. Calling that from the TAPI event is time consuming 'and we might miss a call. Note that when we aren't playing a file or 'attempting to answer a call the timer is disabled Private Sub tmrUpdate_Timer() If m_Answer = True Then tmrUpdate.Enabled = False m_Answer = False IVRS_Start End If End Sub ' TimeAsString returns the system time as a string that does not contain ' the illegal filename characters '/' and ':'. This could blow up on systems ' that have the time settings different, I haven't checked. A quick glance at ' the 'Regional Options' control panel applet looks like all other time/date ' seps are legal filename characters. Private Function TimeAsString() As String Dim lPos As Long Dim strNow As String strNow = Now lPos = InStr(1, strNow, "/") Do While lPos > 0 strNow = Mid(strNow, 1, lPos - 1) & "-" & Mid(strNow, lPos + 1, Len(strNow)) lPos = InStr(1, strNow, "/") Loop lPos = InStr(1, strNow, ":") Do While lPos > 0 strNow = Mid(strNow, 1, lPos - 1) & "-" & Mid(strNow, lPos + 1, Len(strNow)) lPos = InStr(1, strNow, ":") Loop TimeAsString = strNow End Function 'Get a list of wave files in the Messages directory, return the list as a 'collection of string Public Function GetMessages() As Collection Dim oColl As New Collection Dim myString As String myString = Dir(App.Path & "\Messages\*.wav") Do While myString <> "" oColl.Add myString myString = Dir Loop Set GetMessages = oColl End Function 'This is called each time we get a buffer event from DirectSound. We get 'events when the buffer pointer is at the beginning of the buffer and when the 'buffer pointer is at the middle of the buffer. Private Sub DirectXEvent8_DXCallback(ByVal eventid As Long) Select Case eventid Case EVNT(1).hEventNotify basStream.CopyBuffer 1 'Save the first half of the buffer Case EVNT(0).hEventNotify basStream.CopyBuffer 0 'Save the second half of the buffer End Select 'Count down to stop recording m_messageCounter = m_messageCounter - 1 If m_messageCounter < 0 Then StopRecording End If End Sub '----------------------------------------- 'Set the events to the capture buffer '----------------------------------------- Public Sub SetEvents() eventid(0) = gDX.CreateEvent(Me) eventid(1) = gDX.CreateEvent(Me) If gDSCB Is Nothing Then Call Init(hWnd) 'Notify us when the buffer pointer points to the beginning of the buffer EVNT(0).hEventNotify = eventid(0) EVNT(0).lOffset = 0 'Notify us when the buffer pointer points to the middle of the buffer EVNT(1).hEventNotify = eventid(1) EVNT(1).lOffset = (gDSCBD.lBufferBytes \ 2) gDSCB.SetNotificationPositions 2, EVNT() End Sub Private Sub SetCallerInfo(sInfo As String) Dim lPos As Long On Error Resume Next lPos = InStr(1, sInfo, ",") lblTime.Caption = Mid(sInfo, 1, lPos - 1) sInfo = Mid(sInfo, lPos + 1, Len(sInfo)) lPos = InStr(1, sInfo, ",") lblName.Caption = Mid(sInfo, 1, lPos - 1) sInfo = Mid(sInfo, lPos + 1, Len(sInfo)) lblNumber.Caption = Mid(sInfo, 1, Len(sInfo) - 4) 'Trim off the .wav Err.Clear End Sub Private Sub ClearLabels() lblTime = "" lblName = "" lblNumber = "" End Sub Public Sub DisplayCallState(State As CALL_STATE) Dim strMsg As String Select Case State Case CS_CONNECTED strMsg = "call state: CS_CONNECTED" & Chr(13) strMsg = strMsg & "The call was answered, now you can disconnect " strMsg = strMsg & "or wait for disconnected state. " strMsg = strMsg & "Don't press Answer before new call arrives. " Label9.Caption = strMsg Case CS_DISCONNECTED strMsg = "call state: CS_DISCONNECTED" & Chr(13) lblTest.Caption = strMsg Case CS_HOLD Label9.Caption = "call state: CS_HOLD" Case CS_IDLE Label9.Caption = "call state: CS_IDLE" Case CS_INPROGRESS Label9.Caption = "call state: CS_INPROGRESS" Case CS_OFFERING If gbSupportedCall = True Then Label9.Caption = "call state: CS_OFFERING" strMsg = strMsg & Chr(13) & "A call was received. You can answer it" Label9.Caption = strMsg End If Case CS_QUEUED Label9.Caption = "call state: CS_QUEUED" Case Else Label9.Caption = "call state: unknown!!" End Select Label9.Refresh End Sub Private Sub vbbalance_Click() checkbal.Show vbModal End Sub