VBA to send PDF with outlook

Shadkng

Active Member
Joined
Oct 11, 2018
Messages
301
Hi, the following code was written for me by an excel programmer who has since past away. This code creates a PDF of one of my excel worksheets, names it, and saves it a sub folder in the folder where the workbook is created. I would like to have the PDF automatically sent by outlook. I have seen online different code that works with outlook, but I was hoping my code could continue to do what it does, and then after the PDF is created open outlook, attach the file, and then send to an email that sits in a certain cell. I am not expecting that anyone writes all this for me, but if I know it can be done then I could outsource the job. Thanks for your help.

VBA Code:
Sub SALES_CONFIRMATION_PDF()

    Dim response As String
    Dim PrintAreaString As String
    Dim fpath As String
    Dim fName As String
    Dim fileSaveName As String, filePath As String
    Dim reply As Variant
    Dim lc As Long, GT As Long
    Dim shArr
    Dim witsMsg As String

If ActiveSheet.Name <> "DETAIL FORM" Then 'added condition to ensure correct worksheet 8/4/2019
    MsgBox ("Wrong sheet for creating PDF")
    Exit Sub
End If

Call PDFfolder 'Added to prevent Run Time Error 1004 - object not found 8/4/2019
   
Dim LR As Long, hite As Double, wits As Double
Dim i As Long, ii As Long
LR = Cells.Find("*", , , , xlByRows, xlPrevious).Row
lc = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
wits = 0
hite = 0

    For i = 1 To lc
        If Columns(i).Hidden = False Then wits = wits + Columns(i).width
    Next i
   
    For ii = 1 To LR
        If Rows(ii).Hidden = False Then hite = hite + Rows(ii).Height
    Next ii
   
With PageSetup
   
            shArr = Array("DETAIL FORM") '<---- Sheets that the macro should work on. Change to your requirements
            For i = LBound(shArr) To UBound(shArr)
            With Sheets(shArr(i))
             GT = .Cells(1, 2) + .Cells(2, 2).Value
            .PageSetup.PrintArea = Range("A4:A" & GT).Resize(, lc).Address
If wits > 875 Then
.PageSetup.Orientation = xlLandscape

Else
witsMsg = MsgBox("This PDF will fit in Portrait mode. Select YES to continue. Select NO to print in Landscape", vbYesNo, "Printing Options.")
If witsMsg = vbYes Then
.PageSetup.Orientation = xlPortrait
Else
.PageSetup.Orientation = xlLandscape
End If
End If
            .PageSetup.Zoom = False
            .PageSetup.FitToPagesWide = 1
            .PageSetup.FitToPagesTall = False
            .PageSetup.LeftMargin = 36
            .PageSetup.TopMargin = 36
            .PageSetup.RightMargin = 36
            .PageSetup.BottomMargin = 36
            .PageSetup.PrintGridlines = False
    End With
    Next i
    fileSaveName = "FRIEDLAND SALES CONF " & [B7] & " " & "ORD# " & [E5]
   
    filePath = ActiveWorkbook.path & "\PDFQUOTES\" & fileSaveName & ".pdf"
    Shell Environ("windir") & "\explorer.exe """ & ActiveWorkbook.path() & "\PDFQUOTES\", vbNormalFocus
   
    reply = vbNo
    While Dir(filePath) <> vbNullString And fileSaveName <> "" And reply = vbNo
        reply = MsgBox("THE PDF " & fileSaveName & " ALREADY EXISTS." & vbCrLf & vbCrLf & "DO YOU WANT TO REPLACE THE FILE?  CHOOSE NO TO RENAME.", vbYesNo, "Save as PDF")
        If reply = vbNo Then
            fileSaveName = InputBox("Please enter a new file name:", "Save as PDF", fileSaveName)
        End If
        filePath = ActiveWorkbook.path & "\PDFQUOTES\" & fileSaveName & ".pdf" '8/5/2019 ''original code, returned to on 8/6/2019 '8-6-19 steve changed folder name to "APDFQUOTES"
        Shell Environ("windir") & "\explorer.exe """ & ActiveWorkbook.path() & "\PDFQUOTES\", vbNormalFocus '8/5/2019 'original code, returned to on 8/6/2019 '8-6-19 steve changed folder name to "APDFQUOTES"
    Wend
      
    If fileSaveName <> "" Then
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filePath, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True '(change this to "False" to prevent the file from opening after saving)
    Else
        MsgBox "PDF not created"
    End If
    End With
    End Sub
 

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,324
Referring back to YOUR macro and this line :

