VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "OledbSink"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'//
'// Out of Process OLEDB Event Sink
'//

Option Explicit

Implements IExStoreAsyncEvents
Implements IExStoreSyncEvents

Private Sub IExStoreAsyncEvents_OnSave(ByVal pEventInfo As IExStoreEventInfo, _
                                       ByVal bstrURLItem As String, _
                                       ByVal lFlags As Long)

End Sub

Private Sub IExStoreAsyncEvents_OnCopy(ByVal pEventInfo As Exoledb.IExStoreEventInfo, _
                                       ByVal bstrURLSource As String, _
                                       ByVal bstrURLDestination As String, _
                                       ByVal lFlags As Long)

End Sub

Private Sub IExStoreAsyncEvents_OnDelete( _
                                       ByVal pEventInfo As Exoledb.IExStoreEventInfo, _
                                       ByVal bstrURLItem As String, _
                                       ByVal lFlags As Long)

End Sub

Private Sub IExStoreAsyncEvents_OnMove(ByVal pEventInfo As Exoledb.IExStoreEventInfo, _
                                       ByVal bstrURLSource As String, _
                                       ByVal bstrURLDestination As String, _
                                       ByVal lFlags As Long)

End Sub

Private Sub IExStoreSyncEvents_OnSyncDelete( _
                                       ByVal pEventInfo As Exoledb.IExStoreEventInfo, _
                                       ByVal bstrURLItem As String, _
                                       ByVal lFlags As Long)

End Sub

