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

[aarondesin91]

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

 

[zeheckman]

here is another example of what i am trying to do if possible.

this one works, but adds EVERY active sheet in the excel doc.

i only want the 4 in my userform to be active only if selected by checbox.

Private Sub CommandButton1_Click()

    
ActiveWorkbook.Save

  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 = "Empire-Cat Rental Equpment Quote"
 
  ' Define PDF filename
  PdfFile = checkbox.Select
  i = InStrRev(PdfFile, "1")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "" & ".pdf"
    Wkbk = ActiveWorkbook.Path & "/" & ActiveWorkbook.Name
  ' Export activesheet as PDF
  With ThisWorkbook
    .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 = TextBox4.Value
    .CC = TextBox1.Value
    .BCC = "Email Here" 'type any .bcc email here
    .Body = "Text." & vbLf & vbLf _
          & "Text email text " & Application.UserName & vbLf & vbLf & TextBox2.Value & vbLf & vbLf & vbLf _
          & "text email text" & vbLf _
          & "text email text" & vbLf & vbLf
        
    .Attachments.Add PdfFile
    
    x = TextBox3.Value
    If x <> "" Then
        Spx = Split(x, " ; ")
        For k = 0 To UBound(Spx)
            If Trim(Spx(k)) <> "" Then

                .Attachments.Add Trim(Spx(k))
            End If
        Next
    End If
      
    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "Message NOT sent. Try again!", vbCritical
    Else
      MsgBox "Your Rental Quote Has Been Sent To " & TextBox4.Value, vbOKOnly
    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
 Unload Me
End Sub

 

[ZVI]

Put the below code into UserForm's module, replace in the code "Sheet1" ... "Sheet4" by actual names of the sheets and try.
It is assumed that CheckBox1 ... CheckBox4 and CommandButton1 are on the form.

' Put the below code into the module of userform
' with CheckBox1 ... CheckBox4 and CommandButton1
 
Private Sub CommandButton1_Click()
 
  Dim MySheets As String
 
  ' --> Use names of the real sheets instead of the below "Sheet1", ... ,"Sheet4"
  If CheckBox1 Then MySheets = "Sheet1"
  If CheckBox2 Then MySheets = MySheets & ",Sheet2"
  If CheckBox3 Then MySheets = MySheets & ",Sheet3"
  If CheckBox4 Then MySheets = MySheets & ",Sheet4"
  ' <--
 
  ' Select sheets to be exported to the PDF file
  If Left(MySheets, 1) = "," Then MySheets = Mid(MySheets, 2)
  ActiveWorkbook.Sheets(Split(MySheets, ",")).Select
 
  ' Email as PDF the selected sheets
  Call AttachActiveSheetPDF_04
 
  ' Close the form
  Unload Me
 
End Sub
 
Sub AttachActiveSheetPDF_04()
  ' This sends email with attached PDF file of the selected sheets
  Dim IsCreated As Boolean
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object
  Dim i As Long
  Dim Char As Variant, Attachment As Variant
 
  ' Change to suit
  Title = "Empire-Cat Rental Equpment Quote"
 
  ' Define PDF filename in TEMP folder
  PdfFile = ActiveWorkbook.Name
  i = InStrRev(PdfFile, ".xl", , vbTextCompare)
  If i > Len(PdfFile) - 5 Then PdfFile = Left(PdfFile, i - 1)
  For Each Char In Split("? "" / \ < > * | :")
    PdfFile = Replace(PdfFile, Char, "_")
  Next
  PdfFile = Left(CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "\" & PdfFile, 251) & ".pdf"
 
  ' Delete PDF file - for the case it was not deleted at debugging
  If Len(Dir(PdfFile)) Then Kill PdfFile
 
  ' Export the selected sheets of workbook as PDF to the temporary folder
  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
  On Error GoTo 0
 
  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
 
    ' Prepare e-mail
    .Subject = Title
    '.To = TextBox4.Value    ' Email(s) of the main recipient(s)
    '.CC = TextBox1.Value    ' Email(s) of 'copy to' recipient(s) (CC = "Carbon Copy")
    '.BCC = TextBox9.Value   ' Email(s) of hidden recipient(s) (BCC = "Blind Carbon Copy")
    .Body = "Dear Customer," & vbLf & vbLf _
          & Title & " is attached in PDF file" & vbLf & vbLf _
          & "Best Regards," & vbLf _
          & Application.UserName & vbLf & vbLf
    .Attachments.Add PdfFile
 
    ' Add other attachments here
    'For Each Attachment In Split(TextBox3.Value, ";")
    '  If Trim(Attachment) <> "" Then .Attachments.Add Trim(Attachment)
    'Next
 
    ' Try to send
    On Error Resume Next
    .Send  ' or use .Display
 
    ' Return focus to Excel's window
    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 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
 
  ' Release the memory of object variable
  ' Note: sometimes Outlook object can't be released from the memory
  Set OutlApp = Nothing
 
End Sub

 

[ZVI]

You may also add: If CheckBox1 + CheckBox2 + CheckBox3 + CheckBox4 = 0 Then Exit Sub

 

[zeheckman]

Thank you!

This works perfectly!! Exactly what I was looking for!

 

[ZVI]

Thank you!

This works perfectly!! Exactly what I was looking for!

Glad it helped and thanks for the feedback!

 

[steve21a]

ZVI, I would like to use your code from page 1 of this thread but I would need the code to work for a group mailbox in Lotus Notes 8.5. I would need the code to pick the group mailbox as opposed to the personal inbox. Any ideas?

 

[Nelsonpk]

First of all let me thank you for this code. I am using it so a form I created in excel can be generated as a pdf and emailed and it works faultlessly. Is it possible for the code to incorporate a feature extending the rights in the pdf so the receiver can digitally sign it, or is this something that can only be done by Adobe Pro?

Many thanks

 

[shauncasey]

The template code for Excel 2007+ with its own PDF converter:

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

If I wanted the code to just generate the email and allow me to enter the email address and email body, what would I need to change?

Thanks in advance.

 

[shauncasey]

Ignore the above, I missed a page of the thread with the solution to the above

 

[kris77]

Hello ZVI,

I'm new to the forum.

Would you mind to help with adding additional code to the below. I need data in column A to be sorted by supplier name and then copied to seperate sheets, then individally converted into PDF files and saved with column A name and today's date and then send seperately to different email addressess depending of column A.

Please note: Supplier names in the column A will change depence of a date, report will be run every day and data send for previous day only. Column B: it's a date.

thanks so much!

The template code for Excel 2007+ with its own PDF converter:

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