How to write to 'Categories' field using VBA
 

Hi there.

Overview:
I'm trying to analyse my appointments' categories using VBA, then,
depending on the values stored there, add a particular category to
each item, but I can't write the values to it.


System:
Outlook 2003 running on WinXP SP2

More Detail:
I have written some code that examines each item in the default
calendar folder.
For each item the category/categories assigned is/are examined.
If a particular category exists the item is left alone; if not, it is
added to the existing categories.
(I have parsed the category field into an array where more than one
category is set and examined each part of the array for the existence
of the required string)
As a 'check' I have written the category field to the debug window
before examining it, then re-written the categories after examining
and the text shown there looks correct. But, when I go back into the
actual items in the Outlook calendar the categories have not changed
at all!
I think I've probably missed something really simple, but I just can't
spot it! If any experts out there can spot the (hopefully!) simple
error, please point me in the right direction.


Code in Use (Not very elegant, I know, but I'm only an amateur):
Sub Categorise_Appointments()

Const DefaultCategoryString = "Public" 'change this depending on
default category to enter

Dim myOlApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myAppItems As Outlook.Items
Dim myAppItem As Object
Dim ItemCount, CommaCount As Integer, OrigCats As String
Dim TempLoop As Integer, CatSplit()
Dim CorrectCat As Boolean

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myAppItems =
myNameSpace.GetDefaultFolder(olFolderCalendar).Ite ms


ItemCount = 1
For Each myAppItem In myAppItems
CorrectCat = False
CommaCount = 0

Debug.Print ItemCount & " Subject: " & myAppItem.Subject &
"" & vbCr & " Date: " & myAppItem.Start & vbCr & " Cats: "
& myAppItem.Categories

OrigCats = myAppItem.Categories
If OrigCats "" Then
' At least one category, check for multiple
CommaCount = Count_Commas(OrigCats)
If CommaCount 0 Then
' Multiple categories; check for 'Public' or 'Private'
ReDim CatSplit(CommaCount + 1)
For TempLoop = 0 To CommaCount
CatSplit(TempLoop) = Split_Cats(OrigCats,
TempLoop, CommaCount)
Next TempLoop
Else
ReDim CatSplit(1)
CatSplit(0) = OrigCats
End If
For TempLoop = 0 To CommaCount
If CatSplit(TempLoop) = "Public" Or CatSplit(TempLoop)
= "Private" Then
' Correct category exists - flag
CorrectCat = True
End If
Next TempLoop
If Not (CorrectCat) Then myAppItem.Categories =
myAppItem.Categories & ", " & DefaultCategoryString

Else
' No categories, put in either 'Public' or 'Private' -
depending on where this code is running
myAppItem.Categories = DefaultCategoryString
End If

Debug.Print ItemCount & " Subject: " & myAppItem.Subject &
"" & vbCr & " Date: " & myAppItem.Start & vbCr & " Cats: "
& myAppItem.Categories
ItemCount = ItemCount + 1

Next myAppItem



End Sub

Function Count_Commas(Cats As String)
Dim CC, CharLoop
CC = 0
If Len(Cats) = 0 Then
Count_Commas = 0
Else
For CharLoop = 1 To Len(Cats)
If Mid(Cats, CharLoop, 1) = "," Then CC = CC + 1
Next CharLoop
Count_Commas = CC
End If
End Function


Function Split_Cats(CatString As String, CatNum As Integer, CommaCount
As Integer)
Dim CommaChar(), CurrChar, MasterLoop
' 1st category where CatNum=0, 2nd category where CatNum=1 etc.
ReDim CommaChar(CommaCount)
MasterLoop = 1
CurrChar = 1
Do While CurrChar = Len(CatString)
If Mid(CatString, CurrChar, 1) = "," Then
CommaChar(MasterLoop) = CurrChar
MasterLoop = MasterLoop + 1
End If
CurrChar = CurrChar + 1
Loop

' Now position of all commas held in array CommaChar
' Return whichever string is required, based on CatNum var
If CatNum = 0 Then
Split_Cats = Left(CatString, CommaChar(CatNum + 1) - 1)
ElseIf CatNum = CommaCount Then
Split_Cats = Right(CatString, Len(CatString) -
CommaChar(CatNum) - 1)
Else
Split_Cats = Mid(CatString, CommaChar(CatNum) + 2,
CommaChar(CatNum + 1) - CommaChar(CatNum) - 2)
End If

End Function

How to write to 'Categories' field using VBA
 

You might want to try saving the items after changing their categories.

--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm


wrote in message
ups.com...
Hi there.

Overview:
I'm trying to analyse my appointments' categories using VBA, then,
depending on the values stored there, add a particular category to
each item, but I can't write the values to it.


System:
Outlook 2003 running on WinXP SP2

More Detail:
I have written some code that examines each item in the default
calendar folder.
For each item the category/categories assigned is/are examined.
If a particular category exists the item is left alone; if not, it is
added to the existing categories.
(I have parsed the category field into an array where more than one
category is set and examined each part of the array for the existence
of the required string)
As a 'check' I have written the category field to the debug window
before examining it, then re-written the categories after examining
and the text shown there looks correct. But, when I go back into the
actual items in the Outlook calendar the categories have not changed
at all!
I think I've probably missed something really simple, but I just can't
spot it! If any experts out there can spot the (hopefully!) simple
error, please point me in the right direction.


Code in Use (Not very elegant, I know, but I'm only an amateur):
Sub Categorise_Appointments()

Const DefaultCategoryString = "Public" 'change this depending on
default category to enter

Dim myOlApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myAppItems As Outlook.Items
Dim myAppItem As Object
Dim ItemCount, CommaCount As Integer, OrigCats As String
Dim TempLoop As Integer, CatSplit()
Dim CorrectCat As Boolean

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myAppItems =
myNameSpace.GetDefaultFolder(olFolderCalendar).Ite ms


ItemCount = 1
For Each myAppItem In myAppItems
CorrectCat = False
CommaCount = 0

Debug.Print ItemCount & " Subject: " & myAppItem.Subject &
"" & vbCr & " Date: " & myAppItem.Start & vbCr & " Cats: "
& myAppItem.Categories

OrigCats = myAppItem.Categories
If OrigCats "" Then
' At least one category, check for multiple
CommaCount = Count_Commas(OrigCats)
If CommaCount 0 Then
' Multiple categories; check for 'Public' or 'Private'
ReDim CatSplit(CommaCount + 1)
For TempLoop = 0 To CommaCount
CatSplit(TempLoop) = Split_Cats(OrigCats,
TempLoop, CommaCount)
Next TempLoop
Else
ReDim CatSplit(1)
CatSplit(0) = OrigCats
End If
For TempLoop = 0 To CommaCount
If CatSplit(TempLoop) = "Public" Or CatSplit(TempLoop)
= "Private" Then
' Correct category exists - flag
CorrectCat = True
End If
Next TempLoop
If Not (CorrectCat) Then myAppItem.Categories =
myAppItem.Categories & ", " & DefaultCategoryString

Else
' No categories, put in either 'Public' or 'Private' -
depending on where this code is running
myAppItem.Categories = DefaultCategoryString
End If

Debug.Print ItemCount & " Subject: " & myAppItem.Subject &
"" & vbCr & " Date: " & myAppItem.Start & vbCr & " Cats: "
& myAppItem.Categories
ItemCount = ItemCount + 1

Next myAppItem



End Sub

Function Count_Commas(Cats As String)
Dim CC, CharLoop
CC = 0
If Len(Cats) = 0 Then
Count_Commas = 0
Else
For CharLoop = 1 To Len(Cats)
If Mid(Cats, CharLoop, 1) = "," Then CC = CC + 1
Next CharLoop
Count_Commas = CC
End If
End Function


Function Split_Cats(CatString As String, CatNum As Integer, CommaCount
As Integer)
Dim CommaChar(), CurrChar, MasterLoop
' 1st category where CatNum=0, 2nd category where CatNum=1 etc.
ReDim CommaChar(CommaCount)
MasterLoop = 1
CurrChar = 1
Do While CurrChar = Len(CatString)
If Mid(CatString, CurrChar, 1) = "," Then
CommaChar(MasterLoop) = CurrChar
MasterLoop = MasterLoop + 1
End If
CurrChar = CurrChar + 1
Loop

' Now position of all commas held in array CommaChar
' Return whichever string is required, based on CatNum var
If CatNum = 0 Then
Split_Cats = Left(CatString, CommaChar(CatNum + 1) - 1)
ElseIf CatNum = CommaCount Then
Split_Cats = Right(CatString, Len(CatString) -
CommaChar(CatNum) - 1)
Else
Split_Cats = Mid(CatString, CommaChar(CatNum) + 2,
CommaChar(CatNum + 1) - CommaChar(CatNum) - 2)
End If

End Function

How to write to 'Categories' field using VBA
 

On 25 Sep, 18:15, "Ken Slovak - [MVP - Outlook]"
wrote:
You might want to try saving the items after changing their categories.

--
Ken Slovak
[MVP - Outlook]http://www.slovaktech.com
Author: Professional Programming Outlook 2007
Reminder Manager, Extended Reminders, Attachment Optionshttp://www.slovaktech.com/products.htm


Thanks for that. Kind of obvious really - like I thought, missed
something really simple!

Appreciate the pointer, and of course, all the help of everyone on
here.

Rob