Log In
Register
Home
New Member
August 6, 2015
Offline
Hi
I would like a VBA to send a PDF of a work sheet range to a list of recipients listed in a named range (Recipients) on the active worksheet.
I have tried add the range in the variables in red below form the code below but got error. I hope soem one can put me on the right track to get this working
*****************************************************
' ***** You Can Change These Variables *********
EmailSubject = "Latest Dispach Sheet " 'Change this to change the subject of the email. The current month is added to end of subj line
OpenPDFAfterCreating = False 'Change this if you want to open the PDF after creating it : TRUE = Yes or FALSE = No
AlwaysOverwritePDF = False 'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
DisplayEmail = True 'Change this if you don't want to display the email before sending. True =Yes, False=No, Note,
'you must have a TO email address specified for this to work
Email_To = ActiveSheet.Range("Recipients") 'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
Email_CC = "" 'Change this if you want to specify To email
Email_BCC = "dennis.kent@pacificaluminium.com.au" 'Change this if you want to specify To email
************************************************************************************************************
This is the VBA I was using. with some minor changes to stop some actions working. You may recognise it form One I was copying from this site
Sub create_and_email_pdf()
'This creates a PDF file of active worksheet (or a rahge if named this one is PrintArea)
'then will save it to a folder and then email to address stored in file
'
'
' Date
' Create a PDF from the current sheet and email it as an attachment through Outlook
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
CurrentMonth = ""
' *****************************************************
' ***** You Can Change These Variables *********
EmailSubject = "Latest Dispach Sheet " 'Change this to change the subject of the email. The current month is added to end of subj line
OpenPDFAfterCreating = False 'Change this if you want to open the PDF after creating it : TRUE = Yes or FALSE = No
AlwaysOverwritePDF = False 'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
DisplayEmail = True 'Change this if you don't want to display the email before sending. True =Yes, False=No, Note,
'you must have a TO email address specified for this to work
Email_To = ActiveSheet.Range("AB1:AB15") 'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
Email_CC = "" 'Change this if you want to specify To email
Email_BCC = "dennis.kent@pacificaluminium.com.au" 'Change this if you want to specify To email
' ******************************************************
'Prompt for file destination
'With Application.FileDialog(msoFileDialogFolderPicker)
' If .Show = True Then
' DestFolder = .SelectedItems(1)
' Else
' MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
' Exit Sub
' End If
'End With
DestFolder = "P:\METPROD\Warehouse\Domestic Disturbances\PDF Copies "
'Current month/year stored in H6 (this is a merged cell)
CurrentMonth = Format(Range("adate"), "ddmmyy")
'Create new PDF file name including path and file extension
PDFFile = DestFolder & CurrentMonth & ".pdf"
'If the PDF already exists
If Len(Dir(PDFFile)) > 0 Then
If AlwaysOverwritePDF = False Then
'OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
'If you want to overwrite the file then delete the current one
'If OverwritePDF = vbYes Then
Kill PDFFile
Else
'MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
' & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
'Exit Sub
End If
Else
'On Error Resume Next
'Kill PDFFile
End If
'If Err.Number <> 0 Then
' MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
' & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
' Exit Sub
'Create the PDF
With Sheets("Dom.Dispatch")
.Columns("J:Q").EntireColumn.Hidden = True
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
.Columns("J:Q").EntireColumn.Hidden = False
End With
'Create an Outlook object and new mail message
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
'Display email and specify To, Subject, etc
With OutlookMail
.Display
.To = Email_To
.CC = Email_CC
.BCC = Email_BCC
.Subject = EmailSubject & CurrentMonth
.Attachments.Add PDFFile
If DisplayEmail = False Then
.Send
End If
End With
End Sub
VIP
Trusted Members
June 25, 2016
Offline
Hi Dennis
Email_To can only handle one address in the original code. If you have multiple addresses, you will need to add them one by one to Email_To.
Example (not tested)
DIM cel As Range
DIM rng as Range
Set rng = Range("Recipients")
For Each cel In rng
If Email_To ="" then
Email_To= cel.Value
Else
Email_To = Email_To & ";" & cel.Value
endif
Next
Now the Email_To will contain more than 1 email address
Hope this helps.
Sunny
1 Guest(s)
