SHAPE CALENDAR

全コード

COPY

Option Explicit
'---------------------------------------
Dim shpHeight           As Long
Dim shpWidth            As Long
Dim TBT                 As Long
Dim YBT                 As Long
Dim DBT(1 To 6)         As Long
Dim BL(1 To 7)          As Long
 
Private Const ColorSunday = vbRed
Private Const ColorSaturday = vbBlue
Private Const ColorWeekday = vbBlack
Private Const ColorPreHome = 5288016
 
Private Enum IncFlg
    IncForward = 0
    IncBackward = -1
End Enum
 
Private Const FirstYobi = vbSunday
Private Const DayStr    As String = "d"
Private Const MonthStr  As String = "m"
Private Const YearStr   As String = "yyyy"
Private Const WeekStr   As String = "ww"
 
Private StartPosi       As Integer
Private MonthLen        As Variant
Private Yobi(1 To 7)    As Variant
 
Private DefYear         As Integer
Private DefMonth        As Integer
Private DefDay          As Integer
 
Private CurDate         As Date
Private CurYear         As Integer
Private CurMonth        As Integer
Private CurDay          As Integer
 
Private DefFirstYobi    As Integer
Private SelectShape      As String
 
'---------------------------------------
Public Sub OpenCalendar()
    Dim I               As Integer
    Dim J               As Long
    Dim BUF             As String
  
    Call DeleteCal
    
    '--------月の日数の配列　0はダミー値
    MonthLen = Array(0, 31, 28, 31, 30, 31, 30, _
        31, 31, 30, 31, 30, 31)
    
    '--------最初に来る曜日を日曜日に指定
    DefFirstYobi = FirstYobi
    For J = 1 To 7
        Yobi(J) = Left$(WeekdayName(J, FirstDayOfWeek:=DefFirstYobi), 1)
    Next J
 
    shpHeight = 15
    shpWidth = 35
    
    TBT = ActiveCell.OffSet(0, 1).Top
    BL(1) = ActiveCell.OffSet(0, 1).Left
 
    YBT = TBT + shpHeight
    
    DBT(1) = YBT + shpHeight
    For I = 2 To 6
        DBT(I) = DBT(I - 1) + shpHeight
    Next I
   
    For J = 2 To 7
        BL(J) = BL(J - 1) + shpWidth
    Next J
 
    Application.ScreenUpdating = False
 
    BUF = Replace(StrConv(ActiveCell.Value, vbNarrow), ".", "/")
    If IsDate(BUF) Then
        BUF = CDate(BUF)
    Else
        BUF = Date
    End If
    
    '--------年月日の要素を取り出す
    DefDay = DatePart(DayStr, BUF)
    DefMonth = DatePart(MonthStr, BUF)
    DefYear = DatePart(YearStr, BUF)
 
    Call UpShapes
    Call StartValues(BUF)
    Call CalendarDisp
 
    Application.ScreenUpdating = True
 
End Sub
 
'---------------------------------------
Private Sub UpShapes()
    Dim SHP             As Shape
    Dim I               As Integer
    Dim J               As Integer
    Dim intLogicalDay   As Integer
 
    '--------
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(1), _
        TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_PreviousYear"
        .OnAction = "ShapeCalendar.PreviousYearClick"
        .TextFrame.Characters.Text = "▼"
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
        .Fill.ForeColor.RGB = RGB(252, 213, 181)
    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"
        .TextFrame.Characters.Text = ""
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(4), _
        TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_NextYear"
        .OnAction = "ShapeCalendar.NextYearClick"
        .TextFrame.Characters.Text = "▲"
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
        .Fill.ForeColor.RGB = RGB(146, 246, 166)
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(5), _
        TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_PreviousMonth"
        .OnAction = "ShapeCalendar.PreviousMonthClick"
        .TextFrame.Characters.Text = "▼"
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
        .Fill.ForeColor.RGB = RGB(252, 213, 181)
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(6), TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_TextMonth"
        .OnAction = "ShapeCalendar.Dummy"
        .TextFrame.Characters.Text = ""
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
        .Fill.ForeColor.RGB = RGB(221, 221, 221)
    End With
    Call ShapeHyozi(SHP)
    
    Set SHP = ActiveSheet.Shapes.AddShape(1, BL(7), _
        TBT, shpWidth, shpHeight)
    With SHP
        .Name = "SHP_NextMonth"
        .OnAction = "ShapeCalendar.NextMonthClick"
        .TextFrame.Characters.Text = "▲"
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
        .Fill.ForeColor.RGB = RGB(146, 246, 166)
    End With
    Call ShapeHyozi(SHP)
    
    '--------
    For J = 1 To 7
        intLogicalDay = (((J - 1) + (DefFirstYobi - 1)) Mod 7) + 1
        Set SHP = ActiveSheet.Shapes.AddShape(1, BL(J), _
            YBT, shpWidth, shpHeight)
        With SHP
            .Name = "SHPY" & Format(J, "00")
            .OnAction = "ShapeCalendar.Dummy"
            .Fill.ForeColor.RGB = RGB(221, 221, 221)
            If ((intLogicalDay - 1) Mod 7) = 0 Then
                .TextFrame.Characters.Text = Yobi(intLogicalDay)
                .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
            ElseIf ((intLogicalDay - 1) Mod 7) = 6 Then
                .TextFrame.Characters.Text = Yobi(intLogicalDay)
                .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
            Else
                .TextFrame.Characters.Text = Yobi(intLogicalDay)
                .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = ColorWeekday
            End If
        End With
        Call ShapeHyozi(SHP)
    Next J
 
    '--------
    For I = 1 To 6
        For J = 1 To 7
            Set SHP = ActiveSheet.Shapes.AddShape(1, BL(J), _
                DBT(I), shpWidth, shpHeight)
            With SHP
                .OnAction = "ShapeCalendar.DateClick"
                .Name = "SHPD" & I & J
                .TextFrame.Characters.Text = CStr((I - 1) * 7 + J)
                .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = ColorWeekday
                .Fill.ForeColor.RGB = RGB(221, 221, 221)
            End With
            Call ShapeHyozi(SHP)
        Next J
    Next I
 
    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)
        .TextFrame.Characters.Text = "HOME"
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = ColorSaturday
    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)
        .TextFrame.Characters.Text = "preHOME"
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = ColorPreHome
    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)
        .TextFrame.Characters.Text = "CANCEL"
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = ColorSunday
    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
        .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .TextFrame2.TextRange.Font.Size = 10
        .Placement = xlFreeFloating
        .Locked = msoTrue
    End With
    
End Sub
 
'---------------------------------------
Private Sub StartValues(ByVal OpenDate As Date)
 
    CurDate = OpenDate
 
    CurYear = DatePart(YearStr, CurDate)
    CurMonth = DatePart(MonthStr, CurDate)
    CurDay = DatePart(DayStr, CurDate)
    
    Call DispYearMonth
    
End Sub
 
'---------------------------------------
Private Sub DispYearMonth()
 
    With ActiveSheet.Shapes("SHP_TextYaer").DrawingObject
        .Caption = Format(DateSerial(CurYear, CurMonth, 1), "ggge年")
    End With
    
    With ActiveSheet.Shapes("SHP_TextMonth").DrawingObject
        .Caption = Format(DateSerial(CurYear, CurMonth, 1), "m月")
    End With
    
End Sub
 
'---------------------------------------
Private Sub DateClick()
    Dim strN            As String
    Dim FLG             As Boolean
    
    '-----マクロを呼び出したオブジェクトの名前
    strN = Application.Caller
   
    '-----シェイプにテキストデータがない
    If Len(ActiveSheet.Shapes(strN).TextFrame.Characters.Text) = 0 Then
        Exit Sub
    End If
    
    '-----2回連続でクリックされた場合、Tureで新たに押された場合Falseになる
    FLG = (SelectShape = strN)
    
    Call ClickShape(strN)
    
    '-----2回連続でクリックされた場合
    If FLG Then
        ActiveCell.Value = DateSerial(CurYear, CurMonth, CurDay)
        Call DeleteCal
    End If
 
End Sub
 
'---------------------------------------
Public Sub DeleteCal()
    Dim SHP()           As String
    Dim Sp              As Shape
    Dim objRange        As Object
    Dim iCount          As Long
    Dim I               As Integer
    
    '-----シェイプがなければ終了
    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
    
    '-----削除のためシート保護の解除
    ActiveSheet.Unprotect
    
    '----一括削除の実行
    objRange.Delete
 
End Sub
 
'---------------------------------------
Private Sub GoHome()
    Call MoveToToday(UseCurYear:=True)
End Sub
 
'---------------------------------------
Private Sub GoPreHome()
    Call MoveToToday(UseCurYear:=False)
End Sub
 
'---------------------------------------
Private Sub Dummy()
 
End Sub
 
