• 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,

I need to export e-mail as PDF and save.
User has shared Outlook.

In one of the shared account he will have one particular folder.
This folder might have n number of e-mails, let us say 500.
From this 500, I need to export each e-mail as PDF and save.

One more condition is, if the subject line of e-mails is same.
I need to export latest e-mail for that subject line and save.

Is it possible. Can anyone please help me with this.
If you can help me with PDF part then also I will be very thankful.
 

ThrottleWorks

Excel Ninja
Hi @Deepak sir.
I am getting error at below line.
Could you please help if you get time.

Set MyOlNamespace = Application.GetNamespace("MAPI")

Object does not support this property method.
I have clicked on all the required references.
 

Kenneth Hobson

Active Member
If you want the body, then the WordEditor method might suffice. If you want the header to, converting those to msg and then pdf might be best. There are several msg to pdf converters out there.

Your code need then is to simply create the needed msg files. I would put them in a conversion folder. Then manually, run the conversion utility. I guess that might be cheaper than Acrobat. If you had Acrobat, it could likely all be done by code.
 

ThrottleWorks

Excel Ninja
Hi,

I am getting below mentioned error while running this code.
Can anyone please help me in this.

Run time error 462
The remote server machine does not exist or is unavailable

Bug is appearing at below line.
“wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName”

This line is in the second procedure of the attached code.
Procedure name is “Sub PDF_Working”.

Export_To_PDF is the main procedure.

This procedure calls PDF_Working and Sort_Conversation_ID.

We can skip Sort_Conversation_ID procedure.

In Export_To_PDF, procedure, user selects any Outlook folder.
Macro tries to export all the e-mails from this picked folder.
This procedure process each mail via loop.
For Each Item In olFolder.Items
For each e-mail main procedure call ‘PDF_Working’.
Converting and saving e-mail to PDF is done in this procedure.

Macro runs good for first instance of the loop.
Bug appears from the second instance. Not able to understand why this is happening.

Code:
Option Explicit
Public MacroBook As Workbook
Public MacroSht As Worksheet
Public MapSht As Worksheet
Public Item As Object
Public olFolder As outlook.MAPIFolder

Sub Export_To_PDF()
    Application.ScreenUpdating = False
    Application.StatusBar = "Macro in progress, please wait!"

Set MacroBook = ThisWorkbook
    Set MacroSht = MacroBook.Worksheets("MainPage")
    Set MapSht = MacroBook.Worksheets("Mapping")

Dim objNS As outlook.Namespace
    Dim oMail As outlook.MailItem
    Dim TempLr As Long

Set objNS = GetNamespace("MAPI")
    Set olFolder = objNS.PickFolder
    Set oMail = Item

For Each Item In olFolder.Items
        If TypeOf Item Is outlook.MailItem Then
            Application.StatusBar = Item.Subject & " " & Item.ReceivedTime
            Call PDF_Working
            TempLr = MapSht.Cells(MapSht.Rows.Count, 3).End(xlUp).Row + 1
            MapSht.Cells(TempLr, 3).FormulaR1C1 = "=ROW(R[-1]C[-2])" 'C Sr
            MapSht.Cells(TempLr, 4) = Item.Subject 'D Email Subject
            MapSht.Cells(TempLr, 5) = Item.ConversationID 'E Conversation ID
            MapSht.Cells(TempLr, 6) = Item.ConversationTopic 'F Conversation Topic
            MapSht.Cells(TempLr, 7) = Item.ReceivedTime 'G Received Time
            MapSht.Cells(TempLr, 8) = Item.To 'H To
            MapSht.Cells(TempLr, 9) = Item.Sender 'I From
            MapSht.Cells(TempLr, 10) = Now 'J Run time
        End If
    Next
    Call Sort_Conversation_ID
    MacroBook.Activate
    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox "Done !"
End Sub


