Sibainu Relax Room

柴犬と過ごす

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

柴犬はイルミネーションの中にいます。

今回の概要

セルを選択します。

カレンダーが開きます。
空のセルですので初期値はこの日にちが黄色で表示されます。

クリックして22日を選択しました。
続けて22日をクリックします。

選択した日付がセルにセットされました。

22日をクリックする前に移り、25日のしたの小さい字の２（12月2日）をクリックしてみます。
直ちに12月のカレンダーが表示され2日が選択された表示になっています。
想定した動作となっています。

追加修正コード

OpenCalendar

インクリメントの列挙型の追加と、選択したシェイプの名前を登録する変数を追加しています。

copy

    略

    Kanrei = 13
End Enum

'--------追加します。
Private Enum IncFlg
    IncForward = 0
    IncBackward = -1
End Enum

Private shpHeight           As Long
Private shpWidth            As Long

    略

Private StartPosi           As Long
Private DaysAndWeeks()      As Long

'--------追加します。
Private SelectShape         As String

アクション群

全面的に書き直しています。

copy

'---------------------------------------
'
Private Sub NextYearClick()
    Call NextYear
End Sub
'---------------------------------------
'
Private Sub PreviousYearClick()
    Call PreviousYear
End Sub
'---------------------------------------
'
Private Sub NextMonthClick()
    Call NextMonth
End Sub
'---------------------------------------
'
Private Sub PreviousMonthClick()
    Call PreviousMonth
End Sub
'---------------------------------------
'
Public Sub NextYear()
    Call IncChageDraw(IntvYear, IncForward)
End Sub
'---------------------------------------
'
Public Sub PreviousYear()
    Call IncChageDraw(IntvYear, IncBackward)
End Sub
'---------------------------------------
'
Public Sub NextMonth()
    Call IncChageDraw(IntvMonth, IncForward)
End Sub
'---------------------------------------
'
Public Sub PreviousMonth()
    Call IncChageDraw(IntvMonth, IncBackward)
End Sub
'---------------------------------------
'
Private Sub GoHome()
    Call MoveToToday(UseCurYear:=True)
End Sub
'---------------------------------------
'
Private Sub GoPreHome()
    Call MoveToToday(UseCurYear:=False)
End Sub

IncChageDraw

インクリメントしたときの動作を書きます。

copy

'---------------------------------------
'
Private Sub IncChageDraw(ByVal intvMove As String, _
                         ByVal DT As IncFlg)
    Dim IncDate             As Date
    Dim iInc                As Long
    Dim Grid                As Long

    '--------インクリメントの方向を決めます。
    If DT = IncForward Then
        iInc = 1
    Else
        iInc = -1
    End If

    '--------インクリメントした日付を求めます。
    IncDate = DateAdd(intvMove, iInc, CurDate)

    '--------表示年月日（CurDate/CurDay..）をセットします。
    Call StartValues(IncDate)

    '--------年と月を表示します。
    Call DrawYearMonth

    '--------日にちを描画します。
    '        DaysAndWeeks の更新が必要
    Call DaysDraw

    '--------黄色を戻します。
    With ActiveSheet.Shapes(SelectShape)
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
    End With

    '--------日にち（CurDay）を黄色に塗ります。
    Call YellowPaint

End Sub

MoveToToday

HOME はオープン時の日にちに戻し、PreHOME 表示する年は変えず月と日をオープン時に戻します。

copy

'---------------------------------------
'
Private Sub MoveToToday(UseCurYear As Boolean)

    '--------戻る日付を求めます。
    If UseCurYear Then
        CurYear = HoldYear
    End If
    CurMonth = HoldMonth
    CurDay = HoldDay
    CurDate = DateSerial(CurYear, CurMonth, CurDay)

    '--------年と月を表示します。
    Call DrawYearMonth

    '--------日にちを描画します。
    '        DaysAndWeeks の更新が必要
    Call DaysDraw

    '--------黄色を戻します。
    With ActiveSheet.Shapes(SelectShape)
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
    End With

    '--------日にち（CurDay）を黄色に塗ります。
    Call YellwPaint

End Sub

DateClick

DateClick を書き直し、DateClickShape を追加します。
初回選択で選択したシェイプを黄色に塗り、続けて2回目のクリックで決定としアクティブセルに日付をセットします。

copy

'---------------------------------------
'
Private Sub DateClick()
    Dim myCaller            As String

    '--------マクロを呼び出したオブジェクトの名前
    myCaller = Application.Caller
   
    '--------シェイプにテキストデータがない
    If Len(ActiveSheet.Shapes(myCaller).TextFrame2.TextRange.Text) = 0 Then
        Exit Sub
    End If

    '--------2回連続でクリックされた場合、決定しアクティブセルに日付をセットします。
    If (SelectShape = myCaller) Then
        ActiveCell.Value = CurDate
        Call DeleteCal

    '--------新しい選択のシェイプを描画します。
    Else
        Call DateClickShape(myCaller)
    End If
 
End Sub
'---------------------------------------
'
Private Sub DateClickShape(NewSelect As String)
    Dim Grid                As Long

    '--------シェイプの名前から Grid を求めます。
    Grid = Replace(NewSelect, "SHPD", "")

    '--------シェイプが属する月と表示する月が異なる場合
    If CurMonth <> DatePart(IntvMonth, DaysAndWeeks(Grid)) Then

        '--------表示年月日（CurDate/CurDay..）をセットします。
        Call StartValues(DaysAndWeeks(Grid))

        '--------年と月を表示します。
        Call DrawYearMonth

        '--------日にちを描画します。
        '        DaysAndWeeks の更新が必要
        Call DaysDraw

    Else

        '--------一部の更新します。
        CurDate = DaysAndWeeks(Grid)
        CurDay = DatePart(IntvDay, CurDate)

    End If

    '--------黄色を戻します。
    With ActiveSheet.Shapes(SelectShape)
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
    End With

    '--------日にち（CurDay）を黄色に塗ります。
    Call YellowPaint

End Sub

OpenDraw

オープン時の初期日にちを黄色に塗ります。

copy

'---------------------------------------
'
Private Sub OpenDraw()

    略

    '--------日にちを描画します。
    Call DaysDraw

    '--------日にち（CurDay）を黄色に塗ります。（追加）
    Call YellowPaint

End Sub

YellowPaint

新しく追加します。
選択された日にち（シェイプ）からシェイプの名前を求め黄色に塗ります。

copy

'---------------------------------------
'
Private Sub YellowPaint()
    Dim Grid                As Long
    Dim SpName              As String

    '--------選択されたシェイプの名前を求めます。
    Grid = StartPosi + CurDay - 1
    SpName = "SHPD" & Format(Grid, "00")

    '--------選択シェイプに登録します。
    SelectShape = SpName

    With ActiveSheet.Shapes(SpName)
        '--------黄色にします。
        .Fill.ForeColor.RGB = RGB(255, 255, 0)
    End With

End Sub