Excel VBA イベントを利用する

2025年5月31日

ちょっと眠たそうな柴犬です。

概要

EXCELのフォームのコントロールをクリックして、カレンダーを表示します。カレンダーの日付をクリックするとフォームのコントロールに日付が入力されるようにしています。

クラスモジュール clsCmdWeek からフォームのプロシージャを起動していましたが、イベント駆動に変更してみました。

特に、不具合はなかったのですがたまにはVBAを扱ってみないと忘れてしまうので、イベントを使って改造してみることにしました。

コントロール毎にクラスモジュール clsCmdWeek を作って、イベントが発生したらフォームの公開関数を実行させていました。

これを、クラスモジュール clsCmdWeek を管理するクラスモジュール CmdWeekControl を作って、この公開関数を実行させてイベントを発生するようにしました。

クラスモジュール CmdWeekControl のイベントをフォームで受け取れるようにして処理します。

クラスモジュール clsCmdWeek

copy

Option Explicit

Private WithEvents MyLbl    As MSForms.Label
Private MyIndex             As Integer
Private MyCaller            As Object

Public Property Let Item(NewCtrl As MSForms.Label)

    Set MyLbl = NewCtrl
    
End Property

Public Property Let Index(NewIndex As Integer)

    MyIndex = NewIndex
    
End Property

Public Property Let Caller(NewCaller As Object)

    Set MyCaller = NewCaller
    
End Property

'ラベルのClickイベントを処理します
'-----------------------------------------------------------------
Private Sub MyLbl_Click()
    '親クラスのRaiseClickイベントを発生させます
    Call MyCaller.clsCmdWeekClick(MyIndex)
    
End Sub

'ラベルのMouseMoveイベントを処理します
'-----------------------------------------------------------------
Private Sub MyLbl_MouseMove(ByVal Button As Integer, _
                            ByVal Shift As Integer, _
                            ByVal X As Single, _
                            ByVal Y As Single)
    '親クラスのRaiseMouseMoveイベントを発生させます
    Call MyCaller.clsCmdWeekMouseMove(MyIndex)
    
End Sub

'ラベルのDblClickイベントを処理します
'-----------------------------------------------------------------
Private Sub MyLbl_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    '親クラスのRaiseDblClickイベントを発生させます
    Call MyCaller.clsCmdWeekDblClick(MyIndex)
    
End Sub

クラスモジュール CmdWeekControl

copy

Option Explicit

Public Event RaiseClick(ByVal Index As Integer)
Public Event RaiseMouseMove(ByVal Index As Integer)
Public Event RaiseDblClick(ByVal Index As Integer)

Private MyCaller                As Object
Private cmdWeekBtn(1 To 42)     As clsCmdWeek

Public Property Let Caller(NewCaller As Object)

    Set MyCaller = NewCaller

    Call MakeInstance

End Property

Private Sub MakeInstance()
Dim I               As Integer
Dim J               As Integer
Dim L               As Integer
Dim U               As Integer
Dim S               As String
Dim CTRL            As Control

    L = LBound(cmdWeekBtn)
    U = UBound(cmdWeekBtn)

    '子クラス clsCmdWeek オブジェクト を作成します
    For I = L To U
        '目的のコントロール名を作成します
        J = (((I - 1) \ 7) + 1) * 10 + (I - 1) Mod 7 + 1
        S = "lbl" & J
        'フォーム 日付 のコントロールを探査します
        For Each CTRL In MyCaller.Controls
            '目的のコントロールが見つかれば処理します
            If CTRL.Name = S Then
                'インスタンスの生成
                Set cmdWeekBtn(I) = New clsCmdWeek
                With cmdWeekBtn(I)
                    .Item = CTRL       'コントロールの登録
                    .Index = I
                    .Caller = Me       '自分自身を登録
                End With
            End If
        Next CTRL
    Next I

End Sub

Public Sub Terminate()
Dim I               As Integer
Dim L               As Integer
Dim U               As Integer

    L = LBound(cmdWeekBtn)
    U = UBound(cmdWeekBtn)

    For I = L To U
        ' インスタンスの破棄
        Set cmdWeekBtn(I) = Nothing
    Next

End Sub

