Outlook VBA code to convert attachments to pdf and save in a folder

[Derek_123]

Hi Guys

I am looking for outlook VBA code so that when the user selects multiple emails in his folder and run the macro then it should do the following:

1. If its word document then convert that to PDF and save it down in a shared folder.
2. If the attachment is PDF already then save it down in the same format in a shared folder.
3. If there is a message in the email body then save it down separately in PDF file in shared folder.

All the PDF files should be named automatically using the sendername/Date/subject line etc...

Is this achievable?

Thanks

[Derek_123]

The below code will convert email message to PDF . I need the code now to save attachments in Word format to PDF in a folder . Can anyone please help me in this?


Sub SaveEmailMessages()


Dim objOL As Object, MyOlSelection As Outlook.Selection
Dim MyOlNamespace As Outlook.NameSpace
Set MyOlNamespace = Application.GetNamespace("MAPI")
Set MyOlSelection = Application.ActiveExplorer.Selection


Call SaveAsPDFfile(MyOlSelection)


Set MyOlSelection = Nothing
Set objOL = Nothing
End Sub
Sub SaveAsPDFfile(pobjSelection As Outlook.Selection)


Dim objOL As Object, MyOlSelection As Outlook.Selection
Dim xMail As Outlook.MailItem
On Error Resume Next


' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set MyOlSelection = pobjSelection


Dim StrSaveFilename As String
'Make sure at least one item is selected
If MyOlSelection.Count = 0 Then
Response = MsgBox("Please select an email", vbExclamation, "Save as PDF")
Exit Sub
End If
' Now loop through all selected emails
For Each xMail In MyOlSelection
'Get all selected items
'Retrieve the selected item
'Set MySelectedItem = MyOlSelection.Item(1)

'Get the user's TempFolder to store the item in
Dim fso As Object, TmpFolder As Object
Set fso = CreateObject("scripting.filesystemobject")
Set tmpFileName = fso.GetSpecialFolder(2)

'construct the filename for the temp mht-file
strName = "www_howto-outlook_com"
tmpFileName = tmpFileName & "\" & strName & ".mht"

'Save the mht-file
xMail.SaveAs tmpFileName, olMHTML

'Create a Word object
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")

'Open the mht-file in Word without Word visible
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False)

'Define the SafeAs dialog
Dim dlgSaveAs As FileDialog
Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs)

'Determine the FilterIndex for saving as a pdf-file
'Get all the filters
Dim fdfs As FileDialogFilters
Dim fdf As FileDialogFilter
Set fdfs = dlgSaveAs.Filters


'Loop through the Filters and exit when "pdf" is found
Dim I As Integer
I = 0
For Each fdf In fdfs
I = I + 1
If InStr(1, fdf.Extensions, "pdf", vbTextCompare) > 0 Then
Exit For
End If
Next fdf

'Set the FilterIndex to pdf-files
dlgSaveAs.FilterIndex = I

'Get location of My Documents folder
Dim WshShell As Object
Dim SpecialPath As String
Set WshShell = CreateObject("WScript.Shell")
SpecialPath = WshShell.SpecialFolders(16)

'Construct a safe file name from the message subject
Dim msgFileName As String

msgFileName = xMail.Subject


Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Global = True
oRegEx.Pattern = "[\/:*?""<>|]"
msgFileName = Trim(oRegEx.Replace(msgFileName, ""))

'Set the initial location and file name for SaveAs dialog
Dim strCurrentFile As String
' dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName
StrSaveFilename = Trim(oRegEx.Replace(xMail.Subject, ""))
StrSaveFilename = Left(StrSaveFilename, 50)
StrSaveFilename = StrSaveFilename & Format(Time(), "hh-mm-ss") & ".pdf"
dlgSaveAs.InitialFileName = "U:\Aman\Martin Oulook\Word\" & StrSaveFilename
'xMail.SaveAsFile "U:\Aman\Martin Oulook\Word\" & StrSaveFilename

'Show the SaveAs dialog and save the message as pdf
If dlgSaveAs.Show = -1 Then
strCurrentFile = dlgSaveAs.SelectedItems(1)

'Verify if pdf is selected
If Right(strCurrentFile, 4) <> ".pdf" Then
Response = MsgBox("Sorry, only saving in the pdf-format is supported." & _
vbNewLine & vbNewLine & "Save as pdf instead?", vbInformation + vbOKCancel)
If Response = vbCancel Then
wrdDoc.Close
wrdApp.Quit
Exit Sub
ElseIf Response = vbOK Then
intPos = InStrRev(strCurrentFile, ".")
If intPos > 0 Then
strCurrentFile = Left(strCurrentFile, intPos - 1)
End If


strCurrentFile = strCurrentFile & ".pdf"
End If
End If

'Save as pdf
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strCurrentFile, ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False

End If
Set dlgSaveAs = Nothing

' close the document and Word
wrdDoc.Close
wrdApp.Quit
xMail.Categories = ""
xMail.FlagStatus = olFlagComplete
xMail.UnRead = False
xMail.Save
Next
'Cleanup
Set MyOlNamespace = Nothing
Set MyOlSelection = Nothing
Set MySelectedItem = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set oRegEx = Nothing


End Sub

[gmayor]

The following based on code I have posted before will save both the message and the word docx (or PDF) attachments with unique names in the named folder (which it will create if not present). I'll let you modify it to your own file naming preferences.


Option Explicit
Const strSaveFldr As String = "C:\Path\Attachments\"
Private wdApp As Object
Private wdDoc As Object

Sub ProcessMessage()
'An Outlook macro by Graham Mayor
Dim olMsg As Object
'On Error Resume Next
Set olMsg = ActiveExplorer.Selection.item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub

