VBCommons/ui/Calendar/CSE_Calendar.frm

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CSE_Calendar 
   Caption         =   "Calendar"
   ClientHeight    =   4455
   ClientLeft      =   30
   ClientTop       =   390
   ClientWidth     =   4440
   OleObjectBlob   =   "CSE_Calendar.frx":0000
   StartUpPosition =   2  'CenterScreen
End
Attribute VB_Name = "CSE_Calendar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' =========== Calendar picker native VBA ================
' Shared module version: 20210502
' Dependencies: z_CalendarUI, CSE_CallbackCalendar
Option Explicit

Private Const GWL_STYLE = -16
Private Const WS_CAPTION = &HC00000
Private Const MOUSE_LEFT_BTN = 1

Private Const CALENDAR_DAYS_COUNT = 42
Private Const CALENDAR_WEEKDAY_COUNT = 7
Private Const CALENDAR_MONTH_COUNT = 12

Private Const CALENDAR_YEARS_PER_PAGE = 12

Private Type CalendarThemeColors
  background_ As Long
  foreground_ As Long
  curDateBG_ As Long
  curDateFG_ As Long
  inactiveDates_ As Long
End Type

Private Enum CalendarMode
  CAL_MODE_DAY = 0
  CAL_MODE_MONTH = 1
  CAL_MODE_YEAR = 2
End Enum

Private Declare PtrSafe Function FindWindow Lib "user32" _
  Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" _
  Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" _
  Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As LongPtr

Public isCancelled_ As Boolean

Private curDate_ As Long

Private month_ As Long
Private year_ As Long

Private mode_ As CalendarMode
Private theme_ As TCalendarTheme
Private colors_ As CalendarThemeColors

Private firstYear_ As Long
Private lastYear_ As Long

Private xPos_ As Double
Private yPos_ As Double

Private callbacks_ As Collection

Private Sub UserForm_Initialize()
  Call ResetBorders
  Call HideTitleBar
  Call InitLabelCallbacks
  
  isCancelled_ = True
  mode_ = CAL_MODE_DAY

  Call PositionInMiddle
  Call SetCurrentDateInternal(Int(Now))
  Call SetTheme(T_CT_LIGHT)
End Sub

Public Function Init(theDate&, aTheme As TCalendarTheme)
  isCancelled_ = True
  
  Call SetCurrentDateInternal(theDate)
  Call ChangeMode(CAL_MODE_DAY)
  Call UpdateTitle
  Call SetTheme(aTheme)
  Call ResetBorders
End Function

Public Property Get SelectedDate() As Long
  SelectedDate = curDate_
End Property

Public Property Get Theme() As TCalendarTheme
  Theme = theme_
End Property

Public Function SetTheme(newValue As TCalendarTheme)
  theme_ = newValue
  Call UpdateThemeColors
  Call RepaintAllColors
End Function

' ==== Events handlings ======
Public Function OnDayClicked(cLabel As MSForms.Label)
  Call ReturnResult(cLabel.Tag)
End Function

Public Function OnMonthClicked(cLabel As MSForms.Label)
  month_ = TagToMonth(cLabel.Caption)
  Call ChangeMode(CAL_MODE_DAY)
End Function

Public Function OnYearClicked(cLabel As MSForms.Label)
  If Len(Trim(cLabel.Caption)) = 0 Then _
    Exit Function
  year_ = val(cLabel.Caption)
  Call ChangeMode(CAL_MODE_MONTH)
End Function

Private Sub lblToday_Click()
  If mode_ <> CAL_MODE_DAY Then
    Call SetCurrentDateInternal(Int(Now))
    Call ChangeMode(CAL_MODE_DAY)
  Else
    Call ReturnResult(Int(Now))
  End If
End Sub

Private Sub lblThemes_Click()
  If theme_ < TCalendarTheme.[_Last] Then
    Call SetTheme(theme_ + 1)
  Else
    Call SetTheme(TCalendarTheme.[_First])
  End If
End Sub

