I'm using VBA code to convert the selection into PDF and mail through Outlook.
How do I point the StrTo, StrSubject and StrBody below to a specific cell and the file name should also be from a specific cell value.
The values are updated in cells and some values are based on a formula. The code I use is below.
Function RDB_Create_PDF(Source As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim Fname As Variant
If FixedFilePathName = "" Then
'Open the GetSaveAsFilename dialog to enter a file name for the pdf
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
Title:="Create PDF")
'If you cancel this dialog Exit the function
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If
'If OverwriteIfFileExist = False we test if the PDF
'already exist in the folder and Exit the function if that is True
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
'Now the file name is correct we Publish to PDF
On Error Resume Next
Source.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
'If Publish is Ok the function will return the file name
If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
End Function
Function RDB_Mail_PDF_Outlook(FileNamePDF As String, StrTo As Range, _
StrCC As Range, StrBCC As Range, StrSubject As Range, _
Signature As Boolean, Send As Boolean, StrBody As Range)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
If Signature = True Then .Display
.To = StrTo
.CC = StrCC
.BCC = StrBCC
.Subject = StrSubject
.HTMLBody = StrBody & "<br>"& .HTMLBody
.Attachments.Add FileNamePDF
If Send = True Then
.Send
Else
.Display
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Function Create_PDF_Sheet_Level_Names(NamedRange As String, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
'This function will create a PDF with every sheet with
'a sheet level name variable <NamedRange> in it
Dim FileFormatstr As String
Dim Fname As Variant
Dim Ash As Worksheet
Dim sh As Worksheet
Dim ShArr() As String
Dim s As Long
Dim SheetLevelName As Name
'We fill the Array with sheets with the sheet level name variable
For Each sh In ActiveWorkbook.Worksheets
If sh.Visible = -1 Then
Set SheetLevelName = Nothing
On Error Resume Next
Set SheetLevelName = sh.Names(NamedRange)
On Error GoTo 0
If Not SheetLevelName Is Nothing Then
s = s + 1
ReDim Preserve ShArr(1 To s)
ShArr(s) = sh.Name
End If
End If
Next sh
'We exit the function If there are no sheets with
'a sheet level name variable named <NamedRange>
If s = 0 Then Exit Function
If FixedFilePathName = "" Then
'Open the GetSaveAsFilename dialog to enter a file name for the pdf
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
Title:="Create PDF")
'If you cancel this dialog Exit the function
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If
'If OverwriteIfFileExist = False we test if the PDF
'already exist in the folder and Exit the function if that is True
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
'Remember the ActiveSheet
Set Ash = ActiveSheet
'Select the sheets with the sheet level name in it
Sheets(ShArr).Select
'Now the file name is correct we Publish to PDF
On Error Resume Next
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
'If Publish is Ok the function will return the file name
If Dir(Fname) <> "" Then
Create_PDF_Sheet_Level_Names = Fname
End If
Ash.Select
Application.ScreenUpdating = True
Application.EnableEvents = True
Sub RDB_Selection_Range_To_PDF_And_Create_Mail()
Dim FileName As String
If ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "There is more then one sheet selected,"& vbNewLine & _
"ungroup the sheets and try the macro again"
Else
'Call the function with the correct arguments
'For a fixed range use this line
FileName = RDB_Create_PDF(Source:=Range("A10:I15"), _
FixedFilePathName:="", _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)
'For the selection use Selection in the Source argument
'FileName = RDB_Create_PDF(Source:=Selection)
'For a fixed file name use this in the FixedFilePathName argument
'FixedFilePathName:="C:\Users\Ron\Test\YourPdfFile.pdf"
If FileName <> "" Then
RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
StrTo:="", _
StrCC:="", _
StrBCC:="", _
StrSubject:="This is the subject", _
Signature:=True, _
Send:=False, _
StrBody:="<H3><B>Dear Customer</B></H3><br>"& _
"<body>See the attached PDF file with the last figures."& _
"<br><br>"& "Regards Ron de bruin</body>"
Else
MsgBox "Not possible to create the PDF, possible reasons:"& vbNewLine & _
"Microsoft Add-in is not installed"& vbNewLine & _
"You Canceled the GetSaveAsFilename dialog"& vbNewLine & _
"The path to Save the file in arg 2 is not correct"& vbNewLine & _
"You didn't want to overwrite the existing PDF if it exist"
End If
End If
End Sub