Adding an Event Sink Binding for a Folder

        
'=============================================================================='
' This subroutine creates the event binding in the meta-database
' by setting properties in an event registration item and committing it to the
' store.  The event of saving the item triggers the event registration
' event sink, which processes the event registration and saves the item to
' the location defined by the item's rEvent.Fields.Item(propScope)
'=============================================================================='
Sub AddNewStoreEvent(Server As String)
    On Error Resume Next
   
    'heres a handy list of the properties you can set for the registration event item
    'not all of these are used in this example
    Const propcontentclass = "DAV:contentclass"
    Const propEventMethod = "http://schemas.microsoft.com/exchange/events/EventMethod"
    Const propSinkClass = "http://schemas.microsoft.com/exchange/events/SinkClass"
    Const propPriority = "http://schemas.microsoft.com/exchange/events/Priority"
    Const propScope = "http://schemas.microsoft.com/exchange/events/Scope"
    Const propMatchScope = "http://schemas.microsoft.com/exchange/events/MatchScope"
    Const propCriteria = "http://schemas.microsoft.com/exchange/events/Criteria"
    Const propReliable = "http://schemas.microsoft.com/exchange/events/Reliable"
    Const propTimerInterval = "http://schemas.microsoft.com/exchange/events/TimerInterval"
    Const propTimerStartTime = "http://schemas.microsoft.com/exchange/events/TimerStartTime"
    Const propTimerExpiryTime = "http://schemas.microsoft.com/exchange/events/TimerExpiryTime"
    Const propScriptName = "http://schemas.microsoft.com/exchange/events/ScriptName"
   
    Dim cn As New ADODB.Connection
    Dim rEvent As New ADODB.Record
    Dim strGuid
    Dim strBaseUrl
    Dim strEvent
    
    
    'this will serve as the scope as well
    strBaseUrl = "file://./backofficestorage/" + _
                 Server + _
                 "/public folders/internet newsgroups"
                 
    strEvent = strBaseUrl + "/evtreg1" 'evtreg1 is the item name
     
    ' Create the connection
    cn.Provider = "exoledb.datasource"
    cn.ConnectionString = strBaseUrl
    cn.Open
    If Err.Number <> 0 Then
      MsgBox "Error Opening Connection : " & Err.Number & " " & Err.Description & vbCrLf
      Exit Sub
    End If
    
    cn.BeginTrans
    rEvent.Open strEvent, cn, 3, 0     ' adModeReadWrite, adCreateNonCollection
    If Err.Number <> 0 Then
      MsgBox "Error Opening Record : " & Err.Number & " " & Err.Description & vbCrLf
      Exit Sub
    End If
       
    'set the properties in the item
    With rEvent.Fields
      .Item(propcontentclass) = "urn:content-class:storeeventreg"
      .Item(propEventMethod) = "onsave;ondelete" 'register for both save and delete events
      .Item(propSinkClass) = "VB_OutProc.sink"  'your registered event handler sink class ProgID
      
      'folder of scope defines the scope, while the name defines the
      'actual name of the event sink item
      .Item(propScope) = strEvent
      
      'match scope
      .Item(propMatchScope) = "deep"
      .Item(propCriteria) = "WHERE $DAV:ishidden$ = FALSE"
      .Item(propPriority) = "0x3f"
      .Item(propReliable) = True                             '-r in regevent.vbs
      
      'Add custom properties which the event sink can use to
      'determine the context of this event registration
      
      Const customnamespace = "mycustomnamespace:eventsinks/notifyingevents/"
      Dim propname As String
      propname = cust_namespace + "caseswitch"
      .Append propname, adInteger, , , 2         'for a case switch in the event sink
      propname = cust_namespace + "notifygroup"
      .Append propname, adChar, , , "Marketing"  'a group you've created in exchange
      
                                    
      MsgBox "New Event Binding with custom properties created."
        
      .Update  'get the ADO object current
      If Err.Number <> 0 Then
        MsgBox "Error Updating Props : " & Err.Number & " " & Err.Description & vbCrLf
        Exit Sub
      End If
      
    End With
    cn.CommitTrans  'commit transaction to the store
    
    If Err.Number <> 0 Then
      MsgBox "Error Commiting Transaction : " & Err.Number & " " & Err.Description & vbCrLf
      Exit Sub
    End If

End Sub