Saving Selected Emails as PDF and saving Attachments

Status
Not open for further replies.
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
 
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.
 
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:
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

  • 2017-12-22_095444_Re--DR4332---Portland---Checking-In_12_40_34.pdf
    107.1 KB · Views: 482
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.
 
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!
 
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!
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
Rupert Dragwater Background colors not saving in Outlook 365 Using Outlook 15
R Saving Emails and Attachments as .msg file Using Outlook 3
CWM550 Saving Data: Don't check certain folders Using Outlook 2
M Saving emails using Visual Basic - Selecting folder with msoFileDialogFolderPicker Outlook VBA and Custom Forms 6
D Outlook 2016 Outlook not saving Sent Items Using Outlook 4
I Error saving screenshots in a custom form in outlook 2016, outlook 365 - ok in outlook 2013, outlook 2010 Outlook VBA and Custom Forms 5
I Saving attachments from multiple emails and updating file name Outlook VBA and Custom Forms 0
M Adding Subject to this Link-Saving VBA Outlook VBA and Custom Forms 5
L Attachment saving and tracking - PLEASE help! Outlook VBA and Custom Forms 5
B Saving items under a folder Using Outlook 3
R Quick Access view in File Explorer when saving attachments Using Outlook 0
N Saving And Deleting Outlook Attachments with Unknown Error Message Outlook VBA and Custom Forms 1
V Saving attachment from outlook in My Documents Outlook VBA and Custom Forms 14
M Dialog called up multiple times when saving emails from macro Outlook VBA and Custom Forms 2
A saving attachement to folder named the same as rule name Outlook VBA and Custom Forms 0
T Saving all email to file folder in Windows Using Outlook 2
J Saving attachments from specific sender (phone number) to specific folder on hard drive Using Outlook 3
C Saving Outlook attachments and links to attachments with VBA Outlook VBA and Custom Forms 2
Kevin H Remotely saving emails Using Outlook 1
R Outlook 2010 Modify Style "Do not check spelling or grammar" not saving Outlook VBA and Custom Forms 0
R Outlook Office 365 not saving addresses Using Outlook 0
A Keep color categories when saving vCards Using Outlook 1
P Saving All Messages to the Hard Drive Using VBA Outlook VBA and Custom Forms 5
e_a_g_l_e_p_i question about saving my .pst so I can import it to my Outlook after I build a new system Using Outlook 10
S Editing an email with notes and saving it for record using Macro Outlook VBA and Custom Forms 3
O Saving Attachments to folder on disk and adding Initials to end of file name Outlook VBA and Custom Forms 9
J Outlook 2013 crashes saving VBA & clicking tools | digital signature Outlook VBA and Custom Forms 1
bifjamod Saving sent email to specific folder based on category with wildcard Outlook VBA and Custom Forms 1
N Saving .msg as sent item on send Outlook VBA and Custom Forms 1
erichamion Changes to meeting body not properly saving Outlook VBA and Custom Forms 4
A ItemAdd on Imap Folder get endless loop after saving item Using Outlook 5
T Saving Outlook 2010 email with attachments but read the email without Outlook Using Outlook 2
T From Field Blank when saving to folder other than Sent items Using Outlook 2
L Outlook DST (Daylight Saving Time) problem Using Outlook 0
F Using Outlook 2007 as an IMAP Mail Station Without Saving Data Locally Using Outlook 2
E Saving Changes To Edited E-Mail Received Message Using Outlook 0
D File Lock issue when saving message from Outlook to new folder Using Outlook 1
D Remove extension while saving attachments Using Outlook 1
K Printing & Saving Outlook Contacts Using Outlook 3
S Not saving attachments in the Sent Folder Using Outlook 2
S trouble with Outlook 2010 saving sent emails Using Outlook 2
D Saving outlook emails in html and attachments Using Outlook 4
W Default Saving a message as text Using Outlook 2
R Outlook 2007 QAT buttons not saving Using Outlook 2
C Exchange 2003 - Outlook 2003 - Calendar entries saving over each other Using Outlook 2
J Saving Published Outlook Form as msg Using Outlook 1
J Saving recent colors used for fonts in an email? Using Outlook 1
B How to choose which contacts folder to use when saving contacts? Using Outlook 1
J Saving Incoming & Outgoing Outlook 2010 Email Locally with IMAP Using Outlook 2
F Saving Imap Drafts Using Outlook 1

Similar threads

Back
Top