Documents and messages creator program

Documents and messages creator program

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

0 comments

Oldest 

Forgot Password?

No problem! Submit your e-mail address below. We'll send you an email containing your password.

Your password has been sent to:

-ADS BY GOOGLE

SearchEnterpriseLinux

SearchDataCenter

Close