ibmi-brunch-learn

Announcement

Collapse
No announcement yet.

Poor Mans convert my AS400 to Word & e-mail

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Poor Mans convert my AS400 to Word & e-mail

    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).


    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
    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
    Last edited by GLS400; July 6, 2006, 10:16 AM. Reason: changed title
    The problem with quotes on the internet is that it is hard to verify their authenticity.....Abraham Lincoln

  • #2
    Re: Poor Mans convert my AS400 to Word &amp; e-mail

    Very nice - Thanks for posting


    Jamie
    All my answers were extracted from the "Big Dummy's Guide to the As400"
    and I take no responsibility for any of them.

    www.code400.com

    Comment

    Working...
    X