Public Function SaveMessageAsPDF(Subj As String, dtsent As Date)
'Changed Extract Attachment Code to change the flag status
'https://stackoverflow.com/questions/15531093/save-attachments-to-a-folder-and-rename-them
'https://www.experts-exchange.com/questions/28545501/Outlook-VBA-set-flag.html
'Refer to that function for notes and original links
'Combined with new code from Datanumen
'https://www.datanumen.com/blogs/auto-save-email-pdf-file-assigning-specific-color-category/
'Looked at other versions mentioned via https://www.access-programmers.co.uk/forums/threads/extracting-email-into-pdf-format.312163/
'such as website: https://www.howto-outlook.com/howto/saveaspdf.htm
'and https://www.extendoffice.com/documents/outlook/5036-batch-convert-outlook-emails-to-pdf.html#a2
'but found the one from DataNumen was able to be adapted to the existing code without having
'as many debug issues.
'20200615
Dim OlApp As Object 'Late
Dim Inbox As Object
Dim InboxItems As Object
Dim Mailobject As Object
Dim SubjectFilter As String
Dim FSO As Object
Dim TmpFolder As Object
Dim stOldName As String
Dim stNewName As String
Dim stFilePath As String
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
Set OlApp = GetObject(, "Outlook.Application") 'Outlook Running
If Err.Number <> 0 Then
Err.Clear
Set OlApp = CreateObject("Outlook.Application")
End If
'Doc Control Inbox
Set Inbox = OlApp.GetNamespace("Mapi").Folders("Shared Mailbox").Folders("Inbox") 'EDIT THIS TO YOUR INBOX LOCATION
Set InboxItems = Inbox.Items
SubjectFilter = (Subj) '("Fwd: Data and Message for Review") ' THIS IS WHERE YOU PLACE THE EMAIL SUBJECT FOR THE CODE TO FIND
If Not Inbox Is Nothing Then
For Each Mailobject In InboxItems
If InStr(1, Mailobject.Subject, SubjectFilter) > 0 And InStr(1, Mailobject.senton, dtsent) > 0 Then
stOldName = Mailobject.Subject
stNewName = stOldName
'Remove the unsupported characters in the email subject
stNewName = Replace(stNewName, "/", " ")
stNewName = Replace(stNewName, "\", " ")
stNewName = Replace(stNewName, ":", " ")
stNewName = Replace(stNewName, "?", " ")
stNewName = Replace(stNewName, Chr(34), " ")
stNewName = Replace(Format(Mailobject.ReceivedTime, "yyyymmdd") & " " & stNewName, " ", " ")
' DoCmd.OpenForm "frmEditText", , , , , acDialog, "Renaming file. " & _
"Please review and adjust accordingly if the text needs futher editing.|Rename File|NoTimer|" & stOldName & "|" & stNewName
' stNewName = gblText
'Firstly, save the email as a mht file in the temporary folder
stFilePath = FSO.GetSpecialFolder(2) & "\" & stNewName & ".mht"
Mailobject.SaveAs stFilePath, 5 'olMHTML
'Open the mht file in MS Word and export as a PDF file
Call PrintWordDoc(stFilePath, Environ("USERPROFILE") & "\Downloads\") 'EDIT THIS TO YOUR SAVE AS LOCATION
End If
Next
End If
Set OlApp = Nothing
Set Inbox = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
End Function
Sub PrintWordDoc(sfile As String, Optional sSavePath As String)
'Example of how to save a word doc to pdf
'
'---------------------------------------------------------------------------------------
' Procedure : PrintWordDoc
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Print/Save a Word document as a PDF in the specified directory
' Copyright : The following may be altered and reused as you wish so long as the
' copyright notice is left unchanged (including Author, Website and
' Copyright). It may not be sold/resold or reposted on other sites (links
' back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile : Full path, filename and extension of the word document to convert to a PDF
' sSavePath : Path where you would like the PDF saved to
'
' Usage:
' ~~~~~~
' Call PrintWordDoc("C:\Users\Dev\Documents\Test.doc", "C:\Users\Dev\Desktop\")
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2016-02-01 Initial Release
'---------------------------------------------------------------------------------------
'https://www.devhut.net/2016/02/01/vba-save-a-word-document-as-a-pdf/
'20181108
'Made sSavePath optional so that only need to provide if want to
'save the file to a different location. Only need to provide the
'file name if saving to the same location and program will use
'that path for saving to pdf
'20190503
Dim oApp As Object
Dim oDoc As Object
Dim sFileName As String
Dim bAppAlreadyOpen As Boolean
bAppAlreadyOpen = True
'Get an instance of word to work with
'See if Word is already running
On Error Resume Next
Set oApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
On Error GoTo Error_Handler
Set oApp = CreateObject("Word.Application")
bAppAlreadyOpen = False
End If
'Determine the Word doc filename without the path or extension
'sFileName = Right(sfile, Len(sfile) - InStrRev(sfile, "\"))
'sFileName = Left(sFileName, InStr(sFileName, ".") - 1)
'Above code caused problems when there are extra periods/dots in the file name
'so using the function instead
'20200616
sFileName = FileNameNoExt(sfile)
If Len(sSavePath) = 0 Then
sSavePath = FILEPATH(sfile)
End If
'Ensure the path has the final \
If Right(sSavePath, 1) <> "\" Then sSavePath = sSavePath & "\"
'Open the document
Set oDoc = oApp.Documents.Open(sfile)
'Print the document as a PDF
oDoc.ExportAsFixedFormat sSavePath & sFileName & ".pdf", 17
Error_Handler_Exit:
On Error Resume Next
'Close the Document
oDoc.Close False
Set oDoc = Nothing
If bAppAlreadyOpen = False Then oApp.Quit
Set oApp = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: PrintWordDoc" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Sub
Function FileNameNoExt(strPath As String) As String
'https://sqlaccxl.wordpress.com/2013/03/06/vba-function-to-extract-file-name-withwithout-file-extension-or-path-only/
Dim strTemp As String
strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
FileNameNoExt = Left$(strTemp, InStrRev(strTemp, ".") - 1)
End Function
'The following function returns the filename with the extension from the file's full path:
Function FileNameWithExt(strPath As String) As String
FileNameWithExt = Mid$(strPath, InStrRev(strPath, "\") + 1)
End Function
'the following function will get the path only (i.e. the folder) from the file's full path:
Function FILEPATH(strPath As String) As String
FILEPATH = Left$(strPath, InStrRev(strPath, "\"))
End Function
Function FileExtension(strPath As String) As String
'Get the extension of the file name
'https://social.msdn.microsoft.com/Forums/en-US/d112ca5d-2304-4707-bade-b27869c9359f/vba-excel-getting-file-extension?forum=isvvba
'20190129
FileExtension = Split(strPath, ".")(UBound(Split(strPath, ".")))
End Function
