使用Excel 2010 vba打开Outlook并发送电子邮件

Question

In the below excel 2010 vba I am trying to send an email if outlook is closed. I do get the confirmation that the email was sent but nothing gets sent. If outlook is opened there is no problem, but it may not always be. Thank you :).

Option Explicit
Private Sub CommandButton21_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim oOutlook As Object

On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0

If oOutlook Is Nothing Then
    Set oOutlook = CreateObject("Outlook.Application")
End If


strbody = "Hi xxxx," & vbNewLine & vbNewLine & _
          "There are 4 reports ready" & vbNewLine & _
          "Regards" & vbNewLine & vbNewLine & _
          "xxxxx xxxxx"

On Error Resume Next
With OutMail
    .To = "xxxxx@xxxxxxx.com"
    .CC = ""
    .BCC = ""
    .Subject = "data"
    .Body = strbody
    '.Attachments.Add ("C:\test.txt")
    .Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

' Confirm that the email(s) has/have been sent
    MsgBox "The data has been emailed sucessfully.", vbInformation

End Sub

Answer 1

Following code opens outlook...

Application.ActivateMicrosoftApp xlMicrosoftMail
Application.Wait(Now + TimeValue("00:00:03"))

Answer 2

Try a different test. Err.Number is likely 429 ActiveX component can't create object.

On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0

If Err.Number <> 0 Then
    Set oOutlook = CreateObject("Outlook.Application")
End If

Maybe this:

Set oOutlook = Nothing

On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0

If oOutlook Is Nothing Then
    Set oOutlook = CreateObject("Outlook.Application")
End If