to many e-mails



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
'NOTE: To actually send the emails, use .Send instead of .Display
End With
End If
MyTimer = Timer
Loop While Timer - MyTimer < 0.03
Application.StatusBar = "Progress: " & x & " of 25: " & Format(x / 25,
Next x
Application.StatusBar = False
End Sub

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question