Saving Selected Emails as PDF and saving Attachments

Outlook version
Outlook 2016 64 bit
Email Account
Office 365 Exchange
Greetings,

I have inserted code below that, frustratingly, used to work. I need to highlight multiple emails and have the email save as a PDF and the attachments save with similar names for government logging purposes. The code below used to function. The problem was that within 1,000's of emails the naming convention wasn't specific enough and it was throwing errors. These errors would force me to hit "Next" to continue and with so many emails each day, that manual addition really slowed things down. I began adding date and time elements to the names to differentiate but I have seemed to go to far. Somehow, the name of each email pdf is iterating properly through my selected emails, but the email itself is not. Thus, there might be 15 different files with different names, but somehow it's the same email. I'm not sure what I did wrong but I would be most grateful for any help you could provide.

Also, I've used a number of "kills" to try to, again, eliminate the errors that cause the process to stop. If you think those are at fault please advise.

Regards!
David

Code:
Sub SaveMessageAsPDF()
    
    Dim Selection As Selection
    Dim obj As Object
    Dim Item As MailItem
    Dim atmt As Attachment
      
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    Set Selection = Application.ActiveExplorer.Selection

    DisplayAlerts = False
   
For Each obj In Selection
    Set Item = obj
   
    Dim FSO As Object, TmpFolder As Object
    Dim sName As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set tmpfilename = FSO.GetSpecialFolder(2)
    On Error Resume Next
   
    sName = Item.Subject
   
   
    ReplaceCharsForFileName sName, "-"
    tmpfilename = "c:\email\temp" & "\" & sName & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second(Now) & ".mht"
   
   
    Kill tmpfilename
   
   
    Item.SaveAs tmpfilename, olMHTML
   
   
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpfilename, Visible:=True)
    Dim WshShell As Object
    Dim SpecialPath As String
    Dim strToSaveAs As String
    Set WshShell = CreateObject("WScript.Shell")
    MyDocs = WshShell.SpecialFolders(16)
      
  
   If Len(Day(obj.ReceivedTime)) = 2 And Len(Month(obj.ReceivedTime)) = 2 Then
        sName = Year(obj.ReceivedTime) & "-" & Month(obj.ReceivedTime) & "-" & Day(obj.ReceivedTime) & "_" & Format(obj.ReceivedTime, "hhmmss") & "_" & sName
  
   ElseIf Len(Day(obj.ReceivedTime)) = 1 And Len(Month(obj.ReceivedTime)) = 2 Then
    
  
        sName = Year(obj.ReceivedTime) & "-" & Month(obj.ReceivedTime) & "-0" & Day(obj.ReceivedTime) & "_" & Format(obj.ReceivedTime, "hhmmss") & "_" & sName
  
   ElseIf Len(Day(obj.ReceivedTime)) = 1 And Len(Month(obj.ReceivedTime)) = 1 Then
        sName = Year(obj.ReceivedTime) & "-0" & Month(obj.ReceivedTime) & "-0" & Day(obj.ReceivedTime) & "_" & Format(obj.ReceivedTime, "hhmmss") & "_" & sName
  
   Else
        sName = Year(obj.ReceivedTime) & "-0" & Month(obj.ReceivedTime) & "-" & Day(obj.ReceivedTime) & "_" & Format(obj.ReceivedTime, "hhmmss") & "_" & sName

   End If
    
  
   strToSaveAs = "c:\email\" & sName & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second(Now) & ".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
   
    Kill "c:\email\temp\" & sName
   
   
If obj.Attachments.Count > 0 Then
    For Each atmt In obj.Attachments
        atmtName = atmt.FileName
        atmtSave = "c:\email\" & sName & "_" & atmtName
        atmt.SaveAsFile atmtSave
       Next
End If


Next obj
    wrdDoc.Close
    wrdApp.Quit
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set WshShell = Nothing
    Set obj = Nothing
    Set Selection = Nothing
    Set Item = Nothing
DisplayAlerts = True
MsgBox "Export Complete"

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
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
is it dying on duplicate filename? I would add a debug.print after each time you set a file or path name - look at them in the Immediate window and see if you get the expected result.


This gets the message subject:
sName = Item.Subject
ReplaceCharsForFileName sName, "-"
tmpfilename = "c:\email\temp" & "\" & sName & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second(Now) & ".mht"
is using the current time - so everytime you run it, the time changes and create a new file.
path & name should be c:\email\temp\subject_10_23_55.mht

then you delete the file and resave - but because you use hhmmss in the name, there shouldn't be anything to delete.
Kill tmpfilename
Item.SaveAs tmpfilename, olMHTML


