This sample application includes only a single file, the AutoCategory script. This script, called AutoCat.txt, is provided here. You can use it in the installation of this sample application, described in Installing the AutoCategory Agent:
<SCRIPT RunAt=Server Language=VBScript>
'THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT
'WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED,
'INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES
'OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR
'PURPOSE
'Copyright (c) by Microsoft 1993-1997
'
'
'---------------------------------------------------------------------
'FILE DESCRIPTION: Exchange Server Event Script
'---------------------------------------------------------------------
' Auto Category Event Script
'
' 1) Keywords are searched for in the main body of text when a message is posted.
' 2) Keywords are searched for in the main body of text when a message is changed.
' Note: A changed message will rewrite existing keywords (ie: if no keyword
' matches are made in the changed message then the keyword field will now be
' blank).
' 3) The keywords are hardcoded in this script as globals
Option Explicit
'---------------------------------------------------------------------
' Global Variables
'---------------------------------------------------------------------
Dim g_MatchCnt 'The number of matched keywords
Dim g_NumOfKeywords 'Total number of keywords
Dim g_bstrDebug 'DebugString
Dim g_boolSuccess 'Success Boolean
'---------------------------------------------------------------------
' SEARCH ARRAYS
'---------------------------------------------------------------------
Dim g_SearchArray
g_SearchArray = Array("TEST","DEBUG","MEMO", "INVENTORY","NOTE")
Dim g_MatchedArray
g_MatchedArray = Array("","","","","")
'-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
' Event Handlers
'-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
' DESCRIPTION: This event is fired when a new message is added to the folder
Public Sub Folder_OnMessageCreated
Call DebugAppend(vbCrLf&" - AUTOCAT Folder_OnMessageCreated - ",False)
Call AutoCategoryExecute
Call DebugAppend("Action Info: boolSuccess = " & g_boolSuccess & " Matched Keywords = " & g_MatchCnt & " Number Keywords Searched = "&cstr(g_NumOfKeywords+1),False)
Script.Response = g_bstrDebug
end Sub
'-------------
' DESCRIPTION: This event is fired when a message in the folder is changed
Public Sub Message_OnChange
Call DebugAppend(vbCrLf&" - AUTOCAT Message_OnChange - ",False)
Call AutoCategoryExecute
Call DebugAppend("Action Info: boolSuccess = " & g_boolSuccess & " Matched Keywords = " & g_MatchCnt & " Number Keywords Searched = "&cstr(g_NumOfKeywords+1),False)
Script.Response = g_bstrDebug
End Sub
'--------------
' DESCRIPTION: This event is fired when a message is deleted from the folder
Public Sub Folder_OnMessageDeleted
'Not Used
End Sub
' DESCRIPTION: This event is fired when the timer on the folder expires
Public Sub Folder_OnTimer
'Not Used
End Sub
'-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
' PRIVATE FUNCTIONS/SUBS
'-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
'---------------------------------------------------------------------
' Name: AutoCategoryExecute
' Area: App
' Desc: Search and Replace Keywords
' Parm: None
'---------------------------------------------------------------------
Private Sub AutocategoryExecute
On Error Resume next
Dim omsg 'Message Object
Dim omsgfields 'Message Fields Collection Object
Dim oStores 'Stores Collection
Dim oTemp 'Temporary Object
Dim Item 'Object
Dim bstrTarget 'upper case body text
Dim result 'Variant search result
Dim x 'For next Variable
g_NumOfKeywords = ubound(g_SearchArray)
g_MatchCnt = 0
g_boolSuccess = False
'Use Session Object and Message ID to get incomming Message.
Set omsg = EventDetails.Session.GetMessage(EventDetails.MessageID,Null)
If err.number <> 0 then
Call DebugAppend("EventDetails.Session.Getmessage",True)
Else
'--I've got the message now, loop and test for all keywords
bstrTarget = ucase(omsg.Text)
if len(bstrTarget) = 0 then
Call DebugAppend("Message body is Empty.",False)
else
'Search for the text body for keywords.
for x = 0 to g_NumOfKeywords
result = Instr(bstrTarget,g_SearchArray(x))
if result <> 0 then
g_MatchedArray(g_MatchCnt) = g_SearchArray(x)
g_MatchCnt = g_MatchCnt + 1
end if
next
'Reduce the size of the array otherwise field show lots of suffixed commas
Redim Preserve g_MatchedArray(g_MatchCnt-1)
'Get Keywords Field
set oTemp = omsg.Fields.item("Keywords")
If err.number = 0 then
'field already exists replace it
oTemp = g_MatchedArray
omsg.Update
If err.number <> 0 then
Call DebugAppend("omsg.update",True)
Else
g_boolSuccess = True
End If
Else
'Failure to locate keyword field means that I must add it
err.clear
omsg.fields.add "Keywords",vbArray, g_MatchedArray
If err.number <> 0 then
Call DebugAppend("omsg.Fields.Add",True)
Else
omsg.update
If err.number <> 0 then
Call DebugAppend("omsg.update",True)
Else
g_boolSuccess = True
End if
End If
End If
End If
End If
End Sub
'---------------------------------------------------------------------
' Name: DebugAppend
' Area: Debug
' Desc: Simple Debugging Function
' Parm: String Text, Bool ErrorFlag
'---------------------------------------------------------------------
Private Sub DebugAppend(bstrParm,boolErrChkFlag)
if boolErrChkFlag = True then
if err.number <> 0 then
g_bstrDebug = g_bstrDebug & bstrParm & "Failed: " & cstr(err.number) & err.description & vbCrLf
err.clear
end if
else
g_bstrDebug = g_bstrDebug & bstrParm & vbCrLf
end if
End Sub
</SCRIPT>