VBA code to convert excel to pdf and email it as attachment

aarondesin91

New Member
Joined
Jun 23, 2013
Messages
7
Dear Forumers,

I really need your help. I am new to this whole VBA coding thing have no basic at all in programming and stuff so please help me out here. I am currently assigned a project where I have to create a excel sheet which act as a templete for sending request. The requirement of the project is that I need a vba code for a button when i click it, it will convert my active sheet alone to pdf, automatically save it with the title captured from a cell in the active sheet which is entered by the user. Email this pdf as a attachment to the specific person. Please help me out, my job depends on this project please guys out there.

Thank you
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Or use the below code where the setting Const Account is an index or a name of the required account with its default signature.
Rich (BB code):
Sub SendPDF_WithAccountSignatiure()
 
  ' --> User settings, change to suit
  Const IsDisplay As Boolean = True  ' Change to False for .Send instead of .Display
  Const IsSilent As Boolean = False  ' Change to True to show Send status
  Const FontName = "Candara"         ' Font name of the email body
  Const FontSize = 11                ' Font size of the email body
  Const Account = 2                  ' Index or Name of the account to send from
  ' <-- End of the settings
 
  Dim IsCreated As Boolean
  Dim OutlApp As Object
  Dim char As Variant
  Dim PdfFile As String, HtmlFont As String, HtmlBody As String, HtmlSignature As String
 
  ' Edit the body's html text as required
  ' The tags are: h3 is for Header#3; b is for Bold; br is for line break
  ' HTML tag's are not displayed properly in the post of MrExcel forum, thus replacing is used to fix this problem
  HtmlBody = "First line, (br)" _
           & "Second line.(br)" _
           & "Third line."
  HtmlBody = Replace(HtmlBody, "(", "<")
  HtmlBody = Replace(HtmlBody, ")", ">")
 
  ' Set the font for the html-body (parentheses are just because of MrExcel posting limitation)
  HtmlFont = HtmlFont = "(body font: " & FontSize & "pt " & FontName & ";color:black"")"
  HtmlFont = Replace(HtmlFont, "(", "<")
  HtmlFont = Replace(HtmlFont, ")", ">")
 
  ' Define PDF filename
  PdfFile = Range("H2") & "_" & ActiveSheet.Name
 
  ' Replace illegal symbols in PdfFile by underscore
  For Each char In Split("? "" / \ < > * | :")
    PdfFile = Replace(PdfFile, char, "_")
  Next
 
  ' Apply %TEMP% path to the file name and limit lenght of the pathname
  PdfFile = Left(Environ("TEMP") & IIf(Right(Environ("TEMP"), 1) <> "\", "\", "") & PdfFile, 251) & ".pdf"
 
  ' Try to delete PDF file if present
  If Len(Dir(PdfFile)) Then Kill PdfFile
 
  ' Export the activesheet as PDF
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With
 
  ' Use the already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0
 
  ' Prepare email with PDF attachment and the default signature
  With OutlApp.CreateItem(0)
 
    ' Set HTML format
    .BodyFormat = 2
    
    ' Add the attachment first for correct attachment's name with non English symbols
    .Attachments.Add PdfFile
 
    ' Set the required account by const Account
    Set .SendUsingAccount = OutlApp.Session.Accounts.Item(Account)
   
    ' Get default email signature without blinking (instead of .Display method)
    With .GetInspector: End With
    HtmlSignature = .HtmlBody
  
    ' Prepare e-mail
    .Subject = Range("H2") & " / " & Range("K1")
    .To = Range("L1")   ' <-- Put email of the recipient here
    .HtmlBody = HtmlFont & HtmlBody & HtmlSignature
          
    ' Try to send or just display the e-mail
    On Error Resume Next
    If IsDisplay Then .Display Else .Send
 
    ' Show error of the .Send method
    If Not IsDisplay Then
      ' Return focus to Excel's window
      Application.Visible = True
      ' Show error/success message
      If Err Then
        MsgBox "E-mail was not sent for some reasons" & vbLf & "Please check it", vbExclamation
        .Display
      Else
        If Not IsSilent Then
          MsgBox "E-mail successfully sent", vbInformation
        End If
      End If
    End If
    On Error GoTo 0
 
  End With
 
  ' Delete the temporary PDF file
  If Len(Dir(PdfFile)) Then Kill PdfFile
 
  ' Try to quit Outlook if it was not previously open
  If IsCreated Then OutlApp.Quit
 
  ' Try to release the memory of object variable
  Set OutlApp = Nothing
 
End Sub
Regards
 
Last edited:
Upvote 0
I have been trying( to no avail) to apply these steps to my Macro... but hell it gets confusing... can i kinda aslo maybe ask some help... ? the PDF save section works great, its the sending the attchment from specific account with my signature bit that has me baffled completely...
Code:
Sub SaveIt()  
    On Error Resume Next 'In case it already exists
MkDir GetSpecialfolder(CSIDL_DESKTOP) & "\Famous_Brands" & "\" & Range("C7").Value
    
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False


    Dim Filename As String
    Dim Path As String
    Dim i As Integer
    Dim Mail_Object
    Dim Email_Subject
    Dim o As Variant
    
    Filename = Format(Date, "yyyy_mm_dd") & "_" & Range("J7").Value & "_" & Range("J8").Value
    Path = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Path & "\Famous_Brands" & "\" & Range("C7").Value & "\" & Filename & ".Pdf", _
            Quality:=xlQualityStandard, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True


    ActiveWorkbook.SaveAs Filename:=Path & "\Famous_Brands" & "\" & "Complete_Job_Card_2018", _
                            FileFormat:=xlOpenXMLTemplateMacroEnabled, _
                            Password:="", _
                            WriteResPassword:="", _
                            ReadOnlyRecommended:=False, _
                            CreateBackup:=False
                                                      
        ActiveWorkbook.SaveAs Filename:=Path & "\" & "Complete_Job_Card_2018", _
                            FileFormat:=xlOpenXMLTemplateMacroEnabled, _
                            Password:="", _
                            WriteResPassword:="", _
                            ReadOnlyRecommended:=False, _
                            CreateBackup:=False
                                        
            Set Mail_Object = CreateObject("Outlook.Application")
        With Mail_Object.CreateItem(o)
            .Subject = "Famous Brands Repair Job Card" ' CHANGE TO SUIT
            .To = "receptionpta@nexusgroup.co.za" 'CHANGE TO SUIT
            .Body = "Machine Repaired and Ready for collection or courier." & Chr(13) & Chr(13) & "Regards," & Chr(13) & "Werner Johan Slabbert" & Chr(13) & "Nexus Technical" 'Change comments to suit
            .Attachments.Add Filename
            .Send
    End With
        MsgBox "E-mail successfully sent", 64
        Application.DisplayAlerts = False
Set Mail_Object = Nothing


 
End Sub

Or use the below code where the setting Const Account is an index or a name of the required account with its default signature.
Rich (BB code):
Sub SendPDF_WithAccountSignatiure()
 
  ' --> User settings, change to suit
  Const IsDisplay As Boolean = True  ' Change to False for .Send instead of .Display
  Const IsSilent As Boolean = False  ' Change to True to show Send status
  Const FontName = "Candara"         ' Font name of the email body
  Const FontSize = 11                ' Font size of the email body
  Const Account = 2                  ' Index or Name of the account to send from
  ' <-- End of the settings
 
  Dim IsCreated As Boolean
  Dim OutlApp As Object
  Dim char As Variant
  Dim PdfFile As String, HtmlFont As String, HtmlBody As String, HtmlSignature As String
 
  ' Edit the body's html text as required
  ' The tags are: h3 is for Header#3; b is for Bold; br is for line break
  ' HTML tag's are not displayed properly in the post of MrExcel forum, thus replacing is used to fix this problem
  HtmlBody = "First line, (br)" _
           & "Second line.(br)" _
           & "Third line."
  HtmlBody = Replace(HtmlBody, "(", "<")
  HtmlBody = Replace(HtmlBody, ")", ">")
 
  ' Set the font for the html-body (parentheses are just because of MrExcel posting limitation)
  HtmlFont = HtmlFont = "(body font: " & FontSize & "pt " & FontName & ";color:black"")"
  HtmlFont = Replace(HtmlFont, "(", "<")
  HtmlFont = Replace(HtmlFont, ")", ">")
 
  ' Define PDF filename
  PdfFile = Range("H2") & "_" & ActiveSheet.Name
 
  ' Replace illegal symbols in PdfFile by underscore
  For Each char In Split("? "" / \ < > * | :")
    PdfFile = Replace(PdfFile, char, "_")
  Next
 
  ' Apply %TEMP% path to the file name and limit lenght of the pathname
  PdfFile = Left(Environ("TEMP") & IIf(Right(Environ("TEMP"), 1) <> "\", "\", "") & PdfFile, 251) & ".pdf"
 
  ' Try to delete PDF file if present
  If Len(Dir(PdfFile)) Then Kill PdfFile
 
  ' Export the activesheet as PDF
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With
 
  ' Use the already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0
 
  ' Prepare email with PDF attachment and the default signature
  With OutlApp.CreateItem(0)
 
    ' Set HTML format
    .BodyFormat = 2
    
    ' Add the attachment first for correct attachment's name with non English symbols
    .Attachments.Add PdfFile
 
    ' Set the required account by const Account
    Set .SendUsingAccount = OutlApp.Session.Accounts.Item(Account)
   
    ' Get default email signature without blinking (instead of .Display method)
    With .GetInspector: End With
    HtmlSignature = .HtmlBody
  
    ' Prepare e-mail
    .Subject = Range("H2") & " / " & Range("K1")
    .To = Range("L1")   ' <-- Put email of the recipient here
    .HtmlBody = HtmlFont & HtmlBody & HtmlSignature
          
    ' Try to send or just display the e-mail
    On Error Resume Next
    If IsDisplay Then .Display Else .Send
 
    ' Show error of the .Send method
    If Not IsDisplay Then
      ' Return focus to Excel's window
      Application.Visible = True
      ' Show error/success message
      If Err Then
        MsgBox "E-mail was not sent for some reasons" & vbLf & "Please check it", vbExclamation
        .Display
      Else
        If Not IsSilent Then
          MsgBox "E-mail successfully sent", vbInformation
        End If
      End If
    End If
    On Error GoTo 0
 
  End With
 
  ' Delete the temporary PDF file
  If Len(Dir(PdfFile)) Then Kill PdfFile
 
  ' Try to quit Outlook if it was not previously open
  If IsCreated Then OutlApp.Quit
 
  ' Try to release the memory of object variable
  Set OutlApp = Nothing
 
End Sub
Regards
 
Upvote 0
i also would like to implement this in my current macro but Veni,Vidi Velcro... it realy isn't as easy as my noob brain would make it out to be... here is my current macro (pieced together and all.. i would like to attach the saved file to the email with a specific account sending it and a specific signature called "Nexus"

Please help all you smart people...

Code:
Sub SaveIt()  
    On Error Resume Next 'In case it already exists
MkDir GetSpecialfolder(CSIDL_DESKTOP) & "\Famous_Brands" & "\" & Range("C7").Value
    
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False


    Dim Filename As String
    Dim Path As String
    Dim i As Integer
    Dim Mail_Object
    Dim Email_Subject
    Dim o As Variant
    
    Filename = Format(Date, "yyyy_mm_dd") & "_" & Range("J7").Value & "_" & Range("J8").Value
    Path = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Path & "\Famous_Brands" & "\" & Range("C7").Value & "\" & Filename & ".Pdf", _
            Quality:=xlQualityStandard, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True


    ActiveWorkbook.SaveAs Filename:=Path & "\Famous_Brands" & "\" & "Complete_Job_Card_2018", _
                            FileFormat:=xlOpenXMLTemplateMacroEnabled, _
                            Password:="", _
                            WriteResPassword:="", _
                            ReadOnlyRecommended:=False, _
                            CreateBackup:=False
                                                      
        ActiveWorkbook.SaveAs Filename:=Path & "\" & "Complete_Job_Card_2018", _
                            FileFormat:=xlOpenXMLTemplateMacroEnabled, _
                            Password:="", _
                            WriteResPassword:="", _
                            ReadOnlyRecommended:=False, _
                            CreateBackup:=False
                                        
            Set Mail_Object = CreateObject("Outlook.Application")
        With Mail_Object.CreateItem(o)
            .Subject = "Famous Brands Repair Job Card" ' CHANGE TO SUIT
            .To = "receptionpta@nexusgroup.co.za" 'CHANGE TO SUIT
            .Body = "Machine Repaired and Ready for collection or courier." & Chr(13) & Chr(13) & "Regards," & Chr(13) & "Werner Johan Slabbert" & Chr(13) & "Nexus Technical" 'Change comments to suit
            .Attachments.Add Filename
            .Send
    End With
        MsgBox "E-mail successfully sent", 64
        Application.DisplayAlerts = False
Set Mail_Object = Nothing


 
End Sub
 
Upvote 0
Hi there I've pasted your recommended code as below however when I try to run it I get
" Compile error:
User-defined type not defined "
at the same time "mypdfDist As New PdfDistiller" is highlighted.
Any help please ?


Code:
Private Sub CommandButton1_Click()
Dim tempPDFFileName, tempPSFileName, tempPDFRawFileName As String, mypdfDist As New PdfDistiller, _
 i As Integer, Mail_Object, Email_Subject, o As Variant
    tempPDFRawFileName = [COLOR=#FF0000]"V:\Manufacturing\Forms\Handover\Auto Handover Archive\DO NOT DELETE" & Range("CL2") [/COLOR]' Change File Path to suit
    tempPSFileName = tempPDFRawFileName & ".ps"
    tempPDFFileName = tempPDFRawFileName & ".pdf"
    ActiveSheet.PrintOut Copies:=1, preview:=False, ActivePrinter:="Adobe PDF", _
        printtofile:=True, Collate:=True, prtofilename:=tempPSFileName
    mypdfDist.FileToPDF tempPSFileName, tempPDFFileName, ""
     Kill tempPSFileName
Set mypdfDist = Nothing


'************End of PDF section*************
'************Start of emailing code*********
    Set Mail_Object = CreateObject("Outlook.Application")
        With Mail_Object.CreateItem(o)
            .Subject = Range("CL2") ' CHANGE TO SUIT
            .To = "mark.horspool@radius-systems.com" 'CHANGE TO SUIT
            .Body = "E MAIL TEXT GOES HERE" & Chr(13) & Chr(13) & "Regards," & Chr(13) & "YOUR NAME." & Chr(13) & "YOUR ADDRESS." 'Change comments to suit
            .Attachments.Add tempPDFFileName
            .Send
    End With
        MsgBox "E-mail successfully sent", 64
        Application.DisplayAlerts = False
Set Mail_Object = Nothing


End Sub
 
Last edited by a moderator:
Upvote 0
Where can one get the [PDFDistiller] object referred to in the code above? Kindly send the link by reply and oblige.
 
Upvote 0
i also would like to implement this in my current macro but Veni,Vidi Velcro... it realy isn't as easy as my noob brain would make it out to be... here is my current macro (pieced together and all.. i would like to attach the saved file to the email with a specific account sending it and a specific signature called "Nexus"

Please help all you smart people...

Code:
Sub SaveIt()  
    On Error Resume Next 'In case it already exists
MkDir GetSpecialfolder(CSIDL_DESKTOP) & "\Famous_Brands" & "\" & Range("C7").Value
    
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False


    Dim Filename As String
    Dim Path As String
    Dim i As Integer
    Dim Mail_Object
    Dim Email_Subject
    Dim o As Variant
    
    Filename = Format(Date, "yyyy_mm_dd") & "_" & Range("J7").Value & "_" & Range("J8").Value
    Path = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Path & "\Famous_Brands" & "\" & Range("C7").Value & "\" & Filename & ".Pdf", _
            Quality:=xlQualityStandard, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True


    ActiveWorkbook.SaveAs Filename:=Path & "\Famous_Brands" & "\" & "Complete_Job_Card_2018", _
                            FileFormat:=xlOpenXMLTemplateMacroEnabled, _
                            Password:="", _
                            WriteResPassword:="", _
                            ReadOnlyRecommended:=False, _
                            CreateBackup:=False
                                                      
        ActiveWorkbook.SaveAs Filename:=Path & "\" & "Complete_Job_Card_2018", _
                            FileFormat:=xlOpenXMLTemplateMacroEnabled, _
                            Password:="", _
                            WriteResPassword:="", _
                            ReadOnlyRecommended:=False, _
                            CreateBackup:=False
                                        
            Set Mail_Object = CreateObject("Outlook.Application")
        With Mail_Object.CreateItem(o)
            .Subject = "Famous Brands Repair Job Card" ' CHANGE TO SUIT
            .To = "receptionpta@nexusgroup.co.za" 'CHANGE TO SUIT
            .Body = "Machine Repaired and Ready for collection or courier." & Chr(13) & Chr(13) & "Regards," & Chr(13) & "Werner Johan Slabbert" & Chr(13) & "Nexus Technical" 'Change comments to suit
            .Attachments.Add Filename
            .Send
    End With
        MsgBox "E-mail successfully sent", 64
        Application.DisplayAlerts = False
Set Mail_Object = Nothing


 
End Sub

Need help on corrections in this coding. I am receiving the PDF file in 4 pieces. I need it to be sent in one form. IS there a way to adjust the code to take all 4 pages and condense it to 1 page?
 
Last edited:
Upvote 0
To use signature with formatted text & picture, the .HTMLBody should be used in the code instead of the just .Body
Code in post #159 reflects both methods: using of HTML signature with HTML formatted message, and the plain text message with text of a signature.
Here is a mixed version of the code where plain text of the message is converted to a simple HTML code with full HTML signature
Rich (BB code):
Sub Attach_Sheets_As_Pdf_With_HTMLSignature()
' ZVI:2016-09-21 http://www.mrexcel.com/forum/excel-questions/710212-visual-basic-applications-code-convert-excel-pdf-email-attachment-post4637844.html#post4637844

  ' --> User settings, change to suit
  Const MySheets As Variant = "Sheet1,Sheet3" ' Use MySheets = 0 for all the sheets
  Const IsDisplay As Boolean = True           ' Change to False to .Send instead of .Display
  Const IsSilent As Boolean = False           ' Change to True to Send without the confirmation MsgBox
  ' <-- End of settings

  Dim IsCreated As Boolean
  Dim PdfFile As String, Signature As String, Message As String
  Dim OutlApp As Object
  Dim i As Long
  Dim char As Variant

  ' Define PDF filename
  PdfFile = ActiveWorkbook.Name
  i = InStrRev(PdfFile, ".xl", , vbTextCompare)
  If i > Len(PdfFile) - 5 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "_" & ActiveSheet.Name
  ' Clean up the name of PDF file
  For Each char In Split("? "" / \ < > * | :")
    PdfFile = Replace(PdfFile, char, "_")
  Next
  ' Add %TEMP% path to the file name and limit too long name
  PdfFile = Left(CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "\" & PdfFile, 251) & ".pdf"

  ' Try to delete PDF file for the case it was not deleted at debugging
  If Len(Dir(PdfFile)) Then Kill PdfFile

  ' Select sheets to be exported in the PDF (single) file
  If MySheets = 0 Then
    ' All sheets to PDF
    Sheets.Select
  Else
    ' Sheets listed in MySheets to PDF
    Sheets(Split(MySheets, ",")).Select
  End If

  ' Export the selected sheets as PDF to the temporary folder
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    .Select
  End With

  ' Use the already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  On Error GoTo 0

  ' Prepare email with PDF attachment and default signature
  With OutlApp.CreateItem(0)
 
    ' Add the attachment first for correct attachment's name with non English symbols
    .Attachments.Add PdfFile
 
    ' Get default email signature without blinking (instead of .Display method)
    With .GetInspector: End With
    Signature = .HTMLBody

    ' Prepare e-mail (uncommenmt and fill the lines below)
    .Subject = "Payroll Monthly Analysis"
    .To = Range("L3").Value
    .CC = Range("L4").Value
    Message = "Hi," & vbLf & vbLf _
            & "Please find the latest payroll report attached"

    .HTMLBody = Replace(Message, vbLf, Chr(60) & "br" & Chr(62)) & Signature
 
    ' Try to send or just display the e-mail
    On Error Resume Next
    If IsDisplay Then .Display Else .Send
 
    ' Show error of .Send method
    If Not IsDisplay Then
      ' Return focus to Excel's window
      Application.Visible = True
      ' Report on error or success
      If Err Then
        MsgBox "E-mail was not sent for some reasons" & vbLf & "Please check it", vbExclamation
        .Display
      Else
        If Not IsSilent Then
          MsgBox "E-mail successfully sent", vbInformation
        End If
      End If
    End If
    On Error GoTo 0

  End With

  ' Delete the temporary PDF file
  If Len(Dir(PdfFile)) Then Kill PdfFile

  ' Try to quit Outlook if it was not previously open
  If IsCreated Then OutlApp.Quit

  ' Try to release the memory of object variable
  Set OutlApp = Nothing

End Sub

Hi ZVI,

Thank you for your continued help with this project. It seems that many people have benefitted from your skills.

I am using the above code but need to adapt it to attach the sheets as Excel worksheets instead of PDF. Also, It would be great if I could list all the sheets to attach in column A on 'My Sheets' (to be renamed 'Email Sheets' to be attached to an individual email. As in each sheet will be separately emailed to an address in a cell on that sheet. Finally, I have two inboxes on my Outlook, is it possible to define which email address to send it from?

I would appreciate your help with this, as I am unable to find the solutions myself.

Many thanks in advance.

Pad
 
Upvote 0
The template code for Excel 2007+ with its own PDF converter:
Rich (BB code):
Sub AttachActiveSheetPDF()
  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object

  ' Not sure for what the Title is
  Title = Range("A1")

  ' Define PDF filename
  PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"

  ' Export activesheet as PDF
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With

  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
  
    ' Prepare e-mail
    .Subject = Title
    .To = "..." ' <-- Put email of the recipient here
    .CC = "..." ' <-- Put email of 'copy to' recipient here
    .Body = "Hi," & vbLf & vbLf _
          & "The report is attached in PDF format." & vbLf & vbLf _
          & "Regards," & vbLf _
          & Application.UserName & vbLf & vbLf
    .Attachments.Add PdfFile
  
    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
    Else
      MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
  
  End With

  ' Delete PDF file
  Kill PdfFile

  ' Quit Outlook if it was created by this code
  If IsCreated Then OutlApp.Quit

  ' Release the memory of object variable
  Set OutlApp = Nothing

End Sub
I have used your code and it worked great. The only thing is that I wanted to add that I want it to print a select range and in landscape format and one page wide and one page tall. I tried to add the following code and it would not work:

' Export activesheet as PDF
With ActiveSheet
.PageSetup.Orientation = xLandscape
.PageSetup.Zoom = False
.PageSetup.FitToPagesWide = 1
.PageSetup.FitToPagesTall = 1
.PageSetup.PrintArea = "$A$1:$L$31"
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With

I also tried With Sheets("Sheet1")
.PageSetup.Orientation = xLandscape
.PageSetup.Zoom = False
.PageSetup.FitToPagesWide = 1
.PageSetup.FitToPagesTall = 1
.PageSetup.PrintArea = "$A$1:$L$31"
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With

Using With Sheets("Sheet1") worked until I added the .PageSetup items. Can you help at all?
 
Upvote 0
The template code for Excel 2007+ with its own PDF converter:
Rich (BB code):
Sub AttachActiveSheetPDF()
  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object

  ' Not sure for what the Title is
  Title = Range("A1")

  ' Define PDF filename
  PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"

  ' Export activesheet as PDF
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With

  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
 
    ' Prepare e-mail
    .Subject = Title
    .To = "..." ' <-- Put email of the recipient here
    .CC = "..." ' <-- Put email of 'copy to' recipient here
    .Body = "Hi," & vbLf & vbLf _
          & "The report is attached in PDF format." & vbLf & vbLf _
          & "Regards," & vbLf _
          & Application.UserName & vbLf & vbLf
    .Attachments.Add PdfFile
 
    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
    Else
      MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
 
  End With

  ' Delete PDF file
  Kill PdfFile

  ' Quit Outlook if it was created by this code
  If IsCreated Then OutlApp.Quit

  ' Release the memory of object variable
  Set OutlApp = Nothing

End Sub
The template code for Excel 2007+ with its own PDF converter:
Rich (BB code):
Sub AttachActiveSheetPDF()
  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object

  ' Not sure for what the Title is
  Title = Range("A1")

  ' Define PDF filename
  PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"

  ' Export activesheet as PDF
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With

  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
 
    ' Prepare e-mail
    .Subject = Title
    .To = "..." ' <-- Put email of the recipient here
    .CC = "..." ' <-- Put email of 'copy to' recipient here
    .Body = "Hi," & vbLf & vbLf _
          & "The report is attached in PDF format." & vbLf & vbLf _
          & "Regards," & vbLf _
          & Application.UserName & vbLf & vbLf
    .Attachments.Add PdfFile
 
    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
    Else
      MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
 
  End With

  ' Delete PDF file
  Kill PdfFile

  ' Quit Outlook if it was created by this code
  If IsCreated Then OutlApp.Quit

  ' Release the memory of object variable
  Set OutlApp = Nothing

End Sub
The template code for Excel 2007+ with its own PDF converter:
Rich (BB code):
Sub AttachActiveSheetPDF()
  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object

  ' Not sure for what the Title is
  Title = Range("A1")

  ' Define PDF filename
  PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"

  ' Export activesheet as PDF
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With

  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
  
    ' Prepare e-mail
    .Subject = Title
    .To = "..." ' <-- Put email of the recipient here
    .CC = "..." ' <-- Put email of 'copy to' recipient here
    .Body = "Hi," & vbLf & vbLf _
          & "The report is attached in PDF format." & vbLf & vbLf _
          & "Regards," & vbLf _
          & Application.UserName & vbLf & vbLf
    .Attachments.Add PdfFile
  
    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
    Else
      MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
  
  End With

  ' Delete PDF file
  Kill PdfFile

  ' Quit Outlook if it was created by this code
  If IsCreated Then OutlApp.Quit

  ' Release the memory of object variable
  Set OutlApp = Nothing

End Sub
Code is awesome and working for me. But I need help little more help. Email address will vary. So I want the code that take email address from cell C14.
And if possible then the pdf range should be A1:K55
 

Attachments

  • Payment receipt.PNG
    Payment receipt.PNG
    58.6 KB · Views: 20
Upvote 0

Forum statistics

Threads
1,213,507
Messages
6,114,029
Members
448,543
Latest member
MartinLarkin

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