Vba Macro - print a specified range to Pdf - send by Outlook - specified subject/body in a cell.

fleyd

New Member
Joined
Jan 21, 2020
Messages
22
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
  2. Web
Hello,

I´m not and expert in VBA, and i searched the web for a Macro that would do this:
- can print to A4 PDF a specified range in a cell
- Save that PDF to a specified destination in a cell
- Save that PDF with a specific name specified in a cell
- send by Outlook that PDF attachement
- with specified subject/body as a specific a cell
- Email destination and cc as specified in a cell

I managed to find a Macro that does part of this, but not everything. Here´s an Example sheet

Can someone help with the rest of the code to do this?

Feel free to download the file. Many thanks in advance for the help.
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Do a Google search on how to act when cross posting
 
Upvote 0
Do a Google search on how to act when cross posting

I´m just trying to get help, but for what i understand when i place the same question in 2 forums i need to reference the other, is that it?
If that´s the case, here it is the other forum where i place the question Ozgrid

I´m not trying to cheat anybody, i´m just looking for help about the macro.

Can you help?
 
Upvote 0
Yes indeed.
It's free and you could potentially have several people working on the same problem while there could be a solution already.
It would be a waste of their time. They could have been helping people that did not have a solution yet.
But you have supplied the hyperlink. Thank you for that.
 
Upvote 0
Yes indeed.
It's free and you could potentially have several people working on the same problem while there could be a solution already.
It would be a waste of their time. They could have been helping people that did not have a solution yet.
But you have supplied the hyperlink. Thank you for that.

Honestly, it wasn´t my intention to "harm" anyone...

I not getting the code to work and i´m stoping for a bit now.

Hope someone can help.
 
Upvote 0
Just an example.
Change the references where required.
Range("A1") has "A1:J45", without the double quotation marks, in it.
Range("A2") has "C:\Temp", without the double quotation marks, in it.
Range("A3") has "Satifaction Report Comp AAAAA", without the double quotation marks, in it.
Code:
Sub Maybe()
Dim FilePath As String
    With Sheets("Sheet1")    '<---- Change sheet name
        FilePath = Range("A2").Value & "\" & Range("A3").Value & ".PDF"    '<---- Change the reference
            .Range(.Range("A1").Value).ExportAsFixedFormat 0, FilePath    '<---- Change the reference
    End With
End Sub
 
Upvote 0
Hi, I have seen that website but i find it more complicated than another i also found on the web.

So far i´m still missing this:
Important to me
- Choose the range in the sheet to print to Pdf (it can be on the Vba code, but i would prefer a sheet cell reference)
- Choose the name of the sheet to print, because this macro can be useful for other sheets i have ((it can be on the Vba code, but i would prefer a sheet cell reference)

Not so important:
- Choose the computer path to save the document "c:\pdf_prints\" for example . I would prefer to write the path in a excel cell, it´s more flexible to use in another sheets
- Is there a way of deleting the pdf file? Just send it in the email.

This is the file i have so far Excel example

VBA Code:
Sub Save_as_pdf_and_send()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
 
Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
 
If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox ActiveSheet.Range("n9") & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If
'xFolder = ActiveSheet.Range("n9") 'Not working properly
xFolder = xFolder + "\" + ActiveSheet.Range("n10") + ".pdf"  'xSht.Name + ".pdf"_Can´t_have_bars
 
'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If
 
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, FileName:=xFolder, Quality:=xlQualityStandard
     
    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .to = ActiveSheet.Range("n5")
        .CC = ActiveSheet.Range("n6")
        .Subject = ActiveSheet.Range("n7")
        .HTMLBody = "<font face=" & Chr(34) & "Calibri" & Chr(34) & " size=" & Chr(34) & 4 & Chr(34) & ">" & "Good day dear Master," & "<br> <br>" & ActiveSheet.Range("n8") & "<br> <br>" & signature & "</font>"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub
 
Upvote 0
Can you change this to suit your needs?
Change all references etc where required.

Cell A1 has "Sheet1" without the quotation marks in it
Cell A2 Has "A1:J45" without the quotation marks in it
Cell A3 has "C:\TempFolder" without the quotation marks in it
Cell A4 has "Trial File" without the quotation marks in it
Cell A5 has "Hello" without the quotation marks in it

VBA Code:
Sub Mail_PDF()

    Dim PDF_To_Mail As String
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Sheets(Range("A1").Value)
        PDF_To_Mail = Range("A3").Value & "\" & Range("A4").Value & ".PDF"
            .Range(.Range("A2").Value).ExportAsFixedFormat 0, PDF_To_Mail
    End With

    On Error Resume Next

    With OutMail
        .To = "fleyd321@hotmail.com"
        .CC = ""
        .BCC = ""
        .Subject = Range("A5").Value & " Latest News"
        .body = ""
        .Attachments.Add(PDF_To_Mail).FullName
        .send
    End With
    On Error GoTo 0

    Kill PDF_To_Mail

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,894
Messages
6,175,252
Members
452,623
Latest member
Techenthusiast

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