制作指定月份的日历

> 使用这段代码，可以在 PPT 中快速生成指定年份和月份的日历。

**使用方法：**

先新建一页带有`标题占位符`的页面，在里面插入一个 7X7 的表格。

如下图所示，表格第一行设置好周一到周日，并修改标题占位符与表格的样式。

![](https://tu.doc.aboutppt.cn/img/2022/05/17/图片1_压缩后_20220517110026098346.jpg)

设置完成后打开代码编辑器，粘贴下方的代码。

**代码如下：**

```vb
Sub 生成日历()
    
    Dim lngY As Long
    Dim lngM As Long
    Dim firstDay As Long
    Dim lngDayCNT As Long
    Dim lastDay As Long
    Dim lngDay As Long
    Dim lngCount As Long
    Dim X As Long
    Dim L As Long
    Dim osld As Slide
    Dim otbl As Table
    Dim LR As Long
    Dim LC As Long
    Dim rayDays(1 To 42) As String
    Const StartDay As Long = vbMonday
    
    On Error Resume Next
    Set otbl = ActiveWindow.Selection.ShapeRange(1).Table
    If otbl Is Nothing Then
        MsgBox "Select a table", vbCritical
        Exit Sub
    End If
    
    '获取年份以及月份'
    lngY = InputBox("输入日历年份")
    If Not IsNumeric(lngY) Then Exit Sub
    lngM = InputBox("输入日历月份(阿拉伯数字，比如 5 )")
    If Not IsNumeric(lngM) Then Exit Sub
    If lngM < 1 Or lngM > 12 Then Exit Sub
    
    ' Find day of week for 1st of month '
    firstDay = Weekday(DateSerial(lngY, lngM, 1), StartDay)
    ' Find number of days in month '
    lngDayCNT = Day(DateSerial(lngY, lngM + 1, 1) - 1)
    ' find day of week for last day '
    lastDay = lngDayCNT + firstDay - 1
    'add only used days to array '
    For L = firstDay To lastDay
        lngDay = lngDay + 1
        rayDays(L) = lngDay
    Next L
    ' fill in Table omit header row '
    
    For LR = 2 To 7
        For LC = 1 To 7
            X = X + 1
            otbl.Cell(LR, LC).Shape.TextFrame.TextRange = CStr(rayDays(X))
            otbl.Cell(LR, LC).Shape.TextFrame.TextRange.Font.Size = 18
        Next
    Next
    Set osld = ActiveWindow.Selection.SlideRange(1)
    osld.Shapes.Title.TextFrame.TextRange = lngY & "年" & MonthName(lngM)
    
End Sub
```

最后回到普通视图，选中表格，运行宏`生成日历`，输入对应的年份以及月份，即可在表格中自动生成对应的日历。

生成的日历效果如下图：

![](https://tu.doc.aboutppt.cn/img/2022/05/17/图片3_A_20220517112540918248.jpg)