Need help adding the file name as the subject in an email sent from Excel

[rkjudy]

I have a workbook that has a macro that creates a PDF of a certain sheet and attaches it to an email and opens Outlook ready for sending. Then, all i have to do is add the email address of the recipient and send it. As it is coded now, the Subject of the email is simply "New Equipment Quote". I would like for the Subject to be "New Equipment Order for" + Filename. For example, if the filename were ABC Company, the Subject would be "New Equipment Order for ABC Company". Here is my current code.

Sub RDB_Worksheet_Or_Worksheets_To_PDF_And_Create_Mail()
    Dim FileName As String
    
    Application.ScreenUpdating = False
    Application.Run ("GoToQuickQuote")

    If ActiveWindow.SelectedSheets.Count > 1 Then
        MsgBox "There is more then one sheet selected," & vbNewLine & _
               "be aware that every selected sheet will be published"
    End If

    'Call the function with the correct arguments
    'Tip: You can also use Sheets("Sheet3") instead of ActiveSheet in the code(sheet not have to be active then)
    'FileName = RDB_Create_PDF(ActiveSheet, "", True, False)
    
    'Determine if folde exists
   ' Dim fs As Object
    'Set fs = CreateObject("Scripting.FileSystemObject")
    'If fs.FolderExists("C:\Quick Quotes sent via eMail") Then
    

    'For a fixed file name and overwrite it each time you run the macro use
     FileName = RDB_Create_PDF(ActiveSheet, "C:\New Equipment Quote.PDF", True, True)

    If FileName <> "" Then
        RDB_Mail_PDF_Outlook FileName, "", "New Equipment Quote from East Texas Copy Systems", _
                             "Attached is a PDF containing a quote for the new equipment we discussed." _
                           & vbNewLine & vbNewLine & "Thanks." & vbNewLine & vbNewLine, False
    Else
        MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
               "Microsoft Add-in is not installed" & vbNewLine & _
               "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
               "The path to Save the file in arg 2 is not correct" & vbNewLine & _
               "You didn't want to 1overwrite the existing PDF if it exist"
    End If
    
End Sub




Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant

    'Test If the Microsoft Add-in is installed
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                                  Title:="Create PDF")

            'If you cancel this dialog Exit the function
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False we test if the PDF
        'already exist in the folder and Exit the function if that is True
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        'Now the file name is correct we Publish to PDF
        On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
        On Error GoTo 0

        'If Publish is Ok the function will return the file name
        If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
    End If
End Function



Function RDB_Mail_PDF_Outlook(FileNamePDF As String, StrTo As String, _
                              StrSubject As String, StrBody As String, Send As Boolean)
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = StrTo
        .CC = ""
        .BCC = ""
        .Subject = StrSubject
        .Body = StrBody
        .Attachments.Add FileNamePDF
        If Send = True Then
            .Send
        Else
            .Display
        End If
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Function

Can someone show me how to add the filename to the end of the Subject?

[Tinbendr]

.Subject = "New Equipment Order for " & left(FilenamePDF, Len(FileNamePDF) - 4)

[LJMetzger]

Hi rk,

Try the following (your other routines were untouched - you still need them):

Sub RDB_Worksheet_Or_Worksheets_To_PDF_And_Create_Mail()
    Dim FileName As String
    Dim sBaseFileNameWithoutPath As String
    Dim sSubject As String
    
    Application.ScreenUpdating = False
    Application.Run ("GoToQuickQuote")

    If ActiveWindow.SelectedSheets.Count > 1 Then
        MsgBox "There is more then one sheet selected," & vbNewLine & _
               "be aware that every selected sheet will be published"
    End If

    'Call the function with the correct arguments
    'Tip: You can also use Sheets("Sheet3") instead of ActiveSheet in the code(sheet not have to be active then)
    'FileName = RDB_Create_PDF(ActiveSheet, "", True, False)
    
    'Determine if folde exists
   ' Dim fs As Object
    'Set fs = CreateObject("Scripting.FileSystemObject")
    'If fs.FolderExists("C:\Quick Quotes sent via eMail") Then
    

    'For a fixed file name and overwrite it each time you run the macro use
     FileName = RDB_Create_PDF(ActiveSheet, "C:\New Equipment Quote.PDF", True, True)

    If FileName <> "" Then
        'Get the Base File Name without extension and without the path
        sBaseFileNameWithoutPath = LjmExtractBaseFileName(FileName)
    
        'Create the subject string
        sSubject = "New Equipment Order for " & sBaseFileNameWithoutPath
         
        RDB_Mail_PDF_Outlook FileName, "", sSubject, _
                             "Attached is a PDF containing a quote for the new equipment we discussed." _
                           & vbNewLine & vbNewLine & "Thanks." & vbNewLine & vbNewLine, False
    Else
        MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
               "Microsoft Add-in is not installed" & vbNewLine & _
               "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
               "The path to Save the file in arg 2 is not correct" & vbNewLine & _
               "You didn't want to 1overwrite the existing PDF if it exist"
    End If
    
End Sub

Public Function LjmExtractFullFileName(sPathAndName As String)
  'This extracts the file name (including the extension)
  
  Dim iPos As Integer
  
  iPos = InStrRev(sPathAndName, "\", Len(sPathAndName))
  If iPos > 0 Then
    LjmExtractFullFileName = Mid(sPathAndName, iPos + 1, Len(sPathAndName))
  Else
    LjmExtractFullFileName = sPathAndName
  End If
  
End Function

Public Function LjmExtractBaseFileName(sPathAndName As String)
  'This extracts the file name (without the extension)

  Dim iPos As Integer
  Dim sFullFileName As String
  
  sFullFileName = LjmExtractFullFileName(sPathAndName)
  
  iPos = InStrRev(sFullFileName, ".")
  If iPos > 0 Then
    LjmExtractBaseFileName = Mid(sFullFileName, 1, iPos - 1)
  End If

End Function

Lewis

[playaller]

--- Solved ---

[rkjudy]

The first solution provided above did cure the problem, but I guess I left out another key piece of information. I don't want to use a static FileName. I want the FileName to the be the name of the workbook at that time. So I guess I will need to adjust the statement that defines the FileName as static "New Equipment Quote" to where it will make the FileName the current name of the workbook. For example, if the name of the workbook at the time the email is created is "ABC Company", I want the FileName to be "ABC Company", so that the Subject will be "New Equipment Order for ABC Company". Any help?

[Tinbendr]

How about...

    'For a fixed file name and overwrite it each time you run the macro use
     'FileName = RDB_Create_PDF(ActiveSheet, "C:\New Equipment Quote.PDF", True, True)
     FileName = RDB_Create_PDF(ActiveSheet, ActiveSheet.Path & "\" & ActiveSheet.Name & ".PDF", True, True)

[rkjudy]

The FileName is changed (through another routine) every time the workbook is used. So, I don't want a fixed FileName. I want the FileName to be the CURRENT name of the workbook. Therefore the Subject will also also be correct. What do you think?

[rkjudy]

When using the code above:

 FileName = RDB_Create_PDF(ActiveSheet, ActiveSheet.Path & "\" & ActiveSheet.Name & ".PDF", True, True)

I get a Run-time error '438':
Object doesn't support this property or method.

Can someone help me with this issue?

[LJMetzger]

Try replacing 'ActiveSheet.Path' with 'ActiveWorkbook.Path'.

Lewis