Untitled
unknown
plain_text
10 months ago
42 kB
11
Indexable
Option Explicit
Private TimerID As Long, TimerSeconds As Single, tim As Boolean
Dim curDate As Date
Dim i As Long
Dim thisDay As Integer, thisMonth As Integer, thisYear As Integer
Dim CBArray() As New CalendarClass
'*JCR
Dim Darray() As New CalendarClass
'**********
Dim NewXpos As Single
Dim NewYpos As Single
Private Cal_theme As CalendarThemes
Private LdtFormat As String, SdtFormat As String
Public Property Let LongDateFormat(s As String)
LdtFormat = s
lblTitleCurDt.Caption = Format(Date, LdtFormat)
End Property
Public Property Get LongDateFormat() As String
LongDateFormat = LdtFormat
End Property
Public Property Let ShortDateFormat(s As String)
SdtFormat = s
End Property
Public Property Get ShortDateFormat() As String
ShortDateFormat = SdtFormat
End Property
Public Property Let Caltheme(Theme As CalendarThemes)
Cal_theme = Theme
'--> Set the color of controls
Select Case Cal_theme
Case CalendarThemes.Venom
MyBackColor = RGB(69, 69, 69)
MyForeColor = RGB(252, 248, 248)
CurDateColor = RGB(246, 127, 8)
CurDateForeColor = RGB(0, 0, 0)
NotCurDateColor = RGB(90, 90, 90)
Case CalendarThemes.MartianRed
MyBackColor = RGB(87, 0, 0)
MyForeColor = RGB(203, 146, 146)
CurDateColor = RGB(122, 185, 247)
CurDateForeColor = RGB(0, 0, 0)
NotCurDateColor = RGB(116, 0, 0)
Case CalendarThemes.ArcticBlue
MyBackColor = RGB(42, 48, 92)
MyForeColor = RGB(179, 179, 179)
CurDateColor = RGB(122, 185, 247)
CurDateForeColor = RGB(0, 0, 0)
NotCurDateColor = RGB(66, 71, 118)
Case CalendarThemes.Greyscale
MyBackColor = RGB(240, 240, 240)
MyForeColor = RGB(0, 0, 0)
CurDateColor = RGB(246, 127, 8)
CurDateForeColor = RGB(0, 0, 0)
NotCurDateColor = RGB(225, 225, 225)
End Select
Me.BackColor = MyBackColor
FrameDay.BackColor = MyBackColor
FrameMonth.BackColor = MyBackColor
FrameYr.BackColor = MyBackColor
lblTitleCurDt.ForeColor = CurDateColor
lblTitleCurMY.ForeColor = MyForeColor
lblTitleCurMY.BorderColor = MyForeColor
lblTitleClock.ForeColor = MyForeColor
lblTitleAMPM.ForeColor = MyForeColor
lblUnload.ForeColor = MyForeColor
lblThemes.ForeColor = MyForeColor
lblUP.ForeColor = MyForeColor
lblDOWN.ForeColor = MyForeColor
'--> Days
For i = 1 To 42
With Me.Controls("D" & i)
.ForeColor = MyForeColor
.BorderColor = MyForeColor
End With
Next i
'--> Weekdays
For i = 1 To 7
With Me.Controls("WD" & i)
.ForeColor = MyForeColor
End With
Next i
'--> Month
For i = 1 To 12
With Me.Controls("M" & i)
.ForeColor = MyForeColor
.BorderColor = MyForeColor
End With
Next i
'--> Year
For i = 1 To 12
With Me.Controls("Y" & i)
.ForeColor = MyForeColor
.BorderColor = MyForeColor
End With
Next i
'--> Populate this months calendar
PopulateCalendar Date
End Property
Public Property Get Caltheme() As CalendarThemes
Caltheme = Cal_theme
End Property
'--> allow user to cycle thru avialable themes
Private Sub lblThemes_Click()
Dim t As Byte
scss
Copy code
t = ThisWorkbook.Sheets(1).Cells(8, 2)
If t <= 2 Then
t = t + 1
frmETRcalendar.Caltheme = t
frmETRcalendar.Repaint
ThisWorkbook.Sheets(1).Cells(8, 2) = t
Else
frmETRcalendar.Caltheme = 0
frmETRcalendar.Repaint
ThisWorkbook.Sheets(1).Cells(8, 2) = 0
End If
End Sub
'--> Unload form
Private Sub lblUnload_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
'--> remove borders from day labels. i keep them in place for the dev environment.
Dim lblCtrl As control
i = 0
For Each lblCtrl In Me.Controls
If TypeOf lblCtrl Is MSForms.Label Then
lblCtrl.BorderStyle = fmBorderStyleNone
End If
Next
'--> Hide the Title Bar
HideTitleBar Me
Me.LongDateFormat = "dddd mm, yyyy"
Me.ShortDateFormat = "mm/dd/yyyy"
'--> Create a command button control array so that
'--> when we press escape, we can unload the userform
Dim CBCtl As control
i = 0
'*JCR
For Each CBCtl In Me.Controls
If TypeOf CBCtl Is MSForms.Label Then
i = i + 1
ReDim Preserve Darray(1 To i)
Set Darray(i).CommandButtonEvents = CBCtl
End If
Next CBCtl
Set CBCtl = Nothing
'***********
'~~> Set the Time
StartTimer
curDate = Date
thisDay = Day(Date): thisMonth = Month(Date): thisYear = Year(Date)
CurYear = Year(Date): CurMonth = Month(Date)
PopulateCalendar curDate
End Sub
'--> The below 4 procedures will assist in moving the borderless userform
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
NewXpos = X
NewYpos = Y
End If
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button And 1 Then
Me.Left = Me.Left + (X - NewXpos)
Me.Top = Me.Top + (Y - NewYpos)
End If
lblDOWN.ForeColor = MyForeColor
lblUP.ForeColor = MyForeColor
lblUnload.ForeColor = MyForeColor
lblThemes.ForeColor = MyForeColor
End Sub
Private Sub Frame1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
NewXpos = X
NewYpos = Y
End If
End Sub
'--> Stop timer in the terminate event
Private Sub UserForm_Terminate()
EndTimer
End Sub
'--> UP Button
Private Sub lblUP_Click()
Select Case Label5.Caption
Case 1 '~~> When user presses the up button when the dates are displayed
curDate = DateSerial(CurYear, CurMonth, 0)
'~~> Check if date is >= 1/1/1919
If curDate >= DateSerial(1919, 1, 1) Then
'~~> Populate prev months calendar
PopulateCalendar curDate
End If
Case 2 '<~~ Do nothing
Case 3 '~~> When user presses the up button when the Year Range is displayed
If frmYr > 1919 Then
Dim NewToYr As Integer
ToYr = frmYr - 1
NewToYr = frmYr - 1
For i = 1 To 12
Me.Controls("Y" & i).Caption = ""
Next i
For i = 12 To 1 Step -1
If Not NewToYr < 1919 Then
With Me.Controls("Y" & i)
.Caption = NewToYr
If NewToYr = thisYear Then
.BackStyle = fmBackStyleOpaque
.BackColor = CurDateColor
Else
.BackStyle = fmBackStyleTransparent
End If
NewToYr = NewToYr - 1
End With
End If
Next i
frmYr = NewToYr + 1
lblTitleCurMY.Caption = (NewToYr + 1) & " - " & ToYr
End If
End Select
End Sub
'--> Down Button
Private Sub lblDOWN_Click()
Select Case Label5.Caption
Case 1 '~~> When user presses the down button when the dates are displayed
curDate = DateAdd("m", 1, DateSerial(CurYear, CurMonth, 1))
'~~> Check if date is <= 31/12/2119
If curDate <= DateSerial(2119, 12, 31) Then
'~~> Populate prev months calendar
PopulateCalendar curDate
End If
Case 2 '<~~ Do nothing
Case 3 '~~> When user presses the down button when the Year Range is displayed
frmYr = Val(Split(lblTitleCurMY.Caption, "-")(0))
ToYr = Val(Split(lblTitleCurMY.Caption, "-")(1))
If ToYr < 2119 Then
Dim NewFrmYr As Integer
frmYr = ToYr + 1
NewFrmYr = ToYr + 1
For i = 1 To 12
Me.Controls("Y" & i).Caption = ""
Next i
For i = 1 To 12
If NewFrmYr < 2119 Then
With Me.Controls("Y" & i)
.Caption = NewFrmYr
If NewFrmYr = thisYear Then
.BackStyle = fmBackStyleOpaque
.BackColor = CurDateColor
Else
.BackStyle = fmBackStyleTransparent
End If
NewFrmYr = NewFrmYr + 1
End With
ElseIf NewFrmYr = 2119 Then
With Me.Controls("Y" & i)
.Caption = NewFrmYr
NewFrmYr = NewFrmYr + 1
End With
End If
Next i
If NewFrmYr = 2119 Then ToYr = NewFrmYr Else ToYr = NewFrmYr - 1
lblTitleCurMY.Caption = frmYr & " - " & ToYr
End If
End Select
End Sub
'--> Populate the calendar for a specific month
Sub PopulateCalendar(d As Date)
Dim m As Integer, Y As Integer
Dim i As Integer, j As Integer
Dim LastDay As Integer, NextCounter As Integer, PrevCounter As Integer
Dim dtOne As Date, dtLast As Date, dtNext As Date
CurYear = Year(d)
CurMonth = Month(d)
m = Month(d): Y = Year(d)
'--> 1st day of the current month
dtOne = DateSerial(Y, m, 1)
'--> last day of the previous month
dtLast = DateSerial(Year(dtOne), Month(dtOne), 0)
'--> 1st day of the next month
dtNext = DateAdd("m", 1, DateSerial(Year(dtOne), Month(dtOne), 1))
'--> Set the 1st day of the month to its proper weekday
Select Case Weekday(dtOne, 0)
Case 1
NextCounter = 1: PrevCounter = 0
Case 2
NextCounter = 2: PrevCounter = 1
Case 3
NextCounter = 3: PrevCounter = 2
Case 4
NextCounter = 4: PrevCounter = 3
Case 5
NextCounter = 5: PrevCounter = 4
Case 6
NextCounter = 6: PrevCounter = 5
Case 7
NextCounter = 7: PrevCounter = 6
End Select
'--> Get the last day of the current month
LastDay = Val(Format(Excel.Application.WorksheetFunction.EoMonth(dtOne, 0), "dd"))
'--> Populate all days for the current month
For i = 1 To LastDay
Me.Controls("D" & NextCounter).Caption = i
Me.Controls("D" & NextCounter).Tag = Format(DateSerial(Year(d), Month(d), i), frmETRcalendar.ShortDateFormat)
'--> Highlight the current day
If i = thisDay And Month(d) = thisMonth And Year(d) = thisYear Then
With Me.Controls("D" & NextCounter)
.BackStyle = fmBackStyleOpaque
.BackColor = CurDateColor
.ForeColor = CurDateForeColor
End With
Else '--> no highlight
With Me.Controls("D" & NextCounter)
.BackStyle = fmBackStyleTransparent
.BackColor = MyBackColor
.ForeColor = MyForeColor
End With
'*** KEEP JUST IN CASE
' Select Case Cal_theme
' Case CalendarThemes.ArcticBlue
' Me.Controls("D" & NextCounter).BackColor = CurDateColor
' Me.Controls("D" & NextCounter).ForeColor = RGB(0, 0, 0)
' Case Else
' Me.Controls("CB" & NextCounter).ForeColor = RGB(0, 0, 0)
' End Select
'********
End If
NextCounter = NextCounter + 1
Next i
'--> Populate days for the next month
j = 1
If NextCounter < 43 Then
For i = NextCounter To 42
With Me.Controls("D" & i)
.Caption = j
.Tag = Format(DateSerial(Year(dtNext), Month(dtNext), j), frmETRcalendar.ShortDateFormat)
.ForeColor = NotCurDateColor
End With
j = j + 1
Next i
End If
'Populate days of previous month
LastDay = Val(Format(dtLast, "dd"))
If PrevCounter > 1 Then
For i = PrevCounter To 1 Step -1
With Me.Controls("D" & i)
.Caption = LastDay
.Tag = Format(DateSerial(Year(dtLast), Month(dtLast), LastDay), frmETRcalendar.ShortDateFormat)
.ForeColor = NotCurDateColor
End With
LastDay = LastDay - 1
Next i
ElseIf PrevCounter = 1 Then
With Me.Controls("D1")
.Caption = LastDay
.Tag = Format(DateSerial(Year(dtLast), Month(dtLast), LastDay), frmETRcalendar.ShortDateFormat)
.ForeColor = NotCurDateColor
End With
End If
lblTitleCurMY.Caption = Format(d, "mmmm yyyy")
End Sub
'--> Show the months when user clicks on the date label
Sub HiglightCurMonthControl()
For i = 1 To 12
If i = thisMonth Then
With Me.Controls("M" & i)
.BackStyle = fmBackStyleOpaque
.BackColor = CurDateColor
.ForeColor = CurDateForeColor
End With
End If
Next i
End Sub
'--> Show the details for the selected month
Sub ShowSpecificMonth()
lblTitleCurMY.Caption = Format(DateSerial(CurYear, CurMonth, 1), "mmm yyyy")
MPmainDisplay.Value = 0 'switch multipage back to 'Day' page
PopulateCalendar DateSerial(CurYear, CurMonth, 1)
Label5.Caption = 1
lblUP.Visible = True
lblDOWN.Visible = True
End Sub
'--> Handles the month to year multipage display
Private Sub lblTitleCurMY_Click()
Select Case Label5.Caption
Case 1
lblTitleCurMY.Caption = Split(lblTitleCurMY.Caption)(1)
Label5.Caption = 2
Me.MPmainDisplay.Value = 1 '--> Switch active multipage
HiglightCurMonthControl
lblDOWN.Visible = False
lblUP.Visible = False
Case 2 '--> Prep & show year buttons
lblDOWN.Visible = True
lblUP.Visible = True
Me.MPmainDisplay.Value = 2 '--> Switch active multipage
ToYr = Val(lblTitleCurMY.Caption)
frmYr = ToYr - 11
If frmYr < 1919 Then frmYr = 1919
lblTitleCurMY.Caption = frmYr & " - " & ToYr
Label5.Caption = 3
For i = 1 To 12
Me.Controls("Y" & i).Caption = ""
Next i
For i = 12 To 1 Step -1
If Not ToYr < 1919 Then
With Me.Controls("Y" & i)
.Caption = ToYr
.Visible = True
If ToYr = thisYear Then
With Me.Controls("Y" & i)
.BackStyle = fmBackStyleOpaque
.BackColor = CurDateColor
.ForeColor = CurDateForeColor
End With
End If
ToYr = ToYr - 1
End With
End If
Next i
Label5.Caption = 3
Case 3 'Do Nothing
End Select
End Sub
' Logicworkz 12/2019 ----------------------------------------------------------------
'--------- CALENDAR DAY LABEL "BUTTONS" BORDER MOUSE ENTRY/EXIT BEHAVIOR ------------
'------------------------------------------------------------------------------------
Sub NoBorder(SkipLabel As Byte, PreFix As String, ObjCnt As Byte)
Dim d As Byte
For d = 1 To ObjCnt
If d <> SkipLabel Then
With Me.Controls(PreFix & d)
.BorderStyle = fmBorderStyleNone
End With
End If
Next
End Sub
Private Sub D1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D1.BorderStyle = fmBorderStyleNone
Else
D1.BorderStyle = fmBorderStyleSingle
NoBorder 1, "D", 42
End If
End Sub
Private Sub D2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D2.BorderStyle = fmBorderStyleNone
Else
D2.BorderStyle = fmBorderStyleSingle
NoBorder 2, "D", 42
End If
End Sub
Private Sub D3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D3.BorderStyle = fmBorderStyleNone
Else
D3.BorderStyle = fmBorderStyleSingle
NoBorder 3, "D", 42
End If
End Sub
Private Sub D4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D4.BorderStyle = fmBorderStyleNone
Else
D4.BorderStyle = fmBorderStyleSingle
NoBorder 4, "D", 42
End If
End Sub
Private Sub D5_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D5.BorderStyle = fmBorderStyleNone
Else
D5.BorderStyle = fmBorderStyleSingle
NoBorder 5, "D", 42
End If
End Sub
Private Sub D6_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D6.BorderStyle = fmBorderStyleNone
Else
D6.BorderStyle = fmBorderStyleSingle
NoBorder 6, "D", 42
End If
End Sub
Private Sub D7_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D7.BorderStyle = fmBorderStyleNone
Else
D7.BorderStyle = fmBorderStyleSingle
NoBorder 7, "D", 42
End If
End Sub
Private Sub D8_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D8.BorderStyle = fmBorderStyleNone
Else
D8.BorderStyle = fmBorderStyleSingle
NoBorder 8, "D", 42
End If
End Sub
Private Sub D9_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D9.BorderStyle = fmBorderStyleNone
Else
D9.BorderStyle = fmBorderStyleSingle
NoBorder 9, "D", 42
End If
End Sub
Private Sub D10_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D10.BorderStyle = fmBorderStyleNone
Else
D10.BorderStyle = fmBorderStyleSingle
NoBorder 10, "D", 42
End If
End Sub
Private Sub D11_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D11.BorderStyle = fmBorderStyleNone
Else
D11.BorderStyle = fmBorderStyleSingle
NoBorder 11, "D", 42
End If
End Sub
Private Sub D12_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D12.BorderStyle = fmBorderStyleNone
Else
D12.BorderStyle = fmBorderStyleSingle
NoBorder 12, "D", 42
End If
End Sub
Private Sub D13_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D13.BorderStyle = fmBorderStyleNone
Else
D13.BorderStyle = fmBorderStyleSingle
NoBorder 13, "D", 42
End If
End Sub
Private Sub D14_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D14.BorderStyle = fmBorderStyleNone
Else
D14.BorderStyle = fmBorderStyleSingle
NoBorder 14, "D", 42
End If
End Sub
Private Sub D15_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D15.BorderStyle = fmBorderStyleNone
Else
D15.BorderStyle = fmBorderStyleSingle
NoBorder 15, "D", 42
End If
End Sub
Private Sub D16_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D16.BorderStyle = fmBorderStyleNone
Else
D16.BorderStyle = fmBorderStyleSingle
NoBorder 16, "D", 42
End If
End Sub
Private Sub D17_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D17.BorderStyle = fmBorderStyleNone
Else
D17.BorderStyle = fmBorderStyleSingle
NoBorder 17, "D", 42
End If
End Sub
Private Sub D18_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D18.BorderStyle = fmBorderStyleNone
Else
D18.BorderStyle = fmBorderStyleSingle
NoBorder 18, "D", 42
End If
End Sub
Private Sub D19_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D19.BorderStyle = fmBorderStyleNone
Else
D19.BorderStyle = fmBorderStyleSingle
NoBorder 19, "D", 42
End If
End Sub
Private Sub D20_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D20.BorderStyle = fmBorderStyleNone
Else
D20.BorderStyle = fmBorderStyleSingle
NoBorder 20, "D", 42
End If
End Sub
Private Sub D21_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D21.BorderStyle = fmBorderStyleNone
Else
D21.BorderStyle = fmBorderStyleSingle
NoBorder 21, "D", 42
End If
End Sub
Private Sub D22_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D22.BorderStyle = fmBorderStyleNone
Else
D22.BorderStyle = fmBorderStyleSingle
NoBorder 22, "D", 42
End If
End Sub
Private Sub D23_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D23.BorderStyle = fmBorderStyleNone
Else
D23.BorderStyle = fmBorderStyleSingle
NoBorder 23, "D", 42
End If
End Sub
Private Sub D24_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D24.BorderStyle = fmBorderStyleNone
Else
D24.BorderStyle = fmBorderStyleSingle
NoBorder 24, "D", 42
End If
End Sub
Private Sub D25_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D25.BorderStyle = fmBorderStyleNone
Else
D25.BorderStyle = fmBorderStyleSingle
NoBorder 25, "D", 42
End If
End Sub
Private Sub D26_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D26.BorderStyle = fmBorderStyleNone
Else
D26.BorderStyle = fmBorderStyleSingle
NoBorder 26, "D", 42
End If
End Sub
Private Sub D27_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D27.BorderStyle = fmBorderStyleNone
Else
D27.BorderStyle = fmBorderStyleSingle
NoBorder 27, "D", 42
End If
End Sub
Private Sub D28_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D28.BorderStyle = fmBorderStyleNone
Else
D28.BorderStyle = fmBorderStyleSingle
NoBorder 28, "D", 42
End If
End Sub
Private Sub D29_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D29.BorderStyle = fmBorderStyleNone
Else
D29.BorderStyle = fmBorderStyleSingle
NoBorder 29, "D", 42
End If
End Sub
Private Sub D30_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D30.BorderStyle = fmBorderStyleNone
Else
D30.BorderStyle = fmBorderStyleSingle
NoBorder 30, "D", 42
End If
End Sub
Private Sub D31_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D31.BorderStyle = fmBorderStyleNone
Else
D31.BorderStyle = fmBorderStyleSingle
NoBorder 31, "D", 42
End If
End Sub
Private Sub D32_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D32.BorderStyle = fmBorderStyleNone
Else
D32.BorderStyle = fmBorderStyleSingle
NoBorder 32, "D", 42
End If
End Sub
Private Sub D33_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D33.BorderStyle = fmBorderStyleNone
Else
D33.BorderStyle = fmBorderStyleSingle
NoBorder 33, "D", 42
End If
End Sub
Private Sub D34_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D34.BorderStyle = fmBorderStyleNone
Else
D34.BorderStyle = fmBorderStyleSingle
NoBorder 34, "D", 42
End If
End Sub
Private Sub D35_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D35.BorderStyle = fmBorderStyleNone
Else
D35.BorderStyle = fmBorderStyleSingle
NoBorder 35, "D", 42
End If
End Sub
Private Sub D36_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D36.BorderStyle = fmBorderStyleNone
Else
D36.BorderStyle = fmBorderStyleSingle
NoBorder 36, "D", 42
End If
End Sub
Private Sub D37_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D37.BorderStyle = fmBorderStyleNone
Else
D37.BorderStyle = fmBorderStyleSingle
NoBorder 37, "D", 42
End If
End Sub
Private Sub D38_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D38.BorderStyle = fmBorderStyleNone
Else
D38.BorderStyle = fmBorderStyleSingle
NoBorder 38, "D", 42
End If
End Sub
Private Sub D39_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D39.BorderStyle = fmBorderStyleNone
Else
D39.BorderStyle = fmBorderStyleSingle
NoBorder 39, "D", 42
End If
End Sub
Private Sub D40_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D40.BorderStyle = fmBorderStyleNone
Else
D40.BorderStyle = fmBorderStyleSingle
NoBorder 40, "D", 42
End If
End Sub
Private Sub D41_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D41.BorderStyle = fmBorderStyleNone
Else
D41.BorderStyle = fmBorderStyleSingle
NoBorder 41, "D", 42
End If
End Sub
Private Sub D42_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Day_Xmax Or X <= Day_Xmin Or Y <= Day_Ymin Or Y >= Day_Ymax Then
D42.BorderStyle = fmBorderStyleNone
Else
D42.BorderStyle = fmBorderStyleSingle
NoBorder 42, "D", 42
End If
End Sub
' Logicworkz 12/2019 ----------------------------------------------------------------
'--------- CALENDAR MONTH LABEL "BUTTONS" BORDER MOUSE ENTRY/EXIT BEHAVIOR ----------
'------------------------------------------------------------------------------------
Private Sub M1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M1.BorderStyle = fmBorderStyleNone
Else
M1.BorderStyle = fmBorderStyleSingle
NoBorder 1, "M", 12
End If
End Sub
Private Sub M2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M2.BorderStyle = fmBorderStyleNone
Else
M2.BorderStyle = fmBorderStyleSingle
NoBorder 2, "M", 12
End If
End Sub
Private Sub M3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M3.BorderStyle = fmBorderStyleNone
Else
M3.BorderStyle = fmBorderStyleSingle
NoBorder 3, "M", 12
End If
End Sub
Private Sub M4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M4.BorderStyle = fmBorderStyleNone
Else
M4.BorderStyle = fmBorderStyleSingle
NoBorder 4, "M", 12
End If
End Sub
Private Sub M5_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M5.BorderStyle = fmBorderStyleNone
Else
M5.BorderStyle = fmBorderStyleSingle
NoBorder 5, "M", 12
End If
End Sub
Private Sub M6_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M6.BorderStyle = fmBorderStyleNone
Else
M6.BorderStyle = fmBorderStyleSingle
NoBorder 6, "M", 12
End If
End Sub
Private Sub M7_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M7.BorderStyle = fmBorderStyleNone
Else
M7.BorderStyle = fmBorderStyleSingle
NoBorder 7, "M", 12
End If
End Sub
Private Sub M8_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M8.BorderStyle = fmBorderStyleNone
Else
M8.BorderStyle = fmBorderStyleSingle
NoBorder 8, "M", 12
End If
End Sub
Private Sub M9_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M9.BorderStyle = fmBorderStyleNone
Else
M9.BorderStyle = fmBorderStyleSingle
NoBorder 9, "M", 12
End If
End Sub
Private Sub M10_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M10.BorderStyle = fmBorderStyleNone
Else
M10.BorderStyle = fmBorderStyleSingle
NoBorder 10, "M", 12
End If
End Sub
Private Sub M11_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M11.BorderStyle = fmBorderStyleNone
Else
M11.BorderStyle = fmBorderStyleSingle
NoBorder 11, "M", 12
End If
End Sub
Private Sub M12_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
M12.BorderStyle = fmBorderStyleNone
Else
M12.BorderStyle = fmBorderStyleSingle
NoBorder 12, "M", 12
End If
End Sub
' Logicworkz 12/2019 ----------------------------------------------------------------
'--------- MISC LABEL "BUTTON" BORDER MOUSE ENTRY/EXIT BEHAVIOR ----------
'------------------------------------------------------------------------------------
Private Sub lblTitleCurMY_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= 68 Or X <= 2 Or Y <= 2 Or Y >= 10 Then
lblTitleCurMY.ForeColor = MyForeColor
Else
lblTitleCurMY.ForeColor = RGB(73, 255, 60)
End If
End Sub
Private Sub lblUP_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= 20 Or X <= 2 Or Y <= 2 Or Y >= 10 Then
lblUP.ForeColor = MyForeColor
Else
lblUP.ForeColor = RGB(73, 255, 60)
End If
End Sub
Private Sub lblDOWN_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= 20 Or X <= 2 Or Y <= 2 Or Y >= 10 Then
lblDOWN.ForeColor = MyForeColor
Else
lblDOWN.ForeColor = RGB(73, 255, 60)
End If
End Sub
Private Sub lblUnload_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= 20 Or X <= 2 Or Y <= 2 Or Y >= 10 Then
lblUnload.ForeColor = MyForeColor
Else
lblUnload.ForeColor = RGB(73, 255, 60)
End If
End Sub
Private Sub lblThemes_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= 20 Or X <= 2 Or Y <= 2 Or Y >= 10 Then
lblThemes.ForeColor = MyForeColor
Else
lblThemes.ForeColor = RGB(73, 255, 60)
End If
End Sub
' Logicworkz 12/2019 ----------------------------------------------------------------
'--------- CALENDAR MONTH HEADINGS MOUSE ENTRY/EXIT BEHAVIOR ----------
'------------------------------------------------------------------------------------
Private Sub WD1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim d As Byte
For d = 1 To 42
With Me.Controls("D" & d)
.BorderStyle = fmBorderStyleNone
End With
Next
End Sub
Private Sub WD2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim d As Byte
For d = 1 To 42
With Me.Controls("D" & d)
.BorderStyle = fmBorderStyleNone
End With
Next
End Sub
Private Sub WD3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim d As Byte
For d = 1 To 42
With Me.Controls("D" & d)
.BorderStyle = fmBorderStyleNone
End With
Next
End Sub
Private Sub WD4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim d As Byte
For d = 1 To 42
With Me.Controls("D" & d)
.BorderStyle = fmBorderStyleNone
End With
Next
End Sub
Private Sub WD5_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim d As Byte
For d = 1 To 42
With Me.Controls("D" & d)
.BorderStyle = fmBorderStyleNone
End With
Next
End Sub
Private Sub WD6_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim d As Byte
For d = 1 To 42
With Me.Controls("D" & d)
.BorderStyle = fmBorderStyleNone
End With
Next
End Sub
Private Sub WD7_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim d As Byte
For d = 1 To 42
With Me.Controls("D" & d)
.BorderStyle = fmBorderStyleNone
End With
Next
End Sub
' Logicworkz 12/2019 ----------------------------------------------------------------
'--------- CALENDAR YR LABEL "BUTTON" BORDER MOUSE ENTRY/EXIT BEHAVIOR ----------
'------------------------------------------------------------------------------------
Private Sub Y1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y1.BorderStyle = fmBorderStyleNone
Else
Y1.BorderStyle = fmBorderStyleSingle
NoBorder 1, "Y", 12
End If
End Sub
Private Sub Y2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y2.BorderStyle = fmBorderStyleNone
Else
Y2.BorderStyle = fmBorderStyleSingle
NoBorder 2, "Y", 12
End If
End Sub
Private Sub Y3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y3.BorderStyle = fmBorderStyleNone
Else
Y3.BorderStyle = fmBorderStyleSingle
NoBorder 3, "Y", 12
End If
End Sub
Private Sub Y4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y4.BorderStyle = fmBorderStyleNone
Else
Y4.BorderStyle = fmBorderStyleSingle
NoBorder 4, "Y", 12
End If
End Sub
Private Sub Y5_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y5.BorderStyle = fmBorderStyleNone
Else
Y5.BorderStyle = fmBorderStyleSingle
NoBorder 5, "Y", 12
End If
End Sub
Private Sub Y6_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y6.BorderStyle = fmBorderStyleNone
Else
Y6.BorderStyle = fmBorderStyleSingle
NoBorder 6, "Y", 12
End If
End Sub
Private Sub Y7_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y7.BorderStyle = fmBorderStyleNone
Else
Y7.BorderStyle = fmBorderStyleSingle
NoBorder 7, "Y", 12
End If
End Sub
Private Sub Y8_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y8.BorderStyle = fmBorderStyleNone
Else
Y8.BorderStyle = fmBorderStyleSingle
NoBorder 8, "Y", 12
End If
End Sub
Private Sub Y9_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y9.BorderStyle = fmBorderStyleNone
Else
Y9.BorderStyle = fmBorderStyleSingle
NoBorder 9, "Y", 12
End If
End Sub
Private Sub Y10_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y10.BorderStyle = fmBorderStyleNone
Else
Y10.BorderStyle = fmBorderStyleSingle
NoBorder 10, "Y", 12
End If
End Sub
Private Sub Y11_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y11.BorderStyle = fmBorderStyleNone
Else
Y11.BorderStyle = fmBorderStyleSingle
NoBorder 11, "Y", 12
End If
End Sub
Private Sub Y12_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X >= Mo_Xmax Or X <= Mo_Xmin Or Y <= Mo_Ymin Or Y >= Mo_Ymax Then
Y12.BorderStyle = fmBorderStyleNone
Else
Y12.BorderStyle = fmBorderStyleSingle
NoBorder 12, "Y", 12
End If
End SubEditor is loading...
Leave a Comment