Save worksheets to PDF and email in individual (outlook) message each

K

kinaps

New Member
Joined
May 26, 2019
Messages
2
Hello everyone,

I'm trying to convert all worksheets of the excel file into individual PDF and automatically attach to individual email (outlook) message each one of them.

So far I was able to rename each worksheet (as per a certain cell) and save as individual PDF, but I still can't figure out how to automatically create the email message window and have each of the PDFs attach to each message.

Your help is highly appreciated!
Nikola
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
Let's start with this.
Change data in red by your information


Code: 
Sub sendSheet()
'send sheet
    Dim ruta As String, nombre As String, h As Worksheet, dam
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    ruta = ThisWorkbook.Path & "\"
    For Each h In Sheets
        nombre = h.Range("[COLOR=#ff0000]A5[/COLOR]").Value
        '
        h.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ruta & nombre & ".pdf", _
            Quality:=xlQualityStandard, ncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
        '
        Set dam = CreateObject("outlook.application").createitem(0)
        dam.To = "[COLOR=#ff0000]correo@gmail.com[/COLOR]"
        dam.Subject = "[COLOR=#ff0000]subject[/COLOR]"
        dam.Attachments.Add ruta & nombre & ".pdf"
        'dam.Display  'show
        dam.Send     'send
    Next
End Sub
 
Upvote 0
DanteAmor said:
Let's start with this.
Change data in red by your information


Code: 
Sub sendSheet()
'send sheet
    Dim ruta As String, nombre As String, h As Worksheet, dam
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    ruta = ThisWorkbook.Path & "\"
    For Each h In Sheets
        nombre = h.Range("[COLOR=#ff0000]A5[/COLOR]").Value
        '
        h.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ruta & nombre & ".pdf", _
            Quality:=xlQualityStandard, ncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
        '
        Set dam = CreateObject("outlook.application").createitem(0)
        dam.To = "[COLOR=#ff0000]correo@gmail.com[/COLOR]"
        dam.Subject = "[COLOR=#ff0000]subject[/COLOR]"
        dam.Attachments.Add ruta & nombre & ".pdf"
        'dam.Display  'show
        dam.Send     'send
    Next
End Sub
Click to expand...

Thanks Dante, but I got an error "Named argument not found" for this part ncludeDocProperties:=
But I have found a solution in meantime, here it is posted for others to use as they need.

Now I need to find a solution how to copy the Sheet2 based as many times as there are rows in Sheet1, and automatically copy certain cells in each created Sheet from the Sheet1. Can anyone help with that? Thanks so much!

Code: 
[COLOR=#000000][FONT=Arial]Option Explicit[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]Sub SendAllSheetsWORKING()[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]Dim ws As Worksheet[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]For Each ws In Worksheets[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]   ws.Activate[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]   create_and_email_pdf[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]Next[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial] End Sub[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]Sub create_and_email_pdf()[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]Dim EmailSubject As String, EmailSignature As String[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]Dim CurrentMonth As String, DestFolder As String, PDFFile As String[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]Dim Email_To As String, Email_CC As String, Email_BCC As String[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]Dim OverwritePDF As VbMsgBoxResult[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]Dim OutlookApp As Object, OutlookMail As Object[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]CurrentMonth = ""[/FONT][/COLOR]


[COLOR=#000000][FONT=Arial]' *****************************************************[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]' *****     You Can Change These Variables    *********[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]    EmailSubject = "Invoice Attached for "   'Change this to change the subject of the email. The current month is added to end of subj line[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    OpenPDFAfterCreating = False    'Change this if you want to open the PDF after creating it : TRUE or FALSE[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    AlwaysOverwritePDF = False      'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    DisplayEmail = True 'Change this if you don't want to display the email before sending.  Note, you must have a TO email address specified for this to work[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    Email_To = ActiveSheet.Range("A14")   'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    Email_CC = ""[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    Email_BCC = ""[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]' ******************************************************[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]    'Prompt for file destination[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    DestFolder = "C:\Users\yourlocation"[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]    'Current month/year stored in H6 (this is a merged cell)[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    CurrentMonth = Mid(ActiveSheet.Range("D8").Value, InStr(1, ActiveSheet.Range("D8").Value, " ") + 1)[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]    'Create new PDF file name including path and file extension[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Range("A10") & " - " & ActiveSheet.Range("D8") & " - " & ActiveSheet.Range("F10") & ".pdf"[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]    'If the PDF already exists[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    If Len(Dir(PDFFile)) > 0 Then[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]        If AlwaysOverwritePDF = False Then[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]            OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]            On Error Resume Next[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]            'If you want to overwrite the file then delete the current one[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]            If OverwritePDF = vbYes Then[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]                Kill PDFFile[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]            Else[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]                MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]                Exit Sub[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]            End If[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]        Else[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]            On Error Resume Next[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]            Kill PDFFile[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]        End If[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]        If Err.Number <> 0 Then[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]            MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]            Exit Sub[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]        End If[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]    End If[/FONT][/COLOR]


[COLOR=#000000][FONT=Arial]    'Create the PDF[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]        :=False, OpenAfterPublish:=OpenPDFAfterCreating[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]    'Create an Outlook object and new mail message[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    Set OutlookApp = CreateObject("Outlook.Application")[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    Set OutlookMail = OutlookApp.CreateItem(0)[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]    'Display email and specify To, Subject, etc[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]    With OutlookMail[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]        .Display[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]        .To = Email_To[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]        .CC = Email_CC[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]        .BCC = Email_BCC[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]        .Subject = EmailSubject & CurrentMonth[/FONT][/COLOR]
[COLOR=#000000][FONT=Arial]        .Attachments.Add PDFFile[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]        If DisplayEmail = True Then[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]            .Display[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]        End If[/FONT][/COLOR]

[COLOR=#000000][FONT=Arial]    End With[/FONT][/COLOR]


[COLOR=#000000][FONT=Arial]End Sub[/FONT][/COLOR]
[/QUOTE]
 
Upvote 0
kinaps said:
Thanks Dante, but I got an error "Named argument not found" for this part ncludeDocProperties:=
But I have found a solution in meantime, here it is posted for others to use as they need.

Now I need to find a solution how to copy the Sheet2 based as many times as there are rows in Sheet1, and automatically copy certain cells in each created Sheet from the Sheet1. Can anyone help with that? Thanks so much!
Click to expand...

One letter was lost:


Code: 
[SIZE=4][B][COLOR=#ff0000]I[/COLOR][/B][/SIZE]ncludeDocProperties:=True
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Save outlook attachment without file extensions
Replies
3
Views
483
johnnyL
J
R
  • Question
Mail merge to insert the picture in the mail body and schedule the email
Replies
0
Views
769
rafeek4u
R
V
  • Question
Save attachment from outlook to a specific folder on computer, sent by a specific sender and save the file (both excel and pdf) with date & time stamp
Replies
7
Views
4K
vckothari
V
J
  • Solved
Can you add a 5 second delay after each Send statement in the VBA code below.
Replies
5
Views
387
DanteAmor
DanteAmor
O
  • Solved
Save PDF's from a dropdown menu using VBA
2
Replies
12
Views
351
ob1tech77
O

Forum statistics

Threads
1,214,972
Messages
6,122,530
Members
449,088
Latest member
RandomExceller01

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top