Next you add the received time to sName (subject), resulting in recieved_Subject format, which is used in this:
strToSaveAs = "c:\email\" & sName & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second(Now) & ".pdf"
this gives you c:\email\recieved_Subject__10_23_55.pdf

you should have two files - c:\email\temp\subject_10_23_55.mht and c:\email\recieved_Subject__10_23_55.pdf (or potentially, c:\email\recieved_Subject__10_23_56.pdf because you are setting the time as you use it)

Kill "c:\email\temp\" & sName deletes the subject name file, but the file has the time too - you should kill tmpfilename here.

you are saving the pdf as "c:\email\" & sName & "_" & atmtName, which is c:\email\recieved_subject_attachmentname
if you want c:\email\recieved_subject_attachmentname to be c:\email\recieved_Subject__10_23_55_attachmentname, you need to set the times when you set the sname.


sName = Item.Subject & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second(Now)

ReplaceCharsForFileName sName, "-"
tmpfilename = "c:\email\temp" & "\" & sName & ".mht" (I'd put the \ at the end of temp: "c:\email\temp\" & sName & ".mht")
this gives you c:\email\temp\subject_10_23_55.mht

this line would be
strToSaveAs = "c:\email\" & sName & ".pdf"
this gives you c:\email\recieved_Subject__10_23_55.pdf
the attachment would be
c:\email\recieved_Subject__10_23_55_attachmentname.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
when i use your macro as is, with debug.prints added after each string, I get these results (and files in the temp folder)
sName FW--We-are-making-progress
tempfilename c:\email\temp\FW--We-are-making-progress_10_45_21.mht
sName 2016-09-18_180834_FW--We-are-making-progress
strToSaveAs c:\email\2016-09-18_180834_FW--We-are-making-progress_10_45_21.pdf
atmtSave c:\email\2016-09-18_180834_FW--We-are-making-progress_TEST To Diane.xlsm


