Forum

Send PDF by email t...
 
Notifications
Clear all

Send PDF by email to recipent in a named range in excel

2 Posts
2 Users
0 Reactions
122 Views
(@dennis21)
Posts: 3
Active Member
Topic starter
 

 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 = "[email protected]"  '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 = "[email protected]"  '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:METPRODWarehouseDomestic DisturbancesPDF 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

 
Posted : 08/02/2018 9:38 pm
(@sunnykow)
Posts: 1417
Noble Member
 

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

 
Posted : 08/02/2018 10:14 pm
Share: