全コード
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
ワークシートの仕込み
セルの選択した時アイコンを表示します。
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
セルをダブルクリックした時
カレンダーを表示
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Call ShapeCalendar.OpenCalendar
End Sub
祝日休日を判定する関数
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の再帰処理
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
グループ化されたシェイプの処理
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
アイコンのアクションの引数
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