Inserting a Range into an Outlook Appointment

Jesse asks:

In VBA, how do I add a range of cells to the body of an appointment?

Unlike email, the AppointmentItem does not have an HTMLBody property. If it did, then I would convert the range to HTML and use that property. Formatted text in the body of an AppointmentItem is Rich Text Format (RTF). I don’t know of any good ways to convert a range to RTF. Sure, you could learn what all the RTF codes are and build the string to put into the RTFBody property of the AppointmentItem. Then you could go to the dentist for a no-novocaine root canal. I’m not sure which of those would be more fun.

A better way is to programmatically copy the range and paste it into the body of the appointment. Since Office 2007, almost every Outlook object allows you to compose in Word. That’s an option I quickly turn off, but it’s still there under the hood. We’ll use that to our advantage. But first, let’s set up some data. Here I have a Table in Excel with some sample data.

To create a new appointment with this range in the body, I used this code:

Be sure to set a reference to the Microsoft Outlook 1x.x Object Library (VBE – Tools – References). The code produces this happy customer.

The code creates an appointment and fills in some properties, like Start, End, and Subject. The Excel Table is copied to the clipboard ready to be pasted into the appointment. Before we can get to the AppointmentItem’s WordEditor, we have to display it. That’s why the .Display method comes before the paste operation.

The last bit is to paste the range. Starting with an AppointmentItem, we have to get the Inspector object, then the WordEditor object, then a Window object, and finally we can use the PasteAndFormat method on the Selection object. Gool ol’ Word where everything is a Selection object.

This code simply displays the appointment, you will need the .Save method, .Close method, or .Send method if you want to automate any of that.

Creating an Appointment in Outlook 2010 Installation

Creating an Appointment in Outlook 2010
Creating an Appointment in Outlook 2010 Part II

You can download MGoogleCal.zip

Here are the steps to install the code.

  1. Download the zip file from the link above
  2. Unzip the four files and make a note of where they are
  3. Open Outlook 2010
  4. Press Alt+F11 to open the VBE
  5. Press Ctrl+R to show the Project Explorer

    Yours will no doubt look different than mine, but you should have a project called VbaProject.OTM.

  6. Right click anywhere in that project and choose Import File…
  7. Import the two .bas files and the one .frm file (you have to do them all separately)

  8. Edit (thanks Steffan): Choose Tools – References from the menu and add a reference to Microsoft VBScript Regular Expressions 5.5
  9. Choose Debug – Compile from the VBE menu
  10. Choose File – Save VbaProject.OTM from the VBE menu
  11. Close the VBE
  12. Right click on the Ribbon and choose Customize Quick Access Toolbar
  13. Choose Macros from the Choose commands from: dropdown
  14. Add MakeGoogleAppointment to the Customize Quick Access Toolbar listbox

  15. Press Alt+4 to open the form. My icon is fourth on the QAT so Alt+4 will run the macro. Yours may be in a different spot, so use the number for your situation. If you just press Alt, you’ll see the numbers on the QAT.
  16. Create an appointment

  17. Click OK

  18. And you’re done.

Important: Don’t forget this is mostly untested. Install at your own risk. And let me know what doesn’t work.

Creating an Appointment in Outlook 2010 Part II

Yesterday I posted about replicating how you can enter an item on Google’s calendar in Outlook. Today, we’ll look behind the form to see what’s going on. I won’t cover every piece of code, but you can download the code to see all of it. Let’s start with the Initialize event. In the entry point procedure, I set the When property in certain situations. In the Initialize method, I populate the narrative textbox if When already has a value.

Public Sub Initialize()

If Me.When <> 0 Then
Me.tbxNarrative.Text = Format(Me.When, "h:mm am/pm") & Space(1)
End If

End Sub

If the user has already made some sort of selection on a calendar, this saves having to type it. Changing the narrative textbox also fires an event that is the bulk of the code in the form. Let’s take a look at that now.

Private Sub tbxNarrative_Change()

Dim rxNarrative As VBScript_RegExp_55.RegExp
Dim rxMatches As VBScript_RegExp_55.MatchCollection
Dim dtTimeEntered As Date
Dim sMeridian As String

Set rxNarrative = New VBScript_RegExp_55.RegExp
rxNarrative.Pattern = RegExPattern
rxNarrative.IgnoreCase = True

Me.lbxAppointment.Clear
If rxNarrative.test(Me.tbxNarrative.Text) Then
Set rxMatches = rxNarrative.Execute(Me.tbxNarrative.Text)
With rxMatches.Item(0) 'there's only one match, all the capture groups are submatches of it