VBA Code:
filePath = ActiveWorkbook.path & "\PDFQUOTES\" & fileSaveName & ".pdf"

Try :

Code:
filePath = ActiveWorkbook.path & "\PDFQUOTES\" & Range("A1").Value & ".pdf"

Change the cell reference as needed.
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

Shadkng

Active Member
Joined
Oct 11, 2018
Messages
301
Referring back to YOUR macro and this line :

VBA Code:
filePath = ActiveWorkbook.path & "\PDFQUOTES\" & fileSaveName & ".pdf"

Try :

Code:
filePath = ActiveWorkbook.path & "\PDFQUOTES\" & Range("A1").Value & ".pdf"

Change the cell reference as needed.
Below is the current code with modifications along the way.

I'm not sure where to add the line you suggested. Don't I have to remove some of your code that allows the selection of the file?

VBA Code:
[CODE=vba]Sub SEND_OUTLOOK_CONF()
Dim oLook As Object
Dim oMail As Object
Dim FD As Object
Dim vrtSelectedItem As Variant
Dim strbody As String

    Set oLook = CreateObject("Outlook.Application")
    Set oMail = oLook.createitem(0)
    Set FD = Application.FileDialog(3)
    
    With oMail
        .SentOnBehalfOfName = "SALES RFBCORP"
        .To = Worksheets("DETAIL FORM").Range("F4")
        .cc = ""
        .HTMLBody = "See attached order confirmation. Your order will be released for production. Please notify us immediately if any changes are needed." & "<br/>" & "<br/>" _
                   & "Thank You" & "<br/>" & "<br/>" _
                   & "Friedland Brothers" & "<br/>" _
                   & "17 Industrial Drive" & "<br/>" _
                   & "Cliffwood Beach, NJ 07735" & "<br/>" _
                   & "732-290-9800" & "<br/>" _
                   & "sales@rfbcorp.com" & "<br/>" _
                   & "www.friedlandshades.com"
        .Subject = "Friedland Confirmation" & " " & "PO " & Worksheets("DETAIL FORM").Range("B9").Value & ", S/M:" & " " & Worksheets("DETAIL FORM").Range("B8").Value
        
                FD.AllowMultiSelect = True
                FD.Filters.Clear
                FD.Filters.Add "All Files", "*.*"
                FD.InitialFileName = filePath = ActiveWorkbook.path & "\APDFQUOTES\"
                'filePath = ActiveWorkbook.path & "\APDFQUOTES\" & Worksheets("DETAIL FORM").Range("F15").Value & ".pdf"
                
                If FD.Show = True Then
       For Each vrtSelectedItem In FD.SelectedItems
       .Attachments.Add vrtSelectedItem
       
       Next
    End If
            
    .Display

    End With
    
    Set FD = Nothing
    Set oMail = Nothing
    Set oLook = Nothing
    
End Sub
[/CODE]
 

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,324
See if this works. Your file name needs to be in the cell listed in the code line :

ActiveWorkbook.path & "\PDFQUOTES\" & Range("A1").Value & ".pdf"

The above example is using cell A1. It can be any cell you want, but change the cell reference in the code line.
Also .... when listing the file name in the cell DO NOT include the period ( . ) and "pdf" at the end. The line of
code automatically includes these.

VBA Code:
Sub SEND_OUTLOOK_CONF()
Dim oLook As Object
Dim oMail As Object
Dim vrtSelectedItem As Variant
Dim strbody As String

    Set oLook = CreateObject("Outlook.Application")
    Set oMail = oLook.createitem(0)
       
    With oMail
        .SentOnBehalfOfName = "SALES RFBCORP"
        .To = Worksheets("DETAIL FORM").Range("F4")
        .cc = ""
        .HTMLBody = "See attached order confirmation. Your order will be released for production. Please notify us immediately if any changes are needed." & "<br/>" & "<br/>" _
                   & "Thank You" & "<br/>" & "<br/>" _
                   & "Friedland Brothers" & "<br/>" _
                   & "17 Industrial Drive" & "<br/>" _
                   & "Cliffwood Beach, NJ 07735" & "<br/>" _
                   & "732-290-9800" & "<br/>" _
                   & "sales@rfbcorp.com" & "<br/>" _
                   & "www.friedlandshades.com"
       
 .Subject = "Friedland Confirmation" & " " & "PO " & Worksheets("DETAIL FORM").Range("B9").Value & ", S/M:" & " " & Worksheets("DETAIL FORM").Range("B8").Value
       
                .Attachments.Add ActiveWorkbook.path & "\PDFQUOTES\" & Range("A1").Value & ".pdf"
      
     
    End If
            
    .Display

    End With
    
    Set FD = Nothing
    Set oMail = Nothing
    Set oLook = Nothing
    