Private Sub lblUnload_Click()
  isCancelled_ = True
  Call Me.Hide
End Sub

Private Sub btnClose_Click()
  If mode_ <> CAL_MODE_DAY Then
    Call ChangeMode(mode_ - 1)
  Else
    isCancelled_ = True
    Call Me.Hide
  End If
End Sub

Private Sub lblUP_Click()
  Select Case mode_
    Case CAL_MODE_DAY
      Call IncrementMonth(-1)
      
    Case CAL_MODE_MONTH
    
    Case CAL_MODE_YEAR
      lastYear_ = firstYear_ - 1
      firstYear_ = firstYear_ - CALENDAR_YEARS_PER_PAGE
      Call RepaintYearsColor
  End Select
End Sub

Private Sub lblDOWN_Click()
  Select Case mode_
    Case CAL_MODE_DAY
      Call IncrementMonth(1)
    
    Case CAL_MODE_MONTH
    
    Case CAL_MODE_YEAR
      firstYear_ = lastYear_ + 1
      lastYear_ = lastYear_ + CALENDAR_YEARS_PER_PAGE
      Call RepaintYearsColor
  End Select
End Sub

Private Sub UserForm_MouseDown(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single)
  If nBtn = MOUSE_LEFT_BTN Then
    xPos_ = mvX
    yPos_ = mvY
  End If
End Sub

Private Sub UserForm_MouseMove(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single)
  If nBtn And MOUSE_LEFT_BTN Then
    Me.Left = Me.Left + (mvX - xPos_)
    Me.Top = Me.Top + (mvY - yPos_)
  End If
End Sub

Private Sub Frame1_MouseDown(ByVal nBtn As Integer, ByVal nShift As Integer, ByVal mvX As Single, ByVal mvY As Single)
  If nBtn = MOUSE_LEFT_BTN Then
    xPos_ = mvX
    yPos_ = mvY
  End If
End Sub

Private Sub lblTitleCurMY_Click()
'--> Handles the month to year multipage display
  If mode_ = CAL_MODE_YEAR Then _
    Exit Sub
  Call ChangeMode(mode_ + 1)
End Sub

' =========
Private Function ReturnResult(theDate&)
  curDate_ = theDate
  isCancelled_ = False
  Call Me.Hide
End Function

Private Function PositionInMiddle()
  Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (Me.Height / 2)
  Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (Me.Width / 2)
  
  Me.StartUpPosition = 0
  Me.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0)
  Me.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0)
End Function

Private Function HideTitleBar()
  Dim frameHandle As Long: frameHandle = FindWindow(vbNullString, Me.Caption)
  Dim windowHandle As Long: windowHandle = GetWindowLong(frameHandle, GWL_STYLE)
  windowHandle = windowHandle And (Not WS_CAPTION)
  Call SetWindowLong(frameHandle, GWL_STYLE, windowHandle)
  Call DrawMenuBar(frameHandle)
End Function

Private Function ResetBorders()
  Dim aLabel As control
  For Each aLabel In Me.Controls
    If TypeOf aLabel Is MSForms.Label Then _
      aLabel.BorderStyle = fmBorderStyleNone
  Next
End Function

Private Function InitLabelCallbacks()
  Dim aControl As control
  Dim controlType$
  Set callbacks_ = New Collection
  For Each aControl In Me.Controls
    If Not TypeOf aControl Is MSForms.Label Then _
      GoTo NEXT_CONTROL
    controlType = Left(aControl.Name, 1)
    If Not controlType Like "[DMY]" Then _
      GoTo NEXT_CONTROL
    Call AddCallback(aControl)
NEXT_CONTROL:
  Next aControl
  
  Call AddCallback(lblUP)
  Call AddCallback(lblDOWN)
  Call AddCallback(lblThemes)
  Call AddCallback(lblUnload)
  Call AddCallback(lblTitleCurMY, bUnderline:=True)
  Call AddCallback(lblToday, bUnderline:=True)
End Function