'---------------------------------------DateCalendarの日付の描写
Private Sub CalendarDisp()
    Dim newSelected     As String
    Dim TsuBan          As Integer
    
    '--------1日の週日
    StartPosi = DatePart("w", _
        DateSerial(CurYear, CurMonth, 1), DefFirstYobi)
    
    '--------DateCalendarの日付の描写
    Call DaysInMonth(StartPosi)
    
    '--------選択された
    newSelected = "SHPD" & Grid(CurDay, StartPosi)
    Call ClickShape(newSelected)
 
End Sub
 
'---------------------------------------
Private Function Grid(intDay As Integer, _
                      intStart As Integer) As String
    Dim TsuBan          As Integer
    Dim Res             As String
 
    TsuBan = intDay + intStart - 1
 
    Res = CStr(((TsuBan - 1) \ 7) + 1) & CStr((TsuBan - 1) Mod 7 + 1)
    Grid = Res
 
End Function
 
'---------------------------------------
Private Sub DaysInMonth(intStartDay As Integer)
    Dim intRow              As Integer
    Dim intCol              As Integer
    Dim intDays             As Integer
    Dim intCount            As Integer
    Dim strTemp             As String
    Dim lngForeColor        As Long
 
    If CurMonth <> 2 Then
        '--------2月以外の場合
        intDays = MonthLen(CurMonth)
    Else
        '-------2月の場合(3月1日の1日前)
        intDays = DatePart(DayStr, DateSerial(CurYear, 3, 1) - 1)
    End If
    
    '--------月、年を更新した場合、1/31⇒2/28等の処理
    If CurDay > intDays Then
        CurDay = intDays
    End If
    
    '--------DateCalendarの日付の描写
    intCount = 0
    For intRow = 1 To 6
        For intCol = 1 To 7
            If (intRow = 1) And (intCol < intStartDay) Then
                ActiveSheet.Shapes("SHPD1" & intCol).TextFrame.Characters.Text = ""
            Else
                intCount = intCount + 1
                strTemp = "SHPD" & intRow & intCol
                With ActiveSheet.Shapes(strTemp)
                    If intCount <= intDays Then
                        .TextFrame.Characters.Text = intCount
                        '追加--------休日の赤色表示処理
                        Select Case Kyujitu(DateSerial(CurYear, CurMonth, intCount))
                        Case 1
                            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = ColorSunday
                        Case 7
                            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = ColorSaturday
                        Case Else
                            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = ColorWeekday
                        End Select
                    Else
                        .TextFrame.Characters.Text = ""
                    End If
                End With
            End If
        Next intCol
    Next intRow
 
End Sub
 
'---------------------------------------
Private Function HandleSelected(strName As String)
    Call ClickShape(strName)
End Function
 
'---------------------------------------
Private Sub ClickShape(NewSelect As String)
 
    If Len(SelectShape) > 0 Then
        If SelectShape <> NewSelect Then
            With ActiveSheet.Shapes(SelectShape)
                .Fill.ForeColor.RGB = RGB(221, 221, 221)
            End With
            SelectShape = NewSelect
        End If
    Else
        SelectShape = NewSelect
    End If
 
    With ActiveSheet.Shapes(SelectShape)
        .Fill.ForeColor.RGB = RGB(255, 255, 0)
        CurDay = .TextFrame.Characters.Text
    End With
 
End Sub
 
'---------------------------------------
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 Today()
    Call MoveToToday(UseCurYear:=True)
End Sub
 
Public Sub NextMonth()
    Call ChageCalendar(MonthStr, IncForward)
End Sub
 
Public Sub NextYear()
    Call ChageCalendar(YearStr, IncForward)
End Sub
 
Public Sub PreviousMonth()
    Call ChageCalendar(MonthStr, IncBackward)
End Sub
 
Public Sub PreviousYear()
    Call ChageCalendar(YearStr, IncBackward)
End Sub
'---------------------------------------
Private Sub ChageCalendar(strMoveUnit As String, dt As IncFlg)
    Dim iMonth          As Integer
    Dim iYear           As Integer
    Dim iDay            As Integer
    Dim INCDate         As Date
    Dim OldDate         As Date
    Dim iInc            As Integer
 
    iYear = CurYear
    iMonth = CurMonth
    iDay = CurDay
 
    If dt = IncForward Then
        iInc = 1
    Else
        iInc = -1
    End If
    OldDate = DateSerial(iYear, iMonth, iDay)
    INCDate = DateAdd(strMoveUnit, iInc, OldDate)
 
    iMonth = DatePart(MonthStr, INCDate)
    iYear = DatePart(YearStr, INCDate)
    iDay = DatePart(DayStr, INCDate)
 
    If CurMonth = iMonth And CurYear = iYear Then
        Call ClickShape("SHPD" & Grid(iDay, StartPosi))
    Else
        CurDay = iDay
        CurMonth = iMonth
        CurYear = iYear
        
        Call DispYearMonth
        Call CalendarDisp
    End If
 
End Sub
 
'---------------------------------------
Private Sub MoveToToday(UseCurYear As Boolean)
 
    CurMonth = DefMonth
    If UseCurYear Then
        CurYear = DefYear
    End If
    
    CurDay = DefDay
    
    Call DispYearMonth
    Call CalendarDisp
    
End Sub

ワークシートの仕込み

セルの選択した時アイコンを表示します。

COPY

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim weekz           As Variant
Dim wz              As Variant
  
    Call DeleteCal
 
    weekz = Array("yyyy/mm/dd", "yy/m/d", "yy/mm/dd", "d""日""", "dd""日""", "d/m/yyyy", "dd/mm/yyyy", "ggge", "ge")
    For Each wz In weekz
        If InStr(Cells(Target.Row, Target.Column).NumberFormatLocal, wz) > 0 Then
            Call DispCalendarIcon
            Exit For
        End If
    Next
    
End Sub
 
Private Sub DispCalendarIcon()
Dim SHP             As Object
 
    Set SHP = ActiveSheet.Pictures. _
            Insert(Application.Path & "\FORMS\1041\APPTS.ICO")
    With SHP
        .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

セルをダブルクリックした時

カレンダーを表示

COPY

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Call ShapeCalendar.OpenCalendar
End Sub

祝日休日を判定する関数

COPY

Private Function Kyujitu(lDate As Long) As Integer
    Dim CurYear         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
 
    CurYear = 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(CurYear, 1, 1)
            
        '②成人の日　１月１５日　→　１月の第２月曜
        If CurYear > 1949 And CurYear < 2000 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 1, 15)
        ElseIf CurYear > 1999 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 1, 8) + ((9 - Weekday(DateSerial(CurYear, 1, 8))) Mod 7)
        End If
        
        '③建国記念の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 2, 11)
 
        '④春分の日
        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 CurYear
            Case Is < 2100
                DateBUF = Int(20.8431 + 0.242194 * (CurYear - 1980) - Int((CurYear - 1980) / 4))
            Case Is >= 2100
                DateBUF = Int(20.851 + 0.242194 * (CurYear - 1980) - Int((CurYear - 1980) / 4))
            End Select
            lKyujitu(iCount) = DateSerial(CurYear, 3, DateBUF)
 
        '⑤天皇誕生日→みどりの日→昭和の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 4, 29)
 
        '⑥憲法記念日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 5, 3)
 
        '⑦みどりの日
        If CurYear > 2006 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 5, 4)
        End If
 
        '⑧こどもの日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 5, 5)
 
        '⑨海の日　７月２０日　→　７月の第３月曜日
        If CurYear > 1995 And CurYear < 2003 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 7, 20)
        ElseIf CurYear > 2002 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 7, 15) + ((9 - Weekday(DateSerial(CurYear, 7, 15))) Mod 7)
        End If
 
        '⑪山の日
        If CurYear > 2015 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 8, 11)
        End If
 
        '⑫敬老の日　９月１５日　→　９月の第３月曜日
        If CurYear > 1965 And CurYear < 2003 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 9, 15)
        ElseIf CurYear > 2002 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 9, 15) + ((9 - Weekday(DateSerial(CurYear, 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 CurYear
            Case Is < 2100
                DateBUF = Int(23.2488 + 0.242194 * (CurYear - 1980) - Int((CurYear - 1980) / 4))
            Case Is >= 2100
                DateBUF = Int(24.2488 + 0.242194 * (CurYear - 1980) - Int((CurYear - 1980) / 4))
            End Select
            lKyujitu(iCount) = DateSerial(CurYear, 9, DateBUF)
            
        If CurYear > 1965 And CurYear < 2000 Then  '----------体育の日　１０月１０日　→　１０月の第二月曜日
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 10, 10)
        ElseIf CurYear > 1999 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 10, 8) + ((9 - Weekday(DateSerial(CurYear, 10, 8))) Mod 7)
        End If
 
        '⑭文化の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 11, 3)
 
        '⑮勤労感謝の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(CurYear, 11, 23)
 
        '⑯天皇誕生日
        If CurYear > 1988 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
                lKyujitu(iCount) = DateSerial(CurYear, 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 CurYear > 1972 Then
        '----------値の初期化
        iCount = 0
        FLG = False
        DateBUF = 0
        For lDay = DateSerial(CurYear, 1, 1) To DateSerial(CurYear, 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 CurYear > 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(CurYear, 1, 2)
            lKanrei(2) = DateSerial(CurYear, 1, 3)
            lKanrei(3) = DateSerial(CurYear, 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

Shapeの再帰処理

COPY

Public EndFlg    As Boolean
 
Public Sub ShapeAct(ByVal Flg As String, ByRef Sh As Worksheet)
    Dim SP As Shape
 
    EndFlg = False
    For Each SP In Sh.Shapes
        Call ShapeAct2(SP, Flg)
    Next SP
 
End Sub
 
Private Sub ShapeAct2(ByRef SP As Shape, ByVal Flg As String)
    Dim SP2 As Shape
 
    If EndFlg Then
        Exit Sub
    End If
 
    Select Case SP.Type
    Case msoGroup
 
        For Each SP2 In SP.GroupItems
            Call ShapeAct2(SP2, Flg)
        Next SP2
 
    Case msoOLEControlObject
 
        With SP.OLEFormat
            If TypeName(.Object.Object) = "CommadButton" Then
                With .Object.Object
                    If .Caption = "編集" Then
 
                        EndFlg = True
 
                        Select Case Flg
                        Case "AA"
                            If .ForeColor = RGB(0, 0, 255) Then
                                .ForeColor = RGB(255, 0, 0)
                                Call DeleteShape(SP.Parent)
                            End If
                        Case "BB"
                            If .ForeColor = RGB(0, 0, 255) Then
                                .ForeColor = RGB(255, 0, 0)
                                Call DeleteShape(SP.Parent)
                            Else
                                .ForeColor = RGB(0, 0, 255)
                                Call CellForm("ボタン")
                            End If
                        Case Else
                            '何もしません
                        End Select
 
                    Else
                        '何もしません
                    End If
                End With
            Else
                '何もしません
            End If
        End With
 
    Case msoTextBox
        '何もしません
    Case Else
        '何もしません
    End Select
 
End Sub

グループ化されたシェイプの処理

COPY

Public Sub DeleteShape(ByRef Sh As Worksheet)
    Dim Shp()   As String
    Dim SP As Shape
    Dim objRange As Object
    Dim iCount As Long
    Dim Flg As Boolean
 
    'シェイプがなければ抜ける
    If Sh.Shapes.Count = 0 Then
        Exit Sub
    End If
 
    'シェイプの数に合わせて配列の添え字を定義
    ReDim Shp(1 To Sh.Shapes.Count)
 
    'ターゲットとするシェイプの名前を取得する
    iCount = 0
    For Each SP In Sh.Shapes
        If InStr(1, SP.Name, "SHP") > 0 Then
            iCount = iCount + 1
            Shp(iCount) = Sh.Name
        End If
    Next SP
 
    '対象がなければ抜ける
    If iCount = 0 Then
        Exit Sub
    End If
 
    '取得した名前の数に合わせて配列の添え字を修正
    ReDim Preserve Shp(1 To iCount)
 
    'シェイプの集合体を取得
    Set objRange = Sh.Shapes.Range(Shp)
 
    '集合体を一括削除
    If Not objRange Is Nothing Then
        objRange.Select
        objRange.Delete
        Set objRange = Nothing
    End If
 
End Sub

アイコンのアクションの引数

COPY

Public Sub DispIcon(ByRef Sh As Worksheet, _
                    ByRef Target As Range)
    Dim Shp As Object
    Dim Flg As Boolean
 
    If Target.Count <> 1 Then
        Exit Sub
    End If
 
    If Target.Address = Sh.Cells(1, 1).Address Then
        Exit Sub
    End If
 
    Set Shp = Sh.Shapes.AddPicture(ThisWorkbook.Path & "\INFOML.ICO", _
                                   False, _
                                   True, _
                                   Target.Offset(0, 1).Left + 5, _
                                   Target.Offset(0, 1).Top + 2, _
                                   15, _
                                   15)
 
    With Shp
        .Name = "SHP_ICO"
        .OnAction = "'CellForm ""引数""'"
        .Placement = xlMove
        .Locked = msoFalse
    End With
    
End Sub

SIBA INU のメモ帳

エクセルのセルから呼び出すシェイプカレンダー

全コード

ワークシートの仕込み

セルをダブルクリックした時

祝日休日を判定する関数

Shapeの再帰処理

グループ化されたシェイプの処理

アイコンのアクションの引数