Sending emails with Outlook from Excel

[OssieMac]

Office XP (2002) Professional

I am having problems with sending emails from Excel 2002 via Outlook. After
the code has run a number of times then there are multiple processes of
OUTLOOK.EXE in Task Manager. This occurs when Outlook is not already open. If
Outlook is already open and GetObject works then no problem. However, if not
open and uses CreateObject then it works for a while then eventually brings
the system down.

Below are 2 demo Subs. The first is the problem code and then below that is
my workaround that works fine because it requires Outlook to be already open.
However, I would like to know if perhaps my first sub can be improved to
overcome my problem.

Sub SendEmail_1()
'This code creates multiple processes of OUTLOOK.EXE in
'Task Manager if Outlook is not already open.

Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim bolCreate As Boolean

On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number > 0 Then
On Error GoTo 0
Set objOutlook = CreateObject("Outlook.Application")
bolCreate = True
End If
On Error GoTo 0

Set objMail = objOutlook.CreateItem(olMailItem)

With objMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "My Test email"
.Body = "Test message only"
.Send
End With

Set objMail = Nothing
If bolCreate Then
objOutlook.Quit 'Only quit if previously not open.
End If
Set objOutlook = Nothing

End Sub

'********************************

Sub SendEmail_2()
'This code works fine but it requires Outlook to be already open.

Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem

On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number > 0 Then
On Error GoTo 0
MsgBox "Outlook must be open before you can send emails." _
& vbCrLf & vbCrLf & _
"Open Outlook then re-run the code."
Exit Sub
End If
On Error GoTo 0

Set objMail = objOutlook.CreateItem(olMailItem)

With objMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "My Test email"
.Body = "Test message only"
.Send
End With

Set objMail = Nothing
Set objOutlook = Nothing

End Sub

 

[Ron de Bruin]

I have this problem a long time ago and work on it with MS support and no solution

If you use the code from my site it is working if Outlook is open or closed
http://www.rondebruin.nl/sendmail.htm

 

[OssieMac]

Hello Ron,

Thank you for your response. I actually got my original info from your site
and even reverting back to exactly your code, I am still having the same
problems.

However, I have since been doing some more testing. I have an internet
activity monitor and I believe with the use of that, I might have identified
the real issue.

The internet service being used is mobile broadband over the mobile
telephone network. It is not very fast (512mbps max). Everything works fine
if there is sufficient delay between sending the emails to allow one to
completely send before starting another Outlook Process. However, if internet
activity is still taking place when another email is sent, then the previous
one still appears to complete the send but the Outlook process never closes
and I suspect that this is the reason for the multiple Outlook processes.

My workaround of testing if Outlook is open then requesting the User to open
Outlook if it is not already open and use the GetObject code works fine
because Outlook is not being closed so no multiple instances and the emails
simply sit in the Outbox until sent. However, I have improved on that and now
I test if Outlook is open and if not open, then use code to open it with a
Default folder visible and not close it again. All future use of Outlook then
uses GetObject so no multiple instances.

Closing Outlook is left to the user and if they attempt to close it with
unsent messages then they get the usual alert message with a choice to close
or not.

My code below. So far my testing indicates that it is working fine. Feel
free to comment (including adversely if you think there are inherent problems
with it).

Sub SendEmail()

'This code opens Outlook if not already open.
'It does not close Outlook and uses GetObject
'for future call to Outlook.

Dim objOutlook As Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objMail As Outlook.MailItem

On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number > 0 Then
On Error GoTo 0
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
'Following line not required if Outlook has saved logon details
'objNameSpace.Logon "Default Outlook Profile", , False, True
objNameSpace.GetDefaultFolder(olFolderInbox).Display
End If
On Error GoTo 0

Set objMail = objOutlook.CreateItem(olMailItem)

With objMail
.To = "(e-mail address removed)" 'Not a valid address
.CC = ""
.BCC = ""
.Subject = "My Test email"
.Body = "Test message only from Excel Automation"
'.Display
.Send 'If Display used then don't use Send
End With

Set objMail = Nothing
Set objNameSpace = Nothing
Set objOutlook = Nothing

'Without the following line Outlook folder
'remains on top as the Active window.
'Don't use if Display used.
AppActivate "Microsoft Excel"

End Sub