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