Private Sub IExStoreSyncEvents_OnSyncSave( _
                                       ByVal pEventInfo As Exoledb.IExStoreEventInfo, _
                                       ByVal bstrURLItem As String, _
                                       ByVal lFlags As Long)
    
    Dim objDispInfo         As IExStoreDispEventInfo
    Dim objRec              As New ADODB.Record
    Dim objRecAppt          As New ADODB.Record
    Dim objFileSystemObject As Object
    Dim strWinTmpFile       As String
    Dim OnSyncSaveLog
    Dim RootDSE

    Dim objConfiguration    As New CDO.Configuration
    Dim objRequest          As New CDO.CalendarMessage
    Dim objResponse         As New CDO.CalendarMessage
    Dim objAppointment      As New CDO.Appointment
    Dim objAddressee        As New CDO.Addressee
    Dim objMessage          As New CDO.Message
    
    Dim strRequestType      As String
    Dim strFB               As String
    Dim strResponseText     As String
    
    Dim UserData            As SinkUserData
    
    Dim strEmailAddress     As String
    Dim strCalendarLocation As String
    Dim strLDAPServer       As String
    Dim strSubject          As String
    
    On Error Resume Next
    
    
    '// Parse the item URL to extract needed information
    ParseURL bstrURLItem, UserData
    
    '// Construct calendarlocation and emailaddress
    With UserData
        strCalendarLocation = .strPrefix & _
                              .strUserDNSDomain & "/" & _
                              .strMBX & "/" & _
                              .strUserName & "/Calendar"
        strEmailAddress = .strUserName & "@" & .strUserDNSDomain
    End With
    
    Set RootDSE = GetObject("LDAP://RootDSE")
    strLDAPServer = "LDAP://" & RootDSE.Get("defaultNamingContext")
    
    Set objDispInfo = pEventInfo
        
    '// Logfile name
    strWinTmpFile = Environ("SystemDrive") & "\SinkLogs\" & UserData.strUserName & "_AutoAccept.log"
   
    '// Create & Instantiate file system object for logfile
    Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set OnSyncSaveLog = objFileSystemObject.OpenTextFile(strWinTmpFile, 8, True)
    
    '// Start logging
    With OnSyncSaveLog
        .WriteLine ("[VB Event Sink]..:       OnSyncSave() " & Now)
        .WriteLine ("    lFlags.......:      " & "0x" & Hex(lFlags))
        .WriteLine ("    URL Item.....:      " & bstrURLItem)
        .WriteLine ("    CalLocation..:      " & strCalendarLocation)
        .WriteLine ("    EmailAddress.:      " & strEmailAddress)
        .WriteBlankLines (1)
    End With
 
    '// What triggered this event?
    Select Case lFlags
        
        '// Before OnSyncSave transaction gets commited
        '// Case EVT_SYNC_BEGIN (&H1000000) | EVT_INITNEW (&H40) | EVT_IS_DELIVERED (&H8)
        Case &H1000048
            OnSyncSaveLog.WriteLine ("    EVT_SYNC_BEGIN (&H1000000) | EVT_INITNEW (&H40) | EVT_IS_DELIVERED (&H8)")
            OnSyncSaveLog.Close
            Set objFileSystemObject = Nothing
        
        '// if OnSyncSave transaction aborts
        '// Case _TODO:
        
        '// When OnSyncSave transaction gets commited
        '// Case EVT_SYNC_COMMITTED (&H2000000) | EVT_IS_DELIVERED (&H8)
        Case &H2000008
            OnSyncSaveLog.WriteLine ("    EVT_SYNC_COMMITTED (&H2000000) | EVT_IS_DELIVERED (&H8)")
            '// _BUG: X5:134391, Set objRec = objDispInfo.EventRecord
            '// Workaround start
            objRec.Open bstrURLItem, , adModeReadWrite, adFailIfNotExists
            '// Workaround end
            
            '// Write debug data to sink log
            With OnSyncSaveLog
                .WriteLine ("    Content-Class:      " & objRec.Fields("DAV:contentclass").Value)
                .WriteLine ("    Subject......:      " & objRec.Fields("DAV:displayname").Value)
                .WriteLine ("    From.........:      " & objRec.Fields("urn:schemas:httpmail:from").Value)
                .WriteLine ("    To...........:      " & objRec.Fields("urn:schemas:httpmail:to").Value)
                .WriteBlankLines (1)
            End With
            
            '// Did we recieve a meeting request?
            If StrComp(objRec.Fields("DAV:contentclass").Value, "urn:content-classes:calendarmessage") = 0 Then
                OnSyncSaveLog.WriteLine ("    Calendar Message Detected!")
                '// Open Meeting Request
                objRequest.DataSource.Open bstrURLItem, , adModeReadWrite, adFailIfNotExists
                
                '// Set configuration for this mailbox
                With objConfiguration
                    .Fields(cdoSendEmailAddress) = strEmailAddress
                    .Fields("CalendarLocation") = strCalendarLocation
                    .Fields.Update
                End With
    
                Set objRequest.Configuration = objConfiguration
                                
                '// What type of request is this? "REQUEST" or "CANCEL"
                strRequestType = objRequest.CalendarParts.Item(1).CalendarMethod
                
                Select Case UCase(strRequestType)
                
                    Case "REQUEST"
                    
                        OnSyncSaveLog.WriteLine ("        Type = REQUEST")
                                        
                        '// Get Appointment
                        Err.Clear
                        Set objAppointment = objRequest.CalendarParts.Item(1).GetUpdatedItem
                        If Err.Number <> 0 Then
                            OnSyncSaveLog.WriteLine ("        Error in GUI......: " & Err.Number & ":" & Err.Description)
                        End If
                                                                                
                        '// Create addressee object for sink mailbox
                        '// _HACK: Find a way to determine address and servername from sink
                        Err.Clear
                        objAddressee.EmailAddress = strEmailAddress
                        objAddressee.CheckName (strLDAPServer)
                        If Err.Number <> 0 Then
                            OnSyncSaveLog.WriteLine ("        Error in CheckName: " & Err.Number & ":" & Err.Description)
                        End If
    
                        '// GetFreeBusy for the time of the request
                        Err.Clear
                        strFB = objAddressee.GetFreeBusy(objAppointment.StartTime, objAppointment.EndTime, 15)
                        If Err.Number <> 0 Then
                            OnSyncSaveLog.WriteLine ("        Error in GetFB....: " & Err.Number & ":" & Err.Description)
                        Else
                            OnSyncSaveLog.WriteLine ("        Returned FB.......: " & strFB)
                        End If
                
                        '// Check FB status for the time of the request
                        '// FB string must contain all 0's for interval to be free
                        If CLng(strFB) > 1 Then
                            '// Decline Appointment
                            Err.Clear
                            With objAppointment
                                strResponseText = "Your request was declined by an automated " & _
                                                  "EventSink." & vbCrLf & vbCrLf & _
                                                  .Subject & " (" & .Location & ")" & vbCrLf & _
                                                  "Start: " & .StartTime & vbCrLf & _
                                                  "End  : " & .EndTime
                                .ResponseText = strResponseText
                            End With
                            
                            '// preserve subject
                            strSubject = objAppointment.Subject
                            objAppointment.Subject = "Declined: " & objAppointment.Subject
                                                        
                            Set objResponse = objAppointment.Decline(True)
                            If Err.Number <> 0 Then
                                OnSyncSaveLog.WriteLine ("        Error on Decline..: " & Err.Number & ":" & Err.Description)
                            End If
                            
                            OnSyncSaveLog.WriteLine ("        Response : DECLINE")
                        Else
                            '// Accept Appointment
                            Err.Clear
                            With objAppointment
                                strResponseText = "Your request was accepted by an automated " & _
                                                  "EventSink." & vbCrLf & vbCrLf & _
                                                  .Subject & " (" & .Location & ")" & vbCrLf & _
                                                  "Start: " & .StartTime & vbCrLf & _
                                                  "End  : " & .EndTime
                                .ResponseText = strResponseText
                            End With
                            
                            '// preserve subject
                            strSubject = objAppointment.Subject
                            objAppointment.Subject = "Accepted: " & objAppointment.Subject
                            
                            Set objResponse = objAppointment.Accept
                            If Err.Number <> 0 Then
                                OnSyncSaveLog.WriteLine ("        Error on Accept...: " & Err.Number & ":" & Err.Description)
                            End If
                            Err.Clear
                            
                            '// change back the original subject
                            objAppointment.Subject = strSubject
                            objAppointment.DataSource.SaveToContainer strCalendarLocation
                            
                            If Err.Number <> 0 Then
                                OnSyncSaveLog.WriteLine ("        Error on Save.....: " & Err.Number & ":" & Err.Description)
                            End If
                            OnSyncSaveLog.WriteLine ("        Response : ACCEPT")
                    
                        End If
                            
                        '// Send Response
                        Err.Clear
                        objResponse.Message.Send
                        If Err.Number <> 0 Then
                            OnSyncSaveLog.WriteLine ("        Error on send.....: " & Err.Number & ":" & Err.Description)
                        End If
                
                    Case "CANCEL"
                    
                        OnSyncSaveLog.WriteLine ("        Type = CANCELLATION")
                                        
                        '// Get Appointment
                        Err.Clear
                        Set objAppointment = objRequest.CalendarParts.Item(1).GetUpdatedItem
                        If Err.Number <> 0 Then
                            OnSyncSaveLog.WriteLine ("        Error in GUI......: " & Err.Number & ":" & Err.Description)
                        End If
                                                
                        '// delete the Appointment
                        Err.Clear
                        objRecAppt.Open objAppointment.DataSource.SourceURL, , adModeReadWrite
                        objRecAppt.DeleteRecord
                        If Err.Number <> 0 Then
                            OnSyncSaveLog.WriteLine ("        Error on Save.....: " & Err.Number & ":" & Err.Description)
                        End If
                        
                        '// Send message verifying cancelation
                        With objMessage
                            Set .Configuration = objConfiguration
                            .To = objRequest.Message.From
                            .Subject = objAppointment.Subject
                            With objAppointment
                                strResponseText = "Your request was canceled by an automated " & _
                                                  "EventSink." & vbCrLf & vbCrLf & _
                                                  .Subject & " (" & .Location & ")" & vbCrLf & _
                                                  "Start: " & .StartTime & vbCrLf & _
                                                  "End  : " & .EndTime
                            End With
                            .TextBody = strResponseText
                            .Send
                        End With
                        
                    Case "REPLY"
                        
                        OnSyncSaveLog.WriteLine ("        Type = REPLY")
                        
                    Case Else
                    
                        '// Oops! Unexpected Request type
                        OnSyncSaveLog.WriteLine ("        Oops! Unexpected Request Type(" & UCase(strRequestType) & ")")
                    
                End Select
            
            End If
            
            With OnSyncSaveLog
                .WriteLine ("[VB Event Sink]       End. " & Now)
                .WriteBlankLines (1)
                .Close
            End With
            
            Set objFileSystemObject = Nothing
            
        Case Else '// lFlags
        
            '// Oops! We didn't catch the lFlag
            With OnSyncSaveLog
                .WriteLine ("   Oops! Unexpected lFlag.")
                .WriteLine ("[VB Event Sink]       End.")
                .Close
            End With
            Set objFileSystemObject = Nothing
            
    End Select
    
    Set objDispInfo = Nothing

End Sub

