asked on

VBscript Macro for IBM Client Macro for Excel to AS400 Emulator

I am attempting to write a VBscript macro for IBM Client Access that will pull data from the cells of an excel spreadsheet and run through a loop until the rows of the spreadsheet are completed. I saw a related question on Experts Exchange, but the link in the solution was broken. I also found a website that had a template posted, however I just can't seem to get it to work properly. I continue to get "unknown runtime errors" (line 268) in the macro... VBscript really isn't my strongest area by any means, I consider myself a beginner, but I will post the code that I have edited from the template below, as well as the link to the webpage in which I have found the template. I will also have attached a simple version of the excel spreadsheet which will hold the information. Any help in getting this macro up and running will make my job a million times easier. Thanks in advance.

Template site: http://laurens.vankeer.eu/programming/vbscript/excel-2-as400

[PCOMM SCRIPT HEADER]
LANGUAGE=VBSCRIPT
DESCRIPTION=A template for Excel 2 AS/400 macros.
[PCOMM SCRIPT SOURCE]
 
' Excel2AS400_English.mac
' A template for Excel 2 AS/400 macros.
' In this macro we suppose an Excel spreadsheet with the following header:
' COL1 | COL2 | ERROR
'
' @author	Laurens Van Keer
' @since	24/07/08
' @version	1.0
 
OPTION EXPLICIT
autECLSession.SetConnectionByName(ThisSessionName)
 
If Msgbox("Full Excel Transfer Test" & VbCrLf & VbCrLf & _
"Proceed?", vbYesNo, "Welcome") = 6 Then
 
	' Constants
	Const DEBUGMODE = FALSE ' Testfase?
	Const COLORPROCESSED = 65280 ' Green
	Const COLORERROR = 255 ' Red
 
	' Variables
	Dim ObjExcelAppl, ObjWorkbook, ObjWorksheet, StrFileName
	Dim ErrorMessage
	Dim cCOL1, cCOL2, cERROR
	Dim col1, col2
 
		Main
 
		' Clean up.
		Set ObjWorksheet = Nothing
		Set ObjWorkbook = Nothing
		Set ObjExcelAppl = Nothing	
 
		MsgBox "Macro finished."
 
 
End If
 
Sub Main()
 
	Dim currentRow
 
	' Ask for an Excel spreadsheet.
	Set ObjExcelAppl = CreateObject("Excel.Application")
	StrFileName = ObjExcelAppl.GetOpenFilename("Microsoft Excel bestanden (*.xls*),*.xls*")
	ObjExcelAppl.DisplayAlerts = False
 
	' Valid file?
	If StrFileName <> False then
 
		' Open spreadsheet.
		Set ObjWorkbook = ObjExcelAppl.WorkBooks
		ObjWorkbook.Open StrFileName
		' Show Excel sheet.
		ObjExcelAppl.Visible = True
 
		' Check if the sheet is already open.
		On Error Resume Next
		ObjExcelAppl.ActiveWorkbook.Save
		If Err.Number = 1004 Then
			Msgbox "The Excel file is already open, please close and retry."
			Exit Sub
		End If
		On Error GoTo 0
 
		' Activate first sheet.
		ObjExcelAppl.Worksheets(1).Activate
		Set ObjWorksheet = ObjExcelAppl.Worksheets(1)
 
			' Process every row, except for the header row.
			currentRow = 2
 
			' Stop upon the first empty row.
			Do While GetCellData(currentRow, 2) <> Empty
 
			' Skip the row if it is already processed
			     If IsRowError(currentRow) <> True and IsRowProcessed(currentRow) <> _ True Then
 
					If Process_Row(currentRow) = True Then
						MarkRow_Processed(currentRow)
					End If
 
				End If
 
				currentRow = currentRow + 1
 
			Loop
 
		' Save the workbook.
		ObjExcelAppl.ActiveWorkbook.Save
		ObjExcelAppl.DisplayAlerts = True
 
	End If
 
End sub
 
' Populate screen with the spreadsheet data.
Function Process_Row(ByVal row)
 
	' Skip processed rows.
	If IsRowError(row) <> True and IsRowProcessed(row) <> True Then
 
		'''''''''''''''''''''''''''''''''''''''''''
	    ' INIT
		'''''''''''''''''''''''''''''''''''''''''''
 
		' Get cell values from sheet.
		col1 = GetCellData(row, cCOL1)
		col2 = GetCellData(row, cCOL2)
 
		' Place cursor.
		SetCursor 9, 34 ' <= CHANGE
 
		'''''''''''''''''''''''''''''''''''''''''''
	    ' IS VALID ROW? 
		'''''''''''''''''''''''''''''''''''''''''''
 
		' You're validation of the cell values here.
 
		'''''''''''''''''''''''''''''''''''''''''''
	    ' PROCESS ROW
		'''''''''''''''''''''''''''''''''''''''''''
 With autECLSession
.autECLOIA.WaitForAppAvailable
.autECLOIA.WaitForInputReady
.autECLPS.SendKeys col1
.autECLOIA.WaitForInputReady
.autECLPS.SendKeys "[tab]"
.autECLOIA.WaitForInputReady
.autECLPS.SendKeys col2
.autECLOIA.WaitForInputReady
.autECLPS.SendKeys "[enter]"
.autECLOIA.WaitForInputReady
.autECLPS.SendKeys "90"
.autECLOIA.WaitForInputReady
.autECLPS.SendKeys "[enter]"
End With
 
	End If
 
