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