Hi All:
In my company we have a need to generate many small reports and e-mail them to our accounts. I have developed a word macro which will copy the text document generated in the AS400, add the company logo, and email it to the requestor as a word document attachment.
The macro is stored in a word document (in my case as400rpt.doc), the logo is stored in a second word document (logo.doc) , the AS400 report is stored as a text file (qsysprt2.txt) and the e-mail address is stored in an excel document in cell A1 (ME1.XLS).
On the 400 side you need to:
1. cpysplf to qtemp
2. ftp or cpytopcd to your document's drive (in the above example it is H: )
3. strpco
4. strpccmd 'h:as400rpt.doc'
Hope someone can use this
In my company we have a need to generate many small reports and e-mail them to our accounts. I have developed a word macro which will copy the text document generated in the AS400, add the company logo, and email it to the requestor as a word document attachment.
The macro is stored in a word document (in my case as400rpt.doc), the logo is stored in a second word document (logo.doc) , the AS400 report is stored as a text file (qsysprt2.txt) and the e-mail address is stored in an excel document in cell A1 (ME1.XLS).
Code:
Private Sub Document_Open() [COLOR="seagreen"]' open a text file and attach logo then email it to myself[/COLOR] [COLOR="seagreen"]'First get the e-mail address located in cell A1 of ME1.XLS[/COLOR] Dim SEND2 As String Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim EMAIL2 As String On Error Resume Next Set xlApp = GetObject(, "Excel.Application") If Err.Number <> 0 Then Set xlApp = CreateObject("Excel.Application") End If Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Open("H:\ME1.xls") [COLOR="seagreen"]' me1.xls cell a1 will be my email address[/COLOR] xlBook.Sheets(1).Range("A1:A1").Select EMAIL2 = Cells(1, 1).Value xlBook.Close xlApp.Quit Set xlBook = Nothing Set xlApp = Nothing [COLOR="seagreen"]'Second get the text file and copy it to the clip board[/COLOR] Documents.Open FileName:="h:\QSYSPRT2.txt", ConfirmConversions:=False, _ ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _ PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _ WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:="" Selection.WholeStory Selection.Copy [COLOR="seagreen"]'third get the logo and paste the clip board data to it[/COLOR] Documents.Open FileName:="h:\LOGO.doc", ConfirmConversions:=False, ReadOnly:= _ False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _ "", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _ Format:=wdOpenFormatAuto, XMLTransform:="" [COLOR="seagreen"]'starting from the top of the page ' (when logo.doc is saved...leave your cursor at the very top of the page) ' go down "count" number of lines before you paste[/COLOR] Selection.MoveDown UNIT:=wdLine, Count:=6 Documents("LOGO.DOC").Activate Selection.PasteAndFormat (wdPasteDefault) [COLOR="seagreen"] ' delete white space at bottom of the report[/COLOR] Selection.Delete UNIT:=wdCharacter, Count:=56 Application.Visible = False [COLOR="seagreen"] 'document must be saved before it can be e-mailed[/COLOR] ActiveDocument.SaveAs FileName:="h:\ISERIES REPORT.doc", FileFormat:= _ wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _ True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _ False, SaveNativePictureFormat:=False, SaveFormsData:=False, _ SaveAsAOCELetter:=False [COLOR="seagreen"] 'Re-Open the document just saved[/COLOR] Documents.Open FileName:="h:\ISERIES REPORT.doc", ConfirmConversions:=False, ReadOnly:= _ False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _ "", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _ Format:=wdOpenFormatAuto, XMLTransform:="" Documents("h:\ISERIES REPORT.DOC").Activate [COLOR="seagreen"]'fourth start outlook attach document to new mail item and send it[/COLOR] Dim bStarted As Boolean Dim oOutlookApp As Outlook.Application Dim oItem As Outlook.MailItem On Error Resume Next If Len(ActiveDocument.Path) = 0 Then MsgBox "Document needs to be saved first" Exit Sub End If Set oOutlookApp = GetObject(, "Outlook.Application") If Err <> 0 Then Set oOutlookApp = CreateObject("Outlook.Application") bStarted = True End If Set oItem = oOutlookApp.CreateItem(olMailItem) With oItem .To = EMAIL2 .Subject = "ISERIES REPORT" .Attachments.Add Source:=ActiveDocument.FullName, Type:=olByValue, _ DisplayName:="Document as attachment" .Send End With [COLOR="seagreen"] 'end outlook[/COLOR] If bStarted Then oOutlookApp.Quit End If Set oItem = Nothing Set oOutlookApp = Nothing [COLOR="seagreen"] 'end word[/COLOR] Application.Visible = False Application.Quit[COLOR="SeaGreen"][/COLOR] End Sub
1. cpysplf to qtemp
2. ftp or cpytopcd to your document's drive (in the above example it is H: )
3. strpco
4. strpccmd 'h:as400rpt.doc'
Hope someone can use this
Comment