Private Function AddCallback(target As control, Optional bUnderline As Boolean = False)
  Dim newCallback As New CSE_CallbackCalendar
  Call newCallback.Init(target, bUnderline)
  Call callbacks_.Add(newCallback)
End Function

Private Function SetCurrentDateInternal(theDate&)
  curDate_ = theDate
  month_ = Month(curDate_)
  year_ = Year(curDate_)
  Call UpdateDays
End Function

Private Function IncrementMonth(inc&)
  year_ = year_ + ((month_ + inc + CALENDAR_MONTH_COUNT - 1) \ CALENDAR_MONTH_COUNT - 1)
  month_ = 1 + ((CALENDAR_MONTH_COUNT + (month_ + inc - 1) Mod CALENDAR_MONTH_COUNT) Mod CALENDAR_MONTH_COUNT)
  Call UpdateTitle
  Call UpdateDays
End Function

Private Function ChangeMode(newMode As CalendarMode)
  If newMode = mode_ Then _
    Exit Function
  
  Me.MPmainDisplay.Value = newMode
  Call SetArrowsVisibility(newMode <> CAL_MODE_MONTH)
  mode_ = newMode
  Select Case mode_
    Case CAL_MODE_DAY
      Call UpdateDays
  
    Case CAL_MODE_MONTH
      Call RepaintMonthsColors

    Case CAL_MODE_YEAR
      lastYear_ = year_ + 1
      firstYear_ = lastYear_ - CALENDAR_YEARS_PER_PAGE + 1
      Call RepaintYearsColor
  End Select
  Call UpdateTitle
End Function

Private Function UpdateDays()
'--> Populate the calendar
  Dim firstDay&: firstDay = DateSerial(year_, month_, 1)
  firstDay = firstDay - Weekday(firstDay, vbMonday) + 1
  Dim lastDay&: lastDay = firstDay + CALENDAR_DAYS_COUNT - 1
  
  Dim nItem&
  For nItem = 1 To CALENDAR_DAYS_COUNT
    With Me.Controls("D" & nItem)
      .Caption = Day(firstDay + nItem - 1)
      .Tag = firstDay + nItem - 1
    End With
  Next nItem
  
  Call RepaintDaysColors
End Function

Private Function UpdateTitle()
  Select Case mode_
    Case CAL_MODE_DAY
      lblTitleCurMY.Caption = Format(DateSerial(year_, month_, 1), "MMMM yyyy")
  
    Case CAL_MODE_MONTH
      lblTitleCurMY.Caption = year_

    Case CAL_MODE_YEAR
      lblTitleCurMY.Caption = firstYear_ & " - " & lastYear_
  End Select
End Function

Private Function UpdateThemeColors()
  With colors_
    Select Case theme_
      Case TCalendarTheme.T_CT_DARK
        .background_ = RGB(69, 69, 69)
        .foreground_ = RGB(252, 248, 248)
        .curDateBG_ = RGB(246, 127, 8)
        .curDateFG_ = RGB(0, 0, 0)
        .inactiveDates_ = RGB(120, 120, 120)
    
      Case TCalendarTheme.T_CT_RED
        .background_ = RGB(87, 0, 0)
        .foreground_ = RGB(203, 146, 146)
        .curDateBG_ = RGB(122, 185, 247)
        .curDateFG_ = RGB(0, 0, 0)
        .inactiveDates_ = RGB(144, 70, 70)
    
      Case TCalendarTheme.T_CT_BLUE
        .background_ = RGB(42, 48, 92)
        .foreground_ = RGB(179, 179, 179)
        .curDateBG_ = RGB(122, 185, 247)
        .curDateFG_ = RGB(0, 0, 0)
        .inactiveDates_ = RGB(80, 80, 166)
    
      Case TCalendarTheme.T_CT_LIGHT
        .background_ = RGB(240, 240, 240)
        .foreground_ = RGB(0, 0, 0)
        .curDateBG_ = RGB(246, 127, 8)
        .curDateFG_ = RGB(0, 0, 0)
        .inactiveDates_ = RGB(200, 200, 200)
    End Select
  End With
