to many e-mails

[Curt]

From book and net I've put the following together. It sends all right with
only 12 addresses on wks sheet. It sends 200 plus. I sure missed something.
This is first attemp at automation for e-mail. Some place it is repeating and
I am stumped.
Thanks to anyone

Heres what I've got

Sub SendEmail()
Dim x As Integer
Dim MyTimer As Double
'Change this loop as needed.
For x = 1 To 25
'Dummy Loop here just to waste time.
'Replace this loop with your actual code.
Dim OutlookApp As Object
Dim MItem As Object
Dim cell As range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Bonus As String
Dim Msg As String
'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
'Loop through the rows
For Each cell In Columns("K").Cells.specialcells(xlcelltypeconstants)
If cell.Value Like "*@*" Then
'Get the data
Subj = "Veteran's Day Parade"
Recipient = cell.Offset(0, -1).Value
EmailAddr = cell.Value
'Compose message
Msg = "Dear Participant:" & vbCrLf & vbCrLf
Msg = Msg & "I am pleased to inform you that" & vbCrLf & vbCrLf
Msg = Msg & "Your CD of Veteran's Day Parade Is available "
Msg = Msg & Bonus & vbCrLf & vbCrLf
Msg = Msg & "Dan Rupe" & vbCrLf
Msg = Msg & "Chairman"
'Create Mail Item and send it
Set MItem = OutlookApp.CreateItem(0)
With MItem
.To = EmailAddr
.subject = Subj
.Body = Msg
'.Display
'NOTE: To actually send the emails, use .Send instead of .Display
.Send
End With
End If
Next
MyTimer = Timer
Do
Loop While Timer - MyTimer < 0.03
Application.StatusBar = "Progress: " & x & " of 25: " & Format(x / 25,
"Percent")
DoEvents
Next x
Application.StatusBar = False
End Sub

 

[Ron de Bruin]

Hi Curt

See
http://www.rondebruin.nl/mail/folder3/message.htm

 

[Curt]

Thanks Much

Hi Curt

See
http://www.rondebruin.nl/mail/folder3/message.htm