' //////////////////////////////////////////////////////////////////////////////////////
' /// 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
|