david_Johnson_CR
Member
- 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
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
But with the time on it, there shouldn't be dupes. )
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!
