Any simpler VB samples for custom data?

 

Option Explicit

 

Private m_pEditingEvent As CalendarEvent

 

Private Sub AddToCalendar()

 

Dim rs As ADODB.Recordset

Dim sConn As String
Dim sSQL As String
Dim sDB As String

 

On Error GoTo errHandler
   
    sDB = "YourDatabase.mdb"
   
    sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDB & ";Persist Security Info=False"
    sSQL = "SELECT * FROM ActionLog"
   
    Set rs = New ADODB.Recordset
   
    rs.Open sSQL, sConn, adOpenDynamic, adLockOptimistic
   
    Do While rs.EOF = False
       
        Set m_pEditingEvent = CalendarControl.DataProvider.CreateEvent
       
        If m_pEditingEvent.RecurrenceState <> xtpCalendarRecurrenceMaster Then
            m_pEditingEvent.StartTime = rs!dStart
            m_pEditingEvent.EndTime = rs!dEnd
        End If
   
        m_pEditingEvent.Subject = rs!sOperation
        m_pEditingEvent.Location = rs!sStation
        m_pEditingEvent.Body = rs!Body
        m_pEditingEvent.AllDayEvent = False
        m_pEditingEvent.Label = GetStationColor(rs!sStation)
        m_pEditingEvent.BusyStatus = 0
       
        m_pEditingEvent.ScheduleID = 0
       
        m_pEditingEvent.PrivateFlag = False
        m_pEditingEvent.MeetingFlag = False
       
        m_pEditingEvent.Reminder = 0
       
        m_pEditingEvent.CustomProperties.Property("Errors") = rs!lFilesProcErr
        m_pEditingEvent.CustomProperties.Property("BackupComment") = rs!sBackupComment
        m_pEditingEvent.CustomProperties.Property("RestoreComment") = rs!sRestoreComment
        m_pEditingEvent.CustomProperties.Property("BackupUser") = rs!sUser
        m_pEditingEvent.CustomProperties.Property("BackupStation") = rs!sStation
       
        m_pEditingEvent.CustomProperties.Property("RefNo") = rs!sRefNo
           
        m_pEditingEvent.CustomProperties.Property("FileErr") = rs!sFileError
       
        CalendarControl.DataProvider.AddEvent m_pEditingEvent
       
    Loop
   
    rs.Close
   

    CalendarControl.Populate

errHandler:
   
    If Err.Number Then
        MsgBox Err.Number & ", " & Err.Description, vbCritical, ""
    End If
   
    Set rs = Nothing
   
End Sub

 

Public Function GetStationColor(ByVal sPStation As String) As Integer

 

On Error GoTo errHandler
   
    Select Case UCase$(sPStation)
       
        Case "DEVELOPMENT"
            GetStationColor = 2
           
        Case "16-2"
            GetStationColor = 3
           
        Case "10XP"
            GetStationColor = 8
           
        Case "11XP"
            GetStationColor = 10
           
        Case Else
            GetStationColor = 9
           
    End Select
   
errHandler:
   
    If Err.Number Then
        MsgBox Err.Number & ", " & Err.Description, vbCritical, ""
    End If
   
End Function

 

 

 

    Dim pRCDesc As CalendarResourceDescription, pResourceCount As Integer
    Dim pData As CalendarDataProvider
    Dim pEvents As CalendarEvents
    Dim pSchedules As CalendarSchedules, pSchedCount As Integer
   
'   The calendar control uses schedule id's to group events by individual. Since we are dealing with rooms as opposed to individuals we will use the roomid as a schedule id.
   
    g_DataResourcesMan.RemoveDataProvider (0)
   
    Do Until g_DataResourcesMan.ResourcesCount = 0
        g_DataResourcesMan.RemoveResource (0)
    Loop
   
    bResult = g_DataResourcesMan.AddDataProvider("Provider=custom;DSN=" & gAppSettings.DSN, xtpCalendarDPF_CreateIfNotExists + _
            xtpCalendarDPF_SaveOnDestroy + xtpCalendarDPF_CloseOnDestroy)

    If Not bResult Then Exit Function

    Set pData = g_DataResourcesMan.DataProvider(0)
    Set pSchedules = pData.Schedules

    If pSchedules Is Nothing Then Exit Function

    With prsFacilityRooms
   
        .ActiveConnection = gconLocalDatabase
        .CursorType = adOpenDynamic
        .LockType = adLockReadOnly
       
        pstrSQL = "SELECT ID, ROOM FROM rbs_event..FACILITY_ROOMS WHERE FACILITYID = " & cboFacilityLocation.ItemData(cboFacilityLocation.ListIndex)
       
        If cboFacilityRooms.ListIndex > 0 Then pstrSQL = pstrSQL & " AND ID = " & cboFacilityRooms.ItemData(cboFacilityRooms.ListIndex)
       
        .Open pstrSQL & " ORDER BY ROOM"
       
        Do Until .EOF
       
            pSchedules.AddNewSchedule CStr(!Id)
            g_DataResourcesMan.AddResource !ROOM, True
           
            .MoveNext
           
        Loop
       
        pData.Save

        For pSchedCount = 0 To .RecordCount - 1

            Set pRCDesc = g_DataResourcesMan.Resource(pSchedCount)

            pRCDesc.Resource.SetDataProvider pData, False
            pRCDesc.Resource.ScheduleIDs.Add CInt(pSchedules(pSchedCount).Name)
            pRCDesc.GenerateName = True

        Next
       
        .Close
       
    End With