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

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.

R3uK R3uK · Accepted Answer · 2015-04-15T13:30:30

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), "[email protected];[email protected]", , , 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           '"[email protected];[email protected]"
      .cc = CCdest            '"[email protected];[email protected]"
      .bcc = CCIdest          '"[email protected];[email protected]"
      .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

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

1 Answers