Documents and messages creator program
Dim cn400 As New ADODB.Connection
Dim cmSQLCMD As New ADODB.Command
Dim rsRECSET As ADODB.Recordset
Dim fTemp As String
Option Explicit
Private Sub Main()
' command line example: qgpl.file,account@domain.com,user400
Dim sAccount As String
Dim sFile As String
Dim sUser As String
On Error GoTo Err_Handler
' Command$ parsing
sAccount = Right(Command$, Len(Command$) - InStr(Command$, ","))
sAccount = Trim$(sAccount)
sFile = Left(Command$, InStr(Command$, ",") - 1)
sFile = Trim$(sFile)
sUser = Right(sAccount, Len(sAccount) - InStr(sAccount, ","))
sUser = Trim$(sUser)
sAccount = Left(sAccount, InStr(sAccount, ",") - 1)
sAccount = Trim$(sAccount)
cn400.Open "provider=IBMDA400;data source=" & "iSeriesName" & ";", "UserId", "Pwd"
CreateExcel sFile, sUser
createWord sFile, sUser
createmail sAccount, sUser
cn400.Execute "{{sndmsg msg('Job Normally Completed') tousr(" & sUser & ") }}"
Set cn400 = Nothing
Exit Sub
Err_Handler:
' Send the message 'sndmsg msg('Job Abnormally Completed') tousr(" & sUser & ") }}"
' Using FTP remote commnad
' MsgBox Err.Description, vbCritical, "Error: " & Err.Number
End
End Sub
Sub CreateExcel(sFile As String, sUser As String)
Dim oXL As Excel.Application
Dim oWB As Excel.Workbook
Dim oSheet As Excel.Worksheet
Dim oRng As Excel.Range
Dim colCount As Integer
Dim rowIdx, colIdx As Integer
On Error GoTo Err_Handler
' Create new hidden instance of Excel
Set oXL = CreateObject("Excel.Application")
oXL.Visible = False
' Add a new workbook
' Set oWB = oXL.Workbooks.Add
' OR add a template from a path
Set oWB = oXL.Workbooks.Add("c:test.xlt")
Set oSheet = oWB.ActiveSheet
' Add a text as header
oSheet.Cells(1, 1).Value = "This is a Test"
' create the recordset
Set cmSQLCMD.ActiveConnection = cn400
cmSQLCMD.CommandText = "select * from " + sFile
Set rsRECSET = cmSQLCMD.Execute()
colCount = rsRECSET.Fields.Count
rowIdx = 2
For colIdx = 0 To colCount - 1
oSheet.Cells(rowIdx, colIdx + 1).Value = rsRECSET.Fields(colIdx).Name
Next colIdx
Do While Not rsRECSET.EOF
rowIdx = rowIdx + 1
For colIdx = 0 To colCount - 1
oSheet.Cells(rowIdx, colIdx + 1).Value = rsRECSET.Fields(colIdx).Value
Next colIdx
rsRECSET.MoveNext
Loop
Set rsRECSET = Nothing
Set cmSQLCMD = Nothing
' Save Excel application as a temporary file
On Error Resume Next
fTemp = "c:" + Format(Now(), "yymmddhhmmss")
Kill fTemp & ".xls"
On Error GoTo Err_Handler
oWB.SaveAs fTemp & ".xls"
oWB.Close
oXL.Quit
Exit Sub
Err_Handler:
cn400.Execute "{{sndmsg msg('Job Abnormally Completed') tousr(" & sUser & ") }}"
' MsgBox Err.Description, vbCritical, "Error: " & Err.Number
oWB.Close
oXL.Quit
End
End Sub
Sub createWord(sFile As String, sUser As String)
Dim wdApp As Word.Application
Dim oDoc As Word.Document
Dim oTable As Word.Table
Dim colCount, rowCount As Integer
Dim rowIdx, colIdx As Integer
On Error GoTo Err_Handler
' Create new hidden instance of Word.
Set wdApp = New Word.Application
' Create a new document.
' Add a new workbook
' Set oDoc = wdApp.Documents.Add
' OR add a template from a path
Set oDoc = wdApp.Documents.Add("c:test.dot")
wdApp.Visible = False
' Add text to document.
wdApp.Selection.TypeText "This is a test" + vbCr
' create the recordset
Set cmSQLCMD.ActiveConnection = cn400
cmSQLCMD.CommandText = "select * from " + sFile
Set rsRECSET = cmSQLCMD.Execute()
colCount = rsRECSET.Fields.Count
rowIdx = 1
Set oTable = oDoc.Tables.Add( _
Range:=oDoc.Range(Start:=0, End:=0), NumRows:=rowIdx, _
NumColumns:=colCount)
For colIdx = 0 To colCount - 1
With oTable.Cell(Row:=rowIdx, Column:=colIdx + 1).Range
.InsertAfter Text:=rsRECSET.Fields(colIdx).Name
End With
Next colIdx
Do While Not rsRECSET.EOF
rowIdx = rowIdx + 1
With oTable.Rows.Add.Range
For colIdx = 0 To colCount - 1
With oTable.Cell(Row:=rowIdx, Column:=colIdx + 1).Range
.InsertAfter Text:=rsRECSET.Fields(colIdx).Value
End With
Next colIdx
End With
rsRECSET.MoveNext
Loop
oTable.AutoFormat Format:=wdTableFormatColorful2, _
ApplyBorders:=True, ApplyFont:=True, ApplyColor:=True
Set rsRECSET = Nothing
Set cmSQLCMD = Nothing
' Save Word application as a temporary file
On Error Resume Next
Kill fTemp & ".doc"
On Error GoTo Err_Handler
sFile = fTemp & ".doc"
With oDoc
.SaveAs fTemp & ".doc"
End With
wdApp.Quit
Exit Sub
Err_Handler:
cn400.Execute "{{sndmsg msg('Job Abnormally Completed') tousr(" & sUser & ") }}"
' MsgBox Err.Description, vbCritical, "Error: " & Err.Number
oDoc.Close
wdApp.Quit
End
End Sub
Sub createmail(sAccount As String, sUser As String)
Dim objSession As Object
Dim objMessage As Object
Dim objRecipient As Object
Dim objAttachment As Object
Dim profile As String
On Error GoTo Err_Handler
' Modify the profile name according to the Outlook configuration
profile = "administrator"
Set objSession = CreateObject("mapi.session")
objSession.Logon profileName:=profile
' Create a message object
Set objMessage = objSession.Outbox.Messages.Add
objMessage.Subject = "From ISERIES: Subject ..."
objMessage.Text = "From ISERIES: Message ..."
Set objRecipient = objMessage.Recipients.Add
objRecipient.Name = sAccount
objRecipient.Type = 1
objRecipient.Resolve
' Add an attachment object to message object
Set objAttachment = objMessage.Attachments.Add
objAttachment.Name = "EXCEL From AS400"
objAttachment.Source = fTemp & ".xls"
Set objAttachment = objMessage.Attachments.Add
objAttachment.Name = "WORD From AS400"
objAttachment.Source = fTemp & ".doc"
objMessage.DeliveryReceipt = True
objMessage.ReadReceipt = True
' Delete the temporaries files
On Error Resume Next
Kill fTemp & ".doc"
Kill fTemp & ".xls"
On Error GoTo Err_Handler
objMessage.Send showDialog:=False
objSession.Logoff
Exit Sub
Err_Handler:
cn400.Execute "{{sndmsg msg('Job Abnormally Completed') tousr(" & sUser & ") }}"
' MsgBox Err.Description, vbCritical, "Error: " & Err.Number
End
End Sub