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

Question

我一直在尝试在我的 Excel 工作表中创建两个按钮，允许用户使用 select 文件路径保存工作簿（作为新工作簿）和另一个按钮，然后使用各种单元格值创建一个新的 email 并附加新的保存的工作簿。 我可以创建 email，但它附上了原始文件的原始名称。 我创建了一个模块来根据各种单元格值保存新文件，但我一直收到运行时错误（见下文）。

这是我使用新创建的文件创建 email 的代码：

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

在我的代码中，我调用 SaveNewFile 模块来创建一个基于单元格值的新文件。 模块中的代码是：

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

当我单击按钮时，文件名没有正确保存，我收到运行时错误“1004”：无法访问消息（指的是文件名）。 当我取出模块并忽略该部分时，我可以生成一个 email 但主题不包含来自单元格的正确值，现在文件是否已重命名。 关于我如何能够做到这一点有什么想法吗？

---

添加更多详细信息：感谢您的回复，很抱歉花了这么长时间才回复。 我决定删除调用 function，因为我没有正确地来回发送变量，并决定将所有内容保留在一个主子中。 我更正了变量（我在粘贴到该站点之前进行了编辑，但没有正确命名所有变量），我的脚本现在将根本无法运行（以前我可以生成 email）。 我被告知 olMailItem 不是定义的变量，我不需要它是一个。 关于如何让脚本运行并创建正确的文件名的任何想法？

这是我正在使用的修改后的代码：

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

将 Word 文档保存到新位置时， Document.FullName属性不会更改。 因此，我建议将您的 sub 转换为 function ，它返回一个指向新保存文件的文件路径，因此该字符串将用于附加它：

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

所以，你的 main sub 可能看起来像这样：

'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