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
