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
Bart Haarman says
In reply to Diane,
works!
Great and many thanks
CU
Bart
Bart Haarman says
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?
Diane Poremsky says
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 -
strCode = LCase(Item.Subject)Debug.Print strCode
' Set up the array
arrKey = Array("remote", "service", "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"
Debug.Print i, InStr(strCode, arrKey(i))
If InStr(strCode, arrKey(i)) Then
Bart Haarman says
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
Diane Poremsky says
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
Diane Poremsky says
>>
* 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.
Bart Haarman says
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 = LBound(arrKey) To UBound(arrKey)
'MsgBox "Item Processed", , "Message"
Debug.Print i, InStr(strCode, arrKey(i))
If InStr(LCase(strCode), arrKey(i)) Then
With Item
.Categories = arrCat(i)
.ReminderSet = True
.Save
End With
Exit Sub
End If
Next i
'set variable to check for location
strCode = LCase(Item.Location)
Debug.Print strCode
' Set up the array for locations to match
' Items in arrKey MUST be lowercase !!
arrKey = Array("remote sessie", "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"
Debug.Print i, InStr(strCode, arrKey(i))
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
*****
Issue remains:
* after starting Outlook the macro Application_Startup does not fire (no messagebox)
* workaround: start Application_Startup via button in Outlook ribbon.
Requested:
* possible reasons why macro does not for upon application start
Best regards,
Bart
Diane Poremsky says
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
Bart Haarman says
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
Diane Poremsky says
>>
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.
Diane Poremsky says
The macro in the attached file shows how to watch multiple folders for new items and use just one "working" macro.
Bart Haarman says
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.
Diane Poremsky says
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.
Bart Haarman says
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 :-)
Diane Poremsky says
Inactive addins should not be a problem - I have some inactive and macros work.
Thierry Dalon says
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.
Diane Poremsky says
You are trying to do something not supported. What is the full code?
Thierry Dalon says
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.
Chris Brown says
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
Diane Poremsky says
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
Dom says
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
Diane Poremsky says
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.
Rick R. says
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:
Private 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 olCalERP As RecurrencePattern
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") Then
dNewStartTime = DateAdd("h", 8, DateValue(olCalE.Start))
dNewStopTime = DateAdd("n", 30, dNewStartTime)
If olCalE.IsRecurring Then
With olCalE
Set olCalERP = olCalE.GetRecurrencePattern
With olCalERP
.StartTime = dNewStartTime
.EndTime = dNewStopTime
.Duration = 30
End With
.Categories = "Birthday or Anniversary"
.ReminderMinutesBeforeStart = 5760
.BusyStatus = 0
.Save
End With
Else
With olCalE
.Start = dNewStartTime
.End = dNewStopTime
.Duration = 30
.Categories = "Birthday or Anniversary"
.ReminderMinutesBeforeStart = 5760
.AllDayEvent = False
.BusyStatus = 0
.Save
End With
End If
End If
End If
Next
End Sub
Rick R. says
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") Then
dNewStartTime = DateAdd("h", 8, DateValue(olCalE.Start))
dNewStopTime = DateAdd("n", 30, dNewStartTime)
With olCalE
.Start = dNewStartTime
.End = dNewStopTime
.Duration = 30
.Categories = "Birthday or Anniversary"
.ReminderMinutesBeforeStart = 5760
.AllDayEvent = False
.BusyStatus = 0
.Save
End With
End If
End If
Next
End Sub
Jorgen says
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!
Diane Poremsky says
Is the macro in ThisOutlookSession? Automatic macros needs to be put there.
Justin says
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?
Diane Poremsky says
You can certainly change the category of the new appoint created using the code to copy appointments.
Jon says
Hi Diane,
This is a great resource! I am trying to automate some calendar view settings in Outlook (automatic view rules for appointments - View\Customize Current View\Automatic Formatting) How is this done thru VBA or Powershell?
Diane Poremsky says
You can apply a view to a folder using VBA but the ability to create a new view using VBA is limited. Many of the view properties are read-only.
https://msdn.microsoft.com/en-us/library/office/microsoft.office.interop.outlook.calendarview_members.aspx
MA says
Hi Diane...thanks for this. I am looking to do something similar in assigning a category to an appointment by setting up a button in the Calendar Tools ribbon. But what I would like it to do is: -
i) assign a category to the appt
ii) set the appt as private
iii) set the appt as free
How could the script above be modified to do that?
Thanks, MA
Diane Poremsky says
you need ot add these lines:
appt.BusyStatus = olfree
appt.Sensitivity = olPrivate
appt.categories = "cat1"
Maarten from Bangkok says
Thanks for your prompt reply.
It is for adding categories to mail(s) by using VBA.
The picker is too time consuming when you have many categories to choose from. I therefore plan to have various buttons for my projects.
Maarten from Bangkok says
Happy new year Diane,
Q:How is it done when you want to add > 1 (up to 5) categories to open and/or selected mails at once? Thanks for your feedback.
Diane Poremsky says
Using VBA or the Category picker? In the category picker, open the category dialog to to show All categories dialog. For VBA, use: Appt.Categories = "Completed;Something;Another Category;" & Appt.Categories
Mutterings from Africa says
Many thanks, that has worked fine - would never have worked it out myself, I was thinking it was just a couple of lines! Thanks again
Diane Poremsky says
Technically, it could be just one line - it depends if you want to restrict it to only open items, or only selected items. :) But using get current items allows it to work for either. And using the function lets you reuse the function in other macros.
Set HJ = Session.ActiveExplorer.Selection.Item(1) 'uses selected item
Set HJ = Session.ActiveInspector.CurrentItem 'uses item open and in focus
Mutterings from Africa says
If I wanted to just assign a category to a mail Item (not an appointment) that was on the screen could I use VBA to do this?
I've tried
Sub AddDLCategory()
Dim HJ As Object
HJ.Categories = "DL"
End Sub
All I want to do is assign the category "DL" to the open email
Any help appreciated, I'm really struggling with what I'm sure is a really simple task!
Diane Poremsky says
Assigning shortcuts might be easier... but yes, you can use VBA. You need to get the open or selected item - my code sample below uses the function at https://www.slipstick.com/developer/outlook-vba-work-with-open-item-or-select-item/ so it works with open or selected items, but you can change the set line to work only with open items.
Sub AddDLCategory()
Dim HJ As Object
Set HJ = GetCurrentItem()
HJ.Categories = "DL"
End Sub