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

2022年11月16日

今回はカレンダーの外形とシェイプをクリックしたときの動作までとします。

今回の概要

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

アイコンをクリックするとカレンダーの外形が開きます。

シェイプをクリックするとシェイプの名前がメッセージに表示されます。
この例では、「25」のシェイプをクリックしました。

コード

標準モジュールの中のグローバル変数と OpenCalendar

1ブロックを縦15 横35 として図形を構成します。

copy

Option Explicit

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 Firstyobi         As Long = vbSunday
Private Yobi                    As Variant
'---------------------------------------
'
Public Sub OpenCalendar()
    Dim I                   As Long
    Dim J                   As Long

    '--------新しくカレンダーを開く前に既存を抹消します。
    Call DeleteCal

    Yobi = Array("", "日", "月", "火", "水", "木", "金", "土")

    '--------シェイプ1ブロックの大きさです。
    shpHeight = 15
    shpWidth = 35

    '--------カレンダーの最も上の位置です。
    TBT = ActiveCell.Offset(0, 1).Top

    '--------カレンダーの1列目の左の位置です
    BL(1) = ActiveCell.Offset(0, 1).Left

    '--------曜日のトップの位置です。
    YBT = TBT + shpHeight

    '--------日付の1段目の位置です。
    DBT(1) = YBT + shpHeight

    '--------2段目以降の位置です
    For I = 2 To 6
        DBT(I) = DBT(I - 1) + shpHeight
    Next I

    '--------日付の2列以降の左端の位置です。
    For J = 2 To 7
        BL(J) = BL(J - 1) + shpWidth
    Next J

    Application.ScreenUpdating = False

    '--------シェイプを作成します。
    Call UpShapes
    
    Application.ScreenUpdating = True

End Sub

図で示すと次のようになります。

シェイプを描画 UpShapes

ただひたすらシェイプを書きます。
難しいところはなく腕力のみです。

copy

'---------------------------------------
'
Private Sub UpShapes()
    Dim SHP                     As Shape
    Dim Row                     As Long
    Dim Col                     As Long
    Dim intLogicalDay           As Long
    Dim Grid                    As Long

    '--------
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(1), _
                                 TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_PreviousYear"
        .OnAction = "ShapeCalendar.PreviousYearClick"
        .Fill.ForeColor.RGB = RGB(252, 213, 181)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = "▼"
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(2), _
                                 TBT, shpWidth * 2, shpHeight)
    With SHP
        .Name = "SHP_TextYaer"
        .OnAction = "ShapeCalendar.Dummy"
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = ""
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(4), _
                                 TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_NextYear"
        .OnAction = "ShapeCalendar.NextYearClick"
        .Fill.ForeColor.RGB = RGB(146, 246, 166)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = "▲"
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(5), _
                                 TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_PreviousMonth"
        .OnAction = "ShapeCalendar.PreviousMonthClick"
        .Fill.ForeColor.RGB = RGB(252, 213, 181)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = "▼"
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(6), _
                                 TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_TextMonth"
        .OnAction = "ShapeCalendar.Dummy"
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = ""
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(7), _
                                 TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_NextMonth"
        .OnAction = "ShapeCalendar.NextMonthClick"
        .Fill.ForeColor.RGB = RGB(146, 246, 166)
        With .TextFrame2
            .MarginTop = 0
            With .TextRange
                .Text = "▲"
                .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    '--------
    For Col = 1 To 7
        intLogicalDay = (((Col - 1) + (Firstyobi - 1)) Mod 7) + 1
        Set SHP = ActiveSheet.Shapes.AddShape(1, BL(Col), _
                                     YBT, shpWidth, shpHeight)
        With SHP
            .Name = "SHPY" & Format(Col, "00")
            .OnAction = "ShapeCalendar.Dummy"
            .Fill.ForeColor.RGB = RGB(221, 221, 221)
            With .TextFrame2
                .MarginTop = 0
                With .TextRange
                    .Text = Yobi(intLogicalDay)
                    .Font.Size = 10
                    If intLogicalDay = 1 Then
                        .Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
                    ElseIf intLogicalDay = 7 Then
                        .Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
                    Else
                        .Font.Fill.ForeColor.RGB = ColorWeekday
                    End If
                End With
            End With
        End With
        Call ShapeHyozi(SHP)
    Next Col

    '--------
    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
                    With .TextRange
                        .Text = Grid
                        .Font.Fill.ForeColor.RGB = ColorWeekday
                        .Font.Size = 10
                    End With
                End With
            End With
            Call ShapeHyozi(SHP)
        Next Col
    Next Row

    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(1), _
                          DBT(6) + shpHeight, shpWidth * 2, shpHeight)
    With SHP
        .Name = "SHP_HOME"
        .OnAction = "ShapeCalendar.GoHome"
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
        With .TextFrame2
            .MarginTop = 1
            With .TextRange
                .Text = "HOME"
                .Font.Fill.ForeColor.RGB = ColorSaturday
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(3), _
                          DBT(6) + shpHeight, shpWidth * 2, shpHeight)
    With SHP
        .Name = "SHP_PREHOME"
        .OnAction = "ShapeCalendar.GoPreHome"
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
        With .TextFrame2
            .MarginTop = 1
            With .TextRange
                .Text = "preHOME"
                .Font.Fill.ForeColor.RGB = ColorPreHome
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)

    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(5), _
                          DBT(6) + shpHeight, shpWidth * 3, shpHeight)
    With SHP
        .Name = "SHP_CANCEL"
        .OnAction = "ShapeCalendar.DeleteCal"
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
        With .TextFrame2
            .MarginTop = 1
            With .TextRange
                .Text = "CANCEL"
                .Font.Fill.ForeColor.RGB = ColorSunday
                .Font.Size = 10
            End With
        End With
    End With
    Call ShapeHyozi(SHP)

End Sub
'---------------------------------------
'
Private Sub ShapeHyozi(ByRef myShape As Shape)

    With myShape
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = RGB(166, 166, 166)
        .Line.Weight = 0.5
        .Fill.Visible = msoTrue
        .Fill.Solid
        .Placement = xlFreeFloating
        .Locked = msoTrue
        With .TextFrame2
            .HorizontalAnchor = msoAnchorCenter
            With .TextRange
                .ParagraphFormat.Alignment = msoAlignCenter
            End With
        End With
    End With
    
End Sub

登録するアクション群

今回のアクションは、クリックしたシェイプの名前をメッセージで表示することにしました。
シェイプはコントロールのようなイベントを持っていないので、最初これをどうやっていいのか全く分かりませんでした。

調べて行き着いたところが、Application.Caller でした。

copy

'---------------------------------------
'
Private Sub NextYearClick()

    MsgBox Application.Caller

End Sub
'---------------------------------------
'
Private Sub PreviousYearClick()

    MsgBox Application.Caller

End Sub
'---------------------------------------
'
Private Sub NextMonthClick()

    MsgBox Application.Caller

End Sub
'---------------------------------------
'
Private Sub PreviousMonthClick()

    MsgBox Application.Caller

End Sub
'---------------------------------------
'
Private Sub DateClick()

    MsgBox Application.Caller

End Sub
'---------------------------------------
'
Private Sub GoHome()

    MsgBox Application.Caller

End Sub
'---------------------------------------
'
Private Sub GoPreHome()

    MsgBox Application.Caller

End Sub
'---------------------------------------
'
Private Sub Dummy()

    MsgBox Application.Caller

End Sub