Creating a Calendar in Access 2010

Question

I have been desperately trying to find a way to make a calendar in Access. I know it can be done, as I've seen wonderful examples, but I don't know how. (Also, my VB knowledge is minimal.)

Basically, I want the calendar to show a range of dates of when a program (we call them capsules) has been checked out, and when it will be returned.

• DateReserve - the Date a capsule has been reserved
• DateReturn - the Date when the capsule needs to be returned.

For example, if Capsule A is reserved on 6/1/2014 and will return 6/14/2014, I want the calendar to visually show that Capsule A will be unavailable during this time period. That way, we don't accidentally double-book a capsule.

Through one of my many google searches, I did find VB code that pulls up a very nice looking calendar. I just can't get the code right to visually show what dates a capsule will be unavailable. Below is one of the sections of code I can't get to work right:

Private Sub OpenContinuousForm(ctlName As String)
Dim ctlValue As Integer
Dim DaysOfMonth As Long
Dim DateReturn As Date
Dim DateShipOut As Date
Dim DateRangeForProgram As String

DateRangeForProgram = (DateDiff("n", [DateReturn], [DateShipOut]))
On Error GoTo ErrorHandler
ctlValue = Me.Controls(ctlName).Tag
DaysOfMonth = MyArray(ctlValue - 1, 0)

DoCmd.OpenForm "frmCapsulesSchedule", acNormal, , [DateRangeForProgram] = DaysOfMonth

ExitSub:
    Exit Sub
ErrorHandler:
    MsgBox "DATE SHIP OUT FAILED.", , "Error!!!"
    Resume ExitSub

End Sub

Please let me know if you need further information from me.

Answer 1

There is a very useful youtube video I came across by Access All In One. Here is a link to the database used in the example

Answer 2

Your syntax in the Where condition of the openform command is incorrect.

It should be "[DateRangeForProgram]=" & DaysOfMonth, if the field your using to filter the form's recordsource is [DateRangeForProgram].

Also, if you're trying to open the form to multiple days, you should likely be using the Between operator. The datediff function's first argument specifies an interval, and your interval is minutes.

You should post the rest of the code so the entire scenario is clear.

Answer 3

Here is the code I used for the calendar; Anywhere you see 'Teachers,' 'Schools,' or 'Capsules' would be where you'd put your own information:

Option Compare Database
Option Explicit

Private intYear As Integer
Private intMonth As Integer
Private lngFirstDayOfMonth As Long
Private intLastDayOfLastMonth As Integer
Private intFirstWeekday As Integer
Private intDaysInMonth As Integer
Private strFormReference As String
Private MyArray() As Variant

Private Sub cboMonth_Click()
On Error GoTo Errorhandler
Call Main
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub
Private Sub cboYear_AfterUpdate()
On Error GoTo Errorhandler
Call Main
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub

Private Sub Form_Load()
On Error GoTo Errorhandler
'Set the month and date to this current month and date
With Me
    .cboMonth = Month(Date)
    .cboYear = Year(Date)
End With

Call Main

ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub

Public Sub InitVariables()
On Error GoTo Errorhandler
intYear = Me.cboYear
intMonth = Me.cboMonth
lngFirstDayOfMonth = CLng(DateSerial(intYear, intMonth, 1))
intFirstWeekday = getFirstWeekday(lngFirstDayOfMonth)
intDaysInMonth = getDaysInMonth(lngFirstDayOfMonth)
'This is where you add the reference for the form
'It is used in case we wish to add the module to a subform

ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub
Public Sub Main()
On Error GoTo Errorhandler
Call InitVariables
Call InitArray
Call LoadArray
Call PrintArray
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub

Public Sub InitArray()
'First column will add all dates of the array
'Second column will add visible property
'Third column will hold the string variable

Dim i As Integer

On Error GoTo Errorhandler

ReDim MyArray(0 To 41, 0 To 3)

For i = 0 To 41

    MyArray(i, 0) = lngFirstDayOfMonth + 1 - intFirstWeekday + i
    If Month(MyArray(i, 0)) = intMonth Then
        MyArray(i, 1) = True
        'This works out the days of the month
        MyArray(i, 2) = i + 2 - intFirstWeekday & vbNewLine
    Else
        MyArray(i, 1) = False
    End If
   
Next i
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub

End Sub

Public Sub LoadArray()
'This sub loads an array with the relevant variables from a query
Dim db As Database
Dim rs As Recordset
Dim rsFiltered As Recordset
Dim strQuery As String
Dim i As Integer

