Printing sheets to PDF and attaching to an email.

[desnyder2001]

FIRST: I am an extreme novice using Macros so if you choose to assist me please try and talk at my level (thanks).

CURRETLY: I found this macro a while back while searching and it does everything perfect for me. It attaches all my sheets to a single pdf and automatically emails to the person I need it to.

NEEDED: I now need it to print each sheet to its own PDF with the name of the sheet and attach all PDFs to the email.

Following is the code that is being used:

CODE:
Sub Email_ActiveSheet_As_PDF()


'Do not forget to change the email ID
'before running this code


Dim OlApp As Object
Dim NewMail As Object
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


' Temporary file path where pdf
' file will be saved before
' sending it in email by attaching it.


TempFilePath = Environ$("temp") & ""


' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.


TempFileName = "PDF DRAFT Invoices" & "-" & Format(Now, "dd-mmm-yy") & ".pdf"


'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName


'Now Export the Activesshet as PDF with the given File Name and path


On Error GoTo err
With ActiveWorkbook
.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With


'Now open a new mail


Set OlApp = CreateObject("Outlook.Application")
Set NewMail = OlApp.CreateItem(0)


On Error Resume Next
With NewMail
.To = "name@xxx.com"
.CC = "name@xxx.com"
.BCC = ""
.Subject = "Draft Invoices"
.Body = "Michelle, I have attached this months DRAFT invoices for your review and processing."
.Attachments.Add FileFullPath '--- full path of the pdf where it is saved
.Send 'or use .Display to show you the email before sending it.
End With
On Error GoTo 0


'Since mail has been sent with the attachment
'Now delete the pdf file from the temp folder


Kill FileFullPath


'set nothing to the objects created
Set NewMail = Nothing
Set OlApp = Nothing


'Now set the application properties back to true
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox ("Make sure that Outlook is open and your email with attachment will be sent")

Exit Sub
err:
MsgBox err.Description


End Sub

 

[sijpie]

Hi desnyder,

please use code tags when posting code (see in red below)

this should do the trick:

Sub Email_ActiveSheet_As_PDF()


    'Do not forget to change the email ID
    'before running this code
    
    
    Dim OlApp As Object
    Dim NewMail As Object
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileFullPath As String
    Dim wsWS As Worksheet
    
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    
    ' Temporary file path where pdf
    ' file will be saved before
    ' sending it in email by attaching it.
    
    
    TempFilePath = Environ$("temp") & ""
    
    
    
    
    'Now Export each sheet as PDF with the given File Name and path
    'loop through all the sheets
    
    On Error GoTo err
    For Each wsWS In ActiveWorkbook.Sheets
        With wsWS
            ' Create pdf name
            TempFileName = .Name & ".pdf"
            'Complete path of the file where it is saved
            FileFullPath = TempFilePath & TempFileName
            'create the .pdf
            .ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    Filename:=FileFullPath, _
                    Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, _
                    IgnorePrintAreas:=False, _
                    OpenAfterPublish:=False
        End With
    Next wsWS
    
    'Now open a new mail
    
    
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
    
    
    On Error Resume Next
    With NewMail
        .To = "name@xxx.com"
        .CC = "name@xxx.com"
        .BCC = ""
        .Subject = "Draft Invoices"
        .Body = "Michelle, I have attached this months DRAFT invoices for your review and processing."
        '~~> *.* for all files
        TempFileName = Dir(TempFilePath & "*.*")

        Do While Len(TempFileName) > 0
            .Attachments.Add TempFilePath & TempFileName
            TempFileName = Dir
        Loop
        .Send 'or use .Display to show you the email before sending it.
    End With
    On Error GoTo 0
    
    
    'Since mail has been sent with the attachment
    'Now delete the pdf files from the temp folder
    
    
    Kill TempFilePath & "*.pdf"
    
    
    'set nothing to the objects created
    Set NewMail = Nothing
    Set OlApp = Nothing
    
    
    'Now set the application properties back to true
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    MsgBox ("Make sure that Outlook is open and your email with attachment will be sent")
    
    Exit Sub
err:
    MsgBox err.Description


End Sub