Hello All,
I have a Macro that is largely doing what I need, but I would like to make the following changes to it.
- I would like the PDF to be saved in the same location as the Excel file it was created from. Currently it is asking me to select a location.
- I want to have it create a PDF of either the active worksheet or both the active and second worksheet based on the value in one specific cell. Currently it is only converting the active worksheet with no reference to any cell.
- If cell I16 equals either "New Install" or "Install" then the active sheet is converted along with worksheet 2 which is titled "Install Travel Lot" and emailed. The current macro names the PDF as the active worksheet which will always be worksheet 1 as that's where I have placed my Submit Button. I would like this to remain in place regardless of whether it's converting worksheet 2 or not.
- If cell I16 equals anything else, including remaining blank then only the active worksheet is converted and emailed. I16 currently contains a Data Validation List just in case that makes any difference
- The PDF is being named after the active worksheet. I would like the PDF to be named after the file name instead
Here is the current macro I have. It is fully functional with the exception of my wish list above. Thank you in advance for any help I may receive on this!
Code
Sub Saveaspdfandsend()
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
Dim xStr As String
Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"
'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 = ("[email protected]")
.Subject = xSht.Name + "-" + xStr + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else