Question

我有一个代码，我一直在使用它通过命令按钮点击自动发送电子邮件给工作簿。我尝试重新格式化此代码以从工作簿中发送2张单独的表（命名为：Pass，Pass Screenshot），但我无法使其工作。发送电子邮件时，工作表将无法激活。这是我一直在使用的代码，非常感谢任何帮助：

Sub SendEmail()
ThisWorkbook.Save
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 = "my email"
.Subject = "my subject" & Date
.Attachments.Add '???

.Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Answer 1

Attachments.Add方法采用文件路径参数，您无法重新配置它以发送工作表（或工作表数组）对象。你可以做的是将这两张纸张导出到一个新的/临时文件，作为附件发送，然后删除/删除不再需要的临时文件。

Sub SendEmail()

Dim OutApp As Object
Dim OutMail As Object
Dim tempWB as Workbook
Dim tempFile as String
Dim wb as Workbook

tempFile = Environ("Temp") & "\sheets_copy.xlsx"

Set wb = ThisWorkbook
wb.Save
' The Sheets.Copy method will create a new workbook containing the copied sheets
wb.Sheets(Array("Pass", "Pass Screenshot")).Copy 
Set tempWB = ActiveWorkbook

' ensure no temp wb already exists
' this can technically still fail if the file is open/locked
If Len(Dir(tempFile)) <> 0 Then
    Kill tempFile
End If
' Save & close the tempFile
tempWB.SaveAs tempFile
tempWB.Close

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

On Error Resume Next
With OutMail
.to = "my email"
.Subject = "my subject" & Date
.Attachments.Add tempFile '## Add your attachment here
.Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

EXCEL：Attachments.Add for Individual Sheets

1 个答案: