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!

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?

Quote:

---

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.

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?

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.

Code:

---

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

---

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?

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.