|
| | <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
'------------------------------------------------------------------------------
'
' NAME: Agent 007
'
' FILE DESCRIPTION: Changes the message class of each new message that has
' arrived in a particular folder
'
' Portions:
' Copyright (c) CdoLive 1998. All rights reserved.
' Http://www.cdolive.com
' Mailto:samples@cdolive.com
'
' Portions:
' Copyright (c) Microsoft Corporation 1993-1997. All rights reserved.
'
'------------------------------------------------------------------------------
Option Explicit
'------------------------------------------------------------------------------
' Global Variables
'------------------------------------------------------------------------------
Dim g_bstrDebug ' Debug String
'------------------------------------------------------------------------------
' CONSTANTS
'------------------------------------------------------------------------------
'Const CdoPropSetID1 = "{0220060000000000C000000000000046}" 'Used in appointment item properties. Message class:IPM.Appointment
'Const CdoPropSetID2 = "{0320060000000000C000000000000046}" 'Used in task item properties. Message class:IPM.Task
'Const CdoPropSetID3 = "{0420060000000000C000000000000046}" 'Used in contact item properties. Message class:IPM.Contact
Const CdoPropSetID4 = "{0820060000000000C000000000000046}" 'Common Outlook ID. Used with common contact, task and appointment item properties (e. g. reminders)
'Const CdoPropSetID5 = "{2903020000000000C000000000000046}" 'Generic MAPI ID. Used with all type of item properties (e. g. categories)
'Const CdoPropSetID6 = "{0E20060000000000C000000000000046}" 'Used in note item properties. Message class:IPM.StickyNote
'Const CdoPropSetID7 = "{0A20060000000000C000000000000046}" 'Used in journal item properties. Message class:IPM.Activity
Const CdoLinkNameOffset = "0x8586"
'CdoAppt_BillingInformation CdoPropSetID4 & "0x8535" Item.BillingInformation
'CdoAppt_Mileage CdoPropSetID4 & "0x8534" Item.Mileage
Const CdoBillInfoOffset = "0x8535"
Const CdoMileageOffset = "0x8534"
'------------------------------------------------------------------------------
' EVENT HANDLERS
'------------------------------------------------------------------------------
' DESCRIPTION: This event is fired when a new message is added to the folder
Public Sub Folder_OnMessageCreated
'Not used
End Sub
' DESCRIPTION: This event is fired when a message in the folder is changed
Public Sub Message_OnChange
Dim oSession ' Session
Dim oCurrentMsg ' Current message
Dim oFolder ' Current folder
Dim CdoDefaultFolderCalendar
Dim CdoLinkName
Dim CdoBillInfoName
Dim CdoMileageName
dim cdoStart
Dim dummyName
Dim STime
Dim ETime
Dim MsgSubject
dim ConNdex
dim Talktxt
dim Place
Dim Cats
Dim ApMessageClass
Dim Ndex
Dim myUProp
CdoDefaultFolderCalendar = 0
CdoLinkName = CdoPropSetID4 + CdoLinkNameOffset
CdoBillInfoName = CdoPropSetID4 + CdoBillInfoOffset
CdoMileageName = CdoPropSetID4 + CdoMileageOffset
' Clear error buffer
Err.Clear
' Get session informationen
Set oSession = EventDetails.Session
' No errors detected ?
If Err.Number = 0 Then
' Write some logging
Call DebugAppend(oSession.CurrentUser & " Stuff Appointment to SQL - Proccessing OnChange Event", False)
' Get current folder
Set oFolder = oSession.GetFolder(EventDetails.FolderID,Null)
' No errors detected ?
If Err.Number = 0 Then
' Get current message
Set oCurrentMsg = oSession.GetMessage(EventDetails.MessageID,Null)
' Error detected ?
If Not Err.Number = 0 Then
' Error reading new message
Call DebugAppend("Error - Could not read message", True)
Else
' Remember subject of arrived message
Call DebugAppend("Changed message with subject: <" & oCurrentMsg.Subject & "> Fired its event", False)
Dim omyFolder
Dim omyMsgsCol
Dim omyMsg
Dim myMsgsColCount
dim LoopFlag
Set omyFolder = oSession.GetDefaultFolder( CdoDefaultFolderCalendar )
' Error detected ?
If Not Err.Number = 0 Then
' Error reading new message
Call DebugAppend("Error - Could not get Calender Folder", True)
Script.Response = g_bstrDebug
Set omyMsgsCol = Nothing
Set omyFolder = Nothing
Exit Sub
End if
Set omyMsgsCol = omyFolder.Messages
If Not Err.Number = 0 Then
' Error reading new message
Call DebugAppend("Error - Could not get Message Collection Object", True)
Script.Response = g_bstrDebug
Set omyMsgsCol = Nothing
Set omyFolder = Nothing
Exit Sub
End if
On Error Resume Next
myMsgsColCount = omyMsgsCol.Count
LoopFlag = 1
For Ndex = 1 to myMsgsColCount
Set omyMsg = omyMsgsCol.Item(Ndex)
If omyMsg.Subject = oCurrentMsg.Subject Then
'If oSession.CompareIDs(omyMsg.ID, oCurrentMsg.ID) = True Then
LoopFlag = 0
Call DebugAppend("Ndex = " & Ndex, False)
Exit For
End if
If Ndex = myMsgsColCount then Exit For
Next
if LoopFlag = 1 then
Call DebugAppend("Error - We did not find matching message", False)
Else
Call DebugAppend("Success - We DID find the matching message", False)
End if
strSQL = "AddOLAppntEvent "
STime = omyMsg.StartTime
strSQL = strSQL & "'" & STime & "'"
ETime = omyMsg.EndTime
strSQL = strSQL & ", '" & ETime & "'"
MsgSubject = omyMsg.Subject
strSQL = strSQL & ", '" & MsgSubject & "'" 'text
' ConNdex = "101" 'omyMsg.ConversationIndex
' strSQL = strSQL & ", '" & ConNdex & "'"
Talktxt = omyMsg.ConversationTopic
if Talktxt = "" then Talktxt = "No Talk on this omyMsg"
strSQL = strSQL & ", '" & Talktxt & "'"
Dim strContacts
If TypeName(omyMsg.Fields.Item(CdoLinkName)) = "Empty" Then
strContacts = "No Categories!"
Else
strContacts = omyMsg.Fields.Item(CdoLinkName).Value
Call DebugAppend("Number of Contact Links = " & strContact, False)
End If
strSQL = strSQL & ", '" & strContacts & "'" 'omyMsg.Contacts
If TypeName(omyMsg.Categories) = "Empty" Then
Cats = "No Categories!"
Else
Dim vCat
Dim v
Dim LenCat
Cats = ""
vCat = omyMsg.Categories
For Each v In vCat
Cats = Cats & v & "; "
Next
LenCat = Len(Cats)
Cats = Left(Cats, LenCat-2)
End If
strSQL = strSQL & "," & "'" & Cats & "'" 'omyMsg.Categories
Place = omyMsg.Location
If Place = "" Then Place = "No Place selected."
strSQL = strSQL & "," & "'" & Place & "'"
ApMessageClass = omyMsg.Type
strSQL = strSQL & "," & "'" & ApMessageClass & "'"
If omyMsg.TimeCreated = "" then
strSQL = strSQL & "," & "'" & "1/1/1991" & "'"
Else
strSQL = strSQL & "," & "'" & omyMsg.TimeCreated & "'"
End If
Dim omySender
Dim SenderName
Set omySender = omyMsg.Sender
SenderName = omySender.Name
strSQL = strSQL & "," & "'" & SenderName & "'" 'Set objAddrEntry = objMessage.Sender
Set omySender = Nothing
dummyName = "NoInputValue"
Set myUProp = omyMsg.Fields("Appointee")
If myUProp.Value <> "" then dummyName = myUProp.Value
strSQL = strSQL & "," & "'" & dummyName & "'" 'omyMsg.Name
Set myUProp = Nothing
Dim BillInfo
BillInfo = omyMsg.Fields.Item(CdoBillInfoName)
If BillInfo = "" then
strSQL = strSQL & "," & "'" & "NoBillingText" & "'"
Else
strSQL = strSQL & "," & "'" & BillInfo & "'"
End If
Dim strMiles
strMiles = omyMsg.Fields.Item(CdoMileageName)
If strMiles = "" then
strSQL = strSQL & "," & "'" & "NoMileageText" & "'"
Else
strSQL = strSQL & "," & "'" & strMiles & "'"
End If
If omyMsg.Text = "" Then
strSQL = strSQL & "," & "'" & "NoBodyText" & "'"
Else
strSQL = strSQL & "," & "'" & omyMsg.Text & "'"
End If
' call the AddOLAppntEvent stored procedure
dim oConn, strConn
Set oConn = CreateObject("ADODB.Connection")
strConn = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=WebCal;Data Source=OUTLOOKCONSUL01;Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=OBTS-OUTLOOKDEV;"
'strConn = strConn & "User Id=?; Password=?"
oConn.Open strConn
oConn.Execute (strSQL)
' Release objects
Set oConn = Nothing
Set omyMsg = Nothing
Set omyMsgsCol = Nothing
Set omyFolder = Nothing
End If
Else
' Could not get current folder
Call DebugAppend("Error - Could not get current folder", True)
End If
Else
' Check for any possible sys errors
Call DebugAppend("Undefinied Error detected", True)
End If
' Check if folder object is set
If Not oFolder Is Nothing Then
' Write some logging, including the folder name
Call DebugAppend(oFolder.Name & " Change Appointment - Processing finished", False)
Else
' Write some logging, without the folder name
Call DebugAppend("Change Appointment - Processing finished", False)
End If
' Release objects
Set oSession = Nothing
Set oCurrentMsg = Nothing
Set oFolder = Nothing
' Write results in the Scripting Agent log
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: 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 & " - " & cstr(Err.Number) & " " & Err.Description & vbCrLf
Err.Clear
End If
Else
g_bstrDebug = g_bstrDebug & bstrParm & vbCrLf
End If
End Sub
'------------------------------------------------------------------------------
' Name: GetDataConnection
' Area: Debug
' Desc: Open connection to SQL provider
' Parm: String Text, Bool ErrorFlag
'------------------------------------------------------------------------------
</SCRIPT>
|
