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

2022年11月14日

目的の機能

セルを選択するとそのセルの右横にアイコンを表示します。

アイコンをクリックすると Shape で作成したカレンダーが開きます。

カレンダーの日にちをクリックすると、カレンダーを呼び出したセルに日にちがセットされます。

セルを選択すると Icon を表示

今回は、セルを選択するとアイコンを表示して、そのアイコンをクリックするとメッセージが表示されるところまでとします。

シートのモジュール

すべてのセルを対象にするのではなく、書式で日付のフォーマットが推測されるセルのみとします。
そのセルが選択されたなら、プロシージャ DispCalendarIcon を実行します。

copy

Option Explicit
'---------------------------------------
'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim DateFormats             As Variant
Dim DateFormat              As Variant

    DateFormats = Array("yyyy/mm/dd", "yy/m/d", "yy/mm/dd", _
                        "d""日""", "dd""日""", "d/m/yyyy", _
                        "dd/mm/yyyy", "ggge", "ge")

    Call DeleteCal

    For Each DateFormat In DateFormats
        If InStr(Target.NumberFormatLocal, DateFormat) > 0 Then
            Call DispCalendarIcon
            Exit For
        End If
    Next
    
End Sub

例では、アイコンを APPTS.ICO としていますが、1041の中から気に入ったものを選べばいいでしょう。
名前は、SHPが付く名称にしてください。プロシージャ DeleteCal で削除対象にします。
アイコンをクリックしたときの動作は OnAction に登録します。この例では、標準モジュール ShapeCalendar の中にある OpenCalendar を指定しています。

copy

'---------------------------------------
'
Private Sub DispCalendarIcon()
    Dim SHP                 As Object

    Set SHP = ActiveSheet.Pictures. _
            Insert(Application.Path & "\FORMS\1041\APPTS.ICO")

    With SHP
        '-----アクティブセルの1つ右のセル
        .Left = ActiveCell.Offset(0, 1).Left + 5
        .Top = ActiveCell.Offset(0, 1).Top + 2
        '-----名前
        .Name = "SHPIcon"
        '-----クリックしたときの動作
        .OnAction = "ShapeCalendar.OpenCalendar"
        .PrintObject = msoFalse
        .Placement = xlMove
        .Locked = msoTrue
    End With

End Sub

標準モジュール ShapeCalendar

標準モジュールを挿入して、このオブジェクト名を ShapeCalendar とします。

アイコンをクリックしたとき実行されるプロシージャを作成します。名前を OpenCalendar とします。
最終的には、MasBox のところにカレンダーを作成する処理を書きます。

copy

Option Explicit
'---------------------------------------
'
Public Sub OpenCalendar()

    MsgBox "アイコンをクリックした。"

End Sub

Shape で作成するカレンダーは、Shape を60個ほど作成します。これらを削除するときに実行します。
また、アイコンを削除するときにも実行します。
そして、名前に SHP がつくもののみ削除の対象とします。

copy

'---------------------------------------
'
Public Sub DeleteCal()
    Dim SHP()               As String
    Dim Sp                  As Shape
    Dim objRange            As Object
    Dim iCount              As Long
    Dim I                   As Long

    '-----シェイプがなければ終了
    If ActiveSheet.Shapes.Count = 0 Then
        Exit Sub
    End If
    
    '-----名称がSHPから始まるシェイプの拾い上げ
    ReDim SHP(1 To ActiveSheet.Shapes.Count)
    iCount = 0
    For Each Sp In ActiveSheet.Shapes
        If InStr(1, Sp.Name, "SHP") > 0 Then
            iCount = iCount + 1
            SHP(iCount) = Sp.Name
        End If
    Next Sp
    
    '-----なければ終わり
    If iCount = 0 Then
        Exit Sub
    End If
    
    '-----シェイプの一括削除のため一括選択
    ReDim Preserve SHP(1 To iCount)
    Set objRange = ActiveSheet.Shapes.Range(SHP)
    objRange.Select

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

End Sub