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

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

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?

Code:

---

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

---

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.

Code:

---

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

---

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

Use the following macro to call the process

Code:

---

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

---

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

It should have been closed by the command

Code:

---

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.

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

Quote:

---

Originally Posted by 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.

---

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?

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

Quote:

---

Originally Posted by Aussiebear

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

---

ok. I'll start a new thread.