Ошибка Excel Macro отправить код электронной почты на листе

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

Вам нужно что-то вроде этого.

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

Answer 2

Мне удалось успешно запустить ваш код без проблем. Я не вижу ничего похожего на код

Убедитесь, что 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