PowerPointスライドの左3分の1に3ヶ月カレンダーを作成するマクロを紹介します。ユーザーに開始年と月を入力させ、指定された月から3ヶ月分のカレンダーを生成します。各月は曜日ヘッダーと日付セルを含み、日曜日と土曜日は色分けされています。
Option Explicit
' --- DESIGN & LAYOUT PARAMETERS ---
Const FONT_SIZE As Single = 8
Const HEADER_FONT_SIZE As Single = 9
Const MONTH_FONT_SIZE As Single = 16
Const BOX_HEIGHT As Single = 30 ' Height of month title box
Const MARGIN_TOP As Single = 20 ' Bottom margin below calendars
Const MARGIN_LEFT As Single = 20
Const SPACING_VERTICAL As Single = 20 ' Space between calendars
Const CAL_WIDTH As Single = 300 ' Fixed calendar width
Const TOP_OFFSET As Single = 100 ' Space above calendars for title/lead text
Const TABLE_COLS As Integer = 7 ' Days of week
Public Sub CreateThreeMonthCalendar()
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSld As PowerPoint.Slide
Dim ppShpBox As PowerPoint.Shape
Dim ppShpTable As PowerPoint.Shape
Dim ppTbl As PowerPoint.Table
' --- COLOR VARIABLES ---
Dim SUNDAY_COLOR As Long, SATURDAY_COLOR As Long
Dim BORDER_COLOR_HORZ As Long, BORDER_COLOR_VERT As Long
Dim BACKGROUND_COLOR As Long, TEXT_COLOR As Long
Dim HEADER_TEXT_COLOR As Long, BOX_BACKGROUND_COLOR As Long
' --- COLOR CONSTANTS ---
SUNDAY_COLOR = RGB(255, 100, 100)
SATURDAY_COLOR = RGB(100, 100, 255)
BORDER_COLOR_HORZ = RGB(192, 192, 192)
BORDER_COLOR_VERT = RGB(220, 220, 220)
BACKGROUND_COLOR = RGB(255, 255, 255)
TEXT_COLOR = RGB(0, 0, 0)
HEADER_TEXT_COLOR = RGB(0, 0, 0)
BOX_BACKGROUND_COLOR = RGB(230, 230, 230)
' --- INPUTS ---
Dim inputYearStr As String, inputMonthStr As String
Dim currentYear As Integer, currentMonth As Integer
On Error GoTo ErrorHandler
Set ppApp = PowerPoint.Application
Set ppPres = ppApp.ActivePresentation
Set ppSld = ppPres.Slides.Add(ppPres.Slides.Count + 1, ppLayoutBlank)
' Get starting year and month
inputYearStr = InputBox("Enter the starting year (e.g., 2025):", "Calendar Year")
If Not IsNumeric(inputYearStr) Or Len(inputYearStr) <> 4 Then MsgBox "Invalid year.", vbCritical: Exit Sub
currentYear = CInt(inputYearStr)
inputMonthStr = InputBox("Enter the starting month (1-12):", "Calendar Month")
If Not IsNumeric(inputMonthStr) Or CInt(inputMonthStr) < 1 Or CInt(inputMonthStr) > 12 Then MsgBox "Invalid month.", vbCritical: Exit Sub
currentMonth = CInt(inputMonthStr)
' --- Compute dynamic sizes ---
Dim sldWidth As Single, sldHeight As Single
Dim availableHeight As Single, blockHeight As Single
Dim tableHeight As Single, cellHeight As Single
Dim totalWeeks As Integer, rowsCount As Integer
sldWidth = ppPres.PageSetup.SlideWidth
sldHeight = ppPres.PageSetup.SlideHeight
' Available vertical space: subtract top offset, top & bottom margins, and inter-calendar spacing
availableHeight = sldHeight - TOP_OFFSET - 2 * MARGIN_TOP - 2 * SPACING_VERTICAL
blockHeight = availableHeight / 3
' Starting position
Dim currentLeft As Single: currentLeft = MARGIN_LEFT
Dim currentTop As Single: currentTop = TOP_OFFSET + MARGIN_TOP
Dim i As Integer
For i = 1 To 3
Dim currentDate As Date, daysInMonth As Integer, firstDay As Integer
Dim dayCounter As Integer, r As Integer, c As Integer
Dim daysOfWeek As Variant: daysOfWeek = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
currentDate = DateSerial(currentYear, currentMonth, 1)
daysInMonth = Day(DateSerial(currentYear, currentMonth + 1, 0))
firstDay = Weekday(currentDate, vbSunday)
' Calculate weeks needed for this month
totalWeeks = Int((daysInMonth + firstDay - 2) / 7) + 1
rowsCount = totalWeeks
' Compute table height & cell height
tableHeight = blockHeight - BOX_HEIGHT - 5
cellHeight = tableHeight / (rowsCount + 1) ' +1 for header row
' --- MONTH NAME BOX ---
Set ppShpBox = ppSld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
currentLeft, currentTop, CAL_WIDTH, BOX_HEIGHT)
With ppShpBox
.Fill.ForeColor.RGB = BOX_BACKGROUND_COLOR
With .TextFrame
.TextRange.Text = Format(currentDate, "MMMM YYYY")
With .TextRange.Font
.Name = "Arial"
.Size = MONTH_FONT_SIZE
.Bold = msoTrue
.Color.RGB = TEXT_COLOR
End With
.TextRange.ParagraphFormat.Alignment = ppAlignCenter
.VerticalAnchor = msoAnchorMiddle
.MarginLeft = 0: .MarginRight = 0: .MarginTop = 0: .MarginBottom = 0
End With
End With
' --- CALENDAR TABLE ---
currentTop = currentTop + BOX_HEIGHT - 5
Set ppShpTable = ppSld.Shapes.AddTable(rowsCount + 1, TABLE_COLS, _
currentLeft, currentTop, CAL_WIDTH, tableHeight)
Set ppTbl = ppShpTable.Table
' Set column widths and row heights
For c = 1 To TABLE_COLS: ppTbl.Columns(c).Width = CAL_WIDTH / TABLE_COLS: Next c
For r = 1 To rowsCount + 1: ppTbl.Rows(r).Height = cellHeight: Next r
' --- HEADER ROW ---
For c = 1 To TABLE_COLS
With ppTbl.Cell(1, c).Shape.TextFrame
.TextRange.Text = daysOfWeek(c - 1)
With .TextRange.Font
.Name = "Arial"
.Size = HEADER_FONT_SIZE
.Bold = msoTrue
.Color.RGB = IIf(c = 1, SUNDAY_COLOR, IIf(c = 7, SATURDAY_COLOR, HEADER_TEXT_COLOR))
End With
.TextRange.ParagraphFormat.Alignment = ppAlignCenter
.VerticalAnchor = msoAnchorMiddle
.MarginRight = 1
.MarginLeft = 1
End With
Next c
' --- DATE CELLS ---
dayCounter = 1
For r = 2 To rowsCount + 1
For c = 1 To TABLE_COLS
With ppTbl.Cell(r, c).Shape.TextFrame
.VerticalAnchor = msoAnchorMiddle
.MarginRight = 2
.MarginLeft = 2
.TextRange.ParagraphFormat.Alignment = ppAlignRight
If (r = 2 And c >= firstDay) Or (r > 2 And dayCounter <= daysInMonth) Then
.TextRange.Text = dayCounter
With .TextRange.Font
.Name = "Arial"
.Size = FONT_SIZE
.Color.RGB = IIf(c = 1, SUNDAY_COLOR, IIf(c = 7, SATURDAY_COLOR, TEXT_COLOR))
End With
dayCounter = dayCounter + 1
Else
.TextRange.Text = ""
With .TextRange.Font
.Name = "Arial"
.Size = FONT_SIZE
End With
End If
End With
Next c
Next r
' --- BORDER STYLING ---
For r = 1 To rowsCount + 1
For c = 1 To TABLE_COLS
With ppTbl.Cell(r, c)
.Shape.Fill.ForeColor.RGB = BACKGROUND_COLOR
.Shape.Fill.Visible = msoTrue
' Transparent outer borders
If r = 1 Then
.Borders(ppBorderTop).Transparency = 1: .Borders(ppBorderTop).Weight = 0
End If
If r = rowsCount + 1 Then
.Borders(ppBorderBottom).Transparency = 1: .Borders(ppBorderBottom).Weight = 0
End If
If c = 1 Then
.Borders(ppBorderLeft).Transparency = 1: .Borders(ppBorderLeft).Weight = 0
End If
If c = TABLE_COLS Then
.Borders(ppBorderRight).Transparency = 1: .Borders(ppBorderRight).Weight = 0
End If
' Horizontal borders
.Borders(ppBorderTop).Weight = 0.1
.Borders(ppBorderTop).ForeColor.RGB = BORDER_COLOR_HORZ
.Borders(ppBorderBottom).Weight = 0.1
.Borders(ppBorderBottom).ForeColor.RGB = BORDER_COLOR_HORZ
' Vertical borders
.Borders(ppBorderLeft).Weight = 0.3
.Borders(ppBorderLeft).ForeColor.RGB = BORDER_COLOR_VERT
.Borders(ppBorderRight).Weight = 0.3
.Borders(ppBorderRight).ForeColor.RGB = BORDER_COLOR_VERT
End With
Next c
Next r
' --- Next Month Positioning ---
currentMonth = currentMonth + 1
If currentMonth > 12 Then currentMonth = 1: currentYear = currentYear + 1
currentTop = currentTop + tableHeight + SPACING_VERTICAL
Next i
MsgBox "Three-month calendar created successfully!", vbInformation
Exit Sub
ErrorHandler:
MsgBox "Error: " & Err.Description, vbCritical
End Sub
No comments:
Post a Comment