我一直在尝试在Excel工作表中创建两个按钮，允许用户选择文件路径以保存工作簿(作为新工作簿(，另一个按钮将使用各种单元格值创建新电子邮件并附加新保存的工作簿。我可以创建电子邮件，但它附加了具有原始名称的原始文档。我创建了一个模块来保存基于各种单元格值的新文件，但我一直收到运行时错误(见下文(。
以下是我用新创建的文件创建电子邮件的代码：
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"：无法访问消息(指文件名(。当我取出模块并忽略该部分时，我可以生成一封电子邮件，但主题不包含单元格中的正确值，现在文件会被重命名。有没有想过我该如何做到这一点？
添加更多详细信息：感谢您的回复，很抱歉花了这么长时间才回复。我决定删除调用函数，因为我没有正确地来回发送变量，并决定将所有内容都保留在一个主sub中。我更正了变量(我在粘贴到这个网站之前进行了编辑，没有正确命名所有变量(，我的脚本现在根本无法运行(以前我可以收到一封电子邮件来生成(。我被告知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
文档。将Word文档保存到新位置时，FullName属性不会更改。因此，我建议将您的sub转换为一个函数，该函数返回指向新保存文件的文件路径，因此此字符串将用于附加它：
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
所以，你的主潜艇可能看起来像这样：
'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