End Sub
 
Solution

Shadkng

Active Member
Joined
Oct 11, 2018
Messages
301
See if this works. Your file name needs to be in the cell listed in the code line :

ActiveWorkbook.path & "\PDFQUOTES\" & Range("A1").Value & ".pdf"

The above example is using cell A1. It can be any cell you want, but change the cell reference in the code line.
Also .... when listing the file name in the cell DO NOT include the period ( . ) and "pdf" at the end. The line of
code automatically includes these.

VBA Code:
Sub SEND_OUTLOOK_CONF()
Dim oLook As Object
Dim oMail As Object
Dim vrtSelectedItem As Variant
Dim strbody As String

    Set oLook = CreateObject("Outlook.Application")
    Set oMail = oLook.createitem(0)
      
    With oMail
        .SentOnBehalfOfName = "SALES RFBCORP"
        .To = Worksheets("DETAIL FORM").Range("F4")
        .cc = ""
        .HTMLBody = "See attached order confirmation. Your order will be released for production. Please notify us immediately if any changes are needed." & "<br/>" & "<br/>" _
                   & "Thank You" & "<br/>" & "<br/>" _
                   & "Friedland Brothers" & "<br/>" _
                   & "17 Industrial Drive" & "<br/>" _
                   & "Cliffwood Beach, NJ 07735" & "<br/>" _
                   & "732-290-9800" & "<br/>" _
                   & "sales@rfbcorp.com" & "<br/>" _
                   & "www.friedlandshades.com"
      
 .Subject = "Friedland Confirmation" & " " & "PO " & Worksheets("DETAIL FORM").Range("B9").Value & ", S/M:" & " " & Worksheets("DETAIL FORM").Range("B8").Value
      
                .Attachments.Add ActiveWorkbook.path & "\PDFQUOTES\" & Range("A1").Value & ".pdf"
     
    
    End If
           
    .Display

    End With
   
    Set FD = Nothing
    Set oMail = Nothing
    Set oLook = Nothing
   
End Sub
Hi, thanks for the additional information. I removed 2 lines below which I think you left by mistake. Now it's working just right. Below is my latest revision. You might hear from me again if I need any tweaks. Much appreciated.

Set FD = Nothing
End if

***************************

VBA Code:
Sub SEND_OUTLOOK_CONF()

Dim oLook As Object
Dim oMail As Object
Dim vrtSelectedItem As Variant
Dim strbody As String

    Set oLook = CreateObject("Outlook.Application")
    Set oMail = oLook.createitem(0)
       
    With oMail
        .SentOnBehalfOfName = "SALES RFBCORP"
        .To = Worksheets("DETAIL FORM").Range("F4")
        .cc = ""
        .HTMLBody = "See attached order confirmation. Your order will be released for production. Please notify us immediately if any changes are needed." & "<br/>" & "<br/>" _
                   & "Thank You" & "<br/>" & "<br/>" _
                   & "Friedland Brothers" & "<br/>" _
                   & "17 Industrial Drive" & "<br/>" _
                   & "Cliffwood Beach, NJ 07735" & "<br/>" _
                   & "732-290-9800" & "<br/>" _
                   & "sales@rfbcorp.com" & "<br/>" _
                   & "www.friedlandshades.com"
       
 .Subject = "Friedland Confirmation" & " " & "PO " & Worksheets("DETAIL FORM").Range("B9").Value & ", S/M:" & " " & Worksheets("DETAIL FORM").Range("B8").Value
       
                .Attachments.Add ActiveWorkbook.path & "\APDFQUOTES\" & Worksheets("DETAIL FORM").Range("F15").Value & ".pdf"
                
    .Display

    End With
    
    Set oMail = Nothing
    Set oLook = Nothing
    
End Sub
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,403
Messages
5,769,865
Members
425,574
Latest member
grimeslisa

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
Top