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 came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
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

F
  • Question Question
Copy emails from specific folder in Outlook to a shared local folder
Replies
1
Views
227
feni1388
F
J
  • Solved
Save outlook attachment without file extensions
Replies
3
Views
843
johnnyL
J
R
  • Question Question
Mail merge to insert the picture in the mail body and schedule the email
Replies
0
Views
1K
rafeek4u
R
S
  • Question Question
Run Time Error 5 - In converting PDF sheets in a workbook into individual PDFs
Replies
4
Views
74
Micron
M
D
  • Question Question
Save sheet as PDF to a set folder and then email it in outlook using set credentials
Replies
1
Views
72
Logit
Logit

Forum statistics

Threads
1,224,818
Messages
6,181,152
Members
453,021
Latest member
Justyna P

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