Календарь Word теперь печатает за вас!

[Sasha_Smirnov]

Это можете и вы!
Источник: недавняя тема. Прикрутил к ней новую кнопку. Вперёд!

Option Explicit
Option Base 1

Sub PrintWeekDaysGrid(Optional Y, Optional M, Optional d As Integer, Optional wd As Integer)
'печатает календарь на месяц M года Y - или на текущий месяц, если не задано Y, M, d или wd'
Dim j, visokos, weekdayline, firstmonthday, registers, NextDate As Date

If IsMissing(Y) Or IsMissing(M) Or IsMissing(d) Or IsMissing(wd) Then _
Y = Year(Date): M = Month(Date): d = Day(Date): wd = Weekday(Date)      ',vbSunday)

If Y Mod 4 = 0 Then visokos = 1
If Y Mod 100 = 0 Then visokos = 0
If Y Mod 400 = 0 Then visokos = 1

registers = Array(31, 28 + visokos, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)

firstmonthday = (wd - (d - 1) Mod 7 + 7) Mod 7  'день недели 1-го числа месяца'
firstmonthday = 1 + ((firstmonthday + 5) Mod 7) 'день недели 1-го числа месяца по-русски'

With Selection
.EndKey wdStory                             'перемещение курсора в конец документа'
.TypeParagraph                              'печать с новой строки (абзац)'
.TypeText MonthName(M) & "-" & Y & Chr$(11) 'печать названия месяца (в VBA 6 и выше)'

    For weekdayline = 1 To 7
        If weekdayline > IIf(Y > 1964, 5, 6) Then .Font.Color = vbRed 'окраска уик-энда'
        j = 1 + (7 - firstmonthday + weekdayline) Mod 7
        'число, на которое выпал первый ПН, ВТ, СР и т. д.'
        .TypeText WeekdayName(weekdayline, , vbMonday) 'название дня недели на вашем языке'
        
        .ParagraphFormat.TabStops.Add _
        Position:=CentimetersToPoints(0.6 * .Font.Size), Alignment:=wdAlignTabRight
        If j > weekdayline Then .TypeText vbTab     'отступ (табуляция), пока день j > d* '
        .TypeText vbTab                                      '(*первого печатаемого в строке дня)'
        
        .ParagraphFormat.TabStops.Add _
        Position:=CentimetersToPoints(0.25 * .Font.Size), Alignment:=wdAlignTabRight
        
        For d = j To registers(M) Step 7
            .TypeText vbTab
            .TypeText d
        Next d
        
        .Font.Color = wdAuto
        .TypeText IIf(weekdayline = 7, Chr$(13), Chr$(11))
    Next weekdayline
    
.ParagraphFormat.TabStops.ClearAll
End With

'If MsgBox("Продолжить?", vbInformation + vbOKCancel) <> vbCancel Then
'    If Y < 9999 Then
'        NextDate = DateAdd("m", 1, DateSerial(Y, M, 1))
'        Call PrintWeekDaysGrid(Year(NextDate), Month(NextDate), Day(NextDate), Weekday(NextDate))
'        Else: MsgBox "Много!"
'    End If
'End If

End Sub

[Sasha_Smirnov]

На удивление, григорианский календарь печатается не с 1.1.100 (как установлено в VBA), а с 1.1.1.

Похоже, фокус в том, что 1-й и 21-века (по новому стилю) совпадают.

К сожалению, Windows ставит дату минимум 1.1.1980. Максимум — 31.12.2099.

Поэтому используйте все кнопки, там разберётесь.

[Sasha_Smirnov]

А честно, надо переделать: первые 8 лет не были високосными!

Да ещё и каждый 4000-й год невисокосен, как утверждает Серж Близнюков, имея на то основания.

[Sasha_Smirnov]

В принципе то же самое, но...

KeepWithNext свойство полезное, но вдруг «слетело»!

Любытен также спецэффект при пересохранении — сжатие на 1/6 объёма (как в теме http://programmersforum.ru/showthrea...110#post405110).