A Slipstick.com visitor asked how to assign a category to his appointments automatically, as soon as they are over.
You can do this using a macro with a trigger, such as the meetings own reminder or the next appointment reminder, that will kick off the macro. The other option is to run a macro manually, such as at the end of the day.
If you don't assign color categories to any appointments, you can use a custom view to apply automatic formatting colors to old appointments. Category colors take precedence, so this method only works on non-categorized appointments and events.
This macro is triggered by an appointment reminder and checks all appointments with End times between Now and 3 days ago. If you don't restrict it to recent events, the macro will check every appointment, which could take several minutes. (I used 3 days to cover days when there are no appointments.)
To keep any existing categories, use Appt.Categories = "Completed;" & Appt.Categories or Appt.Categories = "Completed" to erase categories and replace them with the Completed category.
To use the Appointment start date, use Appt.Start < Now().
Set the category when a reminder fires
This macro code goes into ThisOutlookSession. When an appointment reminder fires, it runs. To run it when any reminder fires, remove the If... End If code block.
Private Sub Application_Reminder(ByVal Item As Object) If Item.MessageClass <> "IPM.Appointment" Then Exit Sub End If Dim Appt As Object Set Items = Session.GetDefaultFolder(olFolderCalendar).Items For Each Appt In Items On Error Resume Next If Appt.End < Now() And Appt.End> Now() - 3 Then Appt.Categories = "Completed;" & Appt.Categories Appt.ReminderSet = False Appt.Save End If Next Set Appt = Nothing End Sub
Set the category using a macro
This macro can be placed in a module or in ThisOutlookSession and assigned to a button on the ribbon or QAT for easy access.
If you want to make the change at the end of the day, you can run this macro to change all appointments with a start time before now.
Public Sub AddCategory() Dim Appt As Object Set Items = Session.GetDefaultFolder(olFolderCalendar).Items For Each Appt In Items On Error Resume Next If Appt.End < Now() Then With Appt .Categories = "Completed" .ReminderSet = False .Save End with End If Next Set Appt = Nothing End Sub
Using an ItemAdd macro to set the category
This macro is an ItemAdd macro and runs when a new event is added to your calendar.
It looks for words in the subject and sets a category based on the word. If the words you are looking for are also the Category name, you only need one array and would set the category using:
.Categories = arrCode(i)
This macro needs to be in ThisOutlookSession.
Private WithEvents calItems As Outlook.Items Private Sub Application_Startup() Dim olApp As Outlook.Application Dim olNS As Outlook.NameSpace Set olApp = Outlook.Application Set olNS = olApp.GetNamespace("MAPI") Set calItems = olNS.GetDefaultFolder(olFolderCalendar).Items End Sub Private Sub calItems_ItemAdd(ByVal Item As Object) Dim arrKey Dim arrCat strCode = Item.Subject ' Set up the array arrKey = Array("works", "test", "share", "word4", "word5") arrCat = Array("red", "blue", "green", "holiday", "vacation") ' Go through the array and look for a match, then do something For i = LBound(arrKey) To UBound(arrKey) If InStr(LCase(strCode), arrKey(i)) Then .Categories = arrCat(i) .ReminderSet = False .Save Exit Sub End If Next i End Sub
Use ItemAdd to watch multiple calendars
Like the previous macro, this macro is an ItemAdd macro and runs when a new event is added to your calendar. It "watches" the default calendar plus two subfolders of the default calendar.
Private WithEvents calFolder As Outlook.Folder Private WithEvents calItems As Outlook.Items Private WithEvents personalItems As Outlook.Items Private WithEvents familyItems As Outlook.Items Private Sub Application_Startup() Dim olApp As Outlook.Application Dim olNS As Outlook.NameSpace Set olApp = Outlook.Application Set olNS = olApp.GetNamespace("MAPI") Set calFolder = olNS.GetDefaultFolder(olFolderCalendar) Set calItems = calFolder.Items ' subfolders of default calendar Set personalItems = calFolder.Folders("Personal").Items Set familyItems = calFolder.Folders("Family").Items MsgBox "App Start Started" End Sub Private Sub calItems_ItemAdd(ByVal Item As Object) AddCategories Item End Sub Private Sub personalItems_ItemAdd(ByVal Item As Object) AddCategories Item End Sub Private Sub familyItems_ItemAdd(ByVal Item As Object) AddCategories Item End Sub Private Sub AddCategories(ByVal Item As Object) Dim arrKey Dim arrCat 'set variable to check for subject, drop to lower case strCode = LCase(Item.Subject) Debug.Print strCode ' Set up the array for subjects to match ' Items in arrKey MUST be lowercase !! arrKey = Array("remote sessie", "service call", "test") arrCat = Array("MyBusiness", "Service", "Test") ' Go through the array and look for a match, then do something For i = LBound(arrKey) To UBound(arrKey) 'MsgBox "Item Processed", , "Message" Debug.Print i, InStr(strCode, arrKey(i)) If InStr(strCode, arrKey(i)) Then With Item .Categories = arrCat(i) .ReminderSet = True .Save End With Exit Sub End If Next i End Sub
How to use the macros on this page
First: You need to have macro security set to the lowest setting, Enable all macros during testing. The macros will not work with the top two options that disable all macros or unsigned macros. You could choose the option Notification for all macros, then accept it each time you restart Outlook, however, because it's somewhat hard to sneak macros into Outlook (unlike in Word and Excel), allowing all macros is safe, especially during the testing phase. You can sign the macro when it is finished and change the macro security to notify.
To check your macro security in Outlook 2010 and newer, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, look 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.
Macros that run when Outlook starts or automatically need to be in ThisOutlookSession, all other macros should be put in a module, but most will also work if placed in ThisOutlookSession. (It's generally recommended to keep only the automatic macros in ThisOutlookSession and use modules for all other macros.) The instructions are below.
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 put 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
In reply to Diane,
works!
Great and many thanks
CU
Bart
Hi All,
found the macro code above for the following scenario:
Used code as it is now:
** start copy-paste **
Private WithEvents calItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set calItems = olNS.GetDefaultFolder(olFolderCalendar).Items
End Sub
Private Sub calItems_ItemAdd(ByVal Item As Object)
Dim arrKey
Dim arrCat
strCode = Item.Subject
' Set up the array
arrKey = Array("Remote Sessie", "Service Call", "Test")
arrCat = Array("MyBusiness", "MyBusiness", "MyBusiness")
' Go through the array and look for a match, then do something
For i = LBound(arrKey) To UBound(arrKey)
'MsgBox "Item Processed", , "Message"
If InStr(LCase(strCode), arrKey(i)) Then
With Item
.Categories = arrCat(i)
.ReminderSet = True
.Save
End With
Exit Sub
End If
Next i
End Sub
** end copy-paste **
I know the macro runs when a new calendar item is entered, however the IF statement results in FALSE so the category is not set...
Any suggestions?
If you do If InStr(LCase(strCode), arrKey(i)) = 0 Then, it works - so the problem is with the matching.
Oh shoot - took me longer to spot the problem than it should have :)
If InStr(LCase(strCode), arrKey(i)) Then
The array needs to be lower case.
This worked here -
Hi Diane,
*update*
The macro itself works like a charm. Ones it is started...
Issue now is that after start of Outlook the macro does not start...
Current status:
* Trust Center | Macro Settings | Enabel all
* I started from scratch with a new file VbaProject.OTM
* to be able the copy-paste the macro code creating a Class Module was mandatory
* copy-pasted macro code in ThisOutlookSession (as a result that code is also visible in the created Class Module, deleting the code thee will clear the ThisOutlookSession also)
* closed Outlook, saved VbaProject.OTM
* started Outlook, entering a calender item with subject test (see your reply above)
* result: category MyBusiness NOT set
* if and when I start the macro Application_Startup manually all works fine
Workaround could to set the Private Sub Application_Startup() statement to Public Sub Application_Startup() so I can adjust the ribbon and create a button for it, but as I understand it should be possible to have it all running at the start of Outlook...
Note: I do have multiple profiles set up, but I do not think that is an issue here.
Best regards
Bart
I'll take a look at it again.
If you need to restart a startup macro, use a stub and add it to a button. (Errors in other macros can kill startups.)
Sub RunStart()
Call Application_Startup
MsgBox "App Start Started"
End Sub
>>
* to be able the copy-paste the macro code creating a Class Module was mandatory
* copy-pasted macro code in ThisOutlookSession (as a result that code is also visible in the created Class Module, deleting the code thee will clear the ThisOutlookSession also)
<< Not sure I understand this... the entire macro should be in thisoutlooksession and you don't need a class module.
ref. your response "Not sure I understand this... the entire macro should be in thisoutlooksession and you don't need a class module": * starting with a clean VBA project it is not possible to copy-paste code into ThisOutlookSession (no window available) * only after adding a module (any type) the intended copy-paste action is possible * after the copy-paste into ThisOutlookSession it also show in the inserted dmodule * if the code in the module is deleted it also disappears from ThisOutlookSession Through some fiddeling I now have the following situation: 1. only section/module available is ThisOutlookSession 2. code: ***** Private WithEvents calItems As Outlook.Items Private Sub Application_Startup() Dim olApp As Outlook.Application Dim olNS As Outlook.NameSpace Set olApp = Outlook.Application Set olNS = olApp.GetNamespace("MAPI") Set calItems = olNS.GetDefaultFolder(olFolderCalendar).Items MsgBox "App Start Started" End Sub Private Sub calItems_ItemAdd(ByVal Item As Object) Dim arrKey Dim arrCat 'set variable to check for subject strCode = LCase(Item.Subject) Debug.Print strCode ' Set up the array for subjects to match ' Items in arrKey MUST be lowercase !! arrKey = Array("remote sessie", "service call", "test") arrCat = Array("MyBusiness", "MyBusiness", "MyBusiness") ' Go through the array and look for a match, then do something For i =… Read more Âğ
I'm not what you are doing wrong - but with a new VBA file, I don't have to do anything to use thisoutlooksession - https://www.screencast.com/t/l468txbY0e7
Hi Diane,
ah, I see: doubleclick on ThisOutlookSession. My bad :-)
Ok
1. closed Outlook
2. deleted the C:\Users\<username>\AppData\Roaming\Microsoft\Outlook\VbaProject.OTM file
3. started Outlook again
4. copy-pasted the code into ThisOutlookSession
Again: when starting the code via Run or via the Ribbon Button: no issues
But: when I close Outlook and start it again I can determine the code is not running as there is no message box.
Maybe it is of interest that I am using multiple calender categories where my 'personal' ones reside in the folder Calendar, whereas calendar items with non-personal categories (wife, kids, etc.) reside in a subfolder.
See screenshot
However: I tested this creating a calender item (Test) in on of the other calenders: no auto-assign category.
If you cannot find the reason for the code not auto-starting: I have this button in the ribbon as work-around.
But I am curious why it doe snot work as intended.
Note: I am on Office Profesional Plus 2021
Best regards
Bart
>>
Maybe it is of interest that I am using multiple calender categories where my 'personal' ones reside in the folder Calendar, whereas calendar items with non-personal categories (wife, kids, etc.) reside in a subfolder.
<< This is the problem - you are only watching the default calendar. Set calItems = olNS.GetDefaultFolder(olFolderCalendar).Itemsyou need to do that for each calendar - and have an item add for each - but the itemadds can be stubs that call the main macro, so you don't have to have a bunch of identical macros.Give me a few minutes and i'll post a text file with a sample.
The macro in the attached file shows how to watch multiple folders for new items and use just one "working" macro.
Hi Diane,
ok thx, that is a solution for a question not asked :-), but I will look into it.
Main issue is tsill there: any thoughts on why the macro does not auto-start?
Note: I do have multiple profiles defined, but one is stet to be default and used when starting Outlook. For *that* profile I have this macro in use.
The macro, as written for the default calendar folder, will work in every profile - but only on the default calendar folder because that is the folder it is watching. It will fail in other profiles if you include the code for the subfolders, unless the default calendar has those subfolders.
Does it set a categories on items in the default calendar in the profile? If so, there it is working.
Hi Diane,
*update on the issue that the code in ThisOutlookSession does not fire when Outlook is started
Searching for a possible cause I found this old forum thread where exactly this issue was solved:
* the code in ThisOutlookSession only fires after all add- ins have started
* I have multiple add-in available, not all of them activated.
* not sure whether inactive add-ins should be remove or that one or more of the enabled add-ins makes Outlook think its has not started yes
Solution:
* add the startup parameter /autorun <any macroname> to the Outlook link
Note: the macro <any macroname> does not have to exist at all...
Resuly at the moment:
* code in ThisOutlookSession is fired :-)
Inactive addins should not be a problem - I have some inactive and macros work.
I get an error when trying to set a category for a recurring AppointmentItem: The object does not support this method.
On line oItem.Categories = sCat
I would love to hear if you have a workaround for this case.
You are trying to do something not supported. What is the full code?
I have found a solution to this issue and shared it here: https://tdalon.blogspot.com/2021/12/outlook-vba-auto-categorize-by-domain.html#point6
Thanks for your sharing and support.
In the "Using an ItemAdd macro to set the category" I had to add "Item" in front of where you set the ,Category, .Reminder, and .Save for this to wor
Thanks for noticing that -
the With lines are missing - you either need them or use the object name on each.
If InStr(LCase(strCode), arrKey(i)) Then
With item
.Categories = arrCat(i)
.ReminderSet = False
.Save
end with
Exit Sub
This just doesn't seem to work for m - gives no errors but just doesn't assign the "PA" category ??
Private WithEvents calItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set calItems = olNS.GetDefaultFolder(olFolderCalendar).Items
End Sub
Private Sub calItems_ItemAdd(ByVal Item As Object)
Dim arrKey
Dim arrCat
strCode = Item.Subject
' Set up the array
arrKey = Array("_Personal Appointment")
arrCat = Array("PA")
' Go through the array and look for a match, then do something
For i = LBound(arrKey) To UBound(arrKey)
If InStr(LCase(strCode), arrKey(i)) Then
With Item
.Categories = arrCat(i)
.ReminderSet = False
.Save
End With
Exit Sub
End If
Next i
End Sub
is that the only category you are adding?
It's the Case. You are using lcase for the subject in the search but have proper case in the arrkey.
FWIW, I think I have found my own solution. The issue was *recurring* appointments. (Some of the items were, some were not.)
In case it helps anyone, here is the code that finally did the trick:
I've reviewed multiple threads about updating calendar items, and I have a VBA SUB that looks like it should work just fine; it's pretty straightforward. My calendar syncs with an application that turned all of my birthday and anniversary items into all-day events. When I turned that off (with an earlier version of this code), they were all set for 0 minutes at midnight; I'm trying to set them all for 30 minutes at 8am. However, certain key properties - Start, and End in particular - return an error stating that "The object does not support this method" (emphasis mine). There is no start method, so I'm confused. My code worked just fine, though, to change the category. Your examples here don't show me anything that would explain this. Sub FixBDDates() Dim myOLApp As Outlook.Application Dim myNamespace As NameSpace Dim olCalFolder As Outlook.Items Dim olCalEs As Outlook.Items Dim olCalE As Outlook.AppointmentItem Dim dNewStartTime As Date Dim dNewStopTime As Date Set myOLApp = CreateObject("Outlook.Application") Set myNamespace = myOLApp.GetNamespace("MAPI") Set olCalFolder = myNamespace.GetDefaultFolder(olFolderCalendar).Items Set olCalEs = olCalFolder olCalEs.Sort "[Subject]", False For Each olCalE In olCalEs If olCalE.Class = olAppointment Then If (Right(olCalE.Subject, 11) = "'s Birthday") Or (Right(olCalE.Subject, 14) = "'s Anniversary")… Read more Âğ
This thread comes close to solving my problem, but not quite: I would like a macro that automatically assigns categories to appointments (that I create, not invitations) on the basis of words in the subject. Any suggestions?
I have found one VBA script that does this (https://www.experts-exchange.com/questions/25072154/How-to-automatically-assign-categories-to-calendar-appointments-in-Outlook-based-on-simple-rules-on-the-subject.html#answer26411907). However, the opening line "Dim WithEvents olkCalendar As Outlook.Items" produces an error. (It is shown in read, and the Macro does not seem to run).
I would be very grateful for any suggestions!
Is the macro in ThisOutlookSession? Automatic macros needs to be put there.
Let me start by saying you've been amazingly helpful!
That said, I'm looking to copy everything that gets added to one calendar (Cal 1), onto a new and separate one (Cal 2) (which you outline in ) EXCEPT for the content in the body of the appointment itself, (which contains private info not to be shared outside work group).
Also want 'Cal 2' to automatically get assigned a Category (which I will then use to send an email when a reminder fires up ( as you outlined in ). Am I right in trying to combine the two MACROS?
You can certainly change the category of the new appoint created using the code to copy appointments.