VBA Express : Excel - Win/Mac Scalable Calendar Control

Excel

Win/Mac Scalable Calendar Control

Ease of Use

Intermediate

Version tested with

Win: 2000, 2003; Mac: X

Submitted by:

BlueCactus

Description:

A calendar control that runs on both Mac and Windows. Does not rely on ActiveX.

Discussion:

The most-employed calendar control uses ActiveX, barring it from deployment on Mac versions of Office. (Macs do not run ActiveX.) This KB provides an alternative. In addition to allowing the user to select dates, it also allows (if desired) for the selection of one or more events (e.g., holidays, meetings) associated with one or more dates. To learn more, please download and open the sample file provided.

Code:

instructions for use

' ////////////////////////////////////////////////////////////////////////////////////// ' /// The first section of code belongs in a Module named CalendarModule ' ////////////////////////////////////////////////////////////////////////////////////// ' This module (and code) needs to be in your WorkBooks unless you have a solid undestanding of VBA. ' This code acts as a bridge between your code and the Calendar form. Option Explicit Dim displayDate As Date, eventCodes As Variant Dim useCustomExtras As Boolean, optionFindToday As Boolean, widthDay As Double, _ heightDay As Double, forceCancel As Boolean, baseYear As Integer, endYear As Integer, _ formX As Double, formY As Double, bkColor As Long, selColor As Long, highColor As Long Sub customUserDate(Optional bY As Integer = 0, Optional eY As Integer = 0, _ Optional fC As Boolean = False, Optional oFT As Boolean = False, _ Optional wD As Double = 30, Optional hD As Double = 20, Optional fX As Double = -1, _ Optional fY As Double = -1, Optional bC As Long = vbWindowBackground, Optional sC As Long = vbHighlight, _ Optional hC As Long = 255) ' This Sub is used to set some optional parameters before calling the Calendar. Dim tY As Integer forceCancel = fC optionFindToday = oFT If wD >= 30 Then widthDay = wD Else widthDay = 30 If hD >= 20 Then heightDay = hD Else heightDay = 20 If bY > 99 Then baseYear = bY Else baseYear = DatePart("yyyy", Date) - 10 If eY > 99 Then endYear = eY Else endYear = DatePart("yyyy", Date) + 10 formX = fX formY = fY bkColor = bC selColor = sC highColor = hC useCustomExtras = True End Sub Function getUserDate(Optional defaultDate As Date = Empty, Optional dpMode As Integer = 0, _ Optional displayComments As Boolean = False, Optional eL As Variant = "") As Variant ' This code does the actual call to the calendar form. Dim i As Integer, addText As String, dateResults As Variant, eventList As Variant ' customUserDate() not called - set some defaults If Not useCustomExtras Then baseYear = DatePart("yyyy", Date) - 10 endYear = DatePart("yyyy", Date) + 10 optionFindToday = False widthDay = 30 heightDay = 20 forceCancel = False bkColor = vbWindowBackground selColor = vbHighlight highColor = 255 End If If IsArray(eL) Then eventList = eL Load DatePick ' Custom form position specified If useCustomExtras And formX <> -1 And formY <> -1 Then DatePick.startupposition = 3 DatePick.Left = formX DatePick.Top = formY End If useCustomExtras = False Call DatePick.FillVars(defaultDate, dpMode, forceCancel, displayComments, eventList, optionFindToday, widthDay, heightDay, baseYear, endYear, bkColor, selColor, highColor) DatePick.Show ' Events returned to this function - repackage them. If IsArray(eventCodes) Then ReDim dateResults(0 To UBound(eventCodes)) dateResults(0) = displayDate For i = 1 To UBound(eventCodes) dateResults(i) = eventCodes(i) Next i Else If displayDate = Empty Then dateResults = "" Else dateResults = displayDate End If End If getUserDate = dateResults End Function Sub returnDate(dD As Date, rE As Variant) ' The calendar returns date and events via this Sub. displayDate = dD: eventCodes = rE End Sub ' ////////////////////////////////////////////////////////////////////////////////////// ' /// The remaining code belongs in a UserForm named DatePick. ' /// This form requires the presence of: ' /// a. 38 TextBoxes ' /// b. 13 Labels ' /// c. 2 ComboBoxes ' /// d. 2 SpinButtons ' /// e. 1 ListBox ' /// f. 3 CommandButtons ' /// g. 3 OptionButtons ' /// Controls should retain their default names, which should be sequential ' /// (e.g., TextBox10 should not be missing and there should be no TextBox39) ' /// It is not necessary to set any control or form Properties other than ' /// the UserForm.Name (DatePick) ' ////////////////////////////////////////////////////////////////////////////////////// ' This is the actual calendar. This module must be copied to your own WorkBooks (see Page 6 of instructions) Option Explicit Dim dayNames As Variant, monthNames As Variant, daysMonth As Variant Dim canUpdate As Integer, selectDate As Date, dpMode As Integer, eventList As Variant Dim eventMatrix As Variant, baseYear As Integer, eventChars As Integer, codeList As Variant Dim eventTotal As Integer, returnEvents As Variant, displayComments As Boolean Dim eventSelect As Variant, totalSelect As Integer, optionFindToday As Integer Dim bkColor As Long, selColor As Long, highColor As Long ' These are text strings used on the form. Placed here to facilitate changing them globally if customizing the calendar. Const strLabel11 As String = "Event selection mode:" Const strLabel13A As String = "No events selected" Const strLabel13B As String = " selected event(s)" Const strLabel13C As String = "No selected events" Const strLabel12 As String = "Comments" Const strOption1 As String = "Add" Const strOption2 As String = "Remove" Const strOption3 As String = "Off" Const strText38A As String = "<no comment available>" Const strLabel10A As String = "Events for " Const strLabel10B As String = "Remove events from selected list:" Const strLabel9A As String = "Default date selection: " Const strLabel9B As String = "No date selected" Const strLabel9C As String = "Current date selection: " Sub FillVars(Optional sD As Date = Empty, Optional dpM As Integer = 0, Optional fC As Boolean = True, _ Optional dC As Boolean = False, Optional eL As Variant = "", Optional oFT As Boolean = False, _ Optional widthDay As Double = 30, Optional heightDay As Double = 20, Optional bY As Integer = 0, _ Optional endYear As Integer = 0, Optional bC As Long = vbWindowBackground, Optional sC As Long = vbHighlight, _ Optional hC As Long = 255) ' This sub takes the place of Userform_Initialize and is used to fetch parameters from the calling code. ' You may wish to change some of the defaults above. Dim i As Long, posX As Integer, posY As Integer Dim eventDate As Date, eventLabel As String, numYears As Integer, tabMe As Integer dayNames = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat") monthNames = Array("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December") daysMonth = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) selectDate = sD: dpMode = dpM: displayComments = dC: optionFindToday = oFT: eventTotal = 0 bkColor = bC: selColor = sC: highColor = hC ' If calling code supplied baseYear, use that else generate default baseYear If bY > 0 Then baseYear = bY numYears = endYear - baseYear + 1 ' If current date is outside of calendar range, disable 'Find Today' button If DatePart("yyyy", Date) <= baseYear Or DatePart("yyyy", Date) >= endYear Then CommandButton2.Enabled = False End If Else baseYear = DatePart("yyyy", Date) - 9 numYears = 20 End If ' Default date selection outside of calendar limits; reset it to empty. If DatePart("yyyy", selectDate) < baseYear Or DatePart("yyyy", selectDate) > endYear Then selectDate = Empty ' Let's look at the eventList If IsArray(eL) Then eventList = eL ' Some basic error checks If UBound(eventList, 2) < 2 And dpMode > 1 Then MsgBox "Event List does not contain descriptions" Unload Me End If If displayComments And UBound(eventList, 2) < 3 Then MsgBox "Event list does not contain comments" Unload Me End If ' eventMatrix will contain references to eventList sorted by date. This could have been done with a 1D array, ' but this array will contain fewer unused elements. ReDim eventMatrix(0 To numYears, 1 To 12, 1 To 31) eventChars = Len(CStr(UBound(eventList, 1))) ' Scan the contents of eventList For i = 1 To UBound(eventList, 1) ' eventLabel is defined with trailing zeros so that the number of events on a day can be derived from the ' length of that day's eventMatrix entry. eventLabel = CStr(i) If Len(eventLabel) < eventChars Then eventLabel = String(Len(eventChars) - Len(eventLabel), Asc("0")) & eventLabel End If ' Try to set a date. We don't know if it's in the correct format. On Error GoTo InitError1 eventDate = DateValue(eventList(i, 1)) On Error GoTo 0 ' Succeeded. Check that the date is within the dates accessible on the form. If so, load a reference to ' the event into eventMatrix. If DatePart("yyyy", eventDate) - baseYear >= LBound(eventMatrix, 1) And DatePart("yyyy", eventDate) - baseYear <= UBound(eventMatrix, 1) Then eventMatrix(DatePart("yyyy", eventDate) - baseYear, DatePart("m", eventDate), DatePart("d", eventDate)) = _ eventMatrix(DatePart("yyyy", eventDate) - baseYear, DatePart("m", eventDate), DatePart("d", eventDate)) & eventLabel End If Next i Else ' No eventList was passed. Just create a dummy array instead. ReDim eventList(1 To 1, 1 To 3) eventList(1, 1) = "" eventList(1, 2) = "" eventList(1, 3) = "" End If ' Prevent event code from executing while we format the form. canUpdate = 1 If dpMode > 1 Then widthDay = 1.5 * widthDay posX = widthDay / 2 ' ------------------------------------------------------------------------------------------------------------------------------ ' ----------- USERFORM FORMATTING.... ' ----------- The following code is in compressed (multiple statements per line) format to save some space ' ------------------------------------------------------------------------------------------------------------------------------ tabMe = Me.Controls.Count ' >>> TITLE LABEL. Contains month and year of calendar. With Label8 .Left = widthDay / 2: .Top = heightDay / 2: .Width = widthDay * 7: .Height = heightDay * 1.5: .TabIndex = tabMe: tabMe = tabMe - 1 .Font.Name = "Tahoma": .Font.Size = 16 * heightDay / 20: .Font.Bold = True: .Caption = monthNames(DatePart("m", Date) - 1) & " " & DatePart("yyyy", Date) End With ' >>>> LABEL1 through LABEL7 are the WEEKDAY TITLES (Sun thru Sat) For i = 1 To 7 With Me.Controls("Label" & i) .Left = posX: .Top = heightDay * 2: .Width = widthDay: .Height = heightDay .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .Font.Bold = True .Caption = dayNames(i - 1): .TextAlign = fmTextAlignCenter: .TabIndex = tabMe End With posX = posX + widthDay: tabMe = tabMe - 1 Next i ' >>>> TESTBOX1 thru TEXTBOX37 are the numeric day labels. Although CommandButtons are the obvious choice, ' >>>> they have rounded corners on Mac OS X, which would make the form look like a rack of marbles. posX = widthDay / 2: posY = heightDay * 3 For i = 1 To 37 With Me.Controls("TextBox" & i) .Left = posX: .Top = posY: .Width = widthDay: .TabIndex = tabMe: tabMe = tabMe - 1 If dpMode < 2 Then .Height = heightDay Else .Height = 2 * heightDay: .MultiLine = True .Font.Name = "Tahoma": .Font.Size = 9 * heightDay / 20: .TextAlign = fmTextAlignCenter .BackStyle = fmBackStyleOpaque: .BackColor = bkColor End With If i / 7 = i \ 7 Then posX = widthDay / 2: posY = posY + heightDay ' Need extra line in dpModes 2 through 4. If dpMode > 1 Then posY = posY + heightDay Else posX = posX + widthDay End If Next i ' Update posY for next control posY = posY + heightDay If dpMode > 1 Then posY = posY + heightDay ' >>>> COMBOBOX1 is the MONTH SELECTION With ComboBox1 .Left = widthDay / 2: .Top = posY + heightDay / 2: .Width = widthDay * 3.5: .Height = heightDay .Font.Name = "Tahoma": .Font.Size = 9 * heightDay / 20 For i = 1 To 12: .AddItem monthNames(i - 1): Next i .ListIndex = DatePart("m", Date) - 1: .Style = fmStyleDropDownList: .TabIndex = 1 .BackStyle = fmBackStyleOpaque: .BackColor = bkColor End With ' >>>> COMBOBOX2 is the YEAR SELECTION With ComboBox2 .Left = widthDay * 5: .Top = posY + heightDay / 2: .Width = widthDay * 2: .Height = heightDay .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20 For i = baseYear To endYear: .AddItem i: Next i If DatePart("yyyy", selectDate) >= baseYear And DatePart("yyyy", selectDate) <= endYear Then .ListIndex = DatePart("yyyy", selectDate) - baseYear Else .ListIndex = numYears \ 2 End If .Style = fmStyleDropDownList: .TabIndex = 3 .BackStyle = fmBackStyleOpaque: .BackColor = bkColor End With ' >>>> SPINBUTTON1 controls COMBOBOX1 (MONTH) With SpinButton1 .Left = widthDay * 4: .Top = posY + heightDay / 2: .Width = widthDay / 2: .Height = heightDay .Min = 0: .Max = 11: .Value = ComboBox1.ListIndex: .TabIndex = 2 End With ' >>>> SPINBUTTON2 controls COMBOBOX2 (YEAR) With SpinButton2 .Left = widthDay * 7: .Top = posY + heightDay / 2: .Width = widthDay / 2: .Height = heightDay .Min = 0: .Max = numYears - 1: .Value = ComboBox2.ListIndex: .TabIndex = 4 End With ' >>>> COMMANDBUTTON1 is the 'OK' BUTTON With CommandButton1 .Left = widthDay * 5.5 If dpMode < 2 Then .Top = posY + heightDay * 3 Else .Top = posY + heightDay * 2 .Width = widthDay * 2: .Height = heightDay .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .Caption = "OK" .TabIndex = 0 End With ' >>>> COMMANDBUTTON2 is the 'FIND TODAY' BUTTON With CommandButton2 .Left = widthDay / 2: .Top = CommandButton1.Top: .Width = widthDay * 2: .Height = heightDay .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .Caption = "Find Today": .TabIndex = 10 End With ' >>>> COMMANDBUTTON3 is the 'CANCEL' BUTTON With CommandButton3 .Left = widthDay * 3: .Top = CommandButton1.Top: .Width = widthDay * 2: .Height = heightDay .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .Caption = "Cancel" .Enabled = fC: .Visible = fC: .TabIndex = 9 End With ' >>>> LABEL9 is the DATE SELECTION LABEL With Label9 If dpMode < 2 Then .Left = widthDay / 2: .Top = posY + heightDay * 2 Else .Left = widthDay * 8: .Top = CommandButton1.Top If dpMode = 4 Then .Top = .Top + 10 End If .Width = widthDay * 7: .Height = heightDay: .TabIndex = tabMe: tabMe = tabMe - 1 .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20 If selectDate <> Empty Then .Caption = strLabel9A & monthNames(DatePart("m", selectDate) - 1) & " " & _ DatePart("d", selectDate) & ", " & DatePart("yyyy", selectDate) Else .Caption = strLabel9B End If End With ' >>>> LABEL11 is the STATIC 'EVENT SELECTION MODE' LABEL With Label11 .Left = widthDay * 8: .Top = ComboBox1.Top + 2: .Width = widthDay * 3: .Height = heightDay: .TabIndex = tabMe .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .Font.Bold = True: .Caption = strLabel11: tabMe = tabMe - 1 If dpMode < 4 Then .Enabled = False: .Visible = False Else .Enabled = True: .Visible = True End With ' >>>> LABEL13 is the EVENT SELECTION LABEL With Label13 .Left = widthDay * 8: .Top = CommandButton1.Top - 10: .Width = widthDay * 7: .Height = heightDay: .TabIndex = tabMe .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .Caption = strLabel13A: tabMe = tabMe - 1 If dpMode < 4 Then .Enabled = False: .Visible = False Else .Enabled = True: .Visible = True End With ' >>>> OPTIONBUTTON1 is the 'ADD EVENT' OPTION With OptionButton1 .Left = widthDay * 11: .Top = ComboBox1.Top: .Width = widthDay * 1.2: .Height = heightDay: .TabIndex = 6 .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .Caption = strOption1 If dpMode < 4 Then .Enabled = False: .Visible = False Else .Enabled = True: .Visible = True: .Value = True End With ' >>> OPTIONBUTTON2 is the 'REMOVE EVENT' OPTION With OptionButton2 .Left = widthDay * 12.2: .Top = ComboBox1.Top: .Width = widthDay * 2: .Height = heightDay: .TabIndex = 7 .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .Caption = strOption2 If dpMode < 4 Then .Enabled = False: .Visible = False Else .Enabled = True: .Visible = True: .Value = False End With ' >>>> OPTIONBUTTON3 is the 'OFF [EVENT]' OPTION With OptionButton3 .Left = widthDay * 14: .Top = ComboBox1.Top: .Width = widthDay * 1.5: .Height = heightDay: .TabIndex = 8 .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .Caption = strOption3 If dpMode = 4 Then .Enabled = True: .Visible = True: .Value = True Else: .Enabled = False: .Visible = False End With ' If dpMode <2 we don't need ListBox1 or Label10 If dpMode < 2 Then ListBox1.Enabled = False: ListBox1.Visible = False Label10.Enabled = False: Label10.Visible = False Else ' >>>> LABEL10 is the TITLE FOR LISTBOX1 With Label10 .Left = 8 * widthDay: .Top = 2 * heightDay: .Width = 7 * widthDay: .Height = heightDay: .TabIndex = tabMe .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .Font.Bold = True: tabMe = tabMe - 1: .Caption = "Events" End With ' >>>> LISTBOX1 is the EVENT LIST With ListBox1 .Left = 8 * widthDay: .Top = 3 * heightDay: .Width = 7 * widthDay: .TabIndex = 5 If displayComments Then .Height = 9.5 * heightDay Else .Height = 12 * heightDay .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20 .ColumnCount = 2: .ColumnWidths = widthDay & ";" If dpMode = 3 Then .MultiSelect = 2 Else .MultiSelect = 0 .BackColor = bkColor End With ' If calling code supplied a default date, list events for that day If selectDate > 0 Then Call ListEvents End If ' >>>> TEXTBOX38 contains COMMENTS for SELECTED DAY If displayComments Then With TextBox38 .Left = widthDay * 8: .Top = 14 * heightDay: .Width = 7 * widthDay: .Height = 1.5 * heightDay: .TabIndex = tabMe .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .MultiLine = True: tabMe = tabMe - 1 .BackStyle = fmBackStyleOpaque: .BackColor = bkColor: .Locked = True End With ' >>>> LABEL12 is the STATIC 'COMMENTS' LABEL With Label12 .Left = widthDay * 8: .Top = 13 * heightDay: .Width = 7 * widthDay: .Height = heightDay: .TabIndex = tabMe .Font.Name = "Tahoma": .Font.Size = 10 * heightDay / 20: .Font.Bold = True: .Caption = strLabel12: tabMe = tabMe - 1 End With Else Label12.Enabled = False: Label12.Visible = False TextBox38.Enabled = False: TextBox38.Visible = False End If ' Now set some PARENT FORM PROPERTIES With Me If dpMode < 2 Then .Width = 8 * widthDay Else .Width = 15.5 * widthDay .Height = CommandButton1.Top + 2 * heightDay + 10 .Caption = "Calendar" End With ' ------------------------------------------------------------------------------------------------------------------------------ ' ----------- END FORMATTING ' ------------------------------------------------------------------------------------------------------------------------------ ' Start calendar in default month, if available, otherwise just start it in today's month If selectDate <> Empty Then ComboBox2.ListIndex = DatePart("yyyy", selectDate) - baseYear ComboBox1.ListIndex = DatePart("m", selectDate) - 1 Call SetDays(selectDate) Else ComboBox2.ListIndex = numYears \ 2 ComboBox1.ListIndex = DatePart("m", Date) - 1 Call SetDays(DateValue(DatePart("m", Date) & " 1, " & ComboBox2.Text)) End If SpinButton2.Value = ComboBox2.ListIndex SpinButton1.Value = ComboBox1.ListIndex Label8.Caption = ComboBox1.Text & " " & ComboBox2.Text ' Start allowing event code to execute canUpdate = canUpdate - 1 Exit Sub InitError1: MsgBox "Cannot extract date from event list (index: " & i & ")" On Error GoTo 0 Unload Me End Sub Private Sub ComboBox1_Change() ' New month required If canUpdate = 0 Then canUpdate = canUpdate + 1 Label8.Caption = ComboBox1.Text & " " & ComboBox2.Text Call SetDays(DateValue(ComboBox1.Text & " 1, " & ComboBox2.Text)) SpinButton1.Value = ComboBox1.ListIndex canUpdate = canUpdate - 1 End If End Sub Private Sub ComboBox2_Change() ' New year selected If canUpdate = 0 Then canUpdate = canUpdate + 1 Label8.Caption = ComboBox1.Text & " " & ComboBox2.Text Call SetDays(DateValue(ComboBox1.Text & " 1, " & ComboBox2.Text)) SpinButton2.Value = ComboBox2.ListIndex canUpdate = canUpdate - 1 End If End Sub Private Sub CommandButton1_Click() ' The 'OK' button Dim i As Integer, eventsCount As Integer ' dpMode 3 allows multiple event selections If dpMode = 3 Then ' Count events selected in ListBox1 eventsCount = 0 For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) Then eventsCount = eventsCount + 1 Next i If eventsCount > 0 Then ' We have events ReDim returnEvents(1 To eventsCount) ' Enter them into returnEvents() eventsCount = 1 For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) Then returnEvents(eventsCount) = codeList(i + 1) eventsCount = eventsCount + 1 End If Next i Call CalendarModule.returnDate(selectDate, returnEvents) Else ' No events counted Call CalendarModule.returnDate(selectDate, "no events") End If ' In dpMode 4, selected events are already collected in returnEvents() ElseIf dpMode = 4 Then If eventTotal > 0 Then Call CalendarModule.returnDate(selectDate, returnEvents) Else Call CalendarModule.returnDate(selectDate, "no events") End If ' dpModes 0, 1, 2 do not allow event selection Else Call CalendarModule.returnDate(selectDate, "no events") End If ' Quit form Unload Me End Sub Private Sub CommandButton2_Click() ' The 'Find Today' button. Disabled if today is not within the range of the calendar. canUpdate = canUpdate + 1 ' Reset ComboBoxes and SpinButtons to today's date ComboBox2.ListIndex = DatePart("yyyy", Date) - baseYear SpinButton2.Value = ComboBox2.ListIndex ComboBox1.ListIndex = DatePart("m", Date) - 1 SpinButton1.Value = ComboBox1.ListIndex Label8.Caption = ComboBox1.Text & " " & ComboBox2.Text ' Change the calendar to the month containing today Call SetDays(DateValue(ComboBox1.Text & " 1, " & ComboBox2.Text)) canUpdate = canUpdate - 1 ' If optionFindToday, this also changes the Date Selection If optionFindToday Then If dpMode < 2 Then Call SetNewDate(DatePart("d", Date)) Else ' Need to strip the carriage return when events are available Call SetNewDate(DatePart("d", Date) & Chr(13)) End If End If End Sub Private Sub CommandButton3_Click() ' The 'Cancel' button. No date and no events! Call CalendarModule.returnDate(Empty, "no events") Unload Me End Sub Private Sub ListBox1_Change() ' The event list. Disabled for dpModes 0, 1. This code is specific for dpMode3. Dim i As Integer, j As Integer, indexStart As Integer, indexEnd As Integer, stepDir As Integer If dpMode = 3 And displayComments And ListBox1.ListCount > 0 Then ' Start by assuming we'll search for new selections top-to-bottom indexStart = 0 indexEnd = ListBox1.ListCount - 1 ' This block determines direction of additional selections (up or down) For i = 0 To ListBox1.ListCount - 1 ' If we've hit the previous last selection, we already know the answer (top-to-bottom) If eventSelect(i) = totalSelect Then Exit For ' If we hit a new selection before finding the previous last selection, ' then we'll change the search for new selections to be bottom-to-top If eventSelect(i) = 0 And ListBox1.Selected(i) Then indexStart = indexEnd indexEnd = 0 Exit For End If Next i stepDir = Sgn(indexEnd - indexStart) If stepDir = 0 Then stepDir = 1 ' Update selection list in eventSelect() For i = indexStart To indexEnd Step stepDir If ListBox1.Selected(i) = True Then ' Newly selected item: place selection number in eventSelect() and update totalSelect If eventSelect(i) = 0 Then eventSelect(i) = totalSelect + 1 totalSelect = totalSelect + 1 End If Else ' Deselected item: remove its selection number, and update all others to compensate. If eventSelect(i) > 0 Then For j = 0 To ListBox1.ListCount - 1 If eventSelect(j) > eventSelect(i) Then eventSelect(j) = eventSelect(j) - 1 Next j eventSelect(i) = 0 totalSelect = totalSelect - 1 End If End If Next i If totalSelect > 0 Then ' At least one event selected: place comment for most recent selection in TextBox38 For i = 0 To ListBox1.ListCount - 1 If eventSelect(i) = totalSelect Then If Len(eventList(codeList(i + 1), 3)) > 0 Then TextBox38.Text = "[" & i + 1 & "] " & eventList(codeList(i + 1), 3) Else TextBox38.Text = "[" & i + 1 & "] " & strText38A End If End If Next i Else ' No selection: clear TextBox38 TextBox38.Text = "" End If End If End Sub Private Sub ListBox1_Click() ' The event list. Disabled for dpModes 0, 1. dpMode3 uses ListBox1_Change() Dim i As Integer, eventFound As Boolean If dpMode = 4 Then If OptionButton1.Value Then ' Request to add event to returnEvents() ' Note that in this case, ListBox1 is displaying the list of events for the selected date. ' First check it's not already in returnEvents() If eventTotal > 0 Then eventFound = False For i = 1 To UBound(returnEvents) If returnEvents(i) = codeList(ListBox1.ListIndex + 1) Then eventFound = True Next i ' Not found, add it to returnEvents() If Not eventFound Then eventTotal = eventTotal + 1 ReDim Preserve returnEvents(1 To eventTotal) returnEvents(eventTotal) = codeList(ListBox1.ListIndex + 1) End If ' Label13 contains the total number of events in returnEvents() Label13.Caption = eventTotal & strLabel13B Else ' eventTotal is currently 0; this will be the first event in returnEvents() ReDim returnEvents(1 To 1) eventTotal = 1 returnEvents(1) = codeList(ListBox1.ListIndex + 1) Label13.Caption = "1" & strLabel13B End If ElseIf OptionButton2.Value Then ' Request to delete selection from returnEvents() ' Note that in this case, ListBox1 is displaying the list of selected events. If ListBox1.ListIndex + 1 < ListBox1.ListCount Then For i = ListBox1.ListIndex + 1 To eventTotal - 1 returnEvents(i) = returnEvents(i + 1) Next i End If eventTotal = eventTotal - 1 If eventTotal > 0 Then ReDim Preserve returnEvents(1 To eventTotal) Label13.Caption = eventTotal & strLabel13B Else Label13.Caption = strLabel13C End If Call ListEvents End If End If ' Display comments if appropriate If displayComments Then If (dpMode = 4 And Not OptionButton2.Value) Or dpMode < 4 Then If Len(eventList(codeList(ListBox1.ListIndex + 1), 3)) > 0 Then TextBox38.Text = eventList(codeList(ListBox1.ListIndex + 1), 3) Else TextBox38.Text = strText38A End If Else TextBox38.Text = "" End If End If End Sub Private Sub OptionButton1_Click() ' Event 'Add' button for dpMode 4 If canUpdate = 0 And selectDate <> Empty Then Call ListEvents End Sub Private Sub OptionButton2_Click() ' Event 'Delete' button for dpMode 4 If canUpdate = 0 And selectDate <> Empty Then Call ListEvents End Sub Private Sub OptionButton3_Click() ' Event No Add/ No Delete button for dpMode 4 If canUpdate = 0 And selectDate <> Empty Then Call ListEvents End Sub Private Sub SpinButton1_Change() ' Change month ComboBox1.ListIndex = SpinButton1.Value End Sub Private Sub SpinButton2_Change() ' Change year ComboBox2.ListIndex = SpinButton2.Value End Sub ' These all select a new date from the calendar boxes Private Sub TextBox1_enter(): Call SetNewDate(TextBox1.Text): End Sub Private Sub TextBox2_enter(): Call SetNewDate(TextBox2.Text): End Sub Private Sub TextBox3_enter(): Call SetNewDate(TextBox3.Text): End Sub Private Sub TextBox4_enter(): Call SetNewDate(TextBox4.Text): End Sub Private Sub TextBox5_enter(): Call SetNewDate(TextBox5.Text): End Sub Private Sub TextBox6_enter(): Call SetNewDate(TextBox6.Text): End Sub Private Sub TextBox7_enter(): Call SetNewDate(TextBox7.Text): End Sub Private Sub TextBox8_enter(): Call SetNewDate(TextBox8.Text): End Sub Private Sub TextBox9_enter(): Call SetNewDate(TextBox9.Text): End Sub Private Sub TextBox10_enter(): Call SetNewDate(TextBox10.Text): End Sub Private Sub TextBox11_enter(): Call SetNewDate(TextBox11.Text): End Sub Private Sub TextBox12_enter(): Call SetNewDate(TextBox12.Text): End Sub Private Sub TextBox13_enter(): Call SetNewDate(TextBox13.Text): End Sub Private Sub TextBox14_enter(): Call SetNewDate(TextBox14.Text): End Sub Private Sub TextBox15_enter(): Call SetNewDate(TextBox15.Text): End Sub Private Sub TextBox16_enter(): Call SetNewDate(TextBox16.Text): End Sub Private Sub TextBox17_enter(): Call SetNewDate(TextBox17.Text): End Sub Private Sub TextBox18_enter(): Call SetNewDate(TextBox18.Text): End Sub Private Sub TextBox19_enter(): Call SetNewDate(TextBox19.Text): End Sub Private Sub TextBox20_enter(): Call SetNewDate(TextBox20.Text): End Sub Private Sub TextBox21_enter(): Call SetNewDate(TextBox21.Text): End Sub Private Sub TextBox22_enter(): Call SetNewDate(TextBox22.Text): End Sub Private Sub TextBox23_enter(): Call SetNewDate(TextBox23.Text): End Sub Private Sub TextBox24_enter(): Call SetNewDate(TextBox24.Text): End Sub Private Sub TextBox25_enter(): Call SetNewDate(TextBox25.Text): End Sub Private Sub TextBox26_enter(): Call SetNewDate(TextBox26.Text): End Sub Private Sub TextBox27_enter(): Call SetNewDate(TextBox27.Text): End Sub Private Sub TextBox28_enter(): Call SetNewDate(TextBox28.Text): End Sub Private Sub TextBox29_enter(): Call SetNewDate(TextBox29.Text): End Sub Private Sub TextBox30_enter(): Call SetNewDate(TextBox30.Text): End Sub Private Sub TextBox31_enter(): Call SetNewDate(TextBox31.Text): End Sub Private Sub TextBox32_enter(): Call SetNewDate(TextBox32.Text): End Sub Private Sub TextBox33_enter(): Call SetNewDate(TextBox33.Text): End Sub Private Sub TextBox34_enter(): Call SetNewDate(TextBox34.Text): End Sub Private Sub TextBox35_enter(): Call SetNewDate(TextBox35.Text): End Sub Private Sub TextBox36_enter(): Call SetNewDate(TextBox36.Text): End Sub Private Sub TextBox37_enter(): Call SetNewDate(TextBox37.Text): End Sub Private Sub SetNewDate(setDay As String) ' Change the selected date If canUpdate = 0 Then If dpMode = 0 Then ' Quits form with selected date for dpMode 0 Call CalendarModule.returnDate(DateValue(ComboBox1.Text & " " & setDay & ", " & ComboBox2.Text), "no events") Unload Me ElseIf dpMode = 1 Then selectDate = DateValue(ComboBox1.Text & " " & setDay & ", " & ComboBox2.Text) Call SetDays(selectDate) Label9.Caption = strLabel9C & ComboBox1.Text & " " & setDay & ", " & ComboBox2.Text Else setDay = Left(setDay, InStr(setDay, Chr(13)) - 1) selectDate = DateValue(ComboBox1.Text & " " & setDay & ", " & ComboBox2.Text) Call SetDays(selectDate) Label9.Caption = strLabel9C & ComboBox1.Text & " " & setDay & ", " & ComboBox2.Text Call ListEvents End If End If End Sub Private Sub ListEvents() ' For dpModes 2, 3, 4: lists events associated with selected date to ListBox1 Dim eventCodes As String, i As Integer, lEMode As Boolean ' Are we in event delete mode and dpMode 4? lEMode = True If dpMode = 4 And OptionButton2.Value Then lEMode = False ' dpModes <4 or dpMode 4 and event ignore mode: If dpMode < 4 Or (dpMode = 4 And OptionButton3.Value) Then Label10.Caption = strLabel10A & monthNames(DatePart("m", selectDate) - 1) & " " & DatePart("d", selectDate) & ", " & DatePart("yyyy", selectDate) & ":" Else If OptionButton1.Value Then Label10.Caption = "Add events from " & monthNames(DatePart("m", selectDate) - 1) & " " & DatePart("d", selectDate) & ", " & DatePart("yyyy", selectDate) & ":" Else Label10.Caption = strLabel10B End If End If ListBox1.Clear If lEMode Then ' Collect eventCodes eventCodes = eventMatrix(DatePart("yyyy", selectDate) - baseYear, DatePart("m", selectDate), DatePart("d", selectDate)) ' We have events for this date If Len(eventCodes) > 0 Then ReDim codeList(1 To Len(eventCodes) / eventChars) ' Add events for this date to ListBox1 For i = 1 To Len(eventCodes) / eventChars ListBox1.AddItem i ListBox1.List(i - 1, 1) = eventList(Mid(eventCodes, (i - 1) * eventChars + 1, eventChars), 2) codeList(i) = Mid(eventCodes, (i - 1) * eventChars + 1, eventChars) Next i End If ' dpMode = 4; event delete mode Else ' Add selected events to ListBox1 For i = 1 To eventTotal ListBox1.AddItem i ListBox1.List(i - 1, 1) = "[" & DateValue(eventList(returnEvents(i), 1)) & "] " & eventList(returnEvents(i), 2) Next i End If ' dpMode = 3; display comments. Initialize eventList() with no selections If dpMode = 3 And displayComments And ListBox1.ListCount > 0 Then ReDim eventSelect(0 To ListBox1.ListCount - 1) For i = 1 To UBound(eventSelect) eventSelect(i) = False Next i totalSelect = 0 End If If displayComments Then TextBox38.Text = "" End Sub Sub SetDays(ByVal tempDate As Date) ' This code switches the calendar view to the required month and year Dim i As Integer, numDay As Integer, numEvents As Integer ' Use the 1st of whatever month was passed tempDate = DateValue(monthNames(DatePart("m", tempDate) - 1) & " 1, " & DatePart("yyyy", tempDate)) ' What's the day of the week for the first of the month? numDay = DatePart("w", tempDate) ' Leap year? If DatePart("yyyy", tempDate) / 4 = DatePart("yyyy", tempDate) \ 4 Then daysMonth(1) = 29 Else daysMonth(1) = 28 End If ' numDay not Sunday? Disable all boxes leading up to the day of the week for numDay If numDay > 1 Then For i = 1 To numDay - 1 Me.Controls("TextBox" & i).Enabled = False Me.Controls("TextBox" & i).Visible = False Next i End If ' Number the boxes for day of the month. For i = 1 To daysMonth(DatePart("m", tempDate) - 1) With Me.Controls("TextBox" & (numDay + i - 1)) .Visible = True .Enabled = True .Text = i ' For dpModes 2, 3, 4: add the total number of events listed for that day If dpMode > 1 Then numEvents = Len(CStr(eventMatrix(DatePart("yyyy", tempDate) - baseYear, DatePart("m", tempDate), i))) / eventChars If numEvents > 0 Then .Text = .Text & Chr(13) & "[" & numEvents & "]" Else .Text = .Text & Chr(13) End If End If .Locked = True .TabStop = False .BackColor = bkColor .ForeColor = RGB(0, 0, 0) .Font.Bold = False ' Change box formatting for selected date if it's visible If DatePart("yyyy", selectDate) = ComboBox2.Text And monthNames(DatePart("m", selectDate) - 1) = ComboBox1.Text Then If DatePart("d", selectDate) = i Then .BackColor = selColor .ForeColor = vbHighlightText End If End If ' Change box formatting for current date if it's visible If DatePart("yyyy", Date) = ComboBox2.Text And monthNames(DatePart("m", Date) - 1) = ComboBox1.Text Then If DatePart("d", Date) = i Then .ForeColor = highColor .Font.Bold = True End If End If End With Next i ' Hide all boxes past end of month For i = daysMonth(DatePart("m", tempDate) - 1) + numDay To 37 With DatePick.Controls("TextBox" & i) .Enabled = False .Visible = False End With Next i ' Make sure the form is updated on the display Me.Repaint End Sub

How to use:

Download the sample file and open it in Excel.
Follow the instructions and demonstrations contained within the file.
The sample file contains a command button to transfer the code to your WorkBooks.

Test the code:

Download the sample file and open it in Excel.
The demonstrations in the sample file will allow you to test the code.

Sample File:

vbax_calendar.xls.zip 287.91KB

Approved by mdmackillop

This entry has been viewed 421 times.