The following Access Visual Basic function opens a channel with an IBM 5250 emulator session ,creates a recordset from a table in a Microsoft Access Database, writes to the session and searches the screen for error messages.

Return to Introduction

Please note that text that is preceded by a single quotation mark and that is colored green are comments that are ignored by the compiler.

Option Compare Database
Private GuidePtSource As Database
Private GuidePtList As Recordset
Option Explicit
Private Sub AddNumbers_Click()
'Sub EnterBillingNumbers()
'Colin Riley 09/04/00
'This script is used to add DID numbers within a circuit leg
Dim Item As String 'The item in DDE refers to the program that the script that is trying to communicate with.
Dim Topic As String
Dim ChanA As Variant 'Channel Number. A script will have problems running if this value is declared as an integer.
Dim Title As String
Dim TextFile As String
Dim ErrorFile As String
Dim BTN As String
Dim Warning As String
Dim ErrorMsg As String
Dim ErrorDesc As String
Dim ErrorCount As Integer
Dim Proceed As Integer
Dim ErrorList As Recordset
Dim Account As String
Dim CurrDateTime As Date
Dim SessionID As String
DDETerminateAll
ErrorCount = 0
Item = "IBM525032" ' Client Access 5250 session
Proceed = MsgBox("Do you wish to run this script", vbYesNo)
If Proceed <> 6 Then Exit Sub ' 6 = yes
Set GuidePtSource = CurrentDb() 'Declare current data base as the database that you are pulling records from.
'Line below creates list of all records in the GuidePointsToCBP Table.
Set GuidePtList = GuidePtSource.OpenRecordset("SELECT * FROM GuidePointsToCBP", dbOpenSnapshot, dbForwardOnly)
' Open Error Table to allow errors to be recorded.
Set ErrorList = GuidePtSource.OpenRecordset("ErrorTable", dbOpenTable, dbAppendOnly)
SessionID = InputBox("Please enter the session Id (ex. A)", "Session ID")
Topic = "Session" & SessionID ' Create session ID to allow MS Access to know which Emulator session to work in.
On Error GoTo ErrHandle ' Activate error handling. If there is a detected error program control will go to this sub routine
 
ChanA = DDEInitiate(Item, Topic) ' Open channel
MsgBox "Channel Number= " & ChanA, vbOKOnly, "Destination Channel" 'Display communications channel number
'Classification Type: LEG
' location 08/02
'**********************************************************************************************
With GuidePtList
Do While Not .EOF 'Loop until the end of GuidePtList
AddNumber: 'Identifies location in program
BTN = !GuidePoint 'Assign item in GuidePtList to the variable {BTN}
 
DDEExecute ChanA, "[SENDKEY(pf9)]" 'Press {F9}
DDEExecute ChanA, "[SENDKEY(wait inp inh)]" ' Wait until screen change has occured and session will accept input.
DDEExecute ChanA, "[SENDKEY(erase eof)]" 'Erase end of field in case there are any residual characters.
DDEExecute ChanA, "[SENDKEY(wait inp inh)]"
DDEPoke ChanA, "EPS" & "(0905,1)", BTN ' Attempt to add guide point
DDEExecute ChanA, "[SENDKEY(pf4)]" 'Press F4
DDEExecute ChanA, "[SENDKEY(wait inp inh)]"
'Line below is to anticipate a routine error.
Warning = DDERequest(ChanA, "STRING" & "(" & "1841,1," & Chr(34) & "Guiding Number not available" & Chr(34) & ")")
Warning = Left(Warning, 4) ' Chop off garbage. There is a tendency for stray charaters to be appended to the screen location
If Warning <> "None" Then 'If string is found on the screen then there is an error. This error would not be detected by the system.
 
GoTo ErrHandle ' Go to the error handler
End If
 
DDEExecute ChanA, "[SENDKEY(pf4)]"
DDEExecute ChanA, "[SENDKEY(wait inp inh)]"
'MsgBox "Prompt", vbOKOnly
'DDEPoke ChanA, "[SET CURSOR]", "0901"
'DDEExecute ChanA, "[SENDKEY(wait inp inh)]"
'DDEExecute ChanA, "[SENDKEY(erase eof)]" 'Erase end of field in case there are any residual characters.
'DDEExecute ChanA, "[SENDKEY(wait inp inh)]"
MsgBox "Prompt", vbOKOnly
DDEExecute ChanA, "[SENDKEY(" & Chr(34) & "N" & Chr(34) & ")]" 'Directory Assistance fees not waived
DDEExecute ChanA, "[SENDKEY(wait inp inh)]"
DDEExecute ChanA, "[SENDKEY(pf9)]" ' Add Billing Telephone number
DDEExecute ChanA, "[SENDKEY(wait inp inh)]"
If .EOF Then Exit Do
.MoveNext ' Move to next record in list
 
'*********************************************************************************************
Loop ' return to line with {Do While Not .EOF}
StopScript:
GuidePtList.Close 'Close Recordset and free up memory
ErrorList.Close 'Close Recordset and free up memory
DDETerminate ChanA ' Close channel. If too many channels are left open then the computer will crash
MsgBox "I am finished " & " There were " & ErrorCount & " Errors", vbOKOnly 'Report the number of recorded errors to user.
 
Exit Sub
 
 
ErrHandle: 'Error handler. The first section writes the guide point and error description to a table.
ErrorMsg = DDERequest(ChanA, "EPS(1841,40,1)") ' Retrieve whatever text there is at the bottom of the presentation space
ErrorMsg = Mid(ErrorMsg, 20, 30) ' Save charaters 20 through 50
ErrorDesc = Err.Description 'Retrieve MS Access error message if there is one.
CurrDateTime = Now 'Get todays date and time to write to error file.
ErrorCount = ErrorCount + 1 'Count errors total number of errors will be given after script ends.
If ErrorDesc = "" Then ErrorDesc = "Not applicable"
With ErrorList ' Add new record to error table.
.AddNew
!GuidePoint = BTN 'list BTN where error occured
!ErrorDesc = ErrorDesc
!ErrorMsg = ErrorMsg
!Date = CurrDateTime
DDEExecute ChanA, "[SENDKEY(reset)]" 'Send reset or Ctrl command to allow further input in session.
DDEExecute ChanA, "[SENDKEY(wait inp inh)]"
ErrorList.Update 'Save record to error file
End With
DDEExecute ChanA, "[SENDKEY(pf12)]" 'Go back one screen
DDEExecute ChanA, "[SENDKEY(wait inp inh)]"
If GuidePtList.EOF Then GoTo StopScript
.MoveNext 'Advance to next record
If GuidePtList.EOF Then GoTo StopScript
GoTo AddNumber ' If there are still numbers to add then go back to top of program.
End With
 
'Write error to file navigate to restart point
'Guiding Number not available
'Screen location 1841
'DDID Dedicated DID Classification
End Sub