'Get AM or PM
sMeridian = GetAMPM(.SubMatches(0), .SubMatches(1))
dtTimeEntered = ConvertStringToTime(.SubMatches(0), sMeridian)

'Account for time zones
Me.When = Me.Day + ConvertTimeToLocal(dtTimeEntered, .SubMatches(2))
Me.What = .SubMatches(3)

'Default to 1 hour duration if not entered
If Len(.SubMatches(5)) > 0 Then
Me.Duration = Val(.SubMatches(5))
Else
Me.Duration = 1 'hour
End If

If Len(.SubMatches(4)) > 0 Then
Me.Location = .SubMatches(4)
End If

End With

Me.tbxNarrative.BackColor = vbWhite
Else
Me.tbxNarrative.BackColor = vbYellow 'visual indicator that narrative doesn't work
End If

'Show the results
UpdateListbox

End Sub

You need to set a reference to the VBScript Regular Expressions 5.5 library. I put the regex pattern in a separate, private function to keep the code tidy. I’ll show that below. If the regex passes, I call Execute to get the matches, then use the Submatches to populate my form’s properties. I get either AM or PM via another function. Then I use that and yet another function to convert the time the user entered into a Date data type. That date gets converted based to the user’s local time. The Duration property is set to 1 hour if the user doesn’t enter a duration. The submatches are in this order

  1. The time, like 3 or 3:00
  2. Either AM, PM, or an empty string if the user didn’t specify
  3. The time zone – EST, EDT, CST, CDT, MST, MDT, PST, PDT, or an empty string if not specified. Definitely could increase these options at some point.
  4. The subject – text that follows the time and precedes either location or duration
  5. The location – text that follows space+at+space
  6. The duration = n.n hour(s) that follows space+for+space

To get AM or PM, I wrote a separate function that takes the time as a string and whatever the user entered for AM or PM if any. If the user entered AM or PM, that’s what’s returned. If not, I assume the time is between 7AM and 6PM.

Private Function GetAMPM(ByVal sTime As String, ByVal sAmpm As String) As String

Dim sReturn As String
Dim dtTime As Date

If Len(sAmpm) > 0 Then
sReturn = sAmpm
Else
dtTime = ConvertStringToTime(sTime, "AM")
If dtTime >= TimeSerial(7, 0, 0) And dtTime < TimeSerial(12, 0, 0) Then sReturn = "AM" Else sReturn = "PM" End If End If GetAMPM = sReturn End Function

This is a little goofy because it checks the time before any time zone shift. I considered applying the time zone shift first, and probably should have, but I didn't want to rewrite the time zone stuff, so I didn't. Maybe I'll fix that in the next version.

The GetAMPM function and the event procedure both use ConvertStringToTime, shown below. It uses the VBA.TimeValue function. TimeValue doesn't work with a single digit, so I append the ":00" if there's not already a colon in there. I also tack on the meridian. When I call it from GetAMPM, I always use AM because I don't know the meridian yet.

Private Function ConvertStringToTime(sTime As String, sMeridian As String) As Date

If InStr(1, sTime, ":") = 0 Then
ConvertStringToTime = TimeValue(sTime & ":00" & Space(1) & sMeridian)
Else
ConvertStringToTime = TimeValue(sTime & Space(1) & sMeridian)
End If

End Function

Once I have the meridian, I recall ConvertStringToTime with the proper value and store that in dtTimeEntered - this is what the user entered converted to a Date data type. The next step is to account for any time zone information entered by the user. I call ConverTimeToLocal, which uses a Windows API to get the users time zone. I got the time zone API from Chip's site.

Public Function ConvertTimeToLocal(ByVal dtTime As Date, ByVal sZone As String) As Date

Dim tzi As TIME_ZONE_INFORMATION
Dim tz As TIME_ZONE
Dim lGmtOff As Long

tz = GetTimeZoneInformation(tzi)

Select Case sZone
Case "EDT"
lGmtOff = -4
Case "EST", "CDT"
lGmtOff = -5
Case "CST", "MDT"
lGmtOff = -6
Case "MST", "PDT"
lGmtOff = -7
Case "PST"
lGmtOff = -8
Case vbNullString
lGmtOff = -tzi.Bias / 60
End Select

ConvertTimeToLocal = dtTime - (TimeSerial(0, tzi.Bias, 0) + TimeSerial(lGmtOff, 0, 0))

End Function