Sub PDF_Working()
    Dim MySelectedItem As MailItem
    Dim FSO As Object
    Dim TmpFileName As String
    Dim StrName As String
    Dim wrdApp As Object
    Dim wrdDoc As Object
    Dim My_MHT_File As String
    Dim msgFileName As String
    Dim oRegEx As Object
    Dim strCurrentFile As String
    Dim Response As String
    Dim bStarted As Boolean
    Dim intPos As Long
    Dim fdfs As FileDialogFilters
    Dim dlgSaveAs As FileDialog
    Dim i As Long
    Dim fdf As FileDialogFilter
    Dim WshShell As Object
    Dim SpecialPath As String
    Dim MyOlNamespace As Namespace

    Set MyOlNamespace = outlook.Application.GetNamespace("MAPI") 'Mapi
    Set MySelectedItem = Item
    Set FSO = CreateObject("Scripting.FileSystemObject")

    TmpFileName = FSO.GetSpecialFolder(2)
    StrName = "email_temp.mht"

    On Error Resume Next
        Kill TmpFileName
    On Error GoTo 0

    Set MyOlNamespace = outlook.Application.GetNamespace("MAPI")
    Set MySelectedItem = Item
    Set FSO = CreateObject("Scripting.FileSystemObject")

    TmpFileName = FSO.GetSpecialFolder(2)
    StrName = "email_temp.mht"
    TmpFileName = TmpFileName & "\" & StrName
    MySelectedItem.SaveAs TmpFileName, 10

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

    Set wrdDoc = wrdApp.Documents.Open(Filename:=TmpFileName, Visible:=False, Format:=7)
    Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs)
    Set fdfs = dlgSaveAs.Filters

    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

    dlgSaveAs.FilterIndex = i

    Set WshShell = CreateObject("WScript.Shell")

    SpecialPath = WshShell.SpecialFolders(16)
    msgFileName = MySelectedItem.Subject

    Set oRegEx = CreateObject("vbscript.regexp")

    oRegEx.Global = True
    oRegEx.Pattern = "[\/:*?""<>|]"

    msgFileName = Trim(oRegEx.Replace(msgFileName, ""))

    dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName
    If dlgSaveAs.Show = -1 Then
    strCurrentFile = dlgSaveAs.SelectedItems(1)
    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 0
    If bStarted Then 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

    wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
    strCurrentFile, _
    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

    End If
    Set dlgSaveAs = Nothing

    wrdDoc.Close

    If bStarted Then wrdApp.Quit

    Set MyOlNamespace = Nothing
    Set MySelectedItem = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set oRegEx = Nothing
End Sub