Sub ProcessFolder()
'An Outlook macro by Graham Mayor
Dim olNS As Outlook.NameSpace
Dim olMailFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMailItem As Object
On Error GoTo Err_Handler
Set olNS = GetNamespace("MAPI")
Set olMailFolder = olNS.PickFolder
Set olItems = olMailFolder.Items
For Each olMailItem In olItems
SaveAttachments olMailItem
DoEvents
Next olMailItem
Err_Handler:
Set olNS = Nothing
Set olMailFolder = Nothing
Set olItems = Nothing
Set olMailItem = Nothing
lbl_Exit:
Exit Sub
End Sub

Private Sub SaveAttachments(olItem As Object)
'Graham Mayor - http://www.gmayor.com - Last updated - 09 Oct 2018
Dim olAttach As Attachment
Dim strFName As String
Dim strExt As String
Dim j As Long
Dim olInsp As Inspector
Dim oRng As Object
Dim strTemp As String
Dim intPos As Integer
strTemp = Environ("TEMP") & "\"

If Not TypeName(olItem) = "MailItem" Then GoTo lbl_Exit

CreateFolders strSaveFldr

SaveAsPDFfile olItem

If olItem.Attachments.Count > 0 Then
For j = 1 To olItem.Attachments.Count
Set olAttach = olItem.Attachments(j)
Select Case LCase(Mid(olAttach.fileName, InStrRev(olAttach.fileName, Chr(46))))
Case ".docx", ".doc"
On Error Resume Next
olAttach.SaveAsFile strTemp & olAttach.fileName
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(strTemp & olAttach.fileName)
intPos = InStrRev(olAttach.fileName, ".")
strFName = Left(olAttach.fileName, intPos - 1)
strFName = strFName & ".pdf"
strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
strFName = FileNameUnique(strSaveFldr, strFName, strExt)
wdDoc.ExportAsFixedFormat OutputFilename:=strSaveFldr & strFName, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, _
From:=0, _
To:=0, _
item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=0, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
wdDoc.Close 0
'If bWordWasNotRunning = True Then wdApp.Quit
Case ".pdf"
strFName = olAttach.fileName
strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
strFName = FileNameUnique(strSaveFldr, strFName, strExt)
olAttach.SaveAsFile strSaveFldr & strFName
Case Else
End Select
Next j
olItem.Save
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Exit Sub
End Sub

Private Sub SaveAsPDFfile(olItem As Object)
Dim olNS As NameSpace
Dim tmpPath As String
Dim strFileName As String
Dim strName As String
Dim oRegex As Object

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0

Set olNS = Application.GetNamespace("MAPI")

'Get the user's TempFolder to store the temporary file
tmpPath = Environ("TEMP")

'construct the filename for the temp mht-file
strName = "email_temp.mht"
tmpPath = tmpPath & "\" & strName

'Save temporary file
olItem.SaveAs tmpPath, 10

'Open the temporary file in Word
Set wdDoc = wdApp.Documents.Open(fileName:=tmpPath, _
AddToRecentFiles:=False, _
Visible:=False, _
Format:=7)

'Create a file name from the message subject
strFileName = olItem.Subject
'Remove illegal filename characters
Set oRegex = CreateObject("vbscript.regexp")
oRegex.Global = True
oRegex.Pattern = "[\/:*?""<>|]"
strFileName = Trim(oRegex.Replace(strFileName, "")) & ".pdf"
strFileName = FileNameUnique(strSaveFldr, strFileName, "pdf")
strFileName = strSaveFldr & strFileName
wdDoc.ExportAsFixedFormat OutputFilename:= _
strFileName, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, _
From:=0, _
To:=0, _
item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=0, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False

' close the document
wdDoc.Close 0
lbl_Exit:
'Cleanup
Set olNS = Nothing
Set wdDoc = Nothing
Set oRegex = Nothing
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(strName As String) As Boolean
'An Outlook macro by Graham Mayor
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(strFolder As String) As Boolean
'An Outlook macro by Graham Mayor
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(strFolder)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim VPath As Variant
VPath = Split(strPath, "\")
strPath = VPath(0) & "\"
For lngPath = 1 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

[Derek_123]

Thanks so much Graham. How can we amend the code so that it will look into the active folder and only the selected emails will be saved down in PDF format in a folder? Thanks

[gmayor]

Use the following macro to call the process


Sub ProcessSelection()
Dim olMailItem As Object
'An Outlook macro by Graham Mayor
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
For Each olMailItem In Application.ActiveExplorer.Selection
If TypeName(olMailItem) = "MailItem" Then
SaveAttachments olMailItem
End If
DoEvents
Next olMailItem
Err_Handler:
Set olMailItem = Nothing
lbl_Exit:
Exit Sub
End Sub

[Derek_123]

Thanks Graham. I keep on getting an error "Outlook can not save this file because it's already open elsewhere(email_temp.mht).

[gmayor]

It should have been closed by the command

wdDoc.Close 0
If it hasn't it suggests that you had a crash somewhere and the lock file is still present for email_temp.mht
Take a look in the Temp folder (put %TEMP% in the address window of File Explorer to shortcut to the folder) and ensure you begin with email_temp.mht and its lock file deleted.

[Derek_123]

Thanks Graham , The code worked great . You are a star :)

[RaudelJr]

The following based on code I have posted before will save both the message and the word docx (or PDF) attachments with unique names in the named folder (which it will create if not present). I'll let you modify it to your own file naming preferences.


Hi, Is there a way to modify the code to merge the body of the email and all files regardless of type, word, excel, pdf, image extensions, txt, etc., into one PDF file that starts with the body first?

[Aussiebear]

@RaudelJr. This thread is over 5years old. Can you please start a new thread?

[RaudelJr]

This thread is over 5years old. Can you please start a new thread?
ok. I'll start a new thread.