【Word VBA】七曜カレンダー作成マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 七曜カレンダー作成マクロ()

    '*********************

    Const CALENYEAR = 2023        '年（西暦）

    Const CALENMONT = 10           '月

    '*********************

    'テーブルセル

    Const CALENCLWD = 48            '幅

    Const CALENCLH1 = 30             '高さ1(曜日)

    Const CALENCLH2 = 50             '高さ2

    'フォント

    Const CALEFNTNA = "ＭＳ ゴシック"    '名前

    Const CALEFNTS1 = 12             'サイズ1(曜日)

    Const CALEFNTS2 = 24             'サイス2(1～)

    Const CALEFNTS3 = 16             'サイス3(24/31)

    '---------------------------------------------------------------------------

    Dim Ip As Integer, Jp As Integer

    Dim tblCale As Table

    Dim intCl As Integer

    Dim intDy As Integer, intLd As Integer

    '

    '*表作成

    Set tblCale = ActiveDocument.Tables.Add( _

        Range:=ActiveDocument.Range(Start:=0, End:=0), _

        NumRows:=6, NumColumns:=7)

    '

    '*表にデータセット

    With tblCale

        .Style = "表 (格子)"

        'セル幅

        .Columns.SetWidth ColumnWidth:=CALENCLWD, _

                         RulerStyle:=wdAdjustNone

        'セル高さ

        .Rows(1).SetHeight RowHeight:=CALENCLH1, _

                         HeightRule:=wdRowHeightExactly

        For Ip = 2 To 6

           .Rows(Ip).SetHeight RowHeight:=CALENCLH2, _

                        HeightRule:=wdRowHeightExactly

        Next Ip

        '罫線

        With .Borders

             .InsideLineStyle = wdLineStyleSingle

             .OutsideLineStyle = wdLineStyleSingle

             .InsideLineWidth = wdLineWidth100pt

             .OutsideLineWidth = wdLineWidth150pt

       End With

       '

       '*先頭行(日～土)セット

       For Ip = 1 To 7

           Select Case Ip '文字色

                  Case 1: intCl = wdRed

                  Case 2 To 6: intCl = wdBlack

                  Case 7: intCl = wdBlue

           End Select

           With .Cell(1, Ip)

                .Range.Text = WeekdayName(Ip, True)

                .Range.Font.Name = CALEFNTNA

                .Range.Font.Size = CALEFNTS1

                .Range.Font.Bold = True

                .Range.Font.ColorIndex = intCl

                .Range.ParagraphFormat.Alignment = _

                                     wdAlignParagraphCenter

                .VerticalAlignment = wdCellAlignVerticalCenter

                '

                .Range.Cells. _

                 Shading.BackgroundPatternColorIndex = wdGray25

           End With

       Next Ip

       '

       '*数字セット

       '左上の数(０以下はセットしない)

       intDy = 2 - Weekday(DateSerial(CALENYEAR, CALENMONT, 1))

       '月の末日

       intLd = Day(IIf(CALENMONT < 12, _

               DateSerial(CALENYEAR, CALENMONT + 1, 0), _

               DateSerial(CALENYEAR + 1, 1, 0)))

       For Jp = 1 To 5

           For Ip = 1 To 7

               If intDy > 0 And intDy <= intLd Then

                  Select Case Ip '文字色

                      Case 1: intCl = wdRed

                      Case 2 To 6: intCl = wdBlack

                      Case 7: intCl = wdBlue

                  End Select

                  With .Cell(Jp + 1, Ip)

                    If Jp = 5 And _

                       (intDy + 7) <= intLd Then

                    .Range.Text = Str(intDy) & "/" _

                                & Str(intDy + 7)

                    .Range.Font.Size = CALEFNTS3

                    Else

                    .Range.Text = Str(intDy)

                    .Range.Font.Size = CALEFNTS2

                    End If

                    .Range.Font.Name = CALEFNTNA

                    .Range.Font.Bold = True

                    .Range.Font.ColorIndex = intCl

                    .Range.ParagraphFormat.Alignment = _

                                     wdAlignParagraphCenter

                    .VerticalAlignment = wdCellAlignVerticalCenter

                 End With

              End If

              intDy = intDy + 1

           Next Ip

       Next Jp

    End With

End Sub

   '*********************

    Const CALENYEAR = 2023 '年（西暦）

    Const CALENMONT = 11 '月

    '*********************

   '*********************

    Const CALENYEAR = 2023 '年（西暦）

    Const CALENMONT = 12 '月

    '*********************

    '