I am trying to send several emails sequentially from Excel through Outlook.
Each has a different range from the same Worksheet as the body of the email.

Most of the code I am using is from Ron de Bruin’s site with some
modifications.

The problem is that I get different results from different PC’s and even
different results from the same PC when the task is repeated.

Issue 1: Most of the time the emails are sent to the Draft Folder in Outlook
and stay there for a few seconds or minutes and then are sent on their way.
Sometimes, the first of the emails (i.e. 1 of 3) goes to the senders Inbox
and has no “From” address. It never reaches the recipient. It also has no
Body content.

Issue 2: On some PC’s, the senders copy (in the sent folder) has no body
content but the recipient has the full email.

Issue 3: On one test, the recipients email body was not formatted correctly.
There were no borders and the text was misaligned.

Does anyone have a clue as to what is going on?

The desired result is supposed to be an email like this:

From: dnrouse@sbcglobal.net
To: <somebody in Manufacturing>
Subject: Need input to 1002-ProjectName.xls

In Body, the sentence is to print followed by a table with boirders:
We need the following for each item with a requested date but without an
email date.
Manufacturing Requested Completed Lead Time Emailed
1 Labor Estimate 7/8/2005 3

My code is as follows:

Sub Mail_With_Outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim objSafeMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As Range

'Start the process of emailing
‘<See if an email is to be sent to this Department using some code>
‘<If an email is to be sent Then>
‘<Select the range to be sent using some code>
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set OutApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set OutMail = OutApp.CreateItem(0)
strto = EmailTo
strsub = "Need input to " & myProject
Set strbody = Selection
With OutMail
.To = strto
.Subject = strsub
.Importance = olImportanceHigh
.FlagStatus = olFlagMarked
.FlagDueBy = Now + 2
.HTMLBody = _
"We need the following for each item with a requested date
but without an email date." _
& vbNewLine & RangetoHTML ‘See function below
End With

OutMail.Save
Set objSafeMail = CreateObject("Redemption.SafeMailItem")
objSafeMail.Item = OutMail
objSafeMail.Send

Set OutMail = Nothing
Set OutApp = Nothing

‘<End If>
‘<Select next Department>
Loop

‘<More code>
End Sub

Function RangetoHTML()
Dim fso As Object
Dim ts As Object
Dim TempFile As String
TempFile = Environ$("temp") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
source:=Selection.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function

Thank you for your assistance.

--
Don