Here it is...
This is a crappy, quick-and-dirty version. Keep in touch and I'll send you a better one.
-------------------------------
Just put the code below into a vba module, then run the OutlookCleanup macro, assign it to a button, or whatever. I've got it set to check overall for category goodness.
-----
Public Sub OutlookCleanup()
CheckLinksInFolder olFolderCalendar
CheckLinksInFolder olFolderTasks
CheckLinksInFolder olFolderContacts
End Sub
Public Sub CheckLinksInFolder(ByVal iFolder As OlDefaultFolders)
Dim oCurrentFolder As Outlook.MAPIFolder
Dim oNamespace As Outlook.NameSpace
Dim oCurrentItem As Variant
Dim sCategory As Variant
Dim bIsGoodCategory As Boolean
Dim sNewCategory As String
Dim x As Outlook.TaskItem
Dim bIsGoodNewCategory As Boolean
Set oNamespace = Application.GetNamespace("MAPI")
Set oCurrentFolder = oNamespace.GetDefaultFolder(iFolder)
For Each oCurrentItem In oCurrentFolder.Items
' Check the categories
If Len(oCurrentItem.Categories) > 0 Then
bIsGoodCategory = CheckCategory(oCurrentItem.Categories)
If bIsGoodCategory = False Then
sNewCategory = vbNullString
bIsGoodNewCategory = False
While bIsGoodNewCategory = False
sNewCategory = InputBox("Outlook Item '" & oCurrentItem.Subject & _
"' has invalid category: " & oCurrentItem.Categories, "Check Categories")
bIsGoodNewCategory = CheckCategory(sNewCategory)
If bIsGoodNewCategory = True Then
oCurrentItem.Categories = sNewCategory
oCurrentItem.Save
Exit For
End If
Wend
End If
End If
Next
Set oCurrentFolder = Nothing
Set oNamespace = Nothing
End Sub
Public Function CheckCategory(ByVal psCategory As String) As Boolean
Static cCategories As Collection
Dim sCategory As Variant
If IsEmpty(cCategories) = False Then
Set cCategories = GetMasterCategoryList
End If
CheckCategory = False
For Each sCategory In cCategories
If psCategory = sCategory Then
CheckCategory = True
Exit For
End If
Next
End Function
Public Function GetMasterCategoryList() As Collection
Dim cCategories As New Collection
Dim vCategories As Variant
Dim oWSHShell As Object
Dim sCategoryList As String
Dim i As Long
Dim sCategories() As String
'read the categories from the registry
'remember: it's unicode
Set oWSHShell = CreateObject("WScript.Shell")
vCategories = oWSHShell.RegRead("HKEY_CURRENT_USERSoftwareMicrosoftOffice11.0OutlookCategoriesMasterList")
For i = 0 To UBound(vCategories)
If i Mod 2 = 0 Then
sCategoryList = sCategoryList + Chr(vCategories(i))
End If
Next
Debug.Print
sCategories = Split(sCategoryList, ";")
For i = 0 To UBound(sCategories)
cCategories.Add sCategories(i), sCategories(i)
Next
Set GetMasterCategoryList = cCategories
End Function
