This script handles enumerating the existing messages within a mailbox and then assigning categories (or keywords) based on the attachment types on the message. When I used this script I did every message in my mailbox which worked okay but because I was using Outlook in Cache Mode updating a lot a messages this way caused a major re-syncing or the cache (e.g. it seemed to pull down every message again that was updated with an attachment which can consume a lot of bandwidth if you have a large mailbox with large attachments). While this may be okay for some people this could cause some havoc in some networks so with this script I put a filter value so it will only update the messages that are less then 1 month old in the inbox. This could still be a considerable number of messages so you should use this script with great care and always test it first in your dev environment.
The script works by first creating a filter on the Messages in the inbox so only messages that have an attachment and are under 1 month old are included in the collection. It then loops through each message and first build a list of any existing keywords on a message. It then checks the attachment and if there is an attachment types that doesn’t have an existing keyword set on the message a new keyword is added to that message. To avoid assigning a keyword to a message with inline attachments such as people who use images in signatures etc the script checks to see if the attachment in question is a inline attachment if that’s the case it skips over this attachment. The keywords assigned to the message match the categories that where created with the first script. The categories themselves are held in a multivalued String property http://schemas.microsoft.com/mapi/string/{00020329-0000-0000-C000-000000000046}/Keywords.
This script only updates existing message if you want to set the categories on new messages you would need to look at writing an Event Sink or if your using Exchange 2007 you could use a Transport Agent or EWS Notifications application.
As I said before there is filter to stop it updating more than 1 month worth of mail in the line
attFilter.TimeFirst = DateAdd("m",-1,Now())
To run the code you need to supply the servername and mailbox name of the mailbox you want to run it against as commandline parameters eg
Cscript setkeywords.vbs.vbs servername mailboxname
I’ve put a download of the script here the script itself looks like
snServername = wscript.arguments(0)
mbMailboxName = wscript.arguments(1)
Set objSession = CreateObject("MAPI.Session")
Set catDict = CreateObject("Scripting.Dictionary")
objSession.Logon "","",false,true,true,true,snServername & vbLF & mbMailboxName
set ifInboxFolderCol = objSession.inbox.messages
set attFilter = ifInboxFolderCol.Filter
Set attFilterFiled = attFilter.Fields.Add(&h0E1B000B,true)
attFilter.TimeFirst = DateAdd("m",-1,Now())
For Each moMessageobject In ifInboxFolderCol
ceCatExists = False
catDict.RemoveAll
On Error Resume Next
ccCurrentCats = moMessageobject.Fields.item("{2903020000000000C000000000000046}Keywords").value
If Err.number = 0 Then
ceCatExists = True
For Each existingcat In ccCurrentCats
catDict.add existingcat,1
next
End If
On Error goto 0
oldcatlength = catDict.Count
Call GetCategories(moMessageobject,catDict)
If catDict.Count > oldcatlength Then
wscript.echo moMessageobject.Subject
ReDim newcats(catDict.Count-1)
catkeys = catDict.Keys
For i = 0 to catDict.Count-1
newcats(i) = catkeys(i)
Next
If ceCatExists = True then
moMessageobject.Fields.item("{2903020000000000C000000000000046}Keywords").value = newcats
Else
moMessageobject.Fields.add "Keywords", vbArray , newcats, "2903020000000000C000000000000046"
End If
moMessageobject.update
End if
next
sub GetCategories(msgObject,catDict)
For Each attachment In msgObject.Attachments
On Error Resume Next
inline = 0
fnFileName = attachment.fields(&h3704001E)
Err.clear
contentid = attachment.fields(&h3712001F)
If Err.number = 0 Then
inline = 1
Else
inline = 0
End if
Err.clear
attflags = attachment.fields(&h37140003)
If Err.number = 0 Then
If attflags = 4 Then inline = 1
End if
If Len(fnFileName) > 4 And inline = 0 Then
Select Case Right(LCase(fnFileName),4)
Case ".doc" If Not catDict.exists("Word Attachment") Then
catDict.add "Word Attachment",1
End if
Case ".ppt" If Not catDict.exists("PowerPoint Attachment") Then
catDict.add "PowerPoint Attachment",1
End if
Case ".xls" If Not catDict.exists("Excel Attachment") Then
catDict.add "Excel Attachment",1
End if
Case ".jpg" If Not catDict.exists("Image Attachment") Then
catDict.add "Image Attachment",1
End if
Case ".bmp" If Not catDict.exists("Image Attachment") Then
catDict.add "Image Attachment",1
End if
Case ".mov" If Not catDict.exists("Video Attachment") Then
catDict.add "Video Attachment",1
End if
Case ".mpg" If Not catDict.exists("Video Attachment") Then
catDict.add "Video Attachment",1
End if
Case ".wmv" If Not catDict.exists("Video Attachment") Then
catDict.add "Video Attachment",1
End if
Case ".pdf" If Not catDict.exists("PDF Attachment") Then
catDict.add "PDF Attachment",1
End if
Case ".mp3" If Not catDict.exists("Sound Attachment") Then
catDict.add "Sound Attachment",1
End if
Case ".pps" If Not catDict.exists("PowerPoint Attachment") Then
catDict.add "PowerPoint Attachment",1
End if
Case ".zip" If Not catDict.exists("Zip Attachment") Then
catDict.add "Zip Attachment",1
End if
End select
End if
On Error goto 0
next
End sub