Access カレンダーFORM
コントローの配置 1段目 年を減算するコマンドボタン[PY] 年を表示するラベル[DYEAR] 年を加算するコマンドボタン[NY] 月を加算するコマンドボタン[PM] 月を表示するラベル[DMONTH] 月を加算するコマンドボタン[NM] 2段目～7段目 日にちを表示するラベル[Dx] xは0から41までの数字 1クリック目でラベルを窪み表示にして、窪み表示をクリックすると カレンダーは非表示になり、呼び出し元でプロパティ[DateNum][WeekNum] からシリアル値、Week値を取得します。 8段目 カレンダーを開いたときのデフォルト値に戻すコマンドボタン[bu初期] カレンダーを非表示して、呼び出し元でプロパティ[DateNum]の0を評価して 処理します。 カレンダーを閉じるコマンドボタン[bu閉じる]
'----------------------------------------------------------------
'カレンダー
'令和３年５月６日
'----------------------------------------------------------------
Option Compare Database
Option Explicit
Private WithEvents myControls As C_Controls
Private Const SHIFT_MASK As Long = 1
Private Const FirstYobi As Long = vbSunday
Private HoldDate As Long
Private HoldYear As Long
Private HoldMonth As Long
Private HoldDay As Long
Private Enum IncType
Forward = 1
Backward = -1
End Enum
Private GetYobi As C_KyuZitu
Private Const IntvDay As String = "d"
Private Const IntvMonth As String = "m"
Private Const IntvYear As String = "yyyy"
Private Const IntvWeek As String = "ww"
Private CurYear As Long
Private CurMonth As Long
Private CurDay As Long
Private DaysAndWeeks() As Long
Private Yobi As Variant
Private SelectDay As String
Public Property Get DateNum() As Long
If CurYear = 0 Then
DateNum = 0
Else
DateNum = DateSerial(CurYear, CurMonth, CurDay)
End If
End Property
Public Property Get WeekNum() As Long
GetYobi.SetNumDate = DateSerial(CurYear, CurMonth, CurDay)
WeekNum = GetYobi.WeekNum
End Property
'----------------------------------------------------------------
'
Private Sub Form_Load()
Dim Ctrl As Access.Control
Dim I As Long
If Nz(Me.OpenArgs, "") = "" Then
HoldDate = Date
Else
If IsDate(Me.OpenArgs) Then
HoldDate = DateSerial(DatePart("YYYY", Me.OpenArgs), _
DatePart("m", Me.OpenArgs), _
DatePart("d", Me.OpenArgs))
Else
HoldDate = Date
End If
End If
HoldYear = Year(HoldDate)
HoldMonth = Month(HoldDate)
HoldDay = Day(HoldDate)
Set GetYobi = New C_KyuZitu
GetYobi.pYear = HoldYear
CurYear = HoldYear
CurMonth = HoldMonth
CurDay = HoldDay
Set myControls = New C_Controls
With myControls
Set .Parent = Me
.Init
End With
Yobi = Array("日", "月", "火", "水", "木", "金", "土")
For I = 0 To 6
Me("Y" & I).Caption = Yobi((FirstYobi - 1 + I) Mod 7)
Select Case I
Case 0
Me("Y" & I).ForeColor = vbRed
Case 6
Me("Y" & I).ForeColor = vbBlue
End Select
Next I
Call SetCurDisp
Call DispDraw
End Sub
'----------------------------------------------------------------
'
Private Sub Form_Close()
End Sub
'----------------------------------------------------------------
'
Private Sub SetCurDisp()
Me.DMONTH.Caption = CurMonth
Me.DYEAR.Caption = CurYear
End Sub
'----------------------------------------------------------------
'
Private Sub DispDraw()
Dim Ctrl As Access.Control
Dim NewSelect As String
Dim OneDayYobi As Long
Dim OneDaySerial As Long
Dim I As Long
GetYobi.pYear = CurYear
'選択月の最初の日のシリアル値
OneDaySerial = DateSerial(CurYear, CurMonth, 1)
'選択月の最初の日の曜日
OneDayYobi = Weekday(OneDaySerial, FirstYobi)
'配列にシリアル値をセット
ReDim DaysAndWeeks(0 To 41)
For I = 0 To UBound(DaysAndWeeks)
DaysAndWeeks(I) = OneDaySerial - (OneDayYobi - 1) + I
Next I
'ラベルのキャプションに日にちをセット
For I = 0 To UBound(DaysAndWeeks)
Me("Day" & I).Caption = Day(DaysAndWeeks(I))
If Me.DMONTH.Caption <> Month(DaysAndWeeks(I)) Then
Me("Day" & I).FontSize = 10
Else
Me("Day" & I).FontSize = 12
End If
If Me("Day" & I).ForeColor <> InteriorColor(DaysAndWeeks(I)) Then
Me("Day" & I).ForeColor = InteriorColor(DaysAndWeeks(I))
End If
If DaysAndWeeks(I) = DateSerial(CurYear, CurMonth, CurDay) Then
NewSelect = "Day" & I
End If
Next I
Call EffectDraw(NewSelect)
End Sub
'----------------------------------------------------------------
'
Private Sub EffectDraw(NewSelect As String)
If Len(SelectDay) > 0 Then
If SelectDay <> NewSelect Then
Me(SelectDay).SpecialEffect = acNormal
End If
End If
SelectDay = NewSelect
Me(SelectDay).SpecialEffect = acEffectSunken
Me.Repaint
End Sub
'----------------------------------------------------------------
'
Private Function InteriorColor(DrawDate As Long) As Long
GetYobi.SetNumDate = DrawDate
Select Case GetYobi.WeekNum
Case 1, 10, 11, 12, 13
InteriorColor = vbRed
Case 7
InteriorColor = vbBlue
Case Else
InteriorColor = vbBlack
End Select
End Function
'----------------------------------------------------------------
'
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Call ShiftKeys(KeyCode, Shift)
End Sub
'----------------------------------------------------------------
'
Private Sub myControls_Click(myCont As Object)
Select Case myCont.Name
Case "NM"
Me.buDummy.SetFocus
Call NextMonth
Case "NY"
Me.buDummy.SetFocus
Call NextYear
Case "PM"
Me.buDummy.SetFocus
Call PreviousMonth
Case "PY"
Me.buDummy.SetFocus
Call PreviousYear
Case "bu閉じる"
Me.buDummy.SetFocus
Call CloseForm(False)
Case "bu初期"
Me.buDummy.SetFocus
CurYear = HoldYear
CurMonth = HoldMonth
CurDay = HoldDay
Call SetCurDisp
Call DispDraw
Case "bu削除"
Me.buDummy.SetFocus
CurYear = 0
Call CloseForm(True)
Case Else
Select Case True
Case InStr(myCont.Name, "Day") = 1
If myCont.SpecialEffect = acEffectSunken Then
Call CloseForm(True)
Else
If CurMonth <> Month(DaysAndWeeks(Mid(myCont.Name, Len("Day") + 1))) Then
Call ClickDate(myCont.Name)
Call SetCurDisp
Call DispDraw
Else
Call EffectDraw(myCont.Name)
Call ClickDate(myCont.Name)
End If
End If
End Select
End Select
End Sub
'----------------------------------------------------------------
'
Private Sub myControls_DblClick(myCont As Object, Cancel As Integer)
Select Case True
Case InStr(myCont.Name, "Day") = 1
Call EffectDraw(myCont.Name)
Call ClickDate(myCont.Name)
Call CloseForm(True)
End Select
End Sub
'----------------------------------------------------------------
'
Private Sub myControls_KeyDown(myCont As Object, KeyCode As Integer, Shift As Integer)
Select Case myCont.Name
Case "PM", "NM", "PY", "NY", "bu閉じる", "bu初期", "bu削除"
Call ShiftKeys(KeyCode, Shift)
Case Else
Select Case True
Case InStr(myCont.Name, "Day") = 1
Call ShiftKeys(KeyCode, Shift)
End Select
End Select
End Sub
'----------------------------------------------------------------
'
Private Sub ShiftKeys(KeyCode As Integer, Shift As Integer)
Dim ShiftDown As Boolean
ShiftDown = ((Shift And SHIFT_MASK) > 0)
Select Case KeyCode
Case vbKeyEscape
Call CloseForm(Hide:=False)
Case vbKeyReturn
Call CloseForm(Hide:=True)
Case vbKeyHome
If ShiftDown Then
Call MoveToToday(False)
Else
Call MoveToToday(True)
End If
Case vbKeyPageUp
If ShiftDown Then
Call PreviousYear
Else
Call PreviousMonth
End If
Case vbKeyPageDown
If ShiftDown Then
Call NextYear
Else
Call NextMonth
End If
Case vbKeyRight
If ShiftDown Then
Call NextYear
Else
Call NextDay
End If
Case vbKeyLeft
If ShiftDown Then
Call PreviousYear
Else
Call PreviousDay
End If
Case vbKeyUp
If ShiftDown Then
Call PreviousMonth
Else
Call PreviousWeek
End If
Case vbKeyDown
If ShiftDown Then
Call NextMonth
Else
Call NextWeek
End If
End Select
KeyCode = 0
End Sub
'----------------------------------------------------------------
'
Public Sub Today()
Call MoveToToday(UseCurYear:=True)
End Sub
'----------------------------------------------------------------
'
Public Sub NextDay()
Call ChangeDate(IntvDay, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub NextMonth()
Call ChangeDate(IntvMonth, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub NextYear()
Call ChangeDate(IntvYear, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub NextWeek()
Call ChangeDate(IntvWeek, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousDay()
Call ChangeDate(IntvDay, IncType.Backward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousMonth()
Call ChangeDate(IntvMonth, IncType.Backward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousYear()
Call ChangeDate(IntvYear, IncType.Backward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousWeek()
Call ChangeDate(IntvWeek, IncType.Backward)
End Sub
'----------------------------------------------------------------
'
Private Sub MoveToToday(UseCurYear As Boolean)
If UseCurYear Then
CurYear = HoldYear
End If
CurMonth = HoldMonth
CurDay = HoldDay
Call SetCurDisp
Call DispDraw
End Sub
'----------------------------------------------------------------
'
Private Sub ChangeDate(IntvStr As String, IT As IncType)
Dim bufMonth As Integer
Dim bufYear As Integer
Dim bufDay As Integer
Dim NewSelect As String
Dim OLDDate As Long
Dim NewDate As Long
Dim Inc As Long
Dim I As Long
If IT = Forward Then
Inc = 1
Else
Inc = -1
End If
OLDDate = DateSerial(CurYear, CurMonth, CurDay)
NewDate = DateAdd(IntvStr, Inc, OLDDate)
bufMonth = DatePart(IntvMonth, NewDate)
bufYear = DatePart(IntvYear, NewDate)
bufDay = DatePart(IntvDay, NewDate)
If CurMonth = bufMonth And _
CurYear = bufYear Then
CurDay = bufDay
For I = 0 To UBound(DaysAndWeeks)
If DaysAndWeeks(I) = DateSerial(CurYear, CurMonth, CurDay) Then
NewSelect = "Day" & I
End If
Next I
Call EffectDraw(NewSelect)
Else
CurDay = bufDay
CurMonth = bufMonth
CurYear = bufYear
Call SetCurDisp
Call DispDraw
End If
End Sub
'----------------------------------------------------------------
'
Private Sub CloseForm(Hide As Boolean)
If ThisFormSub() Then
Exit Sub
End If
If Hide Then
Me.Visible = False
Else
DoCmd.CLOSE acForm, Me.Name, acSaveNo
End If
End Sub
'----------------------------------------------------------------
'
Private Function ThisFormSub() As Boolean
Dim strName As String
On Error Resume Next
strName = Me.Parent.Name
ThisFormSub = (Err.Number = 0)
Err.Clear
End Function
'----------------------------------------------------------------
'
Private Sub ClickDate(ClickName As String)
Dim Num As Long
Num = Mid(ClickName, Len("Day") + 1)
CurYear = Year(DaysAndWeeks(Num))
CurMonth = Month(DaysAndWeeks(Num))
CurDay = Day(DaysAndWeeks(Num))
End Sub
C_Button
Option Explicit
'********************************************************************
Private WithEvents myButton As Access.CommandButton
Private myParent As C_Controls
Private myIndex As Long
'--------------------------------------------------------------------
'
Public Property Set Item(ByRef Obj As Access.CommandButton)
Set myButton = Obj
End Property
'--------------------------------------------------------------------
'
Public Property Get Item() As Access.CommandButton
Set Item = myButton
End Property
'--------------------------------------------------------------------
'
Public Property Set Parent(ByRef Obj As C_Controls)
Set myParent = Obj
End Property
'--------------------------------------------------------------------
'
Public Property Let Index(ByVal val As Long)
myIndex = val
End Property
'--------------------------------------------------------------------
'
Public Property Get Index() As Long
Index = myIndex
End Property
'--------------------------------------------------------------------
'
Public Property Get Self() As Object
Set Self = Me
End Property
'--------------------------------------------------------------------
'
Public Sub DEL()
Set myButton = Nothing
Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
'
Private Sub Class_Terminate()
Set myButton = Nothing
Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
'
Private Sub myButton_Click()
Call myParent.onClick(myButton)
End Sub
'--------------------------------------------------------------------
'
Private Sub myButton_DblClick(Cancel As Integer)
Call myParent.onDblClick(myButton, Cancel)
End Sub
'--------------------------------------------------------------------
'
Private Sub myButton_KeyDown(KeyCode As Integer, Shift As Integer)
Call myParent.onKeyDown(myButton, KeyCode, Shift)
End Sub
'--------------------------------------------------------------------
'
Private Sub myButton_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Call myParent.onMouseMove(myButton, Button, Shift, X, Y)
End Sub
C_CheckBox
Option Explicit
'********************************************************************
Private WithEvents myCheckBox As Access.CheckBox
Private myParent As C_Controls
Private myIndex As Long
'--------------------------------------------------------------------
'
Public Property Set Item(ByRef Obj As Access.CheckBox)
Set myCheckBox = Obj
End Property
'--------------------------------------------------------------------
'
Public Property Get Item() As Access.CheckBox
Set Item = myCheckBox
End Property
'--------------------------------------------------------------------
'
Public Property Set Parent(ByRef Obj As C_Controls)
Set myParent = Obj
End Property
'--------------------------------------------------------------------
'
Public Property Let Index(ByVal val As Long)
myIndex = val
End Property
'--------------------------------------------------------------------
'
Public Property Get Index() As Long
Index = myIndex
End Property
'--------------------------------------------------------------------
'
Public Property Get Self() As Object
Set Self = Me
End Property
'--------------------------------------------------------------------
'
Public Sub DEL()
Set myCheckBox = Nothing
Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
'
Private Sub Class_Terminate()
Set myCheckBox = Nothing
Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
'
Private Sub myCheckBox_Click()
Call myParent.onClick(myCheckBox)
End Sub
'--------------------------------------------------------------------
'
Private Sub myCheckBox_DblClick(Cancel As Integer)
Call myParent.onDblClick(myCheckBox, Cancel)
End Sub
'--------------------------------------------------------------------
'
Private Sub myCheckBox_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Call myParent.onMouseMove(myCheckBox, Button, Shift, X, Y)
End Sub
C_ComboBox
Option Explicit
'********************************************************************
Private WithEvents myCheckBox As Access.CheckBox
Private myParent As C_Controls
Private myIndex As Long
'--------------------------------------------------------------------
'
Public Property Set Item(ByRef Obj As Access.CheckBox)
Set myCheckBox = Obj
End Property
'--------------------------------------------------------------------
'
Public Property Get Item() As Access.CheckBox
Set Item = myCheckBox
End Property
'--------------------------------------------------------------------
'
Public Property Set Parent(ByRef Obj As C_Controls)
Set myParent = Obj
End Property
'--------------------------------------------------------------------
'
Public Property Let Index(ByVal val As Long)
myIndex = val
End Property
'--------------------------------------------------------------------
'
Public Property Get Index() As Long
Index = myIndex
End Property
'--------------------------------------------------------------------
'
Public Property Get Self() As Object
Set Self = Me
End Property
'--------------------------------------------------------------------
'
Public Sub DEL()
Set myCheckBox = Nothing
Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
'
Private Sub Class_Terminate()
Set myCheckBox = Nothing
Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
'
Private Sub myCheckBox_Click()
Call myParent.onClick(myCheckBox)
End Sub
'--------------------------------------------------------------------
'
Private Sub myCheckBox_DblClick(Cancel As Integer)
Call myParent.onDblClick(myCheckBox, Cancel)
End Sub
'--------------------------------------------------------------------
'
Private Sub myCheckBox_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Call myParent.onMouseMove(myCheckBox, Button, Shift, X, Y)
End Sub
C_Controls
Option Explicit
'*******************************************************************
Public Event Click(myCont As Object)
Public Event Change(myCont As Object)
Public Event DblClick(myCont As Object, _
Cancel As Integer)
Public Event MouseMove(myCont As Object, _
Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Public Event KeyPress(myCont As Object, _
KeyAscii As Integer)
Public Event KeyDown(myCont As Object, _
KeyCode As Integer, _
Shift As Integer)
Private Labels As Dictionary
Private TextBoxs As Dictionary
Private CheckBoxs As Dictionary
Private ComboBoxs As Dictionary
Private Buttons As Dictionary
Private myParent As Object
'*******************************************************************
'
Public Property Set Parent(ByRef Obj As Object)
Set myParent = Obj
End Property
'*******************************************************************
'
Public Sub onClick(myCont As Object)
RaiseEvent Click(myCont)
End Sub
'*******************************************************************
'
Public Sub onDblClick(myCont As Object, Cancel As Integer)
RaiseEvent DblClick(myCont, Cancel)
End Sub
'*******************************************************************
'
Public Sub onMouseMove(myCont As Object, _
Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
RaiseEvent MouseMove(myCont, Button, Shift, X, Y)
End Sub
'*******************************************************************
'
Public Sub onChange(myCont As Object)
RaiseEvent Change(myCont)
End Sub
'*******************************************************************
'
Public Sub onKeyPress(myCont As Object, _
KeyAscii As Integer)
RaiseEvent KeyPress(myCont, KeyAscii)
End Sub
'--------------------------------------------------------------------
'
Public Sub onKeyDown(myCont As Object, _
KeyCode As Integer, _
Shift As Integer)
RaiseEvent KeyDown(myCont, KeyCode, Shift)
End Sub
'*******************************************************************
'
Public Sub Init()
Dim Ctrl As Control
Dim Obj As Object
If myParent Is Nothing Then
Exit Sub
End If
Set Labels = New Dictionary
Set TextBoxs = New Dictionary
Set CheckBoxs = New Dictionary
Set ComboBoxs = New Dictionary
Set Buttons = New Dictionary
For Each Ctrl In myParent.Controls
Select Case TypeName(Ctrl)
Case "TextBox"
With New C_TextBox
Set .Item = Ctrl
Set .Parent = Me
TextBoxs.Add Ctrl.Name, .Self
End With
Case "Label"
With New C_Label
Set .Item = Ctrl
Set .Parent = Me
Labels.Add Ctrl.Name, .Self
End With
Case "ComboBox"
With New C_ComboBox
Set .Item = Ctrl
Set .Parent = Me
ComboBoxs.Add Ctrl.Name, .Self
End With
Case "CheckBox"
With New C_CheckBox
Set .Item = Ctrl
Set .Parent = Me
CheckBoxs.Add Ctrl.Name, .Self
End With
Case "CommandButton"
With New C_Button
Set .Item = Ctrl
Set .Parent = Me
Buttons.Add Ctrl.Name, .Self
End With
End Select
Next Ctrl
End Sub
'*******************************************************************
'
Public Sub DEL()
Dim Keys As Variant
For Each Keys In TextBoxs
TextBoxs(Keys).DEL
Next Keys
Set TextBoxs = Nothing
For Each Keys In Labels
Labels(Keys).DEL
Next Keys
Set Labels = Nothing
For Each Keys In ComboBoxs
ComboBoxs(Keys).DEL
Next Keys
Set ComboBoxs = Nothing
For Each Keys In CheckBoxs
CheckBoxs(Keys).DEL
Next Keys
Set CheckBoxs = Nothing
For Each Keys In Buttons
Buttons(Keys).DEL
Next Keys
Set Buttons = Nothing
Set myParent = Nothing
End Sub
C_TextBox
Option Explicit
'********************************************************************
Private WithEvents myLabel As Access.Label
Private myParent As C_Controls
Private myIndex As Long
'--------------------------------------------------------------------
'
Public Property Set Item(ByRef Obj As Access.Label)
Set myLabel = Obj
End Property
'--------------------------------------------------------------------
'
Public Property Get Item() As Access.Label
Set Item = myLabel
End Property
'--------------------------------------------------------------------
'
Public Property Set Parent(ByRef Obj As C_Controls)
Set myParent = Obj
End Property
'--------------------------------------------------------------------
'
Public Property Let Index(ByVal val As Long)
myIndex = val
End Property
'--------------------------------------------------------------------
'
Public Property Get Index() As Long
Index = myIndex
End Property
'--------------------------------------------------------------------
'
Public Property Get Self() As Object
Set Self = Me
End Property
'--------------------------------------------------------------------
'
Public Sub DEL()
Set myLabel = Nothing
Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
'
Private Sub Class_Terminate()
Set myLabel = Nothing
Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
'
Private Sub myLabel_Click()
Call myParent.onClick(myLabel)
End Sub
'--------------------------------------------------------------------
'
Private Sub myLabel_DblClick(Cancel As Integer)
Call myParent.onDblClick(myLabel, Cancel)
End Sub
'--------------------------------------------------------------------
'
Private Sub myLabel_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Call myParent.onMouseMove(myLabel, Button, Shift, X, Y)
End Sub
C_TextBox
Option Explicit
'********************************************************************
Private WithEvents myTextBox As Access.TextBox
Private myParent As C_Controls
Private myIndex As Long
'--------------------------------------------------------------------
'
Public Property Set Item(ByRef Obj As Access.TextBox)
Set myTextBox = Obj
End Property
'--------------------------------------------------------------------
'
Public Property Get Item() As Access.TextBox
Set Item = myTextBox
End Property
'--------------------------------------------------------------------
'
Public Property Set Parent(ByRef Obj As C_Controls)
Set myParent = Obj
End Property
'--------------------------------------------------------------------
'
Public Property Let Index(ByVal val As Long)
myIndex = val
End Property
'--------------------------------------------------------------------
'
Public Property Get Index() As Long
Index = myIndex
End Property
'--------------------------------------------------------------------
'
Public Property Get Self() As Object
Set Self = Me
End Property
'--------------------------------------------------------------------
'
Public Sub DEL()
Set myTextBox = Nothing
Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
'
Private Sub Class_Terminate()
Set myTextBox = Nothing
Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
'
Private Sub myTextBox_Change()
Call myParent.onChange(myTextBox)
End Sub
'--------------------------------------------------------------------
'
Private Sub myTextBox_DblClick(Cancel As Integer)
Call myParent.onDblClick(myTextBox, Cancel)
End Sub
'--------------------------------------------------------------------
'
Private Sub myTextBox_KeyPress(KeyAscii As Integer)
Call myParent.onKeyPress(myTextBox, KeyAscii)
End Sub
'--------------------------------------------------------------------
'
Private Sub myTextBox_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, _
Y As Single)
Call myParent.onMouseMove(myTextBox, Button, Shift, X, Y)
End Sub
C_Kyuzituクラス
Option Compare Database
Option Explicit
Private Enum YobiType
Shuku = 10
Kokumin = 11
Hurikae = 12
Kanrei = 13
End Enum
Private memShukuzitu As Dictionary
Private memKokumin As Dictionary
Private memHurikae As Dictionary
Private memKanrei As Dictionary
Private memYear As Long
Private memMonth As Long
Private memDay As Long
Private memFormat As String
Public Property Let pYear(val As Long)
Call KyuzituSet(val)
End Property
Public Property Get pYear() As Long
pYear = memYear
End Property
Public Property Let SetStrDate(val As String)
If IsDate(val) Then
Call KyuzituSet(CLng(DatePart("yyyy", val)))
memMonth = CLng(DatePart("m", val))
memDay = CLng(DatePart("d", val))
Else
Call KyuzituSet(1900)
memMonth = 1
memDay = 1
End If
End Property
Public Property Let SetNumDate(val As Long)
Call KyuzituSet(Year(val))
memMonth = Month(val)
memDay = Day(val)
End Property
Public Property Let FormatFormat(val As String)
memFormat = val
End Property
Public Property Get GetStrDate() As String
GetStrDate = Format(DateSerial(memYear, memMonth, memDay), memFormat)
End Property
Public Property Get WeekNum() As Long
WeekNum = Yobi
End Property
Public Property Get DateNum() As Long
DateNum = DateSerial(memYear, memMonth, memDay)
End Property
Private Sub Class_Initialize()
Call KyuzituSet(Year(Date))
memMonth = Month(Date)
memDay = Day(Date)
End Sub
Private Sub Class_Terminate()
Set memShukuzitu = Nothing
Set memKokumin = Nothing
Set memHurikae = Nothing
Set memKanrei = Nothing
End Sub
Private Function Yobi() As Long
If memShukuzitu.Exists(DateNum) Then
Yobi = YobiType.Shuku
Exit Function
End If
If memKokumin.Exists(DateNum) Then
Yobi = YobiType.Kokumin
Exit Function
End If
If memHurikae.Exists(DateNum) Then
Yobi = YobiType.Kanrei
Exit Function
End If
If memKanrei.Exists(DateNum) Then
Yobi = YobiType.Kanrei
Exit Function
End If
Yobi = Weekday(DateNum, vbSunday)
End Function
'---------------------------------------
Private Sub KyuzituSet(NewYear As Long)
If memYear <> NewYear Then
memYear = NewYear
Call makeShukuzitu
Call makeKokumin
Call makeHurikae
Call makeKanrei
End If
End Sub
'---------------------------------------ロング値で与えられた日付の休日判定を行ないます。
Private Sub makeShukuzitu()
Dim iDay As Long
Set memShukuzitu = Nothing
Set memShukuzitu = New Dictionary
'----------元日
If DateSerial(memYear, 1, 1) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 1, 1), "元旦"
End If
'----------成人の日 １月１５日 → １月の第２月曜
If memYear > 1949 And memYear < 2000 Then
memShukuzitu.Add DateSerial(memYear, 1, 15), "成人の日"
ElseIf memYear > 1999 Then
memShukuzitu.Add DateSerial(memYear, 1, 14) - (Weekday(DateSerial(memYear, 1, 14), vbTuesday) Mod 7), "成人の日"
End If
'----------建国記念の日
If DateSerial(memYear, 2, 11) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 2, 11), "建国記念の日"
End If
'----------天皇誕生日
If memYear > 2019 Then
memShukuzitu.Add DateSerial(memYear, 2, 23), "天皇誕生日"
End If
'----------春分の日
'int(19.8277+0.242194*(年-1980)-int((年-1983)/4)) ----------1851-1899年通用
'int(20.8357+0.242194*(年-1980)-int((年-1983)/4)) ----------1900-1979年通用
'int(20.8431+0.242194*(年-1980)-int((年-1980)/4)) ----------1980-2099年通用
'int(21.8510+0.242194*(年-1980)-int((年-1980)/4)) ----------2100-2150年通用
Select Case memYear
Case Is < 2100
iDay = Int(20.8431 + 0.242194 * (memYear - 1980) - Int((memYear - 1980) / 4))
Case Is >= 2100
iDay = Int(20.851 + 0.242194 * (memYear - 1980) - Int((memYear - 1980) / 4))
End Select
If DateSerial(memYear, 3, iDay) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 3, iDay), "春分の日"
End If
'----------天皇誕生日→みどりの日→昭和の日
If DateSerial(memYear, 4, 29) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 4, 29), "昭和の日"
End If
'----------即位の礼
If memYear = 2019 Then
memShukuzitu.Add DateSerial(memYear, 5, 1), "即位の礼"
End If
'----------憲法記念日
If DateSerial(memYear, 5, 3) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 5, 3), "憲法記念日"
End If
'----------みどりの日
If memYear > 2006 Then
memShukuzitu.Add DateSerial(memYear, 5, 4), "みどりの日"
End If
'----------こどもの日
If DateSerial(memYear, 5, 5) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 5, 5), "こどもの日"
End If
'----------海の日 ７月２０日 → ７月の第３月曜日
If memYear > 1995 And memYear < 2003 Then
memShukuzitu.Add DateSerial(memYear, 7, 20), "海の日"
ElseIf memYear > 2002 Then
If memYear = 2020 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 7, 23), "海の日"
ElseIf memYear = 2021 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 7, 22), "海の日"
Else
memShukuzitu.Add DateSerial(memYear, 7, 21) - (Weekday(DateSerial(memYear, 7, 21), vbTuesday) Mod 7), "海の日"
End If
End If
'----------山の日"
If memYear > 2015 Then
If memYear = 2020 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 8, 10), "山の日"
ElseIf memYear = 2021 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 8, 8), "山の日"
Else
memShukuzitu.Add DateSerial(memYear, 8, 11), "山の日"
End If
End If
'----------敬老の日 ９月１５日 → ９月の第３月曜日
If memYear > 1965 And memYear < 2003 Then
memShukuzitu.Add DateSerial(memYear, 9, 15), "敬老の日"
ElseIf memYear > 2002 Then
memShukuzitu.Add DateSerial(memYear, 9, 21) - (Weekday(DateSerial(memYear, 9, 21), vbTuesday) Mod 7), "敬老の日"
End If
'----------秋分の日
'int(22.2588+0.242194*(年-1980)-int((年-1983)/4)) ----------1851-1899年通用
'int(23.2588+0.242194*(年-1980)-int((年-1983)/4)) ----------1900-1979年通用
'int(23.2488+0.242194*(年-1980)-int((年-1980)/4)) ----------1980-2099年通用
'int(24.2488+0.242194*(年-1980)-int((年-1980)/4)) ----------2100-2150年通用
Select Case memYear
Case Is < 2100
iDay = Int(23.2488 + 0.242194 * (memYear - 1980) - Int((memYear - 1980) / 4))
Case Is >= 2100
iDay = Int(24.2488 + 0.242194 * (memYear - 1980) - Int((memYear - 1980) / 4))
End Select
If DateSerial(memYear, 9, iDay) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 9, iDay), "秋分の日"
End If
'----------体育の日 → スポーツの日 １０月１０日 → １０月の第二月曜日
If memYear > 1965 And memYear < 2000 Then
memShukuzitu.Add DateSerial(memYear, 10, 10), "体育の日"
ElseIf memYear > 1999 Then
If memYear = 2020 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 7, 24), "スポーツの日"
ElseIf memYear = 2021 Then
'オリンピックイヤー
memShukuzitu.Add DateSerial(memYear, 7, 23), "スポーツの日"
Else
memShukuzitu.Add DateSerial(memYear, 10, 14) - (Weekday(DateSerial(memYear, 10, 14), vbTuesday) Mod 7), "スポーツの日"
End If
End If
'----------即位礼正殿の儀
If memYear = 2019 Then
memShukuzitu.Add DateSerial(memYear, 10, 22), "即位礼正殿の儀"
End If
'----------文化の日
If DateSerial(memYear, 11, 3) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 11, 3), "文化の日"
End If
'----------勤労感謝の日
If DateSerial(memYear, 11, 23) > DateSerial(1948, 7, 19) Then
memShukuzitu.Add DateSerial(memYear, 11, 23), "勤労感謝の日"
End If
'----------天皇誕生日
If memYear > 1988 And memYear < 2019 Then
memShukuzitu.Add DateSerial(memYear, 12, 23), "天皇誕生日"
End If
End Sub
Private Sub makeKokumin()
Dim D() As Long
Dim Keys As Variant
Dim iCount As Long
Dim I As Long
Dim J As Long
Dim Target As Long
If memShukuzitu.Count = 0 Then
Exit Sub
End If
If memYear < 1988 Then
Exit Sub
End If
Set memKokumin = Nothing
Set memKokumin = New Dictionary
'-------------------------------国民の休日の判定
ReDim D(memShukuzitu.Count - 1)
For Each Keys In memShukuzitu
D(iCount) = Keys
iCount = iCount + 1
Next
For I = 0 To UBound(D)
For J = 0 To UBound(D)
'-----------------------該当の組み合わせがある場合
If D(J) - D(I) = 2 Then
Target = (D(J) + D(I)) / 2
If Not memShukuzitu.Exists(Target) Then
memKokumin.Add Target, "休日"
End If
End If
Next J
Next I
End Sub
Private Sub makeHurikae()
Dim iDay As Long
Dim fDay As Long
Dim boHurikae As Boolean
If memShukuzitu.Count = 0 Then
Exit Sub
End If
If memYear < 1973 Then
Exit Sub
End If
Set memHurikae = Nothing
Set memHurikae = New Dictionary
For iDay = DateSerial(memYear, 1, 1) To DateSerial(memYear, 12, 31)
'---------------------------日曜日であること
If Weekday(iDay) = 1 Then
'-------------------祝日であること
If memShukuzitu.Exists(iDay) Then
boHurikae = True
fDay = iDay
End If
End If
'---------------------------フラッグを立てた後、最初の祝日でない日を振替日とする
If boHurikae = True Then
If iDay > fDay Then
'-------------------祝休日に該当しない場合、振替日にする
If Not memShukuzitu.Exists(iDay) Then
memHurikae.Add iDay, "振替"
boHurikae = False
End If
End If
End If
Next iDay
End Sub
Private Sub makeKanrei()
Set memKanrei = Nothing
Set memKanrei = New Dictionary
'-----------------------------------慣例になっている休日
With memKanrei
.Add DateSerial(memYear, 1, 1), "慣例"
.Add DateSerial(memYear, 1, 2), "慣例"
.Add DateSerial(memYear, 1, 3), "慣例"
.Add DateSerial(memYear, 12, 31), "慣例"
End With
End Sub