VBA code to save incoming email attachments as PDF

[jlive24]

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!

[gmayor]

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?

[jlive24]

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.

[gmayor]

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?

[gmayor]

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

[jlive24]

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?

[gmayor]

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.