I have an Excel VBA script that creates a pdf
of the active worksheet and then sends an email with Outlook with the pdf
attached.
Then I have a rule in Outlook that runs a script on Emails that arrive in the Sent folder based on keywords in the subject that saves a pdf
copy of that email and/or it's attachments.
I would rather just have the Excel VBA script save that pdf
copy of the email that was just sent by the excel vba script. Otherwise, I would need to implement the Outlook "run as script" rule on every computer in our system.
How can I marry the Outlook script with the Excel script??
Excel Code to send email (works fine):
Sub AttachActiveSheetPDF_01()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' Define PDF filename
Title = Range("C218").Value
PdfFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Title & ".pdf"
' Exportactivesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = Title
.To = "" ' <-- Put email of the recipient here
.CC = "" ' <-- Put email of 'copy to' recipient here
.Body = "Hello," & vbLf & vbLf _
& "Please find attached a completed case review." & vbLf & vbLf _
& "Thank you," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
' Try to send
Application.Visible = True
.Display
End With
' Quit Outlook if it was not already open
If IsCreated Then OutlApp.Quit
' Release the memory of object variable
Set OutlApp = Nothing
End Sub
Outlook script to save pdf copy of email (works fine):
Function CleanFileName(strText As String) As String
Dim strStripChars As String
Dim intLen As Integer
Dim i As Integer
strStripChars = "/\[]:=," & Chr(34)
intLen = Len(strStripChars)
strText = Trim(strText)
For i = 1 To intLen
strText = Replace(strText, Mid(strStripChars, i, 1), "")
Next
CleanFileName = strText
End Function
Sub SaveAsPDF(MyMail As MailItem)
' ### Requires reference to Microsoft Scripting Runtime ###
' ### Requires reference to Microsoft Word Object Library ###
' --- In VBE click TOOLS > REFERENCES and check the boxes for both of the above ---
Dim fso As FileSystemObject
Dim strSubject As String
Dim strSaveName As String
Dim blnOverwrite As Boolean
Dim strFolderPath As String
Dim sendEmailAddr As String
Dim senderName As String
Dim looper As Integer
Dim plooper As Integer
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim oMail As Outlook.MailItem
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set oMail = olNS.GetItemFromID(strID)
' ### Get username portion of sender email address ###
sendEmailAddr = oMail.SenderEmailAddress
senderName = Left(sendEmailAddr, InStr(sendEmailAddr, "@") - 1)
' ### USER OPTIONS ###
blnOverwrite = False ' False = don't overwrite, True = do overwrite
' ### Path to save directory ###
bPath = "Z:\email\"
' ### Create Directory if it doesnt exist ###
If Dir(bPath, vbDirectory) = vbNullString Then
MkDir bPath
End If
' ### Get Email subject & set name to be saved as ###
emailSubject = CleanFileName(oMail.Subject)
saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & ".mht"
Set fso = CreateObject("Scripting.FileSystemObject")
' ### Increment filename if it already exists ###
If blnOverwrite = False Then
looper = 0
Do While fso.FileExists(bPath & saveName)
looper = looper + 1
saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & "_" & looper & ".mht"
Loop
Else
End If
' ### Save .mht file to create pdf from Word ###
oMail.SaveAs bPath & saveName, olMHTML
pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & ".pdf"
If fso.FileExists(pdfSave) Then
plooper = 0
Do While fso.FileExists(pdfSave)
plooper = plooper + 1
pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & "_" & plooper &
".pdf"
Loop
Else
End If
' ### Open Word to convert .mht file to PDF ###
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
' ### Open .mht file we just saved and export as PDF ###
Set wrdDoc = wrdApp.Documents.Open(FileName:=bPath & saveName, Visible:=True)
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
pdfSave, 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
' ### Delete .mht file ###
Kill bPath & saveName
' ### Uncomment this section to save attachments ###
'If oMail.Attachments.Count > 0 Then
' For Each atmt In oMail.Attachments
' atmtName = CleanFileName(atmt.FileName)
' atmtSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & atmtName
' atmt.SaveAsFile atmtSave
' Next
'End If
Set oMail = Nothing
Set olNS = Nothing
Set fso = Nothing
End Sub