Sub printSelection()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String, signature As String
Dim OutlApp As Object
Dim RngCopied As Range
Set RngCopied = Selection
' Here we define the pdf path and filename
Title = Range("B11") & " PROPOSAL" ' I only use this line to help fill out the email subject. It is not necessary
With ThisWorkbook
PdfFile = .Path & Application.PathSeparator & _
.Sheets("Sheet1").Range("B11")
End With
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.Zoom = False
End With
' Export activesheet as PDF to the current folder
With ActiveSheet
Range("A1:E100").Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile & " Proposal.pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End With
With ThisWorkbook
PdfFile = PdfFile & " Proposal.pdf"
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
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
.Display ' We need to display email first for signature to be added
.Subject = Title
.To = ActiveSheet.Range("E10").Value ' <-- Put email of the recipient here or use a cell value
.CC = "whoever@abc.com; copy@abc.com" ' <-- Put email of 'copy to' recipients here
.HTMLBody = "Thank you for the opportunity to bid on the painting for " & ActiveSheet.Range("B9").Value & ". " & " Please read our attached proposal in it's entirety to be sure of all inclusions, exclusions, and products proposed. Give us a call with any questions or concerns." & _
vbNewLine & vbNewLine & _
RangetoHTML(RngCopied) & _
"Thank you," & _
.HTMLBody ' Adds default outlook account signature
.Attachments.Add PdfFile
On Error Resume Next
' Return focus to Excel's window
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
' MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
' Try to quit Outlook if it was not previously open
If IsCreated Then OutlApp.Quit
' Release the memory of object variable
' Note: sometimes Outlook object can't be released from the memory
Set OutlApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
