Excel VBA 按钮根据单元格值保存工作簿并发送 email

Question

I have been trying to create two buttons in my Excel sheet that will allow the user to select the file path to save the workbook (as a new workbook) and another button that will then create a new email using various cell values and attach the newly saved workbook. I can get the email created, but it attaches the original document with the original name. I created a module to save a new file based on various cell values, but I kept getting a runtime error (see below).

Here is my code for creating an email with the newly created file:

Private Sub SendEmailButton_Click()

Dim OL          As Object
Dim EmailItem   As Object
Dim Doc

Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveWorkbook
On Error GoTo handler
    Doc.SaveAs
On Error GoTo 0

'Initialize varibles to store data pulled from Excel
Dim facname As Excel.Range, outputsize As Excel.Range, queueno As Excel.Range, CC1 As Excel.Range, ToAddress As Excel.Range, Pri1 As Excel.Range, Pri2 As Excel.Range

'Pull values from Excel and store in variables
Set facname = Sheet1.Range("Facility")
Set outputsize = Sheet1.Range("OutSize")
Set queueno = Sheet1.Range("QueueNum")
Set CC1 = Sheet1.Range("CCemail")
Set ToAddress = Sheet1.Range("emailrecipient")
Set Pri1 = Sheet1.Range("PrimaryContact")
Set Pri2 = Sheet1.Range("AlternateContact")

'Call module to set new filename
Call FileNameAsCellContent

'Create email from application information within workbook
With EmailItem
    .Display
    .Subject = "Small Site - " & queueno & " " & facname & " Customer Application for Billing" & vbCrLf
    .Body = "Business Center, " & vbCrLf & vbCrLf & _
    "Please find attached the Application for Billing to set up the account for a " & outputsize & "facility called" & _
    " " & facname & ". The queue number assigned to this project is " & queueno & "." & vbCrLf & vbCrLf & _
    "INSERT SIGNATURE HERE"
    
'Update recipients based on user data from workbook:
    .To = ToAddress
    .CC = CC1 & "; " & Pri1 & "; " & Pri2
    .Attachments.Add Doc.FullName
    
End With
    
Application.ScreenUpdating = True

Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
    
'*********************************************************************************************************************************************************
' Error Handling for Error 5155. Note, when Excel VBA attempts to Save/SaveAs a read-only document, error 5155 is obtained. This code ignores that error.
'*********************************************************************************************************************************************************
Exit Sub
handler:
    If Err.Number = 5155 Then
        Resume Next
    Else
        MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
        Exit Sub
    End If
    
End Sub

Within my code I call on the SaveNewFile module to create a new file based on cell values. The code in the module is:

Sub FileNameAsCellContent()

Dim FileName As String
Dim Path As String

Application.DisplayAlerts = False

Path = filePath

FileName = "Customer Information Request for Billing " & queueno & " " & facname & ".xlsx"

ActiveWorkbook.SaveAs Path & FileName, x1OpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close

End Sub

When I click the button the file name does not save correctly and I get a Run-Time error '1004': Cannot Access message (referring to the filename). When I take out the module and ignore that part, I can generate an email but the subject does not contain the correct values from the cells now does the file get renamed. Any thoughts on how I might be able to accomplish this?

---

Adding more details: Thank you for your responses and sorry for taking so long to respond. I decided to remove the call function since I was not sending the variables back and forth correctly and decided to keep everything in one main sub. I corrected the variables (I edited before pasting into this site and didn't name all the variables correctly) and my script will now will not run at all (previously I could get an email to generate). I am being told the olMailItem is not a defined variable, which I do not need it to be one. Any idea on how I can get the script to run and create the correct file name?

Here is the revised code that I am using:

Option Explicit

Private Sub SendEmailButton_Click()

Dim OL          As Object
Dim EmailItem   As Object
Dim Doc
Dim FileName As String
Dim Path As String
'Initialize varibles to store data pulled from Excel
Dim facname As Excel.Range, outputsize As Excel.Range, queueno As Excel.Range, CC1 As Excel.Range, ToAddress As Excel.Range, Pri1 As Excel.Range, Pri2 As Excel.Range

Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveWorkbook
On Error GoTo handler
    Doc.SaveAs
On Error GoTo 0

'Application.GetSaveAsFilename InitialFileName:="Dominion Customer Information Request for Billing XX##### ProjName.xlsx"

'Pull values from Excel and store in variables
Set facname = Sheet1.Range("Facility_Name")
Set outputsize = Sheet1.Range("Output_Size")
Set queueno = Sheet1.Range("QueueNum")
Set CC1 = Sheet1.Range("CCemail")
Set ToAddress = Sheet1.Range("emailrecipient")
Set Pri1 = Sheet1.Range("PrimaryContact")
Set Pri2 = Sheet1.Range("AlternateContact")

'Application.DisplayAlerts = False

Path = Sheet1.Range("filePath")

FileName = "Customer Information Request for Billing " & queueno & " " & facname & ".xlsx"

ActiveWorkbook.SaveAs Path & FileName ', x1OpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close

'Create email from application information within workbook
With EmailItem
    .Display
    .Subject = "Generation - " & queueno & " " & facname & " Solar Customer Application for Billing" & vbCrLf
    .Body = "Business Center, " & vbCrLf & vbCrLf & _
    "Please find attached the Customer Application for Billing to set up the billing account for a " & outputsize & "MW solar facility called" & _
    " " & facname & ". The State Interconnection Queue number assigned to this project is " & queueno & "." & vbCrLf & vbCrLf & _
    "INSERT SIGNATURE HERE"
    
'Update recipients based on user data from workbook:
    .To = ToAddress
    .CC = CC1 & "; " & Pri1 & "; " & Pri2
    .Attachments.Add Doc.FullName
    
End With
    
Application.ScreenUpdating = True

Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
    
'*********************************************************************************************************************************************************
' Error Handling for Error 5155. Note, when Excel VBA attempts to Save/SaveAs a read-only document, error 5155 is obtained. This code ignores that error.
'*********************************************************************************************************************************************************
Exit Sub
handler:
    If Err.Number = 5155 Then
        Resume Next
    Else
        MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
        Exit Sub
    End If
    
End Sub

Answer 1

The Document.FullName property is not changed when you save a Word document to a new location. So, I'd suggest converting your sub into a function which returns a file path which points to the newly saved file, so this string will be used for attaching it:

Function FileNameAsCellContent() As String

Dim FileName As String
Dim Path As String

Application.DisplayAlerts = False

Path = filePath

FileName = "Customer Information Request for Billing " & queueno & " " & facname & ".xlsx"

ActiveWorkbook.SaveAs Path & FileName, x1OpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close

Return Path & FileName

End Function

So, you main sub could look like that:

'Create email from application information within workbook
With EmailItem
    .Display
    .Subject = "Small Site - " & queueno & " " & facname & " Customer Application for Billing" & vbCrLf
    .Body = "Business Center, " & vbCrLf & vbCrLf & _
    "Please find attached the Application for Billing to set up the account for a " & outputsize & "facility called" & _
    " " & facname & ". The queue number assigned to this project is " & queueno & "." & vbCrLf & vbCrLf & _
    "INSERT SIGNATURE HERE"
    
'Update recipients based on user data from workbook:
    .To = ToAddress
    .CC = CC1 & "; " & Pri1 & "; " & Pri2
    'Call module to set new filename
    .Attachments.Add FileNameAsCellContent
    
End With