Consulting

Results 1 to 7 of 7

Thread: VBA code to save incoming email attachments as PDF

  1. #1
    VBAX Newbie
    Joined
    Jul 2018
    Posts
    3
    Location

    VBA code to save incoming email attachments as PDF

    Hi Everyone!

    Every day I receive emails that contain 4-5 jpg images, and then have to save each attachement to my computer, and combine them as pdfs in Adobe.

    I would like a macro that would, for every new email that arrives in my POA Review folder, automatically save all attachments and combine them as one PDF file. I would like the name of the PDF to always be "POA PDF", and would like to skip the "overwrite" msg box.

    If possible (but not necessary), it would be incredibly helpful if this macro could then either forward the original email with the newly attached combined pdf, or send a new email with the attached pdf to a specific email address.

    Thanks in advance and please let me know if I can answer questions!

  2. #2
    I have been looking at this dilemma for a couple of days, and as you have probably gathered it is not an easy fix. There are a couple of issues, notleast of which is converting the images to PDF from Outlook VBA, which doesn't have the ability to do that. Then there is the possibility of there being images in the body of the message e.g. if I use html format, my sig block includes a graphic, and that is treated as an attached image file, so if the messages are in HTML format there needs to be a means to identify which images are attachments.

    Grabbing the images and saving them to the hard drive is the easy bit - and sending them on is no real hardship either. I have posted code in this forum previously that could be adapted.

    The only practical approach that might work for you would be to import the images into a Word document and save that as PDF, which would kill two birds with one stone. Can you see any problems with that approach?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Newbie
    Joined
    Jul 2018
    Posts
    3
    Location
    I have been looking at this dilemma for a couple of days, and as you have probably gathered it is not an easy fix. There are a couple of issues, notleast of which is converting the images to PDF from Outlook VBA, which doesn't have the ability to do that. Then there is the possibility of there being images in the body of the message e.g. if I use html format, my sig block includes a graphic, and that is treated as an attached image file, so if the messages are in HTML format there needs to be a means to identify which images are attachments.

    Grabbing the images and saving them to the hard drive is the easy bit - and sending them on is no real hardship either. I have posted code in this forum previously that could be adapted.

    The only practical approach that might work for you would be to import the images into a Word document and save that as PDF, which would kill two birds with one stone. Can you see any problems with that approach?
    Hi gmayor, thank you so much for help.

    I do not see any issues with your approach. At a minimum, all I really NEED this macro to do is take any attachments on an email, and convert them to a single PDF file.

    For context, I currently receive emails that contain img attachments, and I need to look at these attachments to determine if the subject of the email is valid or deficient. I then need to save each one of the attachements as a single PDF, and then re-upload that PDF to a website.

    I have set up a bot in Slack that forwards the email I recieve to my team's Slack group. From there someone opens the email and does what I describe above. If possible (but again, I only really the macro to save these attachments as a single PDF), it would be helpful if the email I was having Slacked to my group already contained the combined PDF attachment.

    Please let me know if this is possible or if I can clarify anything.

  4. #4
    What are the filenames of the attachments like? Are the attachments always images? If not are you only interested in the images? Can you attach one of these e-mails to the mail link on the contacts page of my web site?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    OK The following will work, provided there are no images in the original message body and the conditions are as you have described them.

    If there are images in the message body then they need to be trapped (see my oprevious message). Change the message components at the top of the code to provide the covering message you want to send with the PDF. The process uses a temporary folder which is created first then deleted after use.

    The process will not send the messages unless you release the .Send command so you can test it. Select a message with the image attachments and run the main macro.

    If you have a problem comment out the line On Error Resume Next and run it again and see where it falls over.

    Option Explicit
    'Graham Mayor - http://www.gmayor.com - Last updated - 19 Jul 2018
    'Modify these items as appropriate
    
    Private Const strTo As String = "someone@somewhere.com"
    Private Const strSubject As String = "Attached file"
    Private Const strMsg As String = "This is the forwarded message body." & vbCr & _
            "This is another line." & vbCr & _
            "The default signature will be included"
    
    Sub ProcessAttachments()
    Dim strSaveFldr As String
    Dim olMsg As Outlook.MailItem
    Dim olFwd As Outlook.MailItem
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Object
    Dim wdApp As Object
    Dim oDoc As Object
    Dim oRng As Object
    Dim oNewRng As Object
    Dim strFileName As String
    Dim strPDFName As String
    Dim iCount As Integer
    Dim bWordWasNotRunning As Boolean
    Dim oFSO As Object
    
        strSaveFldr = Environ("TEMP") & "\TempSaveAttachments\"
        CreateFolders strSaveFldr
    
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.Item(1)
        SaveAttachments olMsg, strSaveFldr
        iCount = 0
        strFileName = Dir$(strSaveFldr & "*.jpg")
    
        While Len(strFileName) <> 0
            iCount = iCount + 1
            strFileName = Dir$()
        Wend
    
        If iCount > 0 Then
            bWordWasNotRunning = False
            Set wdApp = GetObject(, "Word.Application")
            If Err Then
                Set wdApp = CreateObject("Word.Application")
                bWordWasNotRunning = True
            End If
            wdApp.Visible = True
            Set oDoc = wdApp.Documents.Add
            strFileName = Dir$(strSaveFldr & "*.jpg")
            While Len(strFileName) <> 0
                Set oRng = oDoc.Range
                With oRng
                    .collapse 0
                    .InlineShapes.AddPicture _
                            fileName:=strSaveFldr & strFileName, _
                            LinkToFile:=False, _
                            SaveWithDocument:=True
                End With
                oDoc.Range.InsertParagraphAfter
                strFileName = Dir$()
            Wend
            oDoc.Range.Paragraphs.Last.Range.Delete
            strPDFName = strSaveFldr & "POA.pdf"
            oDoc.ExportAsFixedFormat OutputFilename:=strPDFName, _
                                     ExportFormat:=17, _
                                     OpenAfterExport:=False, _
                                     OptimizeFor:=0, _
                                     Range:=0, _
                                     From:=1, To:=1, _
                                     Item:=0, _
                                     IncludeDocProps:=True, _
                                     KeepIRM:=True, _
                                     CreateBookmarks:=1, _
                                     DocStructureTags:=True, _
                                     BitmapMissingFonts:=True, _
                                     UseISO19005_1:=False
        End If
        oDoc.Close 0
        If bWordWasNotRunning = True Then wdApp.Quit
        Set olFwd = CreateItem(olMailItem)
        With olFwd
            .To = strTo
            .Subject = strSubject
            .Attachments.Add strPDFName
            .Display
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oNewRng = wdDoc.Range
            oNewRng.collapse 1
            oNewRng.Text = strMsg
            '.Send 'remove apostrophe after testing
        End With
        Kill strSaveFldr & "*.jpg"
        Kill strPDFName
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        oFSO.DeleteFolder Environ("TEMP") & "\TempSaveAttachments"
    lbl_Exit:
        Set oFSO = Nothing
        Set olMsg = Nothing
        Set olFwd = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set wdApp = Nothing
        Set oDoc = Nothing
        Set oRng = Nothing
        Set oNewRng = Nothing
        Exit Sub
    End Sub
    
    Private Sub SaveAttachments(olItem As MailItem, strFldr As String)
    'Graham Mayor - http://www.gmayor.com - Last updated - 26 May 2017
    Dim olAttach As Attachment
    Dim strFname As String
    Dim strExt As String
    Dim j As Long
    
        On Error GoTo lbl_Exit
        If olItem.Attachments.Count > 0 Then
            For j = 1 To olItem.Attachments.Count
                Set olAttach = olItem.Attachments(j)
                'If Not olAttach.fileName Like "image*.*" Then
                strFname = olAttach.fileName
                olAttach.SaveAsFile strFldr & strFname
                'olAttach.Delete        'delete the attachment
                'End If
            Next j
            olItem.Save
        End If
    lbl_Exit:
        Set olAttach = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub
    
    Private Sub CreateFolders(strPath As String)
    'A Graham Mayor/Greg Maxey AddIn Utility Macro
    Dim oFSO As Object
    Dim lng_PathSep As Long
    Dim lng_PS As Long
        If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
        lng_PathSep = InStr(3, strPath, "\")
        If lng_PathSep = 0 Then GoTo lbl_Exit
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        Do
            lng_PS = lng_PathSep
            lng_PathSep = InStr(lng_PS + 1, strPath, "\")
            If lng_PathSep = 0 Then Exit Do
            If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
        Loop
        Do Until lng_PathSep = 0
            If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
                oFSO.CreateFolder Left(strPath, lng_PathSep)
            End If
            lng_PS = lng_PathSep
            lng_PathSep = InStr(lng_PS + 1, strPath, "\")
        Loop
    lbl_Exit:
        Set oFSO = Nothing
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  6. #6
    VBAX Newbie
    Joined
    Jul 2018
    Posts
    3
    Location
    gmayor, thank you so much! You have no idea how much I appreciate this.

    One last thing...is it possible to have this macro run automatically anytime a new email is added to my "POA Review" inbox folder? If so, would my laptop need to be open for this macro to run, or is there a way for it to happen at anytime?

  7. #7
    In theory a modified version of it could be run from a rule, but you would have to have your laptop open to allow the macro on it to run.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •