' Callback function to list the dates of a weekday for a count of weeks.
' By default, the first day of the week according to the system settings
' is listed from the current date for twelve weeks.
'
' Optionally, any weekday, any start date, and any count of weeks can be
' set by the function ConfigWeekdayDates.
' Multiple controls - even a mix of comboboxes and listboxes - can be
' controlled simultaneously with individual settings.
'
' The format of the listed dates are determined by the controls' Format
' properties.
'
' Example for retrieval of selected value:
'
' Dim SelectedDate As Date
' SelectedDate = Me!ControlName.Value
'
' Typical settings for combobox or listbox:
'
' ControlSource: Bound or unbound
' RowSource: Leave empty
' RowSourceType: CallWeekdayDates
' BoundColumn: 1
' LimitToList: Yes
' AllowEditing: No
' ColumnCount: Don't care. Will be set by the function
' ColumnWidths: Don't care. Will be overridden by the function
' ListCount: Don't care. Will be overridden by the function (ComboBox only)
' Format: Optional. A valid format for date values (ComboBox only)
' Tag: Optional. 1 to 255.
' Count of rows listed. If empty or 0, DefaultWeekCount is used
'
' 2021-03-01. Gustav Brock. Cactus Data ApS, CPH.
'
Public Function CallWeekdayDates( _
ByRef Control As Control, _
ByVal Id As Long, _
ByVal Row As Long, _
ByVal Column As Variant, _
ByVal Code As Integer) _
As Variant
' Adjustable constants.
'
' Initial count of weeks to list.
' Fixed for a listbox. A combobox can be reconfigured with function ConfigWeekdayDates.
' Will be overridden by a value specified in property Tag.
Const DefaultWeekCount As Integer = 16
' Format for the display column in a listbox.
Const ListboxFormat As String = "Short Date"
' Left margin of combobox to align the values on list with the formatted value displayed.
' Empiric value.
Const LeftMargin As Integer = 23
' Fixed constants.
'
' Count of columns in the control.
Const ColumnCount As Integer = 2
' Function constants.
'
' Array constants.
Const ControlOption As Integer = 0
Const ApplyOption As Integer = 1
Const WeekdayOption As Integer = 2
Const StartDateOption As Integer = 3
Const RowCountOption As Integer = 4
Const FormatOption As Integer = 5
Const ControlDimension As Integer = 2
' Control IDs.
Const DefaultId As Long = -1
Const ResetId As Long = 0
Const ActionId As Long = 1
' Setting IDs.
Const DayOfWeekId As Long = 1
Const StartDateId As Long = 2
Const RowCountId As Long = 3
Const FormatId As Long = 4
Static ColumnWidth(0 To ColumnCount - 1) As Integer
Static DateFormat As String
Static OptionalValues() As Variant
Static Initialized As Boolean
Dim ControlName As String
Dim ControlIndex As Integer
Dim StartDate As Date
Dim FirstDate As Date
Dim DayOfWeek As VbDayOfWeek
Dim RowCount As Integer
Dim Value As Variant
Select Case Code
Case acLBInitialize
' Control settings.
Control.ColumnCount = ColumnCount ' Set the colum count of the control.
Control.ColumnWidths = MinimalColumnWidth ' Record width of first column. This is used for a requery.
ColumnWidth(0) = HiddenColumnWidth ' Hide the bound (value) column.
ColumnWidth(1) = DefaultColumnWidth ' Set the width of the display column to the default width.
If Control.ControlType = acComboBox Then
' Set the date format later. ' Retrieve the display format from the combobox's Format property.
Control.LeftMargin = LeftMargin ' Adjust left margin of combobox.
Else
DateFormat = ListboxFormat ' Set the display format for the listbox.
End If
If Not Initialized Then
' Array for optional values has not been dimmed in this session.
ReDim OptionalValues(ControlOption To FormatOption, 0 To 0)
Initialized = True
End If
' Initialize.
Value = True ' True to initialize.
Case acLBOpenAsVariant
ControlName = Control.Name
' Find or create the index of the current control.
For ControlIndex = LBound(OptionalValues, ControlDimension) To UBound(OptionalValues, ControlDimension)
If OptionalValues(ControlOption, ControlIndex) = ControlName Then
Exit For
End If
Next
If ControlIndex > UBound(OptionalValues, ControlDimension) Then
' Add yet a control.
ReDim Preserve OptionalValues(ControlOption To FormatOption, 0 To ControlIndex)
OptionalValues(ControlOption, ControlIndex) = ControlName
End If
' Id: Action.
' Row: Parameter id.
' Column: Parameter value.
Select Case Id
Case DefaultId ' Default call.
If OptionalValues(ApplyOption, ControlIndex) = False Then
' Apply initial/default settings.
OptionalValues(ControlOption, ControlIndex) = ControlName
OptionalValues(ApplyOption, ControlIndex) = True
' Use system's first day of week.
OptionalValues(WeekdayOption, ControlIndex) = SystemDayOfWeek
OptionalValues(StartDateOption, ControlIndex) = Date
RowCount = Val(Control.Tag)
If RowCount = 0 Then
RowCount = DefaultWeekCount
End If
OptionalValues(RowCountOption, ControlIndex) = RowCount
' If this is a combobox, retrieve the default format from its Format property.
If Control.ControlType = acComboBox Then
DateFormat = Control.Format
End If
OptionalValues(FormatOption, ControlIndex) = DateFormat
End If
Case ResetId ' Custom call. Ignore custom settings for the current control.
OptionalValues(ApplyOption, ControlIndex) = False
Case ActionId ' Custom call. Set one optional value.
' Row: The id of the parameter to adjust.
' Column: The value of the parameter.
Select Case Row
Case DayOfWeekId ' Day of week.
OptionalValues(WeekdayOption, ControlIndex) = Column
Case StartDateId ' Start date.
If VarType(Column) = vbDate Then
OptionalValues(StartDateOption, ControlIndex) = Column
End If
Case RowCountId ' Count of weeks to list.
OptionalValues(RowCountOption, ControlIndex) = Column
Case FormatId ' Format for display.
If VarType(Column) = vbString Then
OptionalValues(FormatOption, ControlIndex) = Column
End If
End Select
End Select
' Do not return a value.
Case acLBOpen
' Value will be rounded to integer, so multiply by 100. Howeever, a Single
' (as returned by Timer) will be rounded to even, so convert the value to Long.
Value = CLng(Timer * 100) ' Autogenerated unique ID.
Case acLBGetRowCount ' Get count of rows.
ControlName = Control.Name
' Find the index of the current control.
For ControlIndex = LBound(OptionalValues, ControlDimension) To UBound(OptionalValues, ControlDimension)
If OptionalValues(ControlOption, ControlIndex) = ControlName Then
Exit For
End If
Next
' Retrieve current setting.
RowCount = OptionalValues(RowCountOption, ControlIndex)
Value = RowCount ' Set count of rows.
Case acLBGetColumnCount ' Get count of columns.
Value = ColumnCount ' Set count of columns.
Case acLBGetColumnWidth ' Get the column width.
Value = ColumnWidth(Column) ' Use preset column widths.
Case acLBGetValue ' Get the data for each row.
ControlName = Control.Name
' Find the index of the current control.
For ControlIndex = LBound(OptionalValues, ControlDimension) To UBound(OptionalValues, ControlDimension)
If OptionalValues(ControlOption, ControlIndex) = ControlName Then
Exit For
End If
Next
' Retrieve current settings.
StartDate = OptionalValues(StartDateOption, ControlIndex)
DayOfWeek = OptionalValues(WeekdayOption, ControlIndex)
' Retrieve and save for this ControlIndex the format for the
' next call of the function which will have Code = acLBGetFormat.
DateFormat = OptionalValues(FormatOption, ControlIndex)
' Calculate the earliest date later than or equal to the start date.
FirstDate = DateNextWeekday(DateAdd("d", -1, StartDate), DayOfWeek)
' Calculate the date for this row.
Value = DateAdd("ww", Row, FirstDate)
Case acLBGetFormat ' Format the data.
If Column = 1 Then
Value = DateFormat ' Apply the value or the display format.
End If
Case acLBClose ' Do something when the form recalculates or closes.
' no-op.
Case acLBEnd ' Do something more when the form recalculates or closes.
' no-op.
End Select
' Return Value.
CallWeekdayDates = Value
End Function
If Not Initialized Then
' Array for optional values has not been dimmed in this session.
ReDim OptionalValues(ControlOption To FormatOption, 0 To 0)
Initialized = True
End If
Const ControlOption As Integer = 0
Const ApplyOption As Integer = 1
Const WeekdayOption As Integer = 2
Const StartDateOption As Integer = 3
Const RowCountOption As Integer = 4
Const FormatOption As Integer = 5
ControlName = Control.Name
' Find or create the index of the current control.
For ControlIndex = LBound(OptionalValues, ControlDimension) To UBound(OptionalValues, ControlDimension)
If OptionalValues(ControlOption, ControlIndex) = ControlName Then
Exit For
End If
Next
If ControlIndex > UBound(OptionalValues, ControlDimension) Then
' Add yet a control.
ReDim Preserve OptionalValues(ControlOption To FormatOption, 0 To ControlIndex)
OptionalValues(ControlOption, ControlIndex) = ControlName
End If
' Value will be rounded to integer, so multiply by 100. Howeever, a Single
' (as returned by Timer) will be rounded to even, so convert the value to Long.
Value = CLng(Timer * 100) ' Autogenerated unique ID.
Select Case Id
Case DefaultId ' Default call.
If OptionalValues(ApplyOption, ControlIndex) = False Then
' Apply initial/default settings.
OptionalValues(ControlOption, ControlIndex) = ControlName
OptionalValues(ApplyOption, ControlIndex) = True
' Use system's first day of week.
OptionalValues(WeekdayOption, ControlIndex) = SystemDayOfWeek
OptionalValues(StartDateOption, ControlIndex) = Date
RowCount = Val(Control.Tag)
If RowCount = 0 Then
RowCount = DefaultWeekCount
End If
OptionalValues(RowCountOption, ControlIndex) = RowCount
' If this is a combobox, retrieve the default format from its Format property.
If Control.ControlType = acComboBox Then
DateFormat = Control.Format
End If
OptionalValues(FormatOption, ControlIndex) = DateFormat
End If
Case ActionId ' Custom call. Set one optional value.
' Row: The id of the parameter to adjust.
' Column: The value of the parameter.
Select Case Row
Case DayOfWeekId ' Day of week.
OptionalValues(WeekdayOption, ControlIndex) = Column
Case StartDateId ' Start date.
OptionalValues(StartDateOption, ControlIndex) = Column
Case RowCountId ' Count of weeks to list.
OptionalValues(RowCountOption, ControlIndex) = Column
Case FormatId ' Format for display.
If VarType(Column) = vbString Then
OptionalValues(FormatOption, ControlIndex) = Column
End If
End Select
Case acLBGetValue ' Get the data for each row.
ControlName = Control.Name
' Find the index of the current control.
For ControlIndex = LBound(OptionalValues, ControlDimension) To UBound(OptionalValues, ControlDimension)
If OptionalValues(ControlOption, ControlIndex) = ControlName Then
Exit For
End If
Next
' Retrieve current settings.
StartDate = OptionalValues(StartDateOption, ControlIndex)
DayOfWeek = OptionalValues(WeekdayOption, ControlIndex)
' Retrieve and save for this ControlIndex the format for the
' next call of the function which will have Code = acLBGetFormat.
DateFormat = OptionalValues(FormatOption, ControlIndex)
' Calculate the earliest date later than or equal to the start date.
FirstDate = DateNextWeekday(DateAdd("d", -1, StartDate), DayOfWeek)
' Calculate the date for this row.
Value = DateAdd("ww", Row, FirstDate)
Case acLBGetFormat ' Format the data.
If Column = 1 Then
Value = DateFormat ' Apply the value or the display format.
End If
FirstDate = DateAdd("d", 7 - (Weekday(FromDate, DayOfWeek) - 1), FromDate)
Private Sub Form_Load()
Const DefaultRowCount As Integer = 16
Dim FirstDate As Date
Dim RowCount As Long
Dim DayOfWeek As VbDayOfWeek
' Assign the first day of the week as the default selection.
Me!Weekdays1.Value = SystemDayOfWeek
Me!StartDate1.Value = Date
' Assign the last day of the week as the default selection.
Me!Weekdays2.Value = (SystemDayOfWeek - 1 - 1 + DaysPerWeek) Mod DaysPerWeek + 1
Me!StartDate2.Value = Date
' Adjust count of rows to be listed if set in property Tag.
RowCount = Val(Me!WeekdayDates1.Tag)
If RowCount = 0 Then
RowCount = DefaultRowCount
End If
Me!DateRows1.Value = RowCount
RowCount = Val(Me!WeekdayDates2.Tag)
If RowCount = 0 Then
RowCount = DefaultRowCount
End If
Me!DateRows2.Value = RowCount
' Calculate end dates to display.
FirstDate = DateNextWeekday(DateAdd("d", -1, Me!StartDate1.Value), Me!Weekdays1.Value)
Me!EndDate1.Value = DateAdd("ww", RowCount - 1, FirstDate)
FirstDate = DateNextWeekday(DateAdd("d", -1, Me!StartDate2.Value), Me!Weekdays2.Value)
Me!EndDate2.Value = DateAdd("ww", RowCount - 1, FirstDate)
' Retrieve and display the default date format from the comboboxes' Format property.
Me!FormatDate1.DefaultValue = """" & Me!WeekdayDates1.Format & """"
Me!FormatDate2.DefaultValue = """" & Me!WeekdayDates2.Format & """"
' Check if default weekday of the weekday selector is different from SystemDayOfWeek.
DayOfWeek = Me!Weekdays1.Value
If DayOfWeek <> SystemDayOfWeek Then
' Reconfig the list/combobox as the weekday to list is different from SystemDayOfWeek.
ConfigWeekdayDates Me!WeekdayDates1, DayOfWeek
End If
DayOfWeek = Me!Weekdays2.Value
If DayOfWeek <> SystemDayOfWeek Then
' Reconfig the list/combobox as the weekday to list is different from SystemDayOfWeek.
ConfigWeekdayDates Me!WeekdayDates2, DayOfWeek
End If
DayOfWeek = Weekday(Date)
If DayOfWeek <> SystemDayOfWeek Then
' Reconfig the list/combobox as the weekday to list is different from SystemDayOfWeek.
ConfigWeekdayDates Me!ListWeekdayDates, DayOfWeek
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
ConfigWeekdayDates Me!ListWeekdayDates
ConfigWeekdayDates Me!WeekdayDates1
ConfigWeekdayDates Me!WeekdayDates2
End Sub
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (0)