End Function

Private Function SetArrowsVisibility(isVisible As Boolean)
  lblDOWN.Visible = isVisible
  lblUP.Visible = isVisible
End Function

Private Function TagToMonth(sTag$) As Long
  Select Case sTag
    Case "JAN": TagToMonth = 1
    Case "FEB": TagToMonth = 2
    Case "MAR": TagToMonth = 3
    Case "APR": TagToMonth = 4
    Case "MAY": TagToMonth = 5
    Case "JUN": TagToMonth = 6
    Case "JUL": TagToMonth = 7
    Case "AUG": TagToMonth = 8
    Case "SEP": TagToMonth = 9
    Case "OCT": TagToMonth = 10
    Case "NOV": TagToMonth = 11
    Case "DEC": TagToMonth = 12
  End Select
End Function

Private Function RepaintAllColors()
  Me.BackColor = colors_.background_
  FrameDay.BackColor = colors_.background_
  FrameMonth.BackColor = colors_.background_
  FrameYr.BackColor = colors_.background_
  
  lblToday.ForeColor = colors_.foreground_
  lblToday.BorderColor = colors_.foreground_
  
  lblTitleCurMY.ForeColor = colors_.foreground_
  lblTitleCurMY.BorderColor = colors_.foreground_

  lblUnload.ForeColor = colors_.foreground_
  lblThemes.ForeColor = colors_.foreground_

  lblUP.ForeColor = colors_.foreground_
  lblDOWN.ForeColor = colors_.foreground_
  
  Dim nItem&
  For nItem = 1 To CALENDAR_WEEKDAY_COUNT Step 1
    Me.Controls("WD" & nItem).ForeColor = colors_.foreground_
  Next nItem
  
  Call RepaintDaysColors
  Call RepaintMonthsColors
  Call RepaintYearsColor
End Function

Private Function RepaintDaysColors()
  Dim nItem&
  Dim theDate&
  For nItem = 1 To CALENDAR_DAYS_COUNT Step 1
    With Me.Controls("D" & nItem)
      theDate = .Tag
      .BorderStyle = fmBorderStyleNone
      If .Tag = curDate_ Then
        .BackStyle = fmBackStyleOpaque
        .BackColor = colors_.curDateBG_
        .ForeColor = colors_.curDateFG_
      ElseIf Month(.Tag) = month_ Then
        .BackStyle = fmBackStyleTransparent
        .BackColor = colors_.background_
        .ForeColor = colors_.foreground_
      Else
        .BackStyle = fmBackStyleTransparent
        .BackColor = colors_.background_
        .ForeColor = colors_.inactiveDates_
      End If
    End With
  Next nItem
End Function

Private Function RepaintMonthsColors()
  Dim nMonth&
  For nMonth = 1 To CALENDAR_MONTH_COUNT Step 1
    With Me.Controls("M" & nMonth)
      .BorderStyle = fmBorderStyleNone
      If nMonth = month_ Then
        .BackStyle = fmBackStyleOpaque
        .BackColor = colors_.curDateBG_
        .ForeColor = colors_.curDateFG_
      Else
        .BackStyle = fmBackStyleTransparent
        .BackColor = colors_.background_
        .ForeColor = colors_.foreground_
      End If
    End With
  Next nMonth
End Function

Private Function RepaintYearsColor()
  Dim nYear&
  For nYear = 1 To CALENDAR_YEARS_PER_PAGE Step 1
    With Me.Controls("Y" & nYear)
      .BorderStyle = fmBorderStyleNone
      .Caption = CStr(firstYear_ + nYear - 1)
      If nYear + firstYear_ - 1 = year_ Then
        .BackStyle = fmBackStyleOpaque
        .BackColor = colors_.curDateBG_
        .ForeColor = colors_.curDateFG_
      Else
        .BackStyle = fmBackStyleTransparent
        .BackColor = colors_.background_
        .ForeColor = colors_.foreground_
      End If
    End With
  Next nYear
End Function