'--------------------------------------------------------------------------------
' Procedure  : btnExportApptByDates_Click()
' Author     : Patrick Wood, Gaining Access Technologies http://gainingaccess.net
' Date       : 09/20/2008
' Purpose    : Export Appointments from Access to the Outlook Calendar
'            : by Dates selected on a Date Dialog Form
' Usage      : You are welcome to use and modify this code
'            : if you leave this header intact.
'--------------------------------------------------------------------------------
'
Private Sub btnExportApptByDates_Click()
On Error GoTo ErrHandle

    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim strSQL As String
    Dim strWhere As String
    Dim intCount As Integer

    ' Use late binding to avoid the "Reference" issue
    Dim objOutlook As Object        'Outlook.Application
    Dim objAppointItem As Object    'olAppointmentItem

    ' Set the value of the Outlook Appointment Item
    Const olAppointmentItem = 1

    On Error Resume Next
    ' Try to create a new instance using CreateObject
    Set objOutlook = CreateObject("Outlook.Application")

    ' If there is an error, Outlook is already open
    If Err.Number <> 0 Then
        Err.Clear
        ' Resume Error Handling
        On Error GoTo ErrHandle
        ' Outlook is already open--use GetObject
        Set objOutlook = GetObject(, "Outlook.Application")
    End If

    ' Start building the SQL "WHERE" Statement
    strWhere = "WHERE ApptDate >= #" & Me.txtStartDate & "#" _
    & " AND ApptDate <= #" & Me.txtEndDate & "#"
'    Debug.Print "strWhere = " & strWhere

    ' Finish building the SQL string
    strSQL = "SELECT * FROM tblAppointments " & strWhere & ";"
'    Debug.Print strSQL

    'Instantiate database
    Set db = CurrentDb()

    'Create Recordset based on strSQL
    ' Note: You can create a Recordset using SQL in code with Parameters
    ' or criteria that has not been already set.  That is why we built
    ' the complete SQL string and supplied the values of the criteria.
    Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)

    ' Begin a Loop
    rst.MoveFirst
    Do While Not rst.EOF

        ' Create the New Appointment Item each loop through the Recordset
        Set objAppointItem = objOutlook.CreateItem(olAppointmentItem)

        ' Add the data to the Appointment Properties
        With objAppointItem

            ' Set the Start Property Value
            ' ApptDate is Required by the table no need to check it
            ' The Nz Function can handle a Zero Length String or a Null
            .Start = Nz(rst!ApptDate) & " " & Nz(rst!ApptTime)

            ' Set the End Property Value
            .End = Nz(rst!EndDate) & " " & Nz(rst!EndTime, "")
            .Duration = Nz(rst!ApptLength, 0)
            .Subject = Nz(rst!Appt)
            .Body = Nz(rst!ApptNotes)
            .Location = Nz(rst!Location)

            If rst!ApptReminder = True Then
                If rst!ApptDate < Now() Then
                    ' No Reminder is needed
                    .ReminderOverrideDefault = False
                    .ReminderMinutesBeforeStart = 0
                    .ReminderSet = False

                Else
                    ' Use the Reminder data
                    If Not IsNull(rst!ReminderMinutes) Then
                        .ReminderOverrideDefault = True
                        .ReminderMinutesBeforeStart = rst!ReminderMinutes
                        .ReminderSet = True
                    End If
                End If
            End If

            ' Add the Category if it exists
            .Categories = Nz(rst!Categories)

            ' Save the Appointment Item Properties
            .Save
        End With

        ' Get the number of Appointments added to Outlook
        intCount = intCount + 1

        ' Set the AddedToOutlook Field to True
        rst.Edit
        rst!AddedToOutlook = -1        ' True
        rst.Update
        rst.MoveNext
    Loop

    ' Tell the user how many Appointments were Exported
    MsgBox intCount & " Appointments were added to Outlook.", vbInformation

ExitHere:
    ' Release the memory used for the variables.
    On Error Resume Next
    rst.Close
    Set objAppointItem = Nothing
    Set objOutlook = Nothing
    Set rst = Nothing
    Set db = Nothing
    Exit Sub

ErrHandle:
    Call MsgBox(Err.Description & vbCrLf & "Error Number: " & Err.Number & vbCrLf & _
    "In procedure btnExportApptByDates_Click of VBA Document Form_frmAppointmentsToOutlook")
    Resume ExitHere

End Sub