Sub AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String, Esub As String
Dim OutlApp As Object
Dim sendTime As String
sendTime = Now()
sendTime = Format(sendTime, "yyyymmm-dd, hh:mm:ss")
' ### Define email subject and PDF path & filename ###
Title = Range("C218").Value
Esub = "Completed Case Review " & sendTime
PdfFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Title & ".pdf"
' ### Export ActiveSheet to PDF ###
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' ### Open Outlook ###
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application") '<-- If open, use it
If Err Then
Set OutlApp = CreateObject("Outlook.Application") '<-- If not, open it
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' ### Prepare email and attach pdf created above ###
With OutlApp.CreateItem(0)
.Subject = Esub
.To = "" ' <-- Put email of the recipient here
.CC = ""
.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 True '<-- True forces code to wait for user to send email. Or just automate what the user is doing and change this to .Send
End With
Application.Wait (Now + TimeValue("0:00:05")) '<-- 5 second delay allows email to finish sending
' ### Search Sent Mail folder for emails with same timestamp in subject ###
Dim olNameSpace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Object
Set olNameSpace = OutlApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderSentMail)
Set olItem = OutlApp.CreateItem(olMailItem)
For Each olItem In olFolder.Items
If olItem.Class = olMail Then
If olItem.Subject = Esub Then '<-- check for match
SaveAsPDF olItem '< - Call SaveAsPDF code
End If
End If
Next
If IsCreated Then OutlApp.Quit '<-- Quit Outlook if it was not already open
Set OutlApp = Nothing '<-- Release the memory of object variable
' ### Delete our temp pdf file if not needed anymore ###
Kill PdfFile
End Sub
Sub SaveAsPDF(MyMail As MailItem)
' ### Requires reference to Microsoft Scripting Runtime ###
' ### Requires reference to Microsoft Outlook Object Library ###
' ### Requires reference to Microsoft Word Object Library ###
' --- In VBE click TOOLS > REFERENCES and check the boxes for all of the above ---
Dim fso As FileSystemObject
Dim emailSubject As String
Dim saveName As String
Dim blnOverwrite As Boolean
Dim bPath As String
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 App = CreateObject("Outlook.Application")
Set olNS = App.GetNamespace("MAPI")
Set oMail = olNS.GetItemFromID(strID)
' ### Get username portion of sender's email address ###
sendEmailAddr = oMail.SenderEmailAddress
senderName = Left(sendEmailAddr, InStr(sendEmailAddr, "@") - 1)
' ### USER OPTIONS ###
blnOverwrite = False ' False = don't overwrite, True = do overwrite
' ### Path to directory for saving pdf copy of sent email ###
bPath = "Z:\Emails - East\2016\"
' ### 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 = emailSubject & ".mht"
Set fso = CreateObject("Scripting.FileSystemObject")
' ### Save .mht file to create pdf from within Word ###
oMail.SaveAs bPath & saveName, olMHTML
pdfSave = bPath & emailSubject & "_" & senderName & "_" & ".pdf"
' ### 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 our temp .mht file ###
Kill bPath & saveName
' ### Uncomment this section to save attachments also ###
'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
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