On Error GoTo ErrorHandler1

strQuery = "Select * FROM [qryDatesYearsCapsules2]"

Set db = CurrentDb
Set rs = db.OpenRecordset(strQuery)



With rs

    If Not rs.BOF And Not rs.EOF Then
    'Ensures the recordset contains records
  
  On Error GoTo ErrorHandler2

        For i = 0 To UBound(MyArray)
        'Will loop through the array and use dates to filter down the query
        'It firsts checks that the second column has true for its visible property
            If MyArray(i, 1) = True Then
                .Filter = "[NewDate]=" & MyArray(i, 0)
                'To filter you must open a secondary recordset and
                'Use that as the basis for a query
                'This makes sense as you are building a query on a query

                Set rsFiltered = .OpenRecordset
                If Not rsFiltered.BOF And Not rsFiltered.EOF Then
                    'If the recordset is not empty then you are able
                    'to extract the text from the values provided
                    Do While Not rsFiltered.EOF = True

                        MyArray(i, 2) = MyArray(i, 2) & rsFiltered!CapsuleSet
           '             MyArray(i, 2) = MyArray(i, 2) & vbNewLine & rsFiltered!Teacher
                        MyArray(i, 2) = MyArray(i, 2) & vbNewLine & rsFiltered!School
           '             MyArray(i, 2) = MyArray(i, 2) & " - " & rsFiltered!NewDate
                        MyArray(i, 2) = MyArray(i, 2) & vbNewLine & vbNewLine
                        
                    rsFiltered.MoveNext
                    Loop
                End If
            End If
     
        Next i
    
End If
    .Close
End With

ExitSub:
    Set db = Nothing
    Set rs = Nothing
    Exit Sub
ErrorHandler1:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
    
ErrorHandler2:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
    
End Sub

Public Sub PrintArray()

Dim strTextBox As String
Dim i As Integer

On Error GoTo Errorhandler

For i = 0 To 41
    strTextBox = "txt" & CStr(i + 1)
    With Me
        Controls(strTextBox) = ""
        Controls(strTextBox).tag = i + 1
        Controls(strTextBox) = MyArray(i, 2)
    'Debug.Print strTextBox
    'MyArray(i, 2)
    End With
Next i
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub

Private Sub OpenContinuousForm(ctlName As String)
Dim ctlValue As Integer
Dim DayOfMonth As Long

On Error GoTo Errorhandler
ctlValue = Me.Controls(ctlName).tag
DayOfMonth = MyArray(ctlValue - 1, 0)
DoCmd.OpenForm "frmClassDataEntry", acNormal, , "[NewDate]=" & DayOfMonth, , acDialog
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub

End Sub

Private Sub txt1_Click()
On Error GoTo Errorhandler
If Me.ActiveControl.Text <> "" Then
    Call OpenContinuousForm(Me.ActiveControl.Name)
End If
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload form."
    Resume ExitSub
End Sub

'Repeat the code for txt1_Click() all the ways to txt42_Click()

Private Sub Format()

  Dim ctl As Control
  Dim lngBackColor As Long

  For Each ctl In Me.Detail.Controls
    If DCount("*", "lstCapsules", "[Capsule]='" & ctl.Value & "'") = 0 Then

       lngBackColor = 16777215
    Else
       lngBackColor = DLookup("Background", "lstCapsules", "[Capsule]='" & ctl.Value & "'")
    End If

    ctl.BackColor = lngBackColor
    
    Next ctl
    
  Set ctl = Nothing
  
End Sub

I also have a module called modFunctions:

    Option Compare Database
Option Explicit

Public Function getFirstWeekday(lngFirstDayOfMonth As Long) As Integer

On Error GoTo Errorhandler
getFirstWeekday = -1
getFirstWeekday = Weekday(lngFirstDayOfMonth, vbMonday)

ExitFunction:
    Exit Function
Errorhandler:
    getFirstWeekday = 0
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitFunction
End Function

Public Function getDaysInMonth(lngFirstDayOfMonth As Long) As Integer

On Error GoTo Errorhandler
getDaysInMonth = -1
getDaysInMonth = DateDiff("d", lngFirstDayOfMonth, DateAdd("m", 1, lngFirstDayOfMonth))
ExitFunction:
    Exit Function
Errorhandler:
    getDaysInMonth = 0
    MsgBox "Something is wrong with the DATES!.", , "Date Error"
    Resume ExitFunction
End Function