484 lines
13 KiB
Plaintext
484 lines
13 KiB
Plaintext
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
|