Merging two Excel VBA Code (Save as PDF + Send Via Outlook) - excel

Question

kindly I have a two VBA codes one is to save the printed area as PDF with the same name as the workbook is and save file location is Desktop and it works fine
and I do have another code which start outlook new message and take some specific cell value as subject and another value as body.
The problem is I want the code of the new mail to attach that saved PDF file from code 1 and make the subject to be same as PDF file name.
The save pdf code is:
Sub Save_as_pdf()
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
s(0) = "C:\Users\" & Environ("UserName") & "\Desktop\" & ThisWorkbook.Name
If FSO.FileExists(ThisWorkbook.FullName) Then
'//Change Excel Extension to PDF extension in FilePath
s(1) = FSO.GetExtensionName(s(0))
If s(1) <> "" Then
s(1) = "." & s(1)
sNewFilePath = Replace(s(0), s(1), ".pdf")
'//Export to PDF with new File Path
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=sNewFilePath, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Else
'//Error: file path not found
MsgBox "Error: this workbook may be unsaved. Please save and try again."
End If
Set FSO = Nothing
End Sub
... and the second outlook new email code is :
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Sub SendEMail()
Dim Email As String, Subj As String
Dim Msg As String, URL As String
Email = " "
Subj = "P.O # " & "-" & Cells(9, 5) & "-" & Cells(15, 2) & "-" & Cells(15, 8) & Cells(15, 7)
Msg = " "
Msg = "Dear Mr. " & vbCrLf & vbCrLf & "Good Day" & vbCrLf & vbCrLf & "Kindly find the attahched P.O to be delivered to " & Cells(10, 12)
'Replace spaces with %20 (hex)
Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")
'Replace carriage returns with %0D%0A (hex)
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")
'Create the URL
URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg
'Execute the URL (start the email client)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus
'Wait two seconds before sending keystrokes
'Application.Wait (Now + TimeValue("0:00:02"))
'Application.SendKeys "%s"
End Sub
I hope I could clarify my problem fine.
Thanks in advance.

Answer 1

You can try this :
It changes the PDF export to a function to get the file path and use it as an argument in the other one.
URL method doesn't works with attachments, so below is some code for Outlook(edited to contain the whole code)
Preparing mail with Outlook (sorry for french comments):
Sub Send_To_Pdf()
Dim PdfPath As String
Dim BoDy As String
BoDy = Msg = "Dear Mr. " & vbCrLf & vbCrLf & "Good Day" & vbCrLf & vbCrLf & "Kindly find the attahched P.O to be delivered to " & Cells(10, 12)
PdfPath = Save_as_pdf
EnvoiMail Right(PdfPath, InStr(1, StrReverse(PdfPath), "\") - 1), "recepient1#domain.com;recepient2#domain.com", , , BoDy, 1, PdfPath
End Sub
Public Function Save_as_pdf() As String
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
s(0) = "C:\Users\" & Environ("UserName") & "\Desktop\" & ThisWorkbook.Name
If FSO.FileExists(ThisWorkbook.FullName) Then
'//Change Excel Extension to PDF extension in FilePath
s(1) = FSO.GetExtensionName(s(0))
If s(1) <> "" Then
s(1) = "." & s(1)
sNewFilePath = Replace(s(0), s(1), ".pdf")
'//Export to PDF with new File Path
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=sNewFilePath, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Else
'//Error: file path not found
MsgBox "Error: this workbook may be unsaved. Please save and try again."
End If
Set FSO = Nothing
Save_as_pdf = sNewFilePath
End Function
Sub EnvoiMail(Subject As String, Destina As String, Optional CCdest As String, Optional CCIdest As String, Optional BoDyTxt As String, Optional NbPJ As Integer, Optional PjPaths As String)
Dim MonOutlook As Object
Dim MonMessage As Object
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.createitem(0)
Dim PJ() As String
PJ() = Split(PjPaths, ";")
With MonMessage
.Subject = Subject '"Je suis content"
.To = Destina '"marcel#machin.com;julien#chose.com"
.cc = CCdest '"chef#machin.com;directeur#chose.com"
.bcc = CCIdest '"un.copain#supermail.com;une-amie#hotmail.com"
.BoDy = BoDyTxt
If PjPaths <> "" And NbPJ <> 0 Then
For i = 0 To NbPJ - 1
'MsgBox PJ(I)
.Attachments.Add PJ(i) '"C:\Mes Documents\Zoulie Image.gif"
Next i
End If
.display
'.send '.Attachments.Add ActiveWorkbook.FullName
End With '?plusieurs?MonMessage.Attachments.Add "D:\Prof\Janvier\Base clients.mdb"
Set MonOutlook = Nothing
End Sub