ACCESSで使うカレンダー

Access カレンダーFORM

コントローの配置
1段目　年を減算するコマンドボタン[PY]
 　　　年を表示するラベル[DYEAR]
 　　　年を加算するコマンドボタン[NY]
 　　　月を加算するコマンドボタン[PM]
 　　　月を表示するラベル[DMONTH]
 　　　月を加算するコマンドボタン[NM]
2段目～7段目
 　　　日にちを表示するラベル[Dx] xは0から41までの数字
 　　　1クリック目でラベルを窪み表示にして、窪み表示をクリックすると
 　　　カレンダーは非表示になり、呼び出し元でプロパティ[DateNum][WeekNum]
 　　　からシリアル値、Week値を取得します。
8段目　カレンダーを開いたときのデフォルト値に戻すコマンドボタン[bu初期]
 　　　カレンダーを非表示して、呼び出し元でプロパティ[DateNum]の0を評価して
 　　　処理します。
 　　　カレンダーを閉じるコマンドボタン[bu閉じる]

COPY

'----------------------------------------------------------------
'カレンダー
'令和３年５月６日
'----------------------------------------------------------------
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

COPY

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

COPY

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

COPY

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

COPY

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

COPY

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

COPY

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クラス

COPY

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