none
How to save all Outlook emails with attachments as PDF via macro RRS feed

  • Question

  • Hi All,
    I am new to VBA and I hope the experts here could help me. I am trying to have all outlook emails and attachments (doc, xls, tif & etc) save as PDF in desktop. Below is the code I located. The macro only save all emails as PDF but not the attachments. The code currently only extract all attachments according to the attachments file format. I would like to have all the attachments to be saved as PDF too. Just FYI, I am using excel to run this macro.

    Sub SaveOutlookMessages()

    Dim olItem As Outlook.MailItem
    Dim fname As String
    Dim fPath As String
        fPath = ActiveSheet.Cells(2, 2).Value
    Dim atmt As Outlook.Attachment
    Dim sExt As String
    Dim dateFormat
        
    Dim O As Outlook.Application
    Set O = New Outlook.Application

    Dim ONS As Outlook.Namespace
    Set ONS = O.GetNamespace("MAPI")

    Dim oRecip As Outlook.Recipient
    Set oRecip = ONS.CreateRecipient("Mailboxes.Management@xxx.com")

    Dim MYFOL As Outlook.MAPIFolder
    Set MYFOL = ONS.GetSharedDefaultFolder(oRecip, olFolderInbox).Folders("Testing")

    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    For Each olItem In MYFOL.Items

            fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                    Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & _
                    olItem.SenderName & " - " & olItem.Subject
            fname = Replace(fname, Chr(58) & Chr(41), "")
            fname = Replace(fname, Chr(58) & Chr(40), "")
            fname = Replace(fname, Chr(34), "-")
            fname = Replace(fname, Chr(42), "-")
            fname = Replace(fname, Chr(47), "-")
            fname = Replace(fname, Chr(58), "-")
            fname = Replace(fname, Chr(60), "-")
            fname = Replace(fname, Chr(62), "-")
            fname = Replace(fname, Chr(63), "-")
            fname = Replace(fname, Chr(124), "-")
        
        Dim objInspector As Object
        Set objInspector = olItem.GetInspector
        Dim objDoc As Object
        Set objDoc = objInspector.WordEditor
        objDoc.ExportAsFixedFormat fPath & fname & ".pdf", 17
        
    For Each atmt In olItem.Attachments
        sExt = objFSO.GetExtensionName(atmt.Filename)

        If atmt.Size > 9000 Then
            dateFormat = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
            Format(olItem.ReceivedTime, "HH.MM") & Chr(32)
            atmt.SaveAsFile fPath & dateFormat & atmt.Filename
        End If
     Next atmt
     
        Next olItem

        Set objInspector = Nothing
        Set objDoc = Nothing
        Set olItem = Nothing
        
    End Sub 
    Wednesday, May 16, 2018 3:27 AM

All replies

  • Hello MJ-76,

    I think it is impossible to save all attachments as PDF. Both Outlook product and Outlook object model do not provide such function. It is not an unexpected result. For instance, if the attachment is a zip file, how could we print it?

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Thursday, May 17, 2018 6:22 AM
  • Hi Terry,

    Thanks for your advice.

    If I may double confirm is there any possibility to save those attachments which are in Word or Excel format as PDF?  

    Thursday, May 17, 2018 6:56 AM
  • Hello MJ-76,

    Outlook does not provide this function. You could try to create a Word/Excel application to open the saved Documents/Workbooks and then use ExportAsFixedFormat method to export the document/workbook as PDF.

    See below code for more information.

    Document.ExportAsFixedFormat

    Workbook.ExportAsFixedFormat

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, May 18, 2018 6:28 AM