• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

How to save e-mail as PDF with excel VBA

ThrottleWorks

Excel Ninja
Hi,

This code seems to be working for me. Still lot of editing is required. But I guess this will work.

Thanks for the help.

Code:
Option Explicit

'https://stackoverflow.com/questions/51655911/export-outlook-email-as-pdf
Sub Test_1()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = "Please wait, macro in progess !"
    Dim MyOutlook As Outlook.Application
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Dim FSO As Object, TmpFolder As Object
    Dim sName As String
    Dim ONS As Outlook.Namespace
    Dim MYFOLD As Outlook.Folder
    Dim OMAIL As Object
    Dim R As Long
    Dim ListSht As Worksheet
    Dim WshShell As Object
    Dim SpecialPath As String
    Dim strToSaveAs As String
    Dim J As Variant
    Dim TmpFileName As Variant
    Dim MyDocs As Variant
    Dim MapSht As Worksheet
    Dim TempLr As Long
    Set MapSht = ThisWorkbook.Worksheets("Mapping")
    On Error Resume Next
    Set wrdApp = CreateObject("Word.Application")
    Set MyOutlook = New Outlook.Application
    Set ONS = MyOutlook.GetNamespace("MAPI")
    Set ONS = MyOutlook.PickFolder
    Set MYFOLD = ONS.PickFolder
    Set OMAIL = MyOutlook.CreateItem(olMailItem)
    Set ListSht = ThisWorkbook.Worksheets("List")
    Dim MyCount As Long
    MyCount = 0
    '
    Dim objMail As Outlook.MailItem
    Dim strFileName As String
    Dim strWordDocument As String
    Dim objWordApp As Word.Application
    Dim objWordDocument As Word.Document
    Dim objDocumentRange As Word.Range
    '
    For Each OMAIL In MYFOLD.Items
        TempLr = MapSht.Cells(MapSht.Rows.Count, 3).End(xlUp).Row + 1
        MapSht.Cells(TempLr, 3).Value = TempLr - 1
        MapSht.Cells(TempLr, 4).Value = OMAIL.Subject
        MapSht.Cells(TempLr, 5) = OMAIL.ConversationID 'E Conversation ID
        MapSht.Cells(TempLr, 6) = OMAIL.ConversationTopic 'F Conversation Topic
        MapSht.Cells(TempLr, 7) = OMAIL.ReceivedTime 'G Received Time
        MapSht.Cells(TempLr, 8) = OMAIL.To 'H To
        MapSht.Cells(TempLr, 9) = OMAIL.Sender 'I From
        MapSht.Cells(TempLr, 10) = Now 'J Run time
        MyCount = MyCount + 1
        On Error Resume Next
        Set objMail = OMAIL
        strFileName = Replace(objMail.Subject, "/", " ")
        strFileName = Replace(strFileName, "\", " ")
        strFileName = Replace(strFileName, ":", "")
        strFileName = Replace(strFileName, "?", " ")
        strFileName = Replace(strFileName, Chr(34), " ")
        strWordDocument = Environ("Temp") & "\" & strFileName & "_" & MyCount & ".doc"
        objMail.SaveAs strWordDocument, olDoc
        Set objWordApp = CreateObject("Word.Application")
        Set objWordDocument = objWordApp.Documents.Open(strWordDocument)
        objWordApp.Visible = True
        If objWordApp.Selection.PageSetup.Orientation = wdOrientPortrait Then
            objWordApp.Selection.PageSetup.Orientation = wdOrientLandscape
        End If
        Dim MyFileName As String
        MyFileName = "H:\Sachin Sonawane\IIS Paper Saving Project\Save Emails here\"
        MyFileName = MyFileName & Left(OMAIL.Subject, 30) & "_" & MyCount & ".doc"
        MapSht.Cells(TempLr, 11) = MyFileName 'K
        objWordApp.ActiveDocument.SaveAs Filename:=MyFileName
        objWordApp.Quit
    Next OMAIL
    MyCount = 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    MsgBox "Done!"
End Sub
Sub Test_2()
    Dim wordFile As Object
    Dim MyString As String
    Dim wordDoc As Variant
    Dim MapSht As Worksheet
    Set MapSht = ThisWorkbook.Worksheets("Mapping")
    MyString = MapSht.Range("K2")
    Set wordFile = CreateObject("Word.Application")
    Set wordDoc = wordFile.Documents.Open(MyString)
    wordDoc.ExportAsFixedFormat Left(wordDoc.FullName, InStrRev(wordDoc.FullName, ".") - 1), 17
    wordDoc.Close
    wordFile.Quit
End Sub
 

ThrottleWorks

Excel Ninja
Hi @vletm sir, thanks for the help.
I was not able to convert e-mail to PDF hence trying to convert e-mail to word, then converting word to PDF. Now I am converting e-mails to PDF in one module then trying to convert these saved word documents to PDF.

I am aware this is not efficient but could proceed with earlier methods I tried.

Have a nice day ahead. :)
 

ThrottleWorks

Excel Ninja
Hi @vletm sir, thanks for the help.
My requirement is still the same.
Get e-mail to PDF.
However I was not able to do it with coding.

Hence, now I trying to convert e-mail to WORD and then WORD to PDF.
Have a nice day ahead. :)
 

ThrottleWorks

Excel Ninja
Hi @vletm sir, thanks for the help.
I checked my Outlook but could not see export to PDF option.

Also, I need to apply few rules before exporting e-mails hence this needs to be done by macro only.

Have a nice day ahead. :)
 

ThrottleWorks

Excel Ninja
Hi,

I am facing one issue with this code.
Code is not able to retrieve and export archive e-mail.

Can anyone please help in this.
How do I retrieve archive e-mail.
 
Top