R
rob.allchurch
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).Items
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
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).Items
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