I had a special request from a user who wanted to automate sending messages on a schedule. He tried using a macro to send a message written in a task when the reminder fires but his messages included hyperlinks and the formatting was messed up in the conversion from RTF (in the task body) to HTML in the email. He asked if there was a way to create the drafts, with the send date in the subject, then use a macro to send the messages.
The answer is in the macro below.
This macro assumes the messages are in the Drafts folder with a subject line in the format of "201503050900 intended message subject" where 201503050900 is the date and time the message should be released, in yyyymmddhhmm format. The macro compares the current time to the time represented in the subject and if the current time is greater, strips the time from the subject and sends the message.
To send the messages, you need to run the macro or use the do something when a reminder fires macro (or another macro) to trigger this macro.
Because the macro is not constantly running and checking the folder, messages may not be sent at the exact time in the subject. If you need messages sent at a specific time, use the deferred message setting instead.
Public Sub SendDrafts()
Dim olApp As Outlook.Application
Dim NS As Outlook.NameSpace
Dim DraftsFolder As Outlook.MAPIFolder
Dim Drafts As Outlook.Items
Dim DraftItem As Outlook.MailItem
Dim sDate As Variant
Dim sSubject As Variant
Dim lDraftCount As Long
Set olApp = Outlook.Application
Set NS = olApp.GetNamespace("MAPI")
Set DraftsFolder = NS.GetDefaultFolder(olFolderDrafts)
Set Drafts = DraftsFolder.Items
sDate = Format(Now, "yyyymmddhhmm")
'Loop through all Draft Items
For lDraftCount = Drafts.Count To 1 Step -1
Set DraftItem = Drafts.Item(lDraftCount)
sSubject = Left(DraftItem.Subject, 12)
If sDate > sSubject Then
DraftItem.Subject = Right(DraftItem.Subject, Len(DraftItem.Subject) - 12)
'Send Item
DraftItem.Send
End If
Next lDraftCount
'Clean-up
Set DraftsFolder = Nothing
Set NS = Nothing
Set olApp = Nothing
End Sub
Trigger the macro using a task
To trigger the macro when a task reminder fires and reset the reminder, create a task and assign the category "draft mail". Then put the following macro in ThisOutlook Session.
Do not dismiss the task!
Private Sub Application_Reminder(ByVal Item As Object) If Item.MessageClass <> "IPM.Task" Then Exit Sub End If If Item.Categories <> "draft mail" Then Exit Sub End If ' run it every 30 minutes Item.ReminderTime = Now() + 0.02083 Item.Save ' call macro SendDrafts End Sub
How to use macros
First: You will need macro security set to low during testing.
To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.
After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To put the code in a module:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
To use the macro code in ThisOutlookSession:
- Expand Project1 and double click on ThisOutlookSession.
- Copy then paste the macro into ThisOutlookSession. (Click within the code, Select All using Ctrl+A, Ctrl+C to copy, Ctrl+V to paste.)
More information as well as screenshots are at How to use the VBA Editor
Henry says
Hi,
I like your macro idea.
I was wondering if you can program something like this also in Microsoft Power Automate, so that the automatic flow will take care of this even if my computer is shut down.
The benefit would be, that the prepared emails will be automatically send out even if computer is switched off. Everything will happen in the cloud.
What do you think?
Whitney says
Hi-
I would like a scheduled a draft email to forward when a recurring task fires. (One example, I have a task set to go off every two weeks to email managers and remind them to approve timecards, which I have saved as a draft email that I just forward so a copy stays in the drafts.) I tried modifying the code, but it's not working. I've done macros in Excel, but not in Outlook so I'm a bit lost. Can you please help?
Diane Poremsky says
what modification did you make? does it do anything?
This sends based on the date in the subject, but it sounds like you could use just a subject filter. Instead of this:
sSubject = Left(DraftItem.Subject, 12)
If sDate > sSubject Then
DraftItem.Subject = Right(DraftItem.Subject, Len(DraftItem.Subject) - 12)
use this:
if DraftItem.Subject = "Do the time cards!!!"
' send
or use this method at https://www.slipstick.com/developer/send-email-outlook-reminders-fires/ where the message body is in the appointment item (you can change it to use a task) - or use it to bring up a template, which can be pre-addressed to the recipients.
If tasks doesn't have a field you can use to store addresses, you could put them in the body, something like
|to| a@b.com; b@b.com
and pull the addresses out using a functions or regex.
(FWIW, the big difference between outlook vba and excel vba is that outlook doesn't have a macro recorder to get you started and it has a bunch of different windows - excel has workbooks, worksheets and cells... outlook has the main outlook window, selected items, open items... and new items, all with a bunch of fields. Once you get past that, it's all VBA. :))
Dom says
Hi Diane,
I modified your code so that all the items in the draft folder are counted and only 98 are sent. Then using your unmodified macro code set up as a task which should loop through every 30 minutes and send the second batch of 98 draft emails. When the task fires, it takes 98 draft emails and sends them, but it never repeats. Can you see what I am doing wrong in the code below?
Public Sub SendDrafts()Dim olApp As Outlook.Application
Dim NS As Outlook.NameSpace
Dim DraftsFolder As Outlook.MAPIFolder
Dim Drafts As Outlook.Items
Dim DraftItem As Outlook.MailItem
Dim lDraftCount As Long
Set olApp = Outlook.Application
Set NS = olApp.GetNamespace("MAPI")
Set DraftsFolder = NS.GetDefaultFolder(olFolderDrafts)
Set Drafts = DraftsFolder.Items
'Loop through all Draft Items
lstNumber = Drafts.Count - 97
If lstNumber < 1 Then
lstNumber = 1
End If
For lDraftCount = Drafts.Count To lstNumber Step -1
Set DraftItem = Drafts.Item(lDraftCount)
'Send Item
DraftItem.Send
Next lDraftCount
'Clean-up
Set DraftsFolder = Nothing
Set NS = Nothing
Set olApp = Nothing
End Sub
Dom Fino says
Thank you for this code. I modified it to suit my needs but have one question. I want to limit the sent emails to 99. Send them then wait the 30 minutes and send the next 99 until all the draft emails are send.
I tried changing this line but it did not work.
For lDraftCount = Drafts.Count To 99 Step -1
Set DraftItem = Drafts.Item(lDraftCount)
Dom Fino says
I use Access 2016 to send email with attachments to about 500 members. Access creates the email and sends it to the DRAFT folder in Outlook. Will the modified code below take the first 99 emails in DRAFT and send them. Then wait 30 minutes and take the next 99 emails in Draft and send them, until all the DRAFT folder emails are sent?
Public Sub SendDrafts()Dim olApp As Outlook.Application
Dim NS As Outlook.NameSpace
Dim DraftsFolder As Outlook.MAPIFolder
Dim Drafts As Outlook.Items
Dim DraftItem As Outlook.MailItem
Dim lDraftCount As Long
Set olApp = Outlook.Application
Set NS = olApp.GetNamespace("MAPI")
Set DraftsFolder = NS.GetDefaultFolder(olFolderDrafts)
Set Drafts = DraftsFolder.Items
'Loop through all Draft Items
For lDraftCount = Drafts.Count To 99 Step -1
Set DraftItem = Drafts.Item(lDraftCount)
'Send Item
DraftItem.Send
End If
Next lDraftCount
'Clean-up
Set DraftsFolder = Nothing
Set NS = Nothing
Set olApp = Nothing
End Sub
Dom Fino says
This is outstanding. I have an access data base that generates email to 500 members with attachments and sends the emails to the Draft folder in Outlook 2016.. I want to modify your code to only send the first 99 emails then pause for 30 minutes and resume to task taking the next 99 emails and send them etc.
I think I can modify your code to do this by eliminating some lines and changing a few others.
`Public Sub SendDrafts()
Dim olApp As Outlook.Application
Dim NS As Outlook.NameSpace
Dim DraftsFolder As Outlook.MAPIFolder
Dim Drafts As Outlook.Items
Dim DraftItem As Outlook.MailItem
Dim lDraftCount As Long
Set olApp = Outlook.Application
Set NS = olApp.GetNamespace("MAPI")
Set DraftsFolder = NS.GetDefaultFolder(olFolderDrafts)
Set Drafts = DraftsFolder.Items
'Loop through all Draft Items
For lDraftCount = Drafts.Count To 99 Step -1
Set DraftItem = Drafts.Item(lDraftCount)
'Send Item
DraftItem.Send
Next lDraftCount
'Clean-up
Set DraftsFolder = Nothing
Set NS = Nothing
Set olApp = Nothing
End Sub
Dan says
Dear Diana,
The following line gives an error when a message is being saved in Drafts with no subject line:
DraftItem.Subject = Right(DraftItem.Subject, Len(DraftItem.Subject) - 12)
I used the On Error Resume Next statement, but it does not work out.
Diane Poremsky says
the if line should tell the macro to skip it if the subject doesn't include the date field. oh, i bet it's not seeing the date as a number and it's greater than nothing.
use this after Set DraftItem line to kick it out of the subject is less than 12 (and therefore, doesn't have a date in the subject)
If Len(DraftItem.Subject) < 12 Then GoTo NextlDraftCountmake this change so it jumps to the next message NextlDraftCount: Next lDraftCount
Dan says
I am getting "Label is not defined" error.
Diane Poremsky says
it highlights this : GoTo NextlDraftCount ?
did you add NextlDraftCount: before Next lDraftCount?
End If
NextlDraftCount:
Next lDraftCount
Dan says
Dear Diana,
The code runs just great. May I ask if there a way to may this reminder Private Sub Application_Reminder(ByVal Item As Object) invisible? It flashes for a second or two and then disappears. I tried to use Application. ScreenUpdating = False but it did not work. Statement Item.Display = False gives error. Please advise.
Diane Poremsky says
Screen updating false is Excel-only. You can dismiss the reminder and create a new task. The beforeremindershow event should eliminate the flash. The code sample at https://www.slipstick.com/developer/code-samples/running-outlook-macros-schedule/ shows how to dismiss reminders and recreate appointments - the same process would work for tasks.
If the task ran once day (or you used a series of tasks), you could use recurring tasks - mark the task complete (using .Complete) so the next one is generated.
Dan says
Dear Diana,
Not sure how to use beforeremindershow event. Attemped Event.Beforeremindershow=False and this statement give an error. Also tried the combination Private Sub Application_Reminder_BeforeReminderShow(ByVal Item As Object, Cancel As Boolean) and this also did not work out.
Diane Poremsky says
See https://www.slipstick.com/developer/code-samples/running-outlook-macros-schedule/ - the macro on the page uses the event. You just need the olRemind_BeforeReminderShow sub (and the withevents that goes with it)
Dan says
Dear Diana,
Alas, can you please give me more clue how to compile it? I tried to use olRemind_BeforeReminderShow sub, but it does seem to be working with Private Sub Application_Reminder(ByVal Item As Object)? Can you please give me hint how to combine them?
Diane Poremsky says
you need the private withevents line, the beforeremindershow sub and this much of the app reminder macro:
Private Sub Application_Reminder(ByVal Item As Object)
Set olRemind = Outlook.Reminders
End Sub
Tip: if you don't use the if caption line (or something similar to identify the correct reminder), the oldest reminder is dismissed, not the one that just fired.
Penny Goss says
Hello,
I have been a fan and user of MS Office products since the late 90's. I have used Outlook for many generations of the product. Now I am finding that in Microsoft's "wise" decision is to make changes that are not in line with past products. Why?
My 89 year old father recently upgraded from Windows 7 to Windows 10 and along with that updated from Office 2010 to Office 2016/365.
He's constantly struggling to understand the remarkable changes in Outlook 2016 and why the *** Microsoft decided to make such "radical" changes in their product(s) when they, according to him, have been working so well for so many years. He understands and realizes he is NOT the only person struggling with this issue.
One such issue is as he is struggling with is Outlook outgoing email, While writing an outgoing email Outlook suddenly shuts down then re-opens back to the screen he where he was writing the original email. However the message box is now empty. POOF! It's gone! All the text is gone.
He has found that the message he was writing has been saved as a "Draft". However, when he goes into "Drafts" to complete the message, the "Send" button is grayed out, therefore he is unable to send the message. This ANGERS him. He wants to know why this happened and why isn't he allowed to finish the email. Then the screen disappears, reappears and the message is "Poof!" gone!
I am not looking forward to the day I "have" to update because Microsoft decides to "retire" Windows 7 and make it "mandatory" for users to upgrade to Windows 10.
Please clearly and concisely, step by step explain this process so I may explain why this is happening. I welcome your input and feedback! Of course if you prefer to attempt to explain this to him yourself and would like to deal with his crispy attitude you are welcome to it.
Diane Poremsky says
There is something causing it to shut down... I'll see what I can find out. I seem to recall a couple of other people mentioning it but don't recall if it was fixed in an update. updates should be installed automatically about once a month, but double check and see if any are available (if you haven't already).
On the draft problem, is this an imap account?
PickNick says
When the Task reminder pops up on the screen, the Application_Reminder event does not seem to run again anymore. So for me this works only as a one time event.
Diane Poremsky says
Are you using one recurring task or multiple tasks? Recurring tasks need to be marked complete, not dismissed.
Rupert Symss says
We need to add the following line of code after the code "Item.ReminderTime = Now() + 0.02083". Adding this line of code completes the loop and fires the code every 30 minutes.
Item.Save