End Function
 
' Own functions / subroutines here.
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' AS/400 CLIENT FUNCTIONS
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
' F3
Function F3()
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SendKeys "[pf3]"
End Function
 
' F7
Function F7()
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SendKeys "[pf7]"
End Function
 
' F8
Function F8()
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SendKeys "[pf8]"
End Function
 
' F9
Function F9()
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SendKeys "[pf9]"
End Function
 
' F12
Function F12()
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SendKeys "[pf12]"
End Function
 
' + sign
Function Plus()
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SendKeys "[field+]"
End Function
 
' CTRL
Function Reset()
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SendKeys "[reset]"
End Function
 
' PAGE UP
Function PageUp()
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SendKeys "[roll down]"
End Function
 
' PAGE DOWN
Function PageDown()
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SendKeys "[roll up]"
End Function
 
' ENTER
Function Enter()
	autECLSession.autECLOIA.WaitForAppAvailable	
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SendKeys "[enter]"
End Function
 
' Place cursor on the given position.
' Arguments:
'	Required: Long row
'	Required: Long column
' Precondition: the given row and column are within range.
Function SetCursor(ByVal row, ByVal column)
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SetCursorPos row, column
End Function
 
' Type text.
' Arguments:
' 	Required: String text
' Precondition: the cursor is placed on an "editable" field.
Function SendText(ByVal text)
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	autECLSession.autECLPS.SendKeys text
End Function
 
' Returns text from a given position in the AS400 emulator.
' Arguments:
'	Required: Long row
'	Required: Long column
'	Required: Long length
' Precondition: arguments are within range.
' Returns: the trimmed text on that position.
Function GetText(ByVal row, ByVal column, ByVal length)
	autECLSession.autECLOIA.WaitForAppAvailable
	autECLSession.autECLOIA.WaitForInputReady
	GetText = Trim(autECLSession.autECLPS.GetText(row, column, length))
End Function
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' EXCEL FUNCTIONS
' Precondition:
' 	ObjExcelAppl, ObjWorkbook en ObjWorksheet must be set.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
' Returns the value of a cell.
' Arguments:
'	Required: Integer row
'	Required: Integer column
Function GetCellData(ByVal row, ByVal column)
	GetCellData = Trim(CStr(ObjWorksheet.Cells(row, column).Value))
End Function
 
' Sets the value of a cell.
' Arguments:
'	Required: Integer row
'	Required: Integer column
'	Required: String cellValue
Function SetCellData(ByVal row, ByVal column, ByVal cellValue)
	ObjWorksheet.Cells(row, column).Value = cellValue
End Function
 
' Mark the row as invalid.
' Arguments:
'	Required: Integer row
Function MarkRow_Error(ByVal row)
	ObjWorksheet.Rows(row).Interior.Color = COLORERROR
	ObjWorksheet.Cells(row, cERROR).Value = ErrorMessage
	ObjExcelAppl.ActiveWorkbook.Save
	ErrorMessage = ""
End Function
 
' Mark the processed row.
' Arguments:
'	Required: Integer row
Function MarkRow_Processed(ByVal row)
	ObjWorksheet.Rows(row).Interior.Color = COLORPROCESSED
	ObjExcelAppl.ActiveWorkbook.Save
End Function
 
' Check if the row has an error color.
' Arguments:
'	Required: Integer row
Function IsRowError(ByVal row)
 
	If ObjWorksheet.Rows(row).Interior.Color <> Empty Then
 
		If ObjWorksheet.Rows(row).Interior.Color = COLORERROR Then
			IsRowError = True
		Else
			IsRowError = False
		End If
 
	Else
		IsRowError = False
	End If
 
End Function
 
' Check if the row has a "processed" color.
' Arguments:
'	Required: Integer row
Function IsRowProcessed(ByVal row)
 
	If ObjWorksheet.Rows(row).Interior.Color <> Empty Then
		If ObjWorksheet.Rows(row).Interior.Color = COLORPROCESSED Then
			IsRowProcessed = True
		Else
			IsRowProcessed = False
		End If
	Else
		IsRowProcessed = False
	End If
 
End Function
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' VALIDATION FUNCTIONS
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
' blah blah blah
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ERROR HANDLING FUNCTIONS
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
' Check if the user is in the right program window.
' Arguments:
'	Required: String programName => name of the window (check upper left of the AS400 client)
' Returns:
'	True => correct window
'	False => incorrect window
Function IsCorrectWindow(ByVal programName)
 
	Dim thisWindow
 
	' Check first 10 characters starting from row 1, column 2.
	thisWindow = GetText(1, 2, 10)
 
	If thisWindow = programName Then
 
		IsCorrectWindow = True
 
	Else
 
		If DEBUGMODE Then
			MsgBox "Wrong window!"
		End If
 
		IsCorrectWindow = False
 
	End If
 
End Function
 
' Check for errors in the AS/400 emulator (24th row in my case).
' Returns:
'	True => error.
'	False => no error.
Function CheckForError()
 
	ErrorMessage = GetText(24, 2, 78)
	If (ErrorMessage <> "") then
		CheckForError = True
	Else
		CheckForError = False
	End If
 
End Function

Open in new window

Book1.xls

ASKER CERTIFIED SOLUTION

Theo Kouwenhoven

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

musachamll

ASKER

That was exactly what I was looking for. I just needed and example that worked to figure out where I was going wrong. Thanks for your help. This is going to be a tremendous time saver.