![]() |
|
|
| Become a Columnist Microsoft Exchange Site Microsoft Support SiteMSDN Exchange Site | ||
|
|
Administrators universally agree
that cached mode in Exchange 2003 is a good thing providing added value and
reliability to their infrastructure.
|
|
Attribute VB_Name = "msModule" Public Const LogFile As String = "StoreSink.log" 'Name of the file where a log of all the activities in this sink will be stored. Public Const PERFORM_FILE_LOGGING As Boolean = True 'Set this constant to False to prevent any event logging from occurring Public Const PERFORM_ERROR_LOGGING As Boolean = True 'Set this constant to False to prevent any error logging from occurring Public Const DATE_TIME_FORMAT As String = "dddd, mmmm dd, yyyy, hh:nn:ss AM/PM" 'Set the format of the date-time that will get written ' Function ProcessBeginSave(ByVal pEventInfo As Exoledb.IExStoreEventInfo, ByVal bstrURLItem As String, ByVal lFlags As Long) As Boolean 'This function is called when the Item is being saved and the OnSyncSave 'event is fired for the first time in this event sink. Returns True if 'successful, False if not. Dim pDispEventInfo As Exoledb.IExStoreDispEventInfo 'Declare a pointer to the interface that returns information about the executing store event. Dim recItem As ADODB.Record 'Record Object that will point to the item that triggered this event. '============================================================================================ 'ADDED BY SUMATRA ProcessBeginSave = True Exit Function On Error GoTo Errorhandler 'Assume that the function is successful. If any checks which may be coded below fail, ' or if an error occurs, then return False, which would cause the transaction to be aborted. ProcessBeginSave = True 'Write to the log file that this function has been called. Call EventLog("OnSyncSave", bstrURLItem, lFlags, "Begin Phase") Set pDispEventInfo = pEventInfo 'Assign the passed IExStoreEventInfo object reference Set recItem = pDispEventInfo.EventRecord 'get the Record object bound to the item that triggered the event 'Evaluate the different scenarios in which the Save might have been triggered. If lFlags And EVT_NEW_ITEM Then 'The item being saved is a new item. 'Some role checking can be done - like below 'If GetSecurityCallContext.IsSecurityEnabled Then 'If Not GetSecurityCallContext.IsCallerInRole("Example Role") Then ''User is not in a defined role. Handle the condition here ''like preventing the delete by aborting the transaction; i.e. 'pDispEventInfo.AbortChange 'End If 'End If 'The item can be processed below. With recItem 'Process the item's properties, set default values, validate fields etc. here End With End If 'The following blocks of code are similar to the previous one. Similar code can be applied 'here as shown above, like role checking etc. If lFlags And EVT_REPLICATED_ITEM Then 'The item is being saved as a result of replication End If If lFlags And EVT_IS_DELIVERED Then 'The item is being saved as the result of message delivery End If If lFlags And EVT_INVALID_URL Then 'The URL passed to the sink is invalid. End If If lFlags And EVT_IS_COLLECTION Then 'The item being saved is a collection. End If If lFlags And EVT_ERROR Then ' An error occurred in the event. End If Exit Function Errorhandler: 'Some error has occurred. The function can return False (as in the next line) so that the save can be aborted. 'ProcessBeginSave = False 'Log any errors that occur in this function. Call ErrorLog("ProcessBeginSave", CStr(Err.Number) & vbTab & Err.Description, bstrURLItem, lFlags) End Function Sub ProcessCommitSave(ByVal pEventInfo As Exoledb.IExStoreEventInfo, ByVal bstrURLItem As String, ByVal lFlags As Long) 'This function is called after the save of the Item has been committed. 'NOTE: The item is now read-only. Changes made to the item here will not be reflected in the store. Dim pDispEventInfo As Exoledb.IExStoreDispEventInfo 'Declare a pointer to the interface that returns information about the executing store event. Dim recItem As ADODB.Record 'Record Object that will point to the item that triggered this event. '============================================================================================ ' Added by Sumatra ' Dim iCalMsg As CDO.CalendarMessage Dim iMbx As IMailbox Dim person As New CDO.person Dim msg_to As String Dim strURL As String On Error GoTo Err_ProcessCommitSave Call EventLog("ProcessCommitSave", bstrURLItem, lFlags, "Startup-Sumatra") If LenB(bstrURLItem) = 0 Then Call EventLog("ProcessCommitSave", bstrURLItem, lFlags, "Empty URL") End If Set pDispEventInfo = pEventInfo Set recItem = pDispEventInfo.EventRecord 'get the Record object bound to the item that triggered the event Call EventLog("ProcessCommitSave", bstrURLItem, lFlags, "Got event record") 'Evaluate the different scenarios in which the Save might have been triggered. If lFlags And EVT_NEW_ITEM Then 'The item being saved is a new item. End If If lFlags And EVT_REPLICATED_ITEM Then 'The item is being saved as a result of replication End If If lFlags And EVT_IS_DELIVERED Then 'The item is being saved as the result of message delivery Call EventLog("ProcessCommitSave", bstrURLItem, lFlags, "EVT_IS_DELIVERED-Sumatra") 'check if a calendar message 'contentclass"" = 'urn:content-classes:calendarmessage'" If recItem.Fields("DAV:contentclass") = "urn:content-classes:calendarmessage" Then Call EventLog("ProcessCommitSave", bstrURLItem, lFlags, "IS Calendar message") 'Parse fields to determine who the person is msg_to = Split(bstrURLItem, "/")(6) & "@" & Split(bstrURLItem, "/")(4) strURL = "mailto:" & msg_to Call EventLog("ProcessCommitSave", bstrURLItem, lFlags, "Open Person:" & strURL & "-Sumatra") Set person = New CDO.person 'COULD ALSO CreateObject("CDO.Person") person.DataSource.Open strURL ' Now get the mailbox Set iMbx = person.GetInterface("IMailbox") ' Open the calendar message Call EventLog("OnSyncSave", bstrURLItem, lFlags, "Open Calendar Message-Sumatra") Set iCalMsg = New CalendarMessage iCalMsg.DataSource.Open bstrURLItem, , adModeReadWrite Call ProcessResponse(iCalMsg, iMbx) Else Call EventLog("ProcessCommitSave", bstrURLItem, lFlags, "NOT Calendar message; contentclass: " & recItem.Fields("contentclass").Value) End If 'test if calendar message End If If lFlags And EVT_INVALID_URL Then 'The URL passed to the sink is invalid. End If If lFlags And EVT_IS_COLLECTION Then 'The item being saved is a collection. End If If lFlags And EVT_ERROR Then ' An error occurred in the event. End If Exit_ProcessCommitSave: 'release objects Set person = Nothing Set iMbx = Nothing Set iCalMsg = Nothing Set recItem = Nothing Set pDispEventInfo = Nothing Exit Sub Err_ProcessCommitSave: 'Log any errors that occur in this subroutine Call ErrorLog("ProcessCommitSave", CStr(Err.Number) & vbTab & Err.Description, bstrURLItem, lFlags) Err.Clear Resume Exit_ProcessCommitSave End Sub '============================================================================================ 'ADDED BY SUMATRA FROM 'SOURCE: 'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/e2k3/e2k3/_cdo_processing_meeting_request_responses.asp Sub ProcessResponse(iCalMsg As CDO.CalendarMessage, iMbx As IMailbox) ' Reference to Microsoft ActiveX Data Objects 2.5 Library ' Reference to Microsoft CDO for Exchange 2000 Library ' Note: It is recommended that all input parameters be validated when they are ' first obtained from the user or user interface. Dim Rec As New ADODB.Record Dim Conn As New ADODB.Connection '============================================================================================ 'MODIFIED BY SUMATRA ' below is commented out.....causes compiler error ' Dim iCalMsg As New CalendarMessage Dim iCalPart As ICalendarPart Dim iAppt As CDO.Appointment On Error GoTo Err_ProcessResponse Call EventLog("ProcessResponse", bstrURLItem, lFlags, "Started; Subj=" & iCalMsg.Message.Subject & " -Sumatra") App.LogEvent "iCalMsg GUID: " & iCalMsg.Message.Fields("http://schemas.microsoft.com/exchange/permanenturl").Value Conn.Provider = "ExOLEDB.DataSource" Conn.Open iMbx.BaseFolder For Each iCalPart In iCalMsg.CalendarParts Set iAppt = iCalPart.GetUpdatedItem(iMbx.Calendar) App.LogEvent "Appt in CalPart GUID: " & iAppt.Fields("http://schemas.microsoft.com/exchange/permanenturl").Value Call EventLog("ProcessResponse", bstrURLItem, lFlags, "Got Appt from Calpart; Subj=" & iCalMsg.Message.Subject & " -Sumatra") Select Case iCalPart.CalendarMethod Case "REQUEST" Call EventLog("ProcessResponse", bstrURLItem, lFlags, "Request; subj=" & iCalMsg.Message.Subject & "-Sumatra") Case "REPLY" ' Make sure this is a reply App.LogEvent "MSTEST2 Item URL: " & iAppt.Subject App.LogEvent "MSTEST2 Fired at (Before the save): " & Now iAppt.DataSource.Save App.LogEvent "MSTEST2 Fired at (After the save): " & Now Call EventLog("ProcessResponse", bstrURLItem, lFlags, "YEA!! Reply Saved-CalUpdated; subj=" & iCalMsg.Message.Subject & "-Sumatra") Case "CANCEL" Call EventLog("ProcessResponse", bstrURLItem, lFlags, "Cancellation; subj=" & iCalMsg.Message.Subject & "-Sumatra") Case Else Call EventLog("ProcessResponse", bstrURLItem, lFlags, "Not a REPLY: " & iCalPart.CalendarMethod & "; subj=" & iCalMsg.Message.Subject & "-Sumatra") End Select Next Exit_ProcessResponse: ' Clean up. Conn.Close Set Conn = Nothing Set Rec = Nothing Set iAppt = Nothing Set iCalPart = Nothing Exit Sub Err_ProcessResponse: 'Log any errors that occur in this subroutine Call ErrorLog("ProcessResponse-ERROR", CStr(Err.Number) & vbTab & Err.Description, bstrURLItem, lFlags) Err.Clear Resume Exit_ProcessResponse End Sub '============================================================================================ Sub ProcessAbortSave(ByVal pEventInfo As Exoledb.IExStoreEventInfo, ByVal bstrURLItem As String, ByVal lFlags As Long) 'This subroutine is called when saving the item is aborted. The Save is being cancelled here. 'NOTE: The item does not get into the Exchange Store here. Dim pDispEventInfo As Exoledb.IExStoreDispEventInfo 'Declare a pointer to the interface that returns information about the executing store event. Dim recItem As ADODB.Record 'Record Object that will point to the item that triggered this event. '============================================================================================ 'ADDED BY SUMATRA Exit Sub On Error GoTo Errorhandler 'Write to the log file that this subroutine has been called. Call EventLog("OnSyncSave", bstrURLItem, lFlags, "Abort Phase") Set pDispEventInfo = pEventInfo 'Assign the passed IExStoreEventInfo object reference Set recItem = pDispEventInfo.EventRecord 'get the Record object bound to the item that triggered the event 'Evaluate the different scenarios in which the Save might have been triggered. If lFlags And EVT_NEW_ITEM Then 'The item being saved is a new item. End If If lFlags And EVT_REPLICATED_ITEM Then 'The item is being saved as a result of replication End If If lFlags And EVT_IS_DELIVERED Then 'The item is being saved as the result of message delivery End If If lFlags And EVT_INVALID_URL Then 'The URL passed to the sink is invalid. End If If lFlags And EVT_IS_COLLECTION Then 'The item being saved is a collection. End If If lFlags And EVT_ERROR Then ' An error occurred in the event. End If Exit Sub Errorhandler: 'Log any errors that occur in this subroutine Call ErrorLog("ProcessAbortSave", CStr(Err.Number) & vbTab & Err.Description, bstrURLItem, lFlags) End Sub Function ProcessBeginDelete(ByVal pEventInfo As Exoledb.IExStoreEventInfo, ByVal bstrURLItem As String, ByVal lFlags As Long) As Boolean 'This function is called when the Item is being deleted and the OnSyncDelete 'event is fired for the first time in this event sink. Returns True if 'successful, False if not. Dim pDispEventInfo As Exoledb.IExStoreDispEventInfo 'Declare a pointer to the interface that returns information about the executing store event. Dim recItem As ADODB.Record 'Record Object that will point to the item that triggered this event. '============================================================================================ 'ADDED BY SUMATRA ProcessBeginDelete = True Exit Function On Error GoTo Errorhandler 'Assume that the function is successful. If any checks which may be coded below fail, ' or if an error occurs, then return False, which would cause the transaction to be aborted. ProcessBeginDelete = True 'Write to the log file that this function has been called. Call EventLog("OnSyncDelete", bstrURLItem, lFlags, "Begin Phase") Set pDispEventInfo = pEventInfo 'Assign the passed IExStoreEventInfo object reference Set recItem = pDispEventInfo.EventRecord 'get the Record object bound to the item that triggered the event 'Evaluate the different scenarios in which the delete might have been triggered. If lFlags And EVT_MOVE Then 'The item was moved over resulting in an implicit delete. 'Some role checking can be done - like below 'If GetSecurityCallContext.IsSecurityEnabled Then 'If Not GetSecurityCallContext.IsCallerInRole("Example Role") Then ''User is not in a defined role. Handle the condition here ''like preventing the delete by aborting the transaction; i.e. 'pDispEventInfo.AbortChange 'End If 'End If 'The item can be processed below. With recItem 'Access the item's properties, do some actions etc. End With End If 'The following blocks of code are similar to the previous one. Similar code can be applied 'here as shown above, like role checking etc. If lFlags And EVT_COPY Then 'The item was copied over resulting in an implicit delete. End If If lFlags And EVT_IS_COLLECTION Then 'The item being deleted is a collection. End If If lFlags And EVT_INVALID_URL Then ' The URL passed to the sink as invalid. End If If lFlags And EVT_ERROR Then 'An error occurred in the event. End If Exit Function Errorhandler: 'Some error has occurred. The function may return False (as in the next line) so that the delete can be aborted. 'ProcessBeginSave = False 'Log any errors that occur in this function. Call ErrorLog("ProcessBeginDelete", CStr(Err.Number) & vbTab & Err.Description, bstrURLItem, lFlags) End Function Sub ProcessCommitDelete(ByVal pEventInfo As Exoledb.IExStoreEventInfo, ByVal bstrURLItem As String, ByVal lFlags As Long) 'This function is called after the deletion of the Item has been committed. 'NOTE: The item can no longer be changed (read-only) Dim pDispEventInfo As Exoledb.IExStoreDispEventInfo 'Declare a pointer to the interface that returns information about the executing store event. Dim recItem As ADODB.Record 'Record Object that will point to the item that triggered this event. '============================================================================================ 'ADDED BY SUMATRA Exit Sub On Error GoTo Errorhandler 'Write to the log file that this subroutine has been called. Call EventLog("OnSyncDelete", bstrURLItem, lFlags, "Commit Phase") Set pDispEventInfo = pEventInfo 'Assign the passed IExStoreEventInfo object reference Set recItem = pDispEventInfo.EventRecord 'get the Record object bound to the item that triggered the event 'Evaluate the different scenarios in which the delete might have been triggered. If lFlags And EVT_MOVE Then 'The item was moved over resulting in an implicit delete. End If If lFlags And EVT_COPY Then 'The item was copied over resulting in an implicit delete. End If If lFlags And EVT_IS_COLLECTION Then 'The item being deleted is a collection. End If If lFlags And EVT_INVALID_URL Then ' The URL passed to the sink as invalid. End If If lFlags And EVT_ERROR Then 'An error occurred in the event. End If Exit Sub Errorhandler: 'Log any errors that occur in this subroutine Call ErrorLog("ProcessCommitDelete", CStr(Err.Number) & vbTab & Err.Description, bstrURLItem, lFlags) End Sub Sub ProcessAbortDelete(ByVal pEventInfo As Exoledb.IExStoreEventInfo, ByVal bstrURLItem As String, ByVal lFlags As Long) 'This subroutine is called when deletion of the item is aborted. Dim pDispEventInfo As Exoledb.IExStoreDispEventInfo 'Declare a pointer to the interface that returns information about the executing store event. Dim recItem As ADODB.Record 'Record Object that will point to the item that triggered this event. '============================================================================================ 'ADDED BY SUMATRA Exit Sub On Error GoTo Errorhandler 'Write to the log file that this subroutine has been called. Call EventLog("OnSyncDelete", bstrURLItem, lFlags, "Abort Phase") Set pDispEventInfo = pEventInfo 'Assign the passed IExStoreEventInfo object reference Set recItem = pDispEventInfo.EventRecord 'get the Record object bound to the item that triggered the event 'Evaluate the different scenarios in which the delete might have been triggered. If lFlags And EVT_MOVE Then 'The item was moved over resulting in an implicit delete. End If If lFlags And EVT_COPY Then 'The item was copied over resulting in an implicit delete. End If If lFlags And EVT_IS_COLLECTION Then 'The item being deleted is a collection. End If If lFlags And EVT_INVALID_URL Then ' The URL passed to the sink as invalid. End If If lFlags And EVT_ERROR Then 'An error occurred in the event. End If Exit Sub Errorhandler: 'Log any errors that occur in this subroutine Call ErrorLog("ProcessAbortDelete", CStr(Err.Number) & vbTab & Err.Description, bstrURLItem, lFlags) End Sub Sub ErrorLog(EventName As String, errString As String, ByVal bstrURLItem As String, Optional ByVal lFlags As Long = 0) ' JEFFGA Exit Sub ' JEFFGA If Not PERFORM_ERROR_LOGGING Then 'Check if logging is turned off Exit Sub ' If so, do not perform logging End If 'this function writes to the log file details of any error that occurred. It is called from the error handler in all events. Dim FSO As Scripting.FileSystemObject Dim WinTmpFile As String Dim OnSaveFile As Scripting.TextStream Set FSO = New Scripting.FileSystemObject 'Instantiate the FileSystemObject ' WinTmpFile = FSO.GetAbsolutePathName("") & "\" & LogFile ' WinTmpFile = FSO.GetSpecialFolder(SystemFolder).Path & "\" & LogFile 'Set the path of the log file to be in the Windows System Folder WinTmpFile = "C:\TEMP\" & LogFile Set OnSaveFile = FSO.OpenTextFile(WinTmpFile, 8, True) 'Open the file for Appending OnSaveFile.WriteLine (String(35, "*") & "E R R O R " & String(35, "*")) 'Write a separator line OnSaveFile.WriteLine Format(Now, DATE_TIME_FORMAT) 'Write the current date and time OnSaveFile.WriteLine (" Event Name :" & vbTab & EventName) 'Write the Event Name OnSaveFile.WriteLine (" URL of Source Item:" & vbTab & bstrURLItem) 'Write the URL of the Event source OnSaveFile.WriteLine (ReturnEXOLEDBFlags(lFlags)) 'Write the flags that are currently set OnSaveFile.WriteLine (errString) 'Write the Error Text OnSaveFile.WriteLine (String(80, "-")) 'Write a separator line to the file OnSaveFile.WriteBlankLines (1) 'Insert a blank line into the file OnSaveFile.Close 'Close the log file Set FSO = Nothing End Sub Sub EventLog(EventName As String, ByVal bstrURLItem As String, Optional ByVal lFlags As Long = 0, Optional bstrComment As String = "") ' JEFFGA Exit Sub ' JEFFGA 'This function writes to the log file details of an event being executed. It is called from each event procedure. If Not PERFORM_FILE_LOGGING Then 'Check if logging is turned off Exit Sub ' If so, do not perform logging End If Dim FSO As Scripting.FileSystemObject Dim WinTmpFile As String Dim OnSaveFile As Scripting.TextStream Set FSO = New Scripting.FileSystemObject 'Instantiate the FileSystemObject 'WinTmpFile = FSO.GetAbsolutePathName("") & "\" & LogFile WinTmpFile = "C:\TEMP\" & LogFile ' WinTmpFile = FSO.GetSpecialFolder(SystemFolder).Path & "\" & LogFile 'Set the path of the log file to be in the Windows System Folder Set OnSaveFile = FSO.OpenTextFile(WinTmpFile, 8, True) 'Open the file for Appending OnSaveFile.WriteLine Format(Now, DATE_TIME_FORMAT) 'Write the current date and time OnSaveFile.WriteLine (" Event Name:" & EventName) 'Write the Event Name OnSaveFile.WriteLine (" URL of Source Item:" & vbTab & bstrURLItem) 'Write the URL of the Event source OnSaveFile.WriteLine (ReturnEXOLEDBFlags(lFlags)) 'Write the flags that are currently set OnSaveFile.WriteLine (" COMMENT:" & vbTab & bstrComment) 'Write the comment, if any OnSaveFile.WriteLine (String(80, "-")) 'Write a separator line to the file OnSaveFile.WriteBlankLines (1) 'Insert a blank line into the file OnSaveFile.Close 'Close the log file Set FSO = Nothing End Sub Function ReturnEXOLEDBFlags(lFlags As Long, Optional blnFreshy As Boolean = True) As String 'This function returns a string containing a list of all the flags that are currently set. Dim strBuff As String strBuff = " Flags (" & "0x" & Hex(lFlags) & "):" If (lFlags And EVT_NEW_ITEM) > 0 Then strBuff = strBuff & " EVT_NEW_ITEM " End If If (lFlags And EVT_IS_COLLECTION) > 0 Then strBuff = strBuff & " EVT_IS_COLLECTION " End If If (lFlags And EVT_REPLICATED_ITEM) > 0 Then strBuff = strBuff & " EVT_REPLICATED_ITEM " End If If (lFlags And EVT_IS_DELIVERED) > 0 Then strBuff = strBuff & " EVT_IS_DELIVERED " End If If (lFlags And EVT_INITNEW) > 0 Then strBuff = strBuff & " EVT_INITNEW " End If If (lFlags And EVT_MOVE) > 0 Then strBuff = strBuff & " EVT_MOVE " End If If (lFlags And EVT_COPY) > 0 Then strBuff = strBuff & " EVT_COPY " End If If (lFlags And EVT_SYNC_BEGIN) > 0 Then strBuff = strBuff & " EVT_SYNC_BEGIN " End If If (lFlags And EVT_SYNC_COMMITTED) > 0 Then strBuff = strBuff & " EVT_SYNC_COMMITTED " End If If (lFlags And EVT_SYNC_ABORTED) > 0 Then strBuff = strBuff & " EVT_SYNC_ABORTED " End If If (lFlags And EVT_INVALID_SOURCE_URL) > 0 Then strBuff = strBuff & " EVT_INVALID_SOURCE_URL " End If If (lFlags And EVT_INVALID_URL) > 0 Then strBuff = strBuff & " EVT_INVALID_URL " End If ReturnEXOLEDBFlags = strBuff End Function |