After doing a word merge to send a large number of emails I run this macro to add delay to each one so I don't exceed the allowed number of emails per hour.
It works fine except that it only processes 50% of the emails in the folder selected (Set ofldr = Session.PickFolder)
I am puzzeled can anybody help?
Sub AddDelayToEmails()
Dim mai As MailItem 'Object
Dim acct As Long
Dim Delay As Date, Start As Date
Dim UpdtCount As Integer
Dim FirstNm As String
Dim AddAttachment As Integer
Dim EmailsPerHour As Integer
Dim FolderCheck As Integer, FolderName As String
Dim EmailNo As Integer
Dim ofldr As Object
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.propertyAccessor
Const PR_SMTP_ADDRESS As String = "
http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
EmailNo = 1
MsgBox "Select Email Folder"
Set ofldr = Session.PickFolder
AddAttachment = MsgBox("Do You Want to Add an Attachment" & vbNewLine & vbNewLine & "z:\EPM Proposals\Roger D Miller Jr .vcf", vbYesNo + vbDefaultButton2)
EmailsPerHour = InputBox("How Many Emails Per Hour do you want to send?", , 30)
Delay = Now() + 3 / 24 ' + 1 ' / 24
Start = Delay
MsgBox Start
UpdtCount = 0
For Each mai In ofldr.Items
If mai.Class = olMail Then
With mai
' .CC = "mochs@quaillodge.com; salexander@axisonline.net;
mjohnston@axisonline.net; steven@hoodandassociates.n
et; MatthewOMALEY@peninsula.co
m"
.Importance = olImportanceHigh
' .ReadReceiptRequested = True
' .OriginatorDeliveryReportR
equested = True
' .Attachments.Add "J:\11 Jobs\11813 First Capital Bank CM - Arch Selection 300 Bonafacio\Project Manager\Hazardous Materials Survey RFP\11813 First Capital Bank CM - Arch Selection 300 Bonafacio Hazardous Material Survey RFP Drawings 09-19-2011.pdf", olEmbeddeditem
' .Subject = .Subject & String(UpdtCount, " ")
.DeferredDeliveryTime = Delay
.OriginatorDeliveryReportR
equested = True
'12-09-2014 .FlagRequest = "Follow-up"
'12-09-2014 .ReminderTime = Now + 14
'12-09-2014 .ReminderSet = True
'12-09-2014 .Subject = FirstNm & " Could you benefit from Facility Condition Assessment Consulting Services"
UpdtCount = UpdtCount + 1
If UpdtCount = EmailsPerHour Then
Delay = DateAdd("n", 60, Delay) ' adds 60 minutes
UpdtCount = 0
End If
EmailNo = EmailNo + 1
UserForm1.TextBox1 = EmailNo
UserForm1.TextBox2 = "Delay = " & Delay
UserForm1.Show vbModeless
DoEvents
.Send
' .Save
End With
End If
'+++++++++++++++++++++++++
+++===
''+++Sue Mosher 14-May-2003 17:45
''+++DeferredDeliveryTime takes a date/time value. (You can look these things up in Help -- in VBA,
''+++press F2 to get the object browser, select the property, then press F1.)
''+++You can use the DateAdd() function to add 15 minutes to the current date/time:
''+++dteThen = dateadd("n", 15, Now)
''+++objMail.DeferredDeliv
eryTime = dteThen
'+++++++++++++++++++++++++
+++===
Next
Unload UserForm1
MsgBox "Start = " & Start & vbNewLine & "End = " & Delay
End Sub