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

Question

Basically, I want to send an email after I submit a macro button on the Excel worksheet. It will then send an email of the current worksheet to one of my email addresses.

I tried researching to see if this was a bit of old code but no luck

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

comes up saying

"Run-time error '425'" ActiveX component can't create object

and then it highlights this code

Set OutApp = CreateObject("Outlook.Application")

Answer 1

I was able to successfully run your code with no problems. I don't see anything code related that would be an issue.

Make sure Excel and outlook are installed and updated and check this link if you haven't already read up on the error code. 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

You need something like this.

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