Question

基本上，我想在Excel工作表上提交宏按钮后发送电子邮件。然后它将当前工作表的电子邮件发送到我的一个电子邮件地址。

我尝试研究一下这是否是旧代码，但是没有运气

Public Sub Export()

    a = MsgBox("Are you sure you want to save & submit the report?", vbYesNo + vbQuestion)

    If a = vbYes Then

        Dim OutApp As Object
        Dim OutMail As Object
        Dim sTo As String: sTo = "health-safety@example.com"

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

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

        If Dir("\\dpfbhfap003\DP-CLD-Shares\CLD-Health and Safety\", vbDirectory) = "" Then
            ThisWorkbook.SaveAs "C:\Users\" & Environ("UserName") & "\Desktop\FARA - " & shtAssess.Range("sLoc") & " - " & Format(shtAssess.Range("sDate"), "yyyymmdd") & ".xlsm"

            On Error Resume Next
                With OutMail
                    .To = sTo
                    .CC = ""
                    .BCC = ""
                    .Subject = ThisWorkbook.Name
                    .Body = "User did not have access to the ""\\dpfbhfap003\DP-CLD-Shares\CLD-Health and Safety\02_FARA\"" folder when exporting the file, so was unable to save a copy there."
                    .Attachments.Add ThisWorkbook.FullName
                    .Send
'                    .Display
                End With
            On Error GoTo 0

        Else
            ThisWorkbook.SaveAs "\\dpfbhfap003\DP-CLD-Shares\CLD-Health and Safety\02_FARA\FARA - " & shtAssess.Range("sLoc") & " - " & Format(shtAssess.Range("sDate"), "yyyymmdd") & ".xlsm"

            On Error Resume Next
                With OutMail
                    .To = sTo
                    .CC = ""
                    .BCC = ""
                    .Subject = ThisWorkbook.Name
                    .Body = ""
                    .Attachments.Add ThisWorkbook.FullName
                    .Send
        '            .Display
                End With
            On Error GoTo 0
        End If

        Set OutMail = Nothing
        Set OutApp = Nothing

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With

        a = MsgBox("Report has been successfully saved and emailed.", vbOKOnly + vbInformation, "Complete")

    End If

End Sub

说

“运行时错误'425'” ActiveX组件无法创建对象

然后突出显示此代码

Set OutApp = CreateObject("Outlook.Application")

Answer 1

我能够成功运行您的代码而没有任何问题。我看不到任何与代码相关的问题。

请确保已安装并更新了Excel和Outlook，如果尚未阅读错误代码，请检查此链接。 https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/activex-component-can-t-create-object-or-return-reference-to-this-object-error-4

Answer 2

您需要这样的东西。

Sub Mail_workbook_Outlook_1()

    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 = "email1@gmail.com"
        .CC = "email2@gmail.com"
        .BCC = ""
        .Subject = "Environmental Reporting"
        .body = "Hi," & vbNewLine & vbNewLine & "Please find attached the report." & vbNewLine & vbNewLine
        .Attachments.Add ActiveWorkbook.FullName

        .Display
    End With
    Kill Template

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

错误Excel宏发送工作表的电子邮件代码

2 个答案: