Save Selected Outlook Emails as PDF

I have a large project for work where I need to save a large amount of RSS items in Outlook 2007 as PDF documents. I found a VBA macro which works great with a single selected RSS item, but it will not work is multiple items are selected. I am trying to change the coding to run through a For Loop of each selected item but I cannot figure it out. Can someone help with this? Below is the code in question. -Thanks

Sub SaveAsPDFfile()

'====================================================
' Description: Outlook macro to save a selected item in the pdf-format
' Requires Word 2007 SP2 or Word 2010
' Requires a reference to "Microsoft Word <version> Object Library"
' (version is 12.0 or 14.0)
' In VBA Editor; Tools-> References...
'
' author: Robert Sparnaaij
' website: http://www.howto-outlook.com/howto/saveaspdf.htm
'====================================================

    'Get all selected items
    Dim MyOlNamespace As Outlook.NameSpace
    Set MyOlNamespace = Application.GetNamespace("MAPI")
    Set MyOlSelection = Application.ActiveExplorer.Selection

    'Make sure at least one item is selected
    If MyOlSelection.Count <> 1 Then
       Response = MsgBox("Please select a single item", vbExclamation, "Save as PDF")
       Exit Sub
    End If
    
    '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
    MySelectedItem.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
    'File name is being saved with subject and the recieved date and time
    msgFileName = MySelectedItem.Subject & " " & MySelectedItem.ReceivedTime

    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
       
    '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
    
    'Cleanup
    Set MyOlNamespace = Nothing
    Set MyOlSelection = Nothing
    Set MySelectedItem = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set oRegEx = Nothing

End Sub

Open in new window

LVL 1
GileadITAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Bill PrewIT / Software Engineering ConsultantCommented:
Can't easily / quickly test this here, but I think this should be very close to doing the job.

Sub SaveAsPDFfile()

'====================================================
' Description: Outlook macro to save a selected item in the pdf-format
' Requires Word 2007 SP2 or Word 2010
' Requires a reference to "Microsoft Word <version> Object Library"
' (version is 12.0 or 14.0)
' In VBA Editor; Tools-> References...
'
' author: Robert Sparnaaij
' website: http://www.howto-outlook.com/howto/saveaspdf.htm
'====================================================

    'Get all selected items
    Dim MyOlNamespace As Outlook.NameSpace
    Dim MyOlSelection As Outlook.Selection 

    Set MyOlNamespace = Application.GetNamespace("MAPI")
    Set MyOlSelection = Application.ActiveExplorer.Selection

    'Make sure at least one item is selected
    If MyOlSelection.Count < 1 Then
       Response = MsgBox("Please select at least one item", vbExclamation, "Save as PDF")
       Exit Sub
    End If
    
    For i = 1 To MyOlSelection.Count 
    
        'Retrieve the selected item
        Set MySelectedItem = MyOlSelection.Item(i)
        
        '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
        MySelectedItem.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
        'File name is being saved with subject and the recieved date and time
        msgFileName = MySelectedItem.Subject & " " & MySelectedItem.ReceivedTime
    
        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
           
        '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
    
        Set wrdDoc = Nothing
        Set wrdApp = Nothing
        Set oRegEx = Nothing
    
    Next i 

    'Cleanup
    Set MyOlNamespace = Nothing
    Set MyOlSelection = Nothing
    Set MySelectedItem = Nothing

End Sub

Open in new window

~bp

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
GileadITAuthor Commented:
You're a genius! Made a minor change for a duplicate variable but overall perfect. Thanks so much for your help!
Bill PrewIT / Software Engineering ConsultantCommented:
Very welcome, glad that was helpful.

~bp
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.