将 ActiveWorkbook 作为电子邮件附件发送

Question

我的代码可以多次保存文件，第二次保存为 .xlsx 文件，以便在没有开发人员选项卡中的 VBA 代码的情况下向外部发送。

在测试中，当几个人尝试使用该文件时，它可以工作，但在当天晚些时候或第二天等情况下它不起作用，并且没有任何改变。我正在使用最新的 Office 套件。

在下面的代码中，xxx代表私人信息。

Sub SubmitRequest()

Dim OlApp As Object
Dim NewMail As Object
Dim sMsgBody As String

If IsEmpty(Worksheets("Data").Range("A8")) = True Then
    'Cell A8 is not blank
    MsgBox "xxx", vbOKOnly + vbQuestion
    
Else

    Application.ScreenUpdating = False
    
    ActiveWorkbook.Save
    'SaveAsXSLX() to remove code and send externally, works fine
    Worksheets(Array("xx", "xxx")).Copy
    ActiveWorkbook.SaveAs Filename:="xxx"
    Application.DisplayAlerts = True
      
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
    
    On Error Resume Next
    With NewMail
        .to = "xxx@xxx"
        .CC = "xxx@xxx"
        .ReplyRecipients.Add "xxx.xxx"
        .BCC = ""
        .Subject = "xxx@xxx"
        .Attachments.Add ActiveWorkbook.FullName

        sMsgBody = "Hi xxx," & vbCr & vbCr
        sMsgBody = sMsgBody & "xxx?" & vbCr
        sMsgBody = sMsgBody & "xxx," & vbCr & vbCr
    
        .body = sMsgBody
        .Send
        
        End With
    On Error GoTo 0

    Set NewMail = Nothing
    Set OlApp = Nothing
    
    Application.ScreenUpdating = True
   
    MsgBox "xxx" & Worksheets("Data").Range("H4").Value

    'Save and close request
    ActiveWorkbook.Close SaveChanges:=True
    Application.DisplayAlerts = False
    
    Application.Quit
    
End If
End Sub

Answer 1

每当使用多个工作簿时，请确保明确调用它们。例如在Worksheets("Data").Range("A8") 中，没有定义工作表Data 是在哪个工作簿中。所以 Excel 需要做出猜测，这就是它可能出错的地方。

如果您使用ThisWorkbook.Worksheets("Data").Range("A8")，那么您不会给 Excel 猜测的空间。

---

还要确保您知道以下 2 个语句之间的区别：

• ThisWorkbook 是编写代码的工作簿。这永远不会改变。
• ActiveWorkbook 是具有焦点的工作簿（位于顶部）。这将通过任何鼠标单击或其他任何改变焦点的方式轻松更改。

因此，我建议您在真正需要使用ActiveWorkbook 时确保将其设置为变量，以免用户单击或其他方式对其进行更改。

---

然后您的程序结束时有一个Application.Quit。这将关闭整个 Excel 应用程序。不确定这是否是您想要的。

---

考虑到所有这些，您的代码将如下所示：

Option Explicit

Public Sub SubmitRequest()
    If IsEmpty(ThisWorkbook.Worksheets("Data").Range("A8")) Then
        'Cell A8 is not blank
        MsgBox "xxx", vbOKOnly + vbQuestion
    Else
        Application.ScreenUpdating = False

        ThisWorkbook.Save
        'SaveAsXSLX() to remove code and send externally, works fine
        ThisWorkbook.Worksheets(Array("xx", "xxx")).Copy

        Dim NewWb As Workbook 'get the new workbook set to a variable so we fix it
        Set NewWb = ActiveWorkbook
        NewWb.SaveAs Filename:="xxx"
        Application.DisplayAlerts = True

        Dim OlApp As Object
        Set OlApp = CreateObject("Outlook.Application")

        Dim NewMail As Object
        Set NewMail = OlApp.CreateItem(0)

        On Error Resume Next
        With NewMail
            .to = "xxx@xxx"
            .CC = "xxx@xxx"
            .ReplyRecipients.Add "xxx.xxx"
            .BCC = ""
            .Subject = "xxx@xxx"
            .Attachments.Add NewWb.FullName

            Dim sMsgBody As String
            sMsgBody = "Hi xxx," & vbCr & vbCr & _
                       "xxx?" & vbCr & _
                       "xxx," & vbCr & vbCr
            .body = sMsgBody

            .Send
        End With
        On Error GoTo 0

        Set NewMail = Nothing
        Set OlApp = Nothing

        Application.ScreenUpdating = True

        MsgBox "xxx" & ThisWorkbook.Worksheets("Data").Range("H4").Value

        'Save and close request
        NewWb.Close SaveChanges:=True

        Application.DisplayAlerts = False

        Application.Quit 'this will quit Excel completely. Are you sure?
    End If
End Sub

最后，您应该考虑某种错误报告。因为现在如果在On Error Resume Next 和On Error GoTo 0 之间发生错误，您将永远不会注意到，因为所有错误都会被静音。因此，如果发生错误，它不会通知您，而是什么都不做。
查看VBA Error Handling – A Complete Guide。