Sub Sort_Conversation_ID()
    MapSht.Sort.SortFields.Clear
    MapSht.Sort.SortFields.Add Key:=Range("E2:E65000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    MapSht.Sort.SortFields.Add Key:=Range("G2:G65000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    MapSht.Sort.SortFields.Add Key:=Range("I2:I65000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With MapSht.Sort
        .SetRange Range("C1:J65000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
Last edited:

ThrottleWorks

Excel Ninja
Hi @vletm sir,

If we change To:=0 to To:=1 or any other number than 0
Then I am getting below bug
'The remote server machine does not exist or is unavailable’

Please note, even if we do not do any change to line ‘To:=0’
First fille is getting saved in the folder without any problem.

However I am facing issues in the code from the second instance of the loop.
This is happening with and without changing ‘To:=0’.
Also, even if the first email is getting saved, pictures are cropped in PDF.

I am afraid, even if this bug gets resolved, I might not be able to use this code.
Since the picture is getting cropped I can not use this code.
Can anyone please help me in this.
Please see attached file for code.



 

Attachments

Last edited:

vletm

Excel Ninja
ThrottleWorks
Did You read my reply?
Did You check that syntax? ... no?
Did You read about range? ... no?
Did You set range as ExportFromTo? ... no?
Are all other parameters as written in syntax?

... and of course,
I cannot test that code at all!
But that was one case,
which not match with syntax.
 

ThrottleWorks

Excel Ninja
Hi,

I am using below mentioned code.

This code is exporting only first e-mail from the loop.

I am able to generate summary for all the e-mails from the folder.

Even MHT files are getting saved correctly.

For example, I have 8 e-mails in the folder.

My list is getting updated for all the 8 e-mails.

8 MHT files are saved. However only first PDF is getting saved.

There is no bug, but files are not getting exported.

Can anyone please help me in this.

Code:
Option Explicit
'https://stackoverflow.com/questions/51655911/export-outlook-email-as-pdf
Sub OutLook_Export_2()
    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.GetDefaultFolder(olFolderInbox)
    Set MYFOLD = ONS.PickFolder
    Set OMAIL = MyOutlook.CreateItem(olMailItem)
    Set ListSht = ThisWorkbook.Worksheets("List")
    Dim MyCount As Long
    MyCount = 0
    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
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set TmpFileName = MapSht.Range("A2")
        sName = Left(OMAIL.Subject, 60) & "_" & MyCount
        ReplaceCharsForFileName sName, "-"
        TmpFileName = TmpFileName & "\" & sName & ".mht"
        OMAIL.SaveAs TmpFileName, olMHTML
        MapSht.Cells(TempLr, 11) = TmpFileName
        Set wrdDoc = wrdApp.Documents.Open(Filename:=TmpFileName, Visible:=True)
        Set WshShell = CreateObject("WScript.Shell")
        MyDocs = MapSht.Range("A2").Value
        strToSaveAs = MyDocs & "\" & sName & ".pdf"
        MapSht.Cells(TempLr, 12) = strToSaveAs
        If FSO.FileExists(strToSaveAs) Then
            sName = sName & Format(Now, "hhmmss")
            strToSaveAs = MyDocs & "\" & sName & ".pdf"
        End If
        wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        strToSaveAs, 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
        wrdDoc.Close
        wrdApp.Quit
        Set wrdDoc = Nothing
        Set wrdApp = Nothing
        Set WshShell = Nothing
    Next OMAIL
    MyCount = 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    MsgBox "Done!"
End Sub
'This function removes invalid and other characters from file names
Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
    sName = Replace(sName, "/", sChr)
    sName = Replace(sName, "\", sChr)
    sName = Replace(sName, ":", sChr)
    sName = Replace(sName, "?", sChr)
    sName = Replace(sName, Chr(34), sChr)
    sName = Replace(sName, "<", sChr)
    sName = Replace(sName, ">", sChr)
    sName = Replace(sName, "|", sChr)
    sName = Replace(sName, "&", sChr)
    sName = Replace(sName, "%", sChr)
    sName = Replace(sName, "*", sChr)
    sName = Replace(sName, " ", sChr)
    sName = Replace(sName, "{", sChr)
    sName = Replace(sName, "[", sChr)
    sName = Replace(sName, "]", sChr)
    sName = Replace(sName, "}", sChr)
    sName = Replace(sName, "!", sChr)
End Sub
 

Attachments

Last edited:

ThrottleWorks

Excel Ninja
Hi @vletm sir, thanks for the help.
I am getting unique values for all the 8 times.
Infact all the MHT files are saved with correct names.

Have a nice day ahead. :)
 
Last edited:

ThrottleWorks

Excel Ninja
Hi,
I am trying to export word document to pdf with below code.
The code runs without any error but file is not saved at the path.

I tried halting this code after word file is generated and recorded file exporting task in word file.

Copied same part and trying in excel but no success. Can anyone help me in this please.
I guess I am facing problem at "ChangeFileOpenDirectory "C:\Users\abc123\Desktop\"
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
"C:\Users\abc123\Desktop\Test .pdf"' this part.

Code:
Option Explicit

'https://stackoverflow.com/questions/51655911/export-outlook-email-as-pdf
Sub OutLook_Export_2()
    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
    Call MyFolderPath
    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.GetDefaultFolder(olFolderInbox)
    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 & ".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 = Left(OMAIL.Subject, 30)
        ChangeFileOpenDirectory "C:\Users\abc123\Desktop\"
        ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        "C:\Users\abc123\Desktop\Test .pdf" _
        , ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
        objWordApp.Quit
    Next OMAIL
    MyCount = 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    MsgBox "Done!"
End Sub
 

Attachments

vletm

Excel Ninja
ThrottleWorks
1) As this seems to be 'now' Cross-posted, it would be good to let us know that.
2) Have You tested WITHOUT those spaces Test .pdf"?
Screenshot 2019-02-11 at 18.04.37.png
3) Your previous version had always different name for PDF.
Now, You have FIXED filename for PDF.
So, so how many different PDFs would create ... if You use FIXED filename?
 

ThrottleWorks

Excel Ninja
1) Hi @vletm sir, no, it is not cross posted by me.
Else I would have informed in original post.

2) Yes, have tested with original name, but facing same issue.

3) Fixed file name is for testing purpose.
Original macro has real path and real file name but macro is not saving even single file.

Thanks for the help. Have a nice day ahead. :)
 

vletm

Excel Ninja
ThrottleWorks
... after modify those
... many times helps if Quit Excel
and one minute later Open it again.
Quit means Quit (not close)!

Next ...
Why do You have 'all possible' parameters?
Could You even try to use 'only' next? (( to Filename, You should use Yours ))
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=mystr, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
After those ... add needed ONE-by-ONE.
 
Last edited:
Top