Problem with .send from microsoft example for vba send mail from excel code

[Mark Stephens]

I got the code below from:

http://support.microsoft.com/default.aspx/kb/213712/en-us

and when I run it it throws up an error at the very end saying 'Runtime
error 287 Application defined or object defined error':

.To = RecipientList
.Send
End With

Anyone have any idea why .send maight be causing a problem?

Thanks and regards, Mark




Sub SendOutlookMessages()

'Dimension variables.
Dim OL As Object, MailSendItem As Object
Dim W As Object
Dim MsgTxt As String, SendFile As String
Dim ToRangeCounter As Variant

'Identifies Word file to send
SendFile = Application.GetOpenFilename(Title:="Select MS Word " & _
"file to mail, then click 'Open'", buttontext:="Send", _
MultiSelect:=False)

'Starts Word session
Set W = GetObject(SendFile)

'Pulls text from file for message body
MsgTxt = W.Range(Start:=W.Paragraphs(1).Range.Start, _
End:=W.Paragraphs(W.Paragraphs.Count).Range.End)

'Ends Word session
Set W = Nothing

'Starts Outlook session
Set OL = CreateObject("Outlook.Application")
Set MailSendItem = OL.CreateItem(olMailItem)

ToRangeCounter = 0

'Identifies number of recipients for To list.
For Each xCell In ActiveSheet.Range(Range("tolist"), _
Range("tolist").End(xlToRight))
ToRangeCounter = ToRangeCounter + 1
Next xCell

If ToRangeCounter = 256 Then ToRangeCounter = 1

'Creates message
With MailSendItem
.Subject = ActiveSheet.Range("subjectcell").Text
.Body = MsgTxt

'Creates "To" list
For Each xRecipient In Range("tolist").Resize(1, ToRangeCounter)
RecipientList = RecipientList & ";" & xRecipient
Next xRecipient

.To = RecipientList
.Send
End With

'Ends Outlook session
Set OL = Nothing

End Sub

 

[JLGWhiz]

Try .SendMail

 

[Mark Stephens]

Thanks but unfortunately didn't make any difference, regards, Mark

 

[Ron de Bruin]

Hi Mark

Send to all E-mail addresses in a range and check if the mail address is correct.
Add the code below to the macro and change the To line to this: .To = strto

Dim cell As Range
Dim strto As String
For Each cell In ThisWorkbook.Sheets("Sheet1").Range("A1:A10")
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)

 

[TonyG]

run-time error 287

I was getting this error when I ran an automated job on the server, but was not getting it on my PC.

I resolved the issue by getting the address book on the server to match that on my PC.