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

ZVI

MrExcel MVP
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:

WERNER SLABBERT

Board Regular
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
 

WERNER SLABBERT

Board Regular
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
 

Horspool68

New Member
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:

ddhuggi

New Member
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:

Some videos you may like

This Week's Hot Topics

  • Get External Data (long shot question!)
    This is likely a long shot but I am wondering if it is at all possible for Excel to somehow 'change' the contents of a URL that is being linked to...
  • Importing multiple excel files into one spreadsheet
    Hi, I'm trying to import multiple excel files (with the same format into a single spreadsheet) so that each day's file is listed underneath the...
  • Cell Formatting
    Good Morning, I need to format a few different cells in the following manners: A1 has to always add a colon (:) after whatever is typed in by a...
  • How to copy multiple rows using If
    Hi all, I'm very new to VBA and have written this simple code to copy certain cells if a certain cell within that row contains any data. I need...
  • Workbook_Change stopped working !
    I am working on an app to speed up & automate processing of Credit Cards statements. After data is input from a CSV file, it is presented to the...
  • VBA If statement
    Dear All, I have two dates, where I'd like a message box to pop, if the dates are between this criteria. [CODE] sDate1 = #10/1/2019#...
Top