This basically converts the time to GMT, then to the users time. If the user didn't enter a time zone, Case vbNullString, the Bias (in minutes) is added and subtracted leaving the original time.

Everything else in the event procedure is just jamming submatches into properties. I turn the textbox backcolor yellow if the user enters something that the regex can't decipher. At the end of the procedure, all those properties I filled are displayed in a listbox with a call to UpdateListBox.

Private Sub UpdateListbox()

Me.lbxAppointment.AddItem "What: " & Me.What
Me.lbxAppointment.AddItem "Where: " & Me.Location
Me.lbxAppointment.AddItem "Starts at: " & Format(Me.When, "m/d/yyyy hh:mm")
Me.lbxAppointment.AddItem "Ends at: " & Format(Me.EndTime, "m/d/yyyy hh:mm")

End Sub

I created a separate EndTime property that adds the duration to the start time. The duration can be an integer or a decimal and I split that out in a VBA.TimerSerial function. That makes me better than Google.

Public Property Get EndTime() As Date

EndTime = Me.When + TimeSerial(Int(Me.Duration), (Me.Duration - Int(Me.Duration)) * 60, 0)

End Property

As promised, here's the function that holds the regex pattern. I split it out into an array so I could hopefully understand it six months from now.

Private Function RegExPattern() As String

Dim aPattern(1 To 11) As String

aPattern(1) = "^((?:1[0-2]|0?[1-9])(?::[0-5]\d)?)" 'time
aPattern(2) = "\s*" 'optional white space
aPattern(3) = "([ap]m)?" 'optional ampm
aPattern(4) = "\s*"
aPattern(5) = "([ECMP][DS]T)?" 'optional time zone
aPattern(6) = "\s*"
aPattern(7) = "(.*?" 'what
aPattern(8) = "(?=\s+for\s+|\s+at\s+|$))" 'look ahead for ' for ' or ' at '
aPattern(9) = "(?:\s+at\s+(.*?" 'where
aPattern(10) = "(?=\s+for\s+|$)))?" 'look ahead for ' for '
aPattern(11) = "(?:\s+for\s+(\d*(?:\.\d+)?)\s*hour)?" 'duration

RegExPattern = Join(aPattern, vbNullString)

End Function

That's probably enough code for one post. What you don't see, but you can download, is the property getters and setters for UserCancel, Location, When, What, Duration, and Day. There's also code for clicking OK and Cancel, which simply sets the UserCancel property and hides the form.

You can download MGoogleCal.zip

Tomorrow I'll post a couple of notes and some installation instructions if you want to give it a try.

Creating an Appointment in Outlook 2010

I got a new job about a year ago and I went from using Google’s calendar to Outlook. I’ve added some code to Outlook to handle emails a little more like GMail does, but one thing I’ve missed is the ability to add something to the calendar easily. According to Google, you can enter multiple properties of the appointment in one string like “7pm Dinner at Pancho’s” and it’s awesome.

It’s not perfect, though, so I didn’t want to just replicate the function, I wanted to improve it. For one, Google doesn’t deal with fractions of hours very well. Now I can type a narrative in a textbox and create an appointment.

And that opens a pre-filled appointment like this

I started trying to parse the text with a lot of Split() functions, but it quickly became cumbersome. Not impossible, just not very elegant. To be more fancy, I ignored this advice:

Some people, when confronted with a problem, think
“I know, I’ll use regular expressions.” Now they have two problems.

To be perfectly honest, nobody ever confused me with someone who could write regular expressions beyond the incredibly simple ones. But I gave it a go and eventually got some help from stackoverflow and from Rick Measham.

The rules go like this:

  • Start with a time. Can be 5, 5:00, 5pm, 5:00pm, 5 pm, 5 pm CST, 5pmPST and a bunch of other stuff
  • Then the subject or title of the appointment. Stop capturing when you get to " for " or " at " because those are keywords indicating other information.
  • If you get to " at ", everything after that is the location. Stop capturing when you get to " for ".
  • If you get to " for ", everything after that is the duration in hours.

The regex looks like this:
^((?:1[0-2]|0?[1-9])(?::[0-5]\d)?)\s*([ap]m)?\s*([ECMP][DS]T)?\s*(.*?(?=\s+for\s+|\s+at\s+|$))(?:\s+at\s+(.*?(?=\s+for\s+|$)))?(?:\s+for\s+(\d*(?:\.\d+)?)\s*hour)?

Simple, huh? I’ll wrap up this post with a discussion of the entry point procedure. Tomorrow, I’ll discuss the code behind the form.