if i move these two lines to the end, the temp folder is empty after running it. (ETA: this worked once, now fails. :( But with the time on it, there shouldn't be dupes. )
 
Last edited:
Outlook version
Outlook 2016 64 bit
Email Account
Office 365 Exchange
when i use your macro as is, with debug.prints added after each string, I get these results (and files in the temp folder)
sName FW--We-are-making-progress
tempfilename c:\email\temp\FW--We-are-making-progress_10_45_21.mht
sName 2016-09-18_180834_FW--We-are-making-progress
strToSaveAs c:\email\2016-09-18_180834_FW--We-are-making-progress_10_45_21.pdf
atmtSave c:\email\2016-09-18_180834_FW--We-are-making-progress_TEST To Diane.xlsm


if i move these two lines to the end, the temp folder is empty after running it. (ETA: this worked once, now fails. :( But with the time on it, there shouldn't be dupes. )
Hi Diane!

Thanks so much, again, for your help! The code you helped me improve does indeed export and I now get no dupe warnings when I run the emails. I do, however, get emails saved as PDF's with the wrong name. I've attached an example. There are roughly 30 emails in the collection that all have different names but when you open them you can see that it's this email repeated in each file. In my not so knowledgeable opinion, it seems that the filename is iterating more than the email the code is actually saving. I"m not sure what aspect of the code is still doing this, I don't see anything obvious when I examine. The problem vis-a-vis debugging is that this doesn't always occur. So I could have it iterate through each of the 2,000 emails and there is no telling when I'd get to the point where it starts to error. I've attached a copy of one of the bad pdfs and also the code (original + edits you recommended). Thanks so much Diane!

Code:
Sub SaveMessageAsPDF()
   
    Dim Selection As Selection
    Dim obj As Object
    Dim Item As MailItem
    Dim atmt As Attachment
     
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    Set Selection = Application.ActiveExplorer.Selection
    DisplayAlerts = False
   
For Each obj In Selection
    Set Item = obj
   
    Dim FSO As Object, TmpFolder As Object
    Dim sName As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set tmpfilename = FSO.GetSpecialFolder(2)
    On Error Resume Next
   
    'sName = Item.Subject
   ' ReplaceCharsForFileName sName, "-"
   ' tmpfilename = "c:\email\temp" & "\" & sName & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second(Now) & ".mht"
   
    sName = Item.Subject & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second(Now)
    ReplaceCharsForFileName sName, "-"
    tmpfilename = "c:\email\temp" & "\" & sName & ".mht"
   
   
    Item.SaveAs tmpfilename, olMHTML
   
   
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpfilename, Visible:=True)
    Dim WshShell As Object
    Dim SpecialPath As String
    Dim strToSaveAs As String
    Set WshShell = CreateObject("WScript.Shell")
    MyDocs = WshShell.SpecialFolders(16)
     
 
   If Len(Day(obj.ReceivedTime)) = 2 And Len(Month(obj.ReceivedTime)) = 2 Then
        sName = Year(obj.ReceivedTime) & "-" & Month(obj.ReceivedTime) & "-" & Day(obj.ReceivedTime) & "_" & Format(obj.ReceivedTime, "hhmmss") & "_" & sName
 
   ElseIf Len(Day(obj.ReceivedTime)) = 1 And Len(Month(obj.ReceivedTime)) = 2 Then
   
 
        sName = Year(obj.ReceivedTime) & "-" & Month(obj.ReceivedTime) & "-0" & Day(obj.ReceivedTime) & "_" & Format(obj.ReceivedTime, "hhmmss") & "_" & sName
 
   ElseIf Len(Day(obj.ReceivedTime)) = 1 And Len(Month(obj.ReceivedTime)) = 1 Then
        sName = Year(obj.ReceivedTime) & "-0" & Month(obj.ReceivedTime) & "-0" & Day(obj.ReceivedTime) & "_" & Format(obj.ReceivedTime, "hhmmss") & "_" & sName
 
   Else
        sName = Year(obj.ReceivedTime) & "-0" & Month(obj.ReceivedTime) & "-" & Day(obj.ReceivedTime) & "_" & Format(obj.ReceivedTime, "hhmmss") & "_" & sName
   End If
   
 
   'strToSaveAs = "c:\email\" & sName & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second(Now) & ".pdf"
   strToSaveAs = "c:\email\" & 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
   
    Kill "c:\email\temp\" & sName
   
   
If obj.Attachments.Count > 0 Then
    For Each atmt In obj.Attachments
        atmtName = atmt.FileName
        atmtSave = "c:\email\" & sName & "_" & atmtName
        atmt.SaveAsFile atmtSave
       Next
End If
Next obj
    wrdDoc.Close
    wrdApp.Quit
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set WshShell = Nothing
    Set obj = Nothing
    Set Selection = Nothing
    Set Item = Nothing
DisplayAlerts = True
MsgBox "Export Complete"
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

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
There are roughly 30 emails in the collection that all have different names but when you open them you can see that it's this email repeated in each file.
That should mean the loop is not working correctly, but the code looks good.

Its setting item to be the obj at the top and item is used for the email (and its working, because the subject is correct), but obj is used for the attachment, so try changing item to obj:
Item.SaveAs tmpfilename, olMHTML
to
obj.SaveAs tmpfilename, olMHTML

you can change the item. in the item.subject to obj.subject too.
 
Outlook version
Outlook 2016 64 bit
Email Account
Office 365 Exchange
That should mean the loop is not working correctly, but the code looks good.

Its setting item to be the obj at the top and item is used for the email (and its working, because the subject is correct), but obj is used for the attachment, so try changing item to obj:
Item.SaveAs tmpfilename, olMHTML
to
obj.SaveAs tmpfilename, olMHTML

you can change the item. in the item.subject to obj.subject too.
Thanks Diane, trying that now. If that doesn't work I'll try to get an old priest and a young priest to fix my computer... :) I've done a little research for some professional 3rd party solutions. I hate to quite like that but it does have the added advantage of combining the exported emails and attachments into a single PDF which I'm given to understand is difficult if not impossible from Outlook VBA. Thanks again, I'll let you know how it goes!
 
Outlook version
Outlook 2016 64 bit
Email Account
Office 365 Exchange
That should mean the loop is not working correctly, but the code looks good.

Its setting item to be the obj at the top and item is used for the email (and its working, because the subject is correct), but obj is used for the attachment, so try changing item to obj:
Item.SaveAs tmpfilename, olMHTML
to
obj.SaveAs tmpfilename, olMHTML

you can change the item. in the item.subject to obj.subject too

That should mean the loop is not working correctly, but the code looks good.

Its setting item to be the obj at the top and item is used for the email (and its working, because the subject is correct), but obj is used for the attachment, so try changing item to obj:
Item.SaveAs tmpfilename, olMHTML
to
obj.SaveAs tmpfilename, olMHTML

you can change the item. in the item.subject to obj.subject too.
No good. Many came out correctly but there were huge sections where a specific email would repeat 50+ times. For some reason, the problem seems worse at the earliest emails and it never seems to happen in small samples, always larger groups. May have to look at third party solution. I appreciate all the help Diane. Always open to ideas if you have them. Thanks!
 

Top