VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "CSE_CallbackCalendar" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False ' =========== Calendar picker native VBA - Label clicks callback ================ ' Shared module version: 20210130 ' Dependencies: z_CalendarUI, CSE_Calendar Option Explicit Private Const CAL_MOVE_MARGIN = 2 Public WithEvents control_ As MSForms.Label Attribute control_.VB_VarHelpID = -1 Private underline_ As Boolean Public Function Init(aControl As MSForms.Label, Optional bUnderline As Boolean = False) Set control_ = aControl underline_ = bUnderline End Function Private Sub control__Click() Dim controlType$: controlType = Left(control_.Name, 1) Select Case controlType Case "D": Call CSE_Calendar.OnDayClicked(control_) Case "M": Call CSE_Calendar.OnMonthClicked(control_) Case "Y": Call CSE_Calendar.OnYearClicked(control_) End Select End Sub Private Sub control__MouseMove(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single) Dim bIsOutside As Boolean: bIsOutside = IsMoveOutside(mvX, mvY) If underline_ Then control_.Font.Underline = Not bIsOutside control_.Font.Bold = Not bIsOutside Else control_.BorderStyle = IIf(bIsOutside, fmBorderStyleNone, fmBorderStyleSingle) End If End Sub ' ======= Private Function IsMoveOutside(mvX As Single, mvY As Single) IsMoveOutside = _ mvX >= control_.Width - CAL_MOVE_MARGIN Or _ mvX <= CAL_MOVE_MARGIN Or _ mvY <= CAL_MOVE_MARGIN Or _ mvY >= control_.Height - CAL_MOVE_MARGIN End Function