Excel シートにShapeカレンダー 3

2022年11月17日

今回の概要

セルを選択するとアイコンが右横に表示されます。

アイコンをクリックするとカレンダーが開きます。
今回は開いた年月のカレンダーが表示されます。
例は、令和4年11月17日に開いたものです。

本日の日にち17をクリックしたものです。
メッセージにクリックした日付が表示されます。

追加修正コード

OpenCalendar

標準モジュールの中でのグローバル変数を追加しています。
OpenCalendar の中に OpenDraw を追加しています。

copy

Option Explicit

Private Enum YobiType
    Shuku = 10
    Kokumin = 11
    Hurikae = 12
    Kanrei = 13
End Enum

Private shpHeight           As Long
Private shpWidth            As Long
Private TBT                 As Long
Private YBT                 As Long
Private DBT(1 To 6)         As Long
Private BL(1 To 7)          As Long

Private Const ColorSunday   As Long = vbRed
Private Const ColorSaturday As Long = vbBlue
Private Const ColorWeekday  As Long = vbBlack
Private Const ColorPreHome  As Long = 5288016

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 HoldDate            As Date
Private HoldYear            As Long
Private HoldMonth           As Long
Private HoldDay             As Long

Private CurDate             As Date
Private CurYear             As Long
Private CurMonth            As Long
Private CurDay              As Long

Private GetYobi             As C_Kyuzitu
Private Const Firstyobi     As Long = vbSunday
Private Yobi                As Variant
Private StartPosi           As Long
Private DaysAndWeeks()      As Long
'---------------------------------------
'
Public Sub OpenCalendar()

    略

    Application.ScreenUpdating = False

    '--------シェイプを作成します。
    Call UpShapes

    '--------カレンダーを描画します。（追加）
    Call OpenDraw

    Application.ScreenUpdating = True

End Sub

UpShapes

日にちの描画の一部を DaysInMonth で行うように修正しています。

copy

'---------------------------------------
'
Private Sub UpShapes()

    略

    '--------日にちを描画します。
    For Row = 1 To 6
        For Col = 1 To 7
            Set SHP = ActiveSheet.Shapes.AddShape(1, BL(Col), _
                                  DBT(Row), shpWidth, shpHeight)
            Grid = Col + (Row - 1) * 7
            With SHP
                .OnAction = "ShapeCalendar.DateClick"
                .Name = "SHPD" & Format(Grid, "00")
                .Fill.ForeColor.RGB = RGB(221, 221, 221)
                With .TextFrame2
                    .MarginTop = 2
                    '--------Text の描画等は DaysInMonth で行います。（削除）
                End With
            End With
            Call ShapeHyozi(SHP)
        Next Col
    Next Row

    略

End Sub

DateClick

日にちシェイプのクリックのアクションを変更しています。

copy

'---------------------------------------
'
Private Sub DateClick()
    Dim Grid                As Long

    'アクションを起こしたシェイプの名前から「SHPD」を取り Grid を取得します。
    Grid = Int(Replace(Application.Caller, "SHPD", ""))

    MsgBox Format(DaysAndWeeks(Grid), "ggge年m月d日")

End Sub

StartValues

追加しています。
アクティブセルから取得した日付をデフォルト値として存続期間中保持し、年・月をインクリメントして表示する日付をカレント日付とします。
カレンダーの作成時のみ実行されます。

copy

'---------------------------------------
'
Private Sub StartValues(ByVal OpenDate As Date)

    CurDate = OpenDate
    CurYear = DatePart(IntvYear, CurDate)
    CurMonth = DatePart(IntvMonth, CurDate)
    CurDay = DatePart(IntvDay, CurDate)

End Sub

DrawYearMonth

追加しています。
カレンダー上部で表示する年と月をセットします。
年・月をインクリメントする度に実行します。

copy

'---------------------------------------
'
Private Sub DrawYearMonth()

    With ActiveSheet.Shapes("SHP_TextYaer").TextFrame2.TextRange
        .Text = Format(DateSerial(CurYear, CurMonth, 1), "ggge年")
    End With
    
    With ActiveSheet.Shapes("SHP_TextMonth").TextFrame2.TextRange
        .Text = Format(DateSerial(CurYear, CurMonth, 1), "m月")
    End With
    
End Sub

DaysDraw

追加しています。
日にちを描画します。
年・月をインクリメントする度に実行します。

copy

'---------------------------------------
'
Private Sub DaysDraw()
    Dim OneDayYobi          As Long
    Dim OneDaySerial        As Long
    Dim I                   As Long

    '--------月の初めの1日のシリアル値を求めます。
    OneDaySerial = DateSerial(CurYear, CurMonth, 1)

    '--------月の初めの1日の曜日の値（1日の位置）を求めます。
    OneDayYobi = Weekday(OneDaySerial, Firstyobi)

    '--------日にちシェイプに対応した配列にシリアル値を格納します。
    For I = 1 To UBound(DaysAndWeeks)
        DaysAndWeeks(I) = OneDaySerial - OneDayYobi + I
    Next I

    '--------年をセットし、休日を求めます。
    GetYobi.NowYear = CurYear

    '--------日付の描写
    Call DaysInMonth

End Sub
'---------------------------------------
'
Private Sub DaysInMonth()
    Dim Row                 As Long
    Dim Col                 As Long
    Dim Grid                As Long
    Dim SpName              As String

    '--------DateCalendarの日付の描写
    For Row = 1 To 6
        For Col = 1 To 7

            '--------Row/Colポジションにあるシェイプの名前を求めます。
            Grid = Col + (Row - 1) * 7
            SpName = "SHPD" & Format(Grid, "00")

            With ActiveSheet.Shapes(SpName).TextFrame2.TextRange

                '--------Grid に対応するシリアル値から日にち部分を求め表示します。
                .Text = DatePart(IntvDay, DaysAndWeeks(Grid))

                '--------対象月以外のフォントを小さくします。
                If DatePart(IntvMonth, DaysAndWeeks(Grid)) <> CurMonth Then
                    .Font.Size = 8
                Else
                    .Font.Size = 10
                End If

                '--------休日の赤色表示処理
                GetYobi.SetNumDate = DaysAndWeeks(Grid)
                Select Case GetYobi.WeekNum
                Case 1, Shuku, Kokumin, Kanrei, Hurikae
                    .Font.Fill.ForeColor.RGB = ColorSunday
                Case 7
                    .Font.Fill.ForeColor.RGB = ColorSaturday
                Case Else
                    .Font.Fill.ForeColor.RGB = ColorWeekday
                End Select

            End With

        Next Col
    Next Row

End Sub

DeleteCal

休日クラスの参照を破棄するコードを追加しています。

copy

'---------------------------------------
'
Public Sub DeleteCal()

    略

    '-----シェイプの一括削除のため一括選択
    ReDim Preserve SHP(1 To iCount)
    Set objRange = ActiveSheet.Shapes.Range(SHP)
    objRange.Select

    '-----休日クラスの参照を破棄します。（追加）
    If Not GetYobi Is Nothing Then
        Set GetYobi = Nothing
    End If

    '----一括削除の実行
    objRange.Delete

End Sub