'公開関数
'clsCmdWeek オブジェクトから実行されます
Public Sub clsCmdWeekClick(ByVal Index As Integer)

    RaiseEvent RaiseClick(Index)
    
End Sub

'公開関数
'clsCmdWeek オブジェクトから実行されます
Public Sub clsCmdWeekMouseMove(ByVal Index As Integer)

    RaiseEvent RaiseMouseMove(Index)
    
End Sub

'公開関数
'clsCmdWeek オブジェクトから実行されます
Public Sub clsCmdWeekDblClick(ByVal Index As Integer)

    RaiseEvent RaiseDblClick(Index)
    
End Sub

フォーム日付の変更点

フォームのモジュールのヘッダー部分です。

copy

Option Explicit

'----------変更
'追加
Private WithEvents CmdWeekCTL     As CmdWeekControl

'削除
Private cmdWeekBtn(1 To 42)     As clsCmdWeek
'----------変更ここまで


Const SHIFT_MASK = 1

モジュール UserForm_Initialize と UserForm_Terminate を修正します。

copy

Private Sub UserForm_Initialize()
Dim BUF         As Variant
Dim I           As Integer
Dim J           As Integer

    buDummy.SetFocus

    '----------変更
    '追加
    Set CmdWeekCTL = New CmdWeekControl
    CmdWeekCTL.Caller = Me


    '削除
    For I = 1 To 42
        ' インスタンスの生成
        Set cmdWeekBtn(I) = New clsCmdWeek
        J = (((I - 1) \ 7) + 1) * 10 + (I - 1) Mod 7 + 1
        With cmdWeekBtn(I)
            .Item = Me("lbl" & J)
            .Index = I
            .Caller = Me
        End With
    Next I
    '----------変更ここまで



    lblTop(1) = lbl11.Top
    For I = 2 To 6
        lblTop(I) = lblTop(I - 1) + lbl11.Height
    Next I

    '----------以下省略
    
End Sub
'
'-----------------------------------------------------------------
Private Sub UserForm_Terminate()

    '----------変更
    '追加
    CmdWeekCTL.Terminate
    Set CmdWeekCTL = Nothing

    '削除
    Dim I               As Integer
    For I = 1 To 42
        ' インスタンスの破棄
        Set cmdWeekBtn(I) = Nothing
    Next
    '----------変更ここまで

End Sub

クラスCmdWeekCTLからのイベントを処理するモジュールを追加し、クラスclsCmdWeekからのコールバックを削除します。

copy

'CmdWeekCTLからのRaiseDblClickイベントを処理します
'-----------------------------------------------------------------
Private Sub CmdWeekCTL_RaiseDblClick(ByVal Index As Integer)
Dim iGrid               As Integer

    iGrid = (((Index - 1) \ 7) + 1) * 10 + (Index - 1) Mod 7 + 1
    Call SelectDate("lbl" & iGrid)

End Sub

'CmdWeekCTLからのRaiseMouseMoveイベントを処理します
'-----------------------------------------------------------------
Private Sub CmdWeekCTL_RaiseMouseMove(ByVal Index As Integer)

    Call CalMousePoint(Index)

End Sub

'CmdWeekCTLからのRaiseClickイベントを処理します
'-----------------------------------------------------------------
Private Sub CmdWeekCTL_RaiseClick(ByVal Index As Integer)
Dim iGrid               As Integer

    iGrid = (((Index - 1) \ 7) + 1) * 10 + (Index - 1) Mod 7 + 1
    If Me("lbl" & iGrid).BackColor = vbYellow Then
        Call SelectDate("lbl" & iGrid)
    Else
        Call HandleSelected("lbl" & iGrid)
    End If
    
End Sub

'削除
'-----------------------------------------------------------------
Public Sub RaiseClick(ByVal Index As Integer)
Dim iGrid               As Integer

    iGrid = (((Index - 1) \ 7) + 1) * 10 + (Index - 1) Mod 7 + 1
    If Me("lbl" & iGrid).BackColor = vbYellow Then
        Call SelectDate("lbl" & iGrid)
    Else
        Call HandleSelected("lbl" & iGrid)
    End If
    
End Sub

'削除
'-----------------------------------------------------------------
Public Sub RaiseDblClick(ByVal Index As Integer)
Dim iGrid               As Integer

    iGrid = (((Index - 1) \ 7) + 1) * 10 + (Index - 1) Mod 7 + 1
    Call SelectDate("lbl" & iGrid)

End Sub

'削除
'-----------------------------------------------------------------
Public Sub RaiseMouseMove(ByVal Index As Integer)

    Call CalMousePoint(Index)

End Sub

フォーム日付の全コード

copy

Option Explicit

Private WithEvents CmdWeekCTL     As CmdWeekControl

Const SHIFT_MASK = 1
Private mOldDate As Date
Private Const adhcFirstDayOfWeek = vbSunday
Private Const adhcColorSunday = vbRed
Private Const adhcColorSaturday = vbBlue
Private Const adhcColorWeekday = vbBlack

Private Const adhcDayStr    As String = "d"
Private Const adhcMonthStr  As String = "m"
Private Const adhcYearStr   As String = "yyyy"
Private Const adhcWeekStr   As String = "ww"

Private Enum DirectionType
    dtMoveForward = 0
    dtMoveBackward = -1
End Enum

Private mdtmStartDate       As Date
Private mintFirstDay        As Integer
Private mastrDays(1 To 7)   As String
Private mintStartDOW        As Integer
Private lblTop(1 To 7)      As Integer

Private mintYearToday       As Integer
Private mintMonthToday      As Integer
Private mintDayToday        As Integer

Private mintYear            As Integer
Private mintMonth           As Integer
Private mintDay             As Integer

Private mvarMonthLen        As Variant
Private mstrSelected        As String

Public Property Get Value() As Date

    Value = DateSerial(mintYear, mintMonth, mintDay)
     
End Property

Public Property Let Value(ByVal DateValue As Date)

    Call FillInStartValues(DateValue)
     
End Property
'
'-----------------------------------------------------------------
Private Sub UserForm_Initialize()
Dim BUF         As Variant
Dim I           As Integer
Dim J           As Integer

    buDummy.SetFocus

    Set CmdWeekCTL = New CmdWeekControl
    CmdWeekCTL.Caller = Me

    lblTop(1) = lbl11.Top
    For I = 2 To 6
        lblTop(I) = lblTop(I - 1) + lbl11.Height
    Next I

    '--------月の日数の配列　0はダミー値
    mvarMonthLen = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)

    '--------引数firstdayofweek　最初に来る曜日を日曜日に指定
    '        Left$はLeftより処理速度が早い
    For I = 1 To 7
        mastrDays(I) = Left$(WeekdayName(I, FirstDayOfWeek:=vbSunday), 1)
    Next I

    BUF = Replace(StrConv(CalendarDate, vbNarrow), ".", "/")
    If IsDate(BUF) Then
        BUF = CDate(BUF)
    Else
        BUF = Date
    End If

    '--------年月日の要素を取り出す
    mintDayToday = DatePart(adhcDayStr, BUF)
    mintMonthToday = DatePart(adhcMonthStr, BUF)
    mintYearToday = DatePart(adhcYearStr, BUF)

    '--------日曜日をファーストデイにする
    mintFirstDay = adhcFirstDayOfWeek

    '--------フォームを開くときに渡されたパラメーターを処理する
    '        パラメーターが無ければ今日の日とする
    Call FillInStartValues(BUF)
                                                                                
    '--------カンレダー部の曜日、色描写
    FixUpDisplay

    '--------カンレダー部の日付描写
    DisplayCal
    
End Sub
'
'-----------------------------------------------------------------
Private Sub UserForm_Terminate()

    CmdWeekCTL.Terminate
    Set CmdWeekCTL = Nothing

End Sub

'CmdWeekCTLからのRaiseDblClickイベントを処理します
'-----------------------------------------------------------------
Private Sub CmdWeekCTL_RaiseDblClick(ByVal Index As Integer)
Dim iGrid               As Integer

    iGrid = (((Index - 1) \ 7) + 1) * 10 + (Index - 1) Mod 7 + 1
    Call SelectDate("lbl" & iGrid)

End Sub

'CmdWeekCTLからのRaiseMouseMoveイベントを処理します
'-----------------------------------------------------------------
Private Sub CmdWeekCTL_RaiseMouseMove(ByVal Index As Integer)

    Call CalMousePoint(Index)

End Sub

'CmdWeekCTLからのRaiseClickイベントを処理します
'-----------------------------------------------------------------
Private Sub CmdWeekCTL_RaiseClick(ByVal Index As Integer)
Dim iGrid               As Integer

    iGrid = (((Index - 1) \ 7) + 1) * 10 + (Index - 1) Mod 7 + 1
    If Me("lbl" & iGrid).BackColor = vbYellow Then
        Call SelectDate("lbl" & iGrid)
    Else
        Call HandleSelected("lbl" & iGrid)
    End If
    
End Sub
'
'----------------------------------------------------------------
Private Sub Cancel_Click()

    Unload Me
    
End Sub
'
'-----------------------------------------------------------------
Private Sub Delete_Click()

    Me.Value = 0
    Me.Hide
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdNextYear_Click()
    
    buDummy.SetFocus
    
    Call NextYear
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdPreviousYear_Click()
    
    buDummy.SetFocus
    
    Call PreviousYear
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdNextMonth_Click()
    
    buDummy.SetFocus
    
    Call NextMonth
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdPreviousMonth_Click()
    
    buDummy.SetFocus
    
    Call PreviousMonth
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdPreviousMonth_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                                     ByVal Shift As Integer)

    HandleKeys KeyCode, Shift
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdNextYear_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                                ByVal Shift As Integer)

    HandleKeys KeyCode, Shift
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdPreviousYear_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                                    ByVal Shift As Integer)

    HandleKeys KeyCode, Shift
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdNextMonth_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                                 ByVal Shift As Integer)

    HandleKeys KeyCode, Shift
    
End Sub
'
'-----------------------------------------------------------------
Private Sub buDummy_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                            ByVal Shift As Integer)

    HandleKeys KeyCode, Shift
    
End Sub

'フォームを開くときの最初の日付を設定
'-----------------------------------------------------------------
Private Sub FillInStartValues(ByVal myDate As Long)

    mdtmStartDate = myDate

    Call SetUpPublics
    
End Sub

'プロパティValueに代入されたとき実行するプロシージャでもある
'-----------------------------------------------------------------
Private Sub SetUpPublics()

    '--------最初の日付の要素を変数に代入
    '        または、プロパティValueの値を代入
    mintMonth = DatePart(adhcMonthStr, mdtmStartDate)
    mintYear = DatePart(adhcYearStr, mdtmStartDate)
    mintDay = DatePart(adhcDayStr, mdtmStartDate)
    
    Call SetDisplayDate
    
End Sub

'プロパティYear,Monthの値をテキストボックスに表示
'-----------------------------------------------------------------
Private Sub SetDisplayDate()

    txtMonth = Format(DateSerial(mintYear, mintMonth, 1), "m月")
    txtYear = Format(DateSerial(mintYear, mintMonth, 1), "yyyy年")
    
End Sub
'
'-----------------------------------------------------------------
Private Sub FixUpDisplay()
Dim intCol              As Integer
Dim intRow              As Integer
Dim intLogicalDay       As Integer
Dim intDiff             As Integer
Dim lngForeColor        As Long

    For intCol = 1 To 7

        '--------列順番と曜日順番の調整
        intLogicalDay = (((intCol - 1) + (mintFirstDay - 1)) Mod 7) + 1

        Select Case intLogicalDay
        Case 1
            lngForeColor = adhcColorSunday
        Case 7
            lngForeColor = adhcColorSaturday
        Case Else
            lngForeColor = adhcColorWeekday
        End Select

        '--------曜日ラベル
        With Me("lblDay" & intCol)
            .Caption = mastrDays(intLogicalDay)
            .ForeColor = lngForeColor
        End With

    Next intCol

End Sub

'DateCalendarの日付の描写
'-----------------------------------------------------------------
Private Sub DisplayCal()
Static fInHere As Boolean

    If fInHere Then Exit Sub
    
    fInHere = True

    '--------月の1日の週日
    mintStartDOW = FirstDOM(mintMonth, mintYear)

    '--------DateCalendarの日付の描写
    ShowDate mintStartDOW

    fInHere = False

End Sub
'
'-----------------------------------------------------------------
Private Function FirstDOM(intMonth As Integer, intYear As Integer) As Integer

    '--------月の1日が、日曜日を初日とする週の何日目
    FirstDOM = DatePart("w", DateSerial(intYear, intMonth, 1), mintFirstDay)

End Function
'
'-----------------------------------------------------------------
Private Sub ShowDate(intStartDay As Integer)
Dim newSelected             As String

    '--------DateCalendarの日付の描写
    FixDaysInMonth intStartDay

    newSelected = "lbl" & ButtonGrid(mintDay, intStartDay)

    '--------凹みの描写
    HandleIndent newSelected

End Sub
'
'-----------------------------------------------------------------
Private Sub FixDaysInMonth(intStartDay As Integer)
Dim intRow              As Integer
Dim intCol              As Integer
Dim intNumDays          As Integer
Dim intCount            As Integer
Dim strTemp             As String
Dim lngForeColor        As Long

    If mintMonth <> 2 Then
        '--------2月以外の場合
        intNumDays = mvarMonthLen(mintMonth)
    Else
        '--------2月の場合(3月1日の1日前)
        intNumDays = DatePart(adhcDayStr, DateSerial(mintYear, 3, 1) - 1)
    End If

    If mintDay > intNumDays Then
        '--------月、年を更新した場合、1/31⇒2/28等の処理
        mintDay = intNumDays
    End If

    intCount = 0
    For intRow = 1 To 6
        '--------DateCalendarの日付の描写
        For intCol = 1 To 7
            If (intRow = 1) And (intCol < intStartDay) Then
                Me("lbl1" & intCol).Visible = False
            Else
                intCount = intCount + 1
                strTemp = "lbl" & intRow & intCol
                With Me(strTemp)
                    If intCount <= intNumDays Then
                        If Not .Visible Then
                            .Visible = True
                        End If
                        .Caption = intCount
                        Select Case Kyujitu(DateSerial(mintYear, mintMonth, intCount))
                        Case 1
                            lngForeColor = adhcColorSunday
                        Case 7
                            lngForeColor = adhcColorSaturday
                        Case Else
                            lngForeColor = adhcColorWeekday
                        End Select
                        .ForeColor = lngForeColor
                    Else
                        If .Visible Then
                            .Visible = False
                        End If
                    End If
                End With
            End If
        Next intCol
    Next intRow
    
    For intRow = 1 To 6
        For intCol = 1 To 7
            If Not Me.lbl51.Visible And Not Me.lbl61.Visible Then
                strTemp = "lbl" & intRow & intCol
                Me(strTemp).Top = lblTop(intRow) + lbl11.Height
            ElseIf Me.lbl51.Visible And Not Me.lbl61.Visible Then
                strTemp = "lbl" & intRow & intCol
                Me(strTemp).Top = lblTop(intRow) + lbl11.Height * 0.5
            Else
                strTemp = "lbl" & intRow & intCol
                Me(strTemp).Top = lblTop(intRow)
            End If
        Next intCol
    Next intRow
    
End Sub
'
'-----------------------------------------------------------------
Private Function ButtonGrid(wDay As Integer, intStartDay As Integer) As String
Dim Index               As Integer
Dim iGrid               As Integer
    
    Index = wDay + intStartDay - 1
    iGrid = (((Index - 1) \ 7) + 1) * 10 + (Index - 1) Mod 7 + 1
    ButtonGrid = iGrid

End Function
'
'-----------------------------------------------------------------
Private Sub HandleIndent(strNewSelect As String)

    If Len(mstrSelected) > 0 Then
        '--------新しい日にちが選択された場合、前の日にちの凹みを凸に戻す
        If mstrSelected <> strNewSelect Then
            With Me(mstrSelected)
                .SpecialEffect = fmSpecialEffectRaised
                .BackColor = vbButtonFace
            End With
        End If
    End If

    mstrSelected = strNewSelect

    With Me(mstrSelected)
        '--------新しい日にちを凹みにする
        .SpecialEffect = fmSpecialEffectBump
        .BackColor = vbYellow
    End With

    '--------凹みの日にちをフォームの日にちにする
    mintDay = Me(mstrSelected).Caption

End Sub

'日付をクリックした時に実行する関数
'-----------------------------------------------------------------
Private Function HandleSelected(strName As String)

    HandleIndent strName
    
End Function

'日付をダブルクリックした時に実行する関数
'-----------------------------------------------------------------
Private Function SelectDate(strName As String)

    HandleIndent strName
    
    Me.Hide
    
End Function
'
'-----------------------------------------------------------------
' Leftarrow 　　　  = Previous Day
' Shift-Leftarrow   = Previous Year
' Rightarrow 　　　 = Next Day
' Shift-Rightarrow  = Next Year
' Uparrow           = Previous week
' Shift-Uparrow 　　= Previous Month
' Dnarrow           = Next Week
' Shift-Dnarrow     = Next Month
' PgUp              = Previous Month
' Shift-PgUp        = Previous Year
' PgDn              = Next Month
' Shift-PgDn        = Next Year
' Home              = Move to Today
' Shift-Home        = Move to today in selected year.
Private Sub HandleKeys(ByRef KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim ShiftDown As Boolean

    ShiftDown = (Shift And SHIFT_MASK)

    Select Case KeyCode.Value
        Case vbKeyEscape
            Unload Me
        Case vbKeyReturn
            Me.Hide
        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.Value = 0
    
End Sub
'
'-----------------------------------------------------------------
Public Sub Today()

    Call MoveToToday(True)
    
End Sub
'
'-----------------------------------------------------------------
Public Sub NextDay()

    ChangeDate adhcDayStr, dtMoveForward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub NextMonth()

    ChangeDate adhcMonthStr, dtMoveForward
     
End Sub
'
'-----------------------------------------------------------------
Public Sub NextYear()

    ChangeDate adhcYearStr, dtMoveForward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub NextWeek()

    ChangeDate adhcWeekStr, dtMoveForward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub PreviousDay()

    ChangeDate adhcDayStr, dtMoveBackward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub PreviousMonth()

    ChangeDate adhcMonthStr, dtMoveBackward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub PreviousYear()

    ChangeDate adhcYearStr, dtMoveBackward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub PreviousWeek()

    ChangeDate adhcWeekStr, dtMoveBackward
    
End Sub
'
'-----------------------------------------------------------------
Private Sub ChangeDate(strMoveUnit As String, dt As DirectionType)
Dim intMonth        As Integer
Dim intYear         As Integer
Dim intDay          As Integer
Dim dtmDate         As Date
Dim dtmOldDate      As Date
Dim intInc          As Integer
On Error GoTo ERROR_SHORI

    intYear = mintYear
    intMonth = mintMonth
    intDay = mintDay

    If dt = dtMoveForward Then
        intInc = 1
    Else
        intInc = -1
    End If
    dtmOldDate = DateSerial(intYear, intMonth, intDay)
    '--------年・月・日をインクリメント・デクリメント
    dtmDate = DateAdd(strMoveUnit, intInc, dtmOldDate)

    intMonth = DatePart(adhcMonthStr, dtmDate)
    intYear = DatePart(adhcYearStr, dtmDate)
    intDay = DatePart(adhcDayStr, dtmDate)

    If mintMonth = intMonth And mintYear = intYear Then
        HandleIndent "lbl" & ButtonGrid(intDay, mintStartDOW)
    Else
        mintDay = intDay
        mintMonth = intMonth
        mintYear = intYear

        '--------プロパティYear,Monthの値をテキストボックスに表示
        Call SetDisplayDate

        '--------DateCalendarの日付の描写
        Call DisplayCal
        
    End If

OWARI:
    Exit Sub

ERROR_SHORI:
    Resume OWARI
    
End Sub
'
'-----------------------------------------------------------------
Private Sub MoveToToday(UseCurrentYear As Boolean)

    mintMonth = mintMonthToday
    If UseCurrentYear Then
        mintYear = mintYearToday
    End If
    
    mintDay = mintDayToday

    '--------プロパティYear,Monthの値をテキストボックスに表示
    Call SetDisplayDate

    '--------DateCalendarの日付の描写
    Call DisplayCal
    
End Sub

'ロング値で与えられた日付の休日判定を行ないます。
'-----------------------------------------------------------------
Private Function Kyujitu(lDate As Long) As Integer
Dim myYear          As Integer
Dim ResWeekNum      As Integer
Dim FLG             As Boolean
Dim I               As Integer
Dim J               As Integer
Dim k               As Integer
Dim iCount          As Integer
Dim lDay            As Long
Dim DateBUF         As Long
Dim lKyujitu()      As Long
Dim lKokumin()      As Long
Dim lKanrei()       As Long
Dim lHurikae()      As Long

    myYear = Year(lDate)
    ResWeekNum = Weekday(lDate)

    '----------値の初期化
    ReDim lKyujitu(0)
        lKyujitu(0) = 0
    ReDim lHurikae(0)
        lHurikae(0) = 0
    ReDim lKokumin(0)
        lKokumin(0) = 0
    ReDim lKanrei(0)
        lKanrei(0) = 0

    '----------祝祭日のセット
    If ResWeekNum <> 1 And lDate > DateSerial(1948, 7, 19) Then

        '----------元日
        iCount = 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 1, 1)

        '----------成人の日　１月１５日　→　１月の第２月曜
        If myYear > 1949 And myYear < 2000 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 1, 15)
        ElseIf myYear > 1999 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 1, 8) + _
                               ((9 - Weekday(DateSerial(myYear, 1, 8))) Mod 7)
        End If
        
        iCount = iCount + 1  '----------建国記念の日
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 2, 11)

        '----------天皇誕生日
        If myYear > 2018 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
                lKyujitu(iCount) = DateSerial(myYear, 2, 23)
        End If

        iCount = iCount + 1  '----------春分の日
        ReDim Preserve lKyujitu(iCount)
            '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 myYear
            Case Is < 2100
                DateBUF = Int(20.8431 + 0.242194 * (myYear - 1980) - Int((myYear - 1980) / 4))
            Case Is >= 2100
                DateBUF = Int(20.851 + 0.242194 * (myYear - 1980) - Int((myYear - 1980) / 4))
            End Select
            lKyujitu(iCount) = DateSerial(myYear, 3, DateBUF)

        '----------天皇誕生日→みどりの日→昭和の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 4, 29)

        '----------憲法記念日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 5, 3)

        '----------みどりの日
        If myYear > 2006 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 5, 4)
        End If

        '----------こどもの日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 5, 5)

        '----------海の日　７月２０日　→　７月の第３月曜日
        If myYear > 1995 And myYear < 2003 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 7, 20)
        ElseIf myYear > 2002 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 7, 15) + _
                               ((9 - Weekday(DateSerial(myYear, 7, 15))) Mod 7)
        End If

        '----------山の日
        If myYear > 2015 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 8, 11)
        End If

        '----------敬老の日　９月１５日　→　９月の第３月曜日
        If myYear > 1965 And myYear < 2003 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 9, 15)
        ElseIf myYear > 2002 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 9, 15) + _
                               ((9 - Weekday(DateSerial(myYear, 9, 15))) Mod 7)
        End If

        '----------秋分の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            '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 myYear
            Case Is < 2100
                DateBUF = Int(23.2488 + 0.242194 * (myYear - 1980) - Int((myYear - 1980) / 4))
            Case Is >= 2100
                DateBUF = Int(24.2488 + 0.242194 * (myYear - 1980) - Int((myYear - 1980) / 4))
            End Select
            lKyujitu(iCount) = DateSerial(myYear, 9, DateBUF)

        '----------体育の日　１０月１０日　→　１０月の第二月曜日
        If myYear > 1965 And myYear < 2000 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 10, 10)
        ElseIf myYear > 1999 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 10, 8) + _
                               ((9 - Weekday(DateSerial(myYear, 10, 8))) Mod 7)
        End If

        '----------文化の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 11, 3)

        '----------勤労感謝の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 11, 23)

        '----------天皇誕生日
        If myYear > 1988 And myYear < 2018 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
                lKyujitu(iCount) = DateSerial(myYear, 12, 23)
        End If

        '----------祝祭休日の判定
        For I = 1 To UBound(lKyujitu())
            If lKyujitu(I) = lDate Then
                ResWeekNum = 1
            End If
        Next I
    End If

    '----------振り替え休日の判定
    If ResWeekNum <> 1 And myYear > 1972 Then

        '----------値の初期化
        iCount = 0
        FLG = False
        DateBUF = 0
        For lDay = DateSerial(myYear, 1, 1) To DateSerial(myYear, 12, 31)

            If Weekday(lDay) = vbSunday Then
                For I = 1 To UBound(lKyujitu())
                    '----------日曜日で祝日であること
                    If lKyujitu(I) = lDay Then
                        FLG = True
                        DateBUF = lDay
                    End If
                Next I
            End If

            '----------翌日の判定
            If FLG = True And lDay = DateBUF + 1 Then
                    
                FLG = False
                DateBUF = 0
                '----------祝日のチェック
                For I = 1 To UBound(lKyujitu())
                    If lKyujitu(I) = lDay Then
                        '----------祝休日該当
                        FLG = True
                        DateBUF = lDay
                    End If
                Next I

                '----------祝日に該当しない場合、振替日にする
                If FLG = False Then
                    iCount = iCount + 1
                    ReDim Preserve lHurikae(iCount)
                        lHurikae(iCount) = lDay
                        FLG = False
                        DateBUF = 0
                End If
            End If
        Next lDay

        '----------振り替え休日の判定
        If UBound(lHurikae()) > 0 Then
            For I = 1 To UBound(lHurikae())
                If lHurikae(I) = lDate Then
                    ResWeekNum = 1
                End If
            Next I
        End If
    End If

    '----------国民の休日の判定
    If ResWeekNum <> 1 And myYear > 1987 Then
        '----------値の初期化
        iCount = 0
        For I = 1 To UBound(lKyujitu()) - 1
            For J = I + 1 To UBound(lKyujitu())
                '----------挟まれた日が休日かどうかチェックします
                If Abs(lKyujitu(J) - lKyujitu(I)) = 2 Then
                    FLG = False
                    For k = 1 To iCount
                        If lKyujitu(k) = (lKyujitu(I) + lKyujitu(J)) / 2 Then
                            FLG = True
                        End If
                    Next k
                    '----------挟まれた日が休日でない場合その日を追加登録します
                    If FLG = False Then
                        iCount = iCount + 1
                        ReDim Preserve lKokumin(iCount)
                        lKokumin(iCount) = (lKyujitu(I) + lKyujitu(J)) / 2
                    End If
                End If
            Next J
        Next I

        '----------国民の休日の判定
        If UBound(lKokumin()) > 0 Then
            For I = 1 To UBound(lKokumin())
                If lKokumin(I) = lDate Then
                    ResWeekNum = 1
                End If
            Next I
        End If
    End If

    '----------慣例になっている休日の判定
    If ResWeekNum <> 1 Then
        ReDim Preserve lKanrei(3)
            lKanrei(1) = DateSerial(myYear, 1, 2)
            lKanrei(2) = DateSerial(myYear, 1, 3)
            lKanrei(3) = DateSerial(myYear, 12, 31)

        For I = 1 To UBound(lKanrei())
            If lKanrei(I) = lDate Then
                ResWeekNum = 1
            End If
        Next I
    End If

    Erase lHurikae()
    Erase lKyujitu()
    Erase lKokumin()
    Erase lKanrei()
    
    Kyujitu = ResWeekNum

End Function
'
'-----------------------------------------------------------------
Private Sub UserForm_MouseMove(ByVal Button As Integer, _
                               ByVal Shift As Integer, _
                               ByVal X As Single, _
                               ByVal Y As Single)

    Call CalMousePoint(0)

End Sub
'
'-----------------------------------------------------------------
Private Sub CalMousePoint(ByVal Index As Integer)
Dim I As Integer
Dim J As Integer

    For I = 1 To 6
        For J = 1 To 7
            With Me("lbl" & I & J)
                If (((I - 1) * 7 + J) = Index) Then
                    If (.BackColor = Me.BackColor) Then
                        .BackColor = 16764159
                    End If
                Else
                    If (.BackColor <> Me.BackColor) And _
                       (.SpecialEffect <> fmSpecialEffectBump) Then
                        .BackColor = Me.BackColor
                    End If
                End If
            End With
        Next J
    Next I
    
End Sub

ここまでとします。