Public Sub MakeGoogleAppointment()

Dim dtStart As Date
Dim dtDay As Date
Dim ufGoogle As UGoogle
Dim ai As AppointmentItem

'if the user is on a calendar, get the date and/or time
On Error Resume Next
dtDay = Int(Application.ActiveExplorer.CurrentView.SelectedStartTime)
dtStart = Application.ActiveExplorer.CurrentView.SelectedStartTime - dtDay
On Error GoTo 0

'if their not on a calendar, assume today
If dtDay = 0 Then
dtDay = Date
End If

'Get the rest of the string via a form
Set ufGoogle = New UGoogle
ufGoogle.Day = dtDay
ufGoogle.When = dtStart
ufGoogle.Initialize
ufGoogle.Show

'create the new appointment
If Not ufGoogle.UserCancel Then
Set ai = Application.CreateItem(olAppointmentItem)
ai.Start = ufGoogle.When
ai.Duration = ufGoogle.Duration * 60
ai.Subject = ufGoogle.What
ai.Location = ufGoogle.Location
ai.Display
End If

End Sub

The first section attempts to get whatever is selected if the user is looking at a calendar. The SelectedStartTime property returns a Date. It’s only the date portion if the user is on Month view (pretty much the only view I use). It includes both the date and time if the user is on a view that has times. The Int() function gets only the date by lopping off the time if it exists.

If the date is zero, then the user isn’t on a calendar view and I set the date to today.

Next, I instantiate a new userform, pass in some data via Property Let procedures, and run some setup code in an Initialize method.

Finally, if the user doesn’t click Cancel, a new AppointmentItem is created. The duration in my narrative is in hours, but Outlook’s Duration is in minutes, so I multiply by 60 to convert it. The new AppointmentItem is displayed for the user to add more information of change things.

Stop Replying to Yourself

In this edition of How to Make Outlook More Like GMail, I address the problem of replying to a message that you have sent. Inexplicably, Outlook creates a message addressed to you. That make sense from the standpoint that a reply to should be addressed to the sender. But then there’s the whole common sense thing. You know that thing where you wouldn’t send an email to yourself.

I’m a chronic reply-er to my own sent messages. I send a message to someone that omits some key information like, oh I don’t know, the attachment, and need to send a quick follow up.

In general, I need to monitor newly created email messages, see if they’re addressed to me, and then figure out to whom they should be addressed. That starts with creating an Inspectors variable declared WithEvents. The WithEvents keyword exposes the events of the object declared. In the ThisOutlookSession module:

Private WithEvents olInsp As Inspectors

Private Sub Application_Startup()

Set olInsp = Application.Inspectors

End Sub

Now by using the dropdown boxes at the top of the code module, I can select olInsp from the left and NewInspector (the only event for this type of object) from the right. I cobbled this next bit of code from various places, so not only will I not be giving proper attribution, but I don’t know what it all means either.

Private Sub olInsp_NewInspector(ByVal Inspector As Inspector)

Dim olMi As MailItem
Dim olParent As MailItem
Dim olRecip As Recipient

If Inspector.currentItem.Size = 0 And Inspector.currentItem.Class = olMail Then

Set olMi = Inspector.currentItem

If olMi.Recipients.Count = 1 Then
If olMi.Recipients.Item(1).Name = "Dick Kusleika" Then
Set olParent = FindParentMessage(olMi)

If Not olParent Is Nothing Then
olMi.Recipients.Remove 1

For Each olRecip In olParent.Recipients
olMi.Recipients.Add olRecip.Name
Next olRecip

olMi.Recipients.ResolveAll
End If
End If
End If
End If

End Sub

I’m not sure why (or if) I need to check that the size of the item is zero, but there it is. The second part of the If statement makes sure it’s email because an Inspector can hold any type of item. Next I check that there is only one Recipient and that it’s me. The FindParentMessage sub is shown below and it finds the message I’m replying to.

As long as everything works up to this point, I’m removed as the only Recipient and every recipient from the parent message is added. To find the parent message, I use the following code, which I borrowed from Sue Mosher. Sue says

The key to finding the parent message for a reply or forward is knowing that all messages in a conversation have the same ConversationTopic value, while the ConversationIndex is increased by 5 bytes with each exchange.

Function FindParentMessage(msg As Outlook.MailItem) As Outlook.MailItem

Dim sFind As String
Dim sIndex As String
Dim olFldr As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMi As Object

sIndex = Left$(msg.ConversationIndex, Len(msg.ConversationIndex) - 10)

If Application.ActiveInspector Is Nothing Then
Set olFldr = Application.ActiveExplorer.Selection.Item(1).Parent
Else
Set olFldr = Application.ActiveInspector.currentItem.Parent
End If

sFind = "[ConversationTopic] = " & Chr$(34) & msg.ConversationTopic & Chr$(34)

Set olItems = olFldr.Items.Restrict(sFind)

For Each olMi In olItems
If olMi.Class = olMail Then
If olMi.ConversationIndex = sIndex Then
Set FindParentMessage = olMi
Exit For
End If
End If
Next olMi

End Function

I could reply from an open message (ActiveInspector) or from a list of messages (ActiveExplorer) and I get the folder depending on which it was. I find all of the messages in that folder with the same ConversationTopic, then loop through them to determine which has the correct ConversationIndex.

And that’s it. Now when I reply to a message I’ve sent, it’s addressed properly.

Opening Outlook Attachments Redux

In Opening Outlook Attachments, I posted some code to open Outlook attachments using the keyboard. Now that I’m back using Outlook, I had to dig out the old code and put it to use. Of course I won’t be leaving well enough alone, but thanks for asking.

The last change I made was to refactor a lot of the code into separate procedures. When my procedure is bigger than one code pane, it’s time to refactor.

I was perfectly happy getting the last attachment on the list. If I had more than one attachment, I would resort to the mouse. I thought I could do better. I change the code so that successive calls opened each attachment in order. A static variable keeps my place. That meant that I needed to get a collection of valid attachments. I couldn’t just grab the last attachment that wasn’t hidden, I need to get them all. Here’s the main procedure:

Public Sub OpenAttachment()

Dim miItem As MailItem
Dim sFileName As String
Dim sPath As String
Dim olAtt As Attachment
Dim colValidAtts As Collection

Static lAtt As Long

sPath = VBA.Environ$("Tmp") & "\"
Set miItem = GetCurrentItem

If Not miItem Is Nothing Then
Set colValidAtts = GetValidAttachments(miItem)

If colValidAtts.Count > 0 Then
lAtt = CycleAttachments(lAtt, colValidAtts.Count)
Set olAtt = colValidAtts.Item(lAtt)

sFileName = olAtt.FileName
'delete just in case it exists from before
On Error Resume Next
Kill sPath & sFileName

If Err.Number <> 70 Then
On Error GoTo 0

olAtt.SaveAsFile sPath & sFileName
DisplayAttachment olAtt, sFileName, sPath
End If
End If
End If

End Sub

In English: Get the path to the Temp folder, get the current item (either open email or selected in a folder), collect the valid attachments, pick the next in the cycle, display it. Getting the current item didn’t change from the last version, it’s just in it’s own procedure now.

Public Function GetCurrentItem() As MailItem

Dim miReturn As MailItem

On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set miReturn = ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set miReturn = ActiveInspector.currentItem
End Select
On Error GoTo 0

Set GetCurrentItem = miReturn

End Function

Next, I collect the valid attachments. I have to check some MAPI property. I don’t understand MAPI properties fully, but I don’t need to to be able to copy stuff from the web. The error trapping is because this property isn’t True or False, rather it exists or it doesn’t.

Public Function GetValidAttachments(miItem As MailItem) As Collection

Dim colReturn As Collection
Dim olAtt As Attachment

Set colReturn = New Collection

For Each olAtt In miItem.Attachments
If Not AttIsHidden(olAtt) Then
colReturn.Add olAtt
End If
Next olAtt

Set GetValidAttachments = colReturn

End Function

Public Function AttIsHidden(olAtt As Attachment) As Boolean

On Error Resume Next
AttIsHidden = olAtt.propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x7FFE000B")
On Error GoTo 0

End Function

Once I have a collection of attachments, I pick the next one based on the value of lAtt (the static variable). It’s a reverse order progression, so if lAtt is 0 or 1, it picks the last attachments. Otherwise it decrements lAtt.

Public Function CycleAttachments(ByVal lAtt As Long, ByVal lCount As Long) As Long

Dim lReturn As Long

If lAtt <= 1 Or lAtt > lCount Then
lReturn = lCount
Else
lReturn = lAtt - 1
End If

CycleAttachments = lReturn

End Function

Another minor change I made was to check for Error 70 – permission denied. That means I already opened that attachment and it’s still opened. Finally, I display the attachment. This is where things get very imcompletish. Some people send me other emails as attachments. That’s a whole other ball game, so I have to check if the Attachment.Type is olEmbeddedItem. If it is, I display the item. If it’s embedded but not a MailItem, the whole thing blows up. There can be other types of embedded items. I might be able to simply cast miNew as Object and get away with it. But for now, it’s strongly type and will strongly fail if the embedded attachments is not mail. I’ll deal with that when it happens, but for now I don’t care enough.

If it’s not embedded, it’s opened in the same manner as the prior code.

Public Sub DisplayAttachment(olAtt As Attachment, sFile As String, sPath As String)

Dim oShell As Object
Dim miNew As MailItem

If olAtt.Type = olEmbeddeditem Then
Set miNew = Application.GetNamespace("MAPI").OpenSharedItem(sPath & sFile)
miNew.Display
Else
sFile = GetShortFileName(sPath & sFile)
Set oShell = CreateObject("WScript.Shell")
oShell.Run sFile
End If

End Sub

There’s one other problem with this code and that’s the static variable. It doesn’t get reset when a different email is opened. If I open one attachment of three, then use this code on a different email, it will open the second attachment rather than the last. The first email has three attachments, so the code will select the third. The next email has, say, four attachments. When the code runs again, lAtt will be 3, then changed to 2. The solution is to make lAtt a public variable and code up some event that resets it when a different email is active. Meh. It works well enough.

Blind Copy GoodTodo in Outlook

Not long ago, both my personal and business email was managed by Google. Those were the good old days. I had a consistent interface, and more importantly, consistent shortcut keys. Can you guess why I keep refreshing gmail? Now my work email is Outlook and Exchange.

I’ve been setting up some macros in Outlook to try to make it palatable. At least one advantage Outlook has over GMail is VBA. Mostly I can make it do whatever I want. Mostly.

Today I’m starting with an easy one. When I send an email that requires some follow up, I need to get it on GoodTodo. If you’re a GoodTodo user, you know how well it handles email. All I need to do is BCC one of several email addresses and GoodTodo handles the rest. I’m sure most GoodTodo users use the many email addresses GoodTodo offers – you can email to a specific date or a relative date in a variety of syntaxes – but I use today@goodtodo.com exclusively. I just find it easier to get it on today’s list and move it the next time I’m using the list.

To add today@goodtodo to an email I’m composing, I created this simple procedure.

Sub AddTodo()

Dim olMi As MailItem
Dim olRecip As Recipient

If TypeName(ActiveInspector.currentItem) = "MailItem" Then
Set olMi = ActiveInspector.currentItem

If Not olMi.Sent Then
olMi.BCC = "today@goodtodo.com"
End If
End If

End Sub

Pretty simple. Then I got to thinking (sometimes that happens). Maybe I would use some of the other email syntaxes if they were as handy as “today” is. All of my todo items go in one of a few spots: the specific day it’s due, today, tomorrow, this Saturday (I’d like to get it done this week, but it’s not critical), the last day of the month (I’d like to get it done someday, but let’s face it…). Every Saturday, my list grows and I’m forced to either push the items off another week, do them, or delete them. The same happens at the end of the month. It’s nice way for me to create the list items and encourage myself to review them on a regular basis.

OK, enough of that. With only a few relevant dates, I changed the code to cycle through them. This macro is on the QAT in the second position, so Alt+2 does the deed.

Sub AddTodo()

Dim olMi As MailItem
Dim olRecip As Recipient
Dim aBcc(1 To 4) As String
Dim i As Long

Const sDOMAIN As String = "@goodtodo.com"

aBcc(1) = "today"
aBcc(2) = "tomorrow"
aBcc(3) = "saturday"
aBcc(4) = Format(DateSerial(Year(Now), Month(Now) + 1, 0), "mmmmd")

If TypeName(ActiveInspector.currentItem) = "MailItem" Then
Set olMi = ActiveInspector.currentItem

If Not olMi.Sent Then
If Len(olMi.BCC) = 0 Then
olMi.BCC = aBcc(LBound(aBcc)) & sDOMAIN
Else
For i = LBound(aBcc) To UBound(aBcc)
If olMi.BCC = aBcc(i) & sDOMAIN Then
If i = UBound(aBcc) Then
olMi.BCC = aBcc(LBound(aBcc)) & sDOMAIN
Else
olMi.BCC = aBcc(i + 1) & sDOMAIN
End If
Exit For
End If
Next i
End If
End If
End If

End Sub

Nice little arrow anti-pattern there. And the result.