Calendar Macro

by Eric Gans

Revised 12/15/2004

This macro allows you to print a one-page year calendar as well as a month-by-month calendar with a few useful features:

automatically generates movable holidays, including Jewish and Christian holidays
allows you to add birthdays, anniversaries, etc. (up to three items per day)
last week of previous month is repeated as first week of present month, to avoid calendar-flipping at the end of the month

How to use this macro:

copy the text of the macro (between dotted lines) to a text file called "cal.bas" (the .bas extension is important)
in MSWord, hit Alt-F11 to open the Visual Basic window
go to the File menu, click on "Import File", and import cal.bas
the cal macro has now been installed

Data File

You can create a data file for birthdays, anniversaries, etc., described in a maximum of 17 characters. It is convenient but not necessary to put them in chronological order. You can use the "date" 0,0 for comments. The format for entries in the file (one to a line) is:

mo,day,"description"

Example

0,0,"Birthdays" 
1,3,"John's Birthday"
0,0,"Anniversaries"
4,11,"Our Anniversary"

Please make sure there are no blank lines in the file; do not hit a carriage return at the end of the last line!

Customizing

The six "Const" expressions at the top of the macro should be changed to your personal settings:

fiveday gives a five-day week, excluding weekends (originally set to False)
ucla gives academic calendar settings for UCLA (originally set to False)
brit writes dates dd/mm instead of the US mm/dd (originally set to False)
docdirec is where the calendar file will be generated
datafile is the path of your personal data file
myfont is the font you want to print in. Changing this may affect character size; you may have to experiment with the point settings below (the seven following Const numbers).

Movable holidays

M L King Day
Presidents' Day
Purim
Passover
Good Friday
Easter
Mother's Day
Memorial Day
Father's Day
Labor Day
Rosh Hashonah
Yom Kippur
Election Day
Thanksgiving
Hanukkah

Disclaimer

This macro has worked on several printer/computer combinations and several versions of Word and Windows; I hope (but can't guarantee) that it works for you. Connoisseurs of beautiful code please excuse the lack of comments and general sloppiness. If you find something that looks like a bug, please report it to me.

NB: The formatting is set to work with the Mistral AV font, which may not be on your computer (but can easily be found on line). If you change the font, you'll probably have to do some experimenting with font sizes to get the calendar to print correctly. If you do this, please send me the results and I'll include them in the macro listing.

- - - - - - - - - - - - - -
Option Explicit
' begun 11/14/99
' revised 12/15/04
#Const fiveday = False
#Const ucla = False
#Const brit = False
Const docdirec$ = "C:\Documents and Settings\default\My Documents\"
Const datafile$ = "c:\misc\calx.dat"
Const myfont$ = "Mistral AV"
Const tinyfont% = 8
Const smfont% = 10
Const medfont% = 12
Const bigmedfont% = 14
Const mlfont% = 17
Const largefont% = 40
Const bigfont% = 48
Dim cm%(13), m$(12), dayj%, cal0doc As Document, myrange As Range, daym%

Sub cal()
Dim mo%, dy%, da As Date, da2 As Date, d$(7)

Dim i%, y%
Dim dd%, ii%, jj%, lm%
Dim lm1%, mm%, ll%, x$, zz$, twx As Boolean, bd%, tw%, ma%, mz%
Dim mtables(12) As Table, caldoc As Document, adoc As Document

Dim hol$(13, 31), wks$(53)

cm(0) = -31: cm(1) = 0: cm(2) = 31: cm(3) = 59: cm(4) = 90: cm(5) = 120
cm(6) = 151: cm(7) = 181: cm(8) = 212: cm(9) = 243: cm(10) = 273
cm(11) = 304: cm(12) = 334: cm(13) = 365
m(1) = "January": m(2) = "February": m(3) = "March": m(4) = "April"
m(5) = "May": m(6) = "June": m(7) = "July": m(8) = "August"
m(9) = "September": m(10) = "October": m(11) = "November": m(12) = "December"
d(1) = "Sunday": d(2) = "Monday": d(3) = "Tuesday": d(4) = "Wednesday"
d(5) = "Thursday": d(6) = "Friday": d(7) = "Saturday"

Options.DefaultBorderLineWidth = wdLineWidth050pt
Options.DefaultBorderLineStyle = wdLineStyleSingle

#If fiveday = False Then
For i = 1 To 10
wks(i + 1) = Trim$(Str$(i))
wks(i + 13) = Trim$(Str$(i))
wks(i + 39) = Trim$(Str$(i))
Next
For i = 1 To 6
wks(25 + i) = Trim$(Str$(i))
wks(31 + i) = Trim$(Str$(i))
Next
wks(1) = "0"
wks(12) = "X": wks(24) = "X"
wks(39) = "0": wks(50) = "X"
#End If

' month & year input feature

y = Year(Now)
If Month(Now) > 4 Then
i = MsgBox("Print next year's calendar? (No for this year)", vbYesNoCancel)
    If i = vbCancel Then
    End
    ElseIf i = vbYes Then
    y = y + 1
    End If
Else
i = MsgBox("Print this year's calendar? (No for next year)", vbYesNoCancel)
    If i = vbCancel Then
    End
    ElseIf i = vbNo Then
    y = y + 1
    End If
End If
100
i = MsgBox("Print monthly calendar? (No for yearly)", vbYesNoCancel)
If i = vbCancel Then
End
ElseIf i = vbNo Then
yearcal (y)
GoTo 100
End If

i = MsgBox("Print all 12 months?", vbYesNoCancel)
If i = vbCancel Then End
If i = vbNo Then
ma = InputBox("First month?")
If ma < 1 Or ma > 12 Then End
mz = InputBox("Last month?")
If mz < 1 Or mz > 12 Or mz < ma Then End
Else
ma = 1: mz = 12
End If

hol(1, 1) = "New Year's Day" & vbCrLf
hol(2, 14) = "Valentine's Day" & vbCrLf
hol(7, 4) = "Independence Day" & vbCrLf
hol(10, 31) = "Halloween" & vbCrLf
hol(11, 11) = "Veteran's Day" & vbCrLf
hol(12, 25) = "Christmas" & vbCrLf
hol(13, 1) = "New Year's Day" & vbCrLf

Select Case Weekday("7/4/" & Trim$(Str$(y)))
Case 1
hol(7, 5) = "Ind. Day Observed" & vbCrLf
Case 7
hol(7, 3) = "Ind. Day Observed" & vbCrLf
End Select

Select Case Weekday("11/11/" & Trim$(Str$(y)))
Case 1
hol(11, 12) = "Vet. Day Observed" & vbCrLf
Case 7
hol(11, 10) = "Vet. Day Observed" & vbCrLf
End Select

hol(1, Day(mlk(y))) = "M L King Day" & vbCrLf
hol(2, Day(presidents(y))) = "Presidents' Day" & vbCrLf
hol(4, Day(dayl1(y))) = "Daylight Savings Begins" & vbCrLf
hol(5, Day(mother(y))) = "Mother's Day" & vbCrLf
hol(6, Day(father(y))) = "Father's Day" & vbCrLf
hol(9, Day(labor(y))) = "Labor Day" & vbCrLf
hol(10, Day(dayl2(y))) = hol(10, Day(dayl2(y))) & "Daylight Savings Ends" & vbCrLf
hol(11, Day(elect(y))) = "Election Day" & vbCrLf
hol(11, Day(thanks(y))) = "Thanksgiving" & vbCrLf
hol(5, Day(dec(y))) = "Memorial Day" & vbCrLf

#If ucla Then
Dim wqc As Date
If Weekday("1/1/" & y) < 4 Then
wqc = wq(y) + 5
Else
wqc = wq(y) + 3
End If
hol(1, Day(wq(y))) = "Winter Quarter" & vbCrLf
hol(1, Day(wqc)) = "Classes begin" & vbCrLf
hol(1, Day(wqc + 15)) = "Study Lists" & vbCrLf
hol(3, Day(wqc + 67)) = "Thesis Deadline" & vbCrLf
hol(3, Day(wqc + 69)) = "Classes end" & vbCrLf
hol(3, Day(wqc + 77)) = "Quarter ends" & vbCrLf
hol(3, Day(wqc + 78)) = "Cesar Chavez holiday" & vbCrLf
hol(3, Day(wqc + 83)) = "Spring Quarter" & vbCrLf
hol(Month(wqc + 88), Day(wqc + 88)) = "Classes begin" & vbCrLf ' 12 wks
hol(4, Day(wqc + 11 + 88)) = "Study Lists" & vbCrLf
hol(6, Day(wqc + 63 + 88)) = "Thesis Deadline" & vbCrLf
hol(6, Day(wqc + 67 + 88)) = "Classes end" & vbCrLf
hol(6, Day(wqc + 74 + 88)) = "Quarter ends" & vbCrLf
hol(6, Day(wqc + 75 + 88)) = "Commencement" & vbCrLf
hol(6, Day(wqc + 172)) = "S. S. A" & vbCrLf    ' 24 weeks
hol(8, Day(wqc + 172 + 39)) = "S. S. A ends" & vbCrLf
hol(8, Day(wqc + 214)) = "S. S. C" & vbCrLf    ' 30 wks
hol(9, Day(wqc + 214 + 39)) = "S. S. C ends" & vbCrLf
hol(9, Day(wqc + 263)) = "Fall Quarter" & vbCrLf ' 37 wks
hol(9, Day(wqc + 263 + 3)) = "Classes begin" & vbCrLf ' Thursday
hol(10, Day(wqc + 263 + 18)) = "Study Lists" & vbCrLf
hol(12, Day(wqc + 263 + 70)) = "Thesis Deadline" & vbCrLf
hol(12, Day(wqc + 263 + 74)) = "Classes end" & vbCrLf
'hol(12, Day(wqc + 263 + 74)) = "Reading Day" & vbCrLf
hol(12, Day(wqc + 263 + 81)) = "Quarter ends" & vbCrLf ' 48 wks
hol(13, Day(wq(y + 1))) = "Winter Quarter" & vbCrLf
If Weekday("1/1/" & y + 1) < 4 Then
wqc = wq(y + 1) + 5
Else
wqc = wq(y + 1) + 3
End If
hol(13, Day(wqc)) = "Classes begin" & vbCrLf
#End If

da = easter(y): mo = Month(da): dy = Day(da): hol(mo, dy) = "Easter" & vbCrLf

mo = Month(da - 2): dy = Day(da - 2)
hol(mo, dy) = hol(mo, dy) & "Good Friday" & vbCrLf

da = rosh(y): mo = Month(da): dy = Day(da)
hol(mo, dy) = hol(mo, dy) & "Rosh Hashonah" & vbCrLf

mo = Month(da + 9): dy = Day(da + 9)
hol(mo, dy) = hol(mo, dy) & "Yom Kippur" & vbCrLf

da2 = passo(da): mo = Month(da2): dy = Day(da2)
hol(mo, dy) = hol(mo, dy) & "Passover" & vbCrLf

da2 = da2 - 30: mo = Month(da2): dy = Day(da2)
hol(mo, dy) = hol(mo, dy) & "Purim" & vbCrLf

da2 = hanukah(da): mo = Month(da2): dy = Day(da2)
hol(mo, dy) = hol(mo, dy) & "Hanukkah" & vbCrLf

da2 = hanukah(rosh(y - 1)): mo = 0: dy = Day(da2)
hol(mo, dy) = hol(mo, dy) & "Hanukkah" & vbCrLf ' year before

If Len(Dir(datafile)) > 0 Then
GoSub 500
End If

If y Mod 4 = 0 And Not (y Mod 100 = 0 And y Mod 400 <> 0) Then
For i = 3 To 13: cm(i) = cm(i) + 1: Next
End If
dayj = Weekday("1/1/" & y) - 1
tw = 1 - (dayj + bd - 2) / 7

Set caldoc = Documents.Add
caldoc.Activate
caldoc.Content.Font.Name = myfont

With ActiveDocument.PageSetup
.Orientation = wdOrientLandscape
#If fiveday = False Then
.LeftMargin = InchesToPoints(0.5)
.RightMargin = InchesToPoints(0.5)
#Else
.LeftMargin = InchesToPoints(0.3)
.RightMargin = InchesToPoints(0)
#End If
    .TopMargin = InchesToPoints(0)
    .BottomMargin = InchesToPoints(0)
    .HeaderDistance = 0
    .FooterDistance = 0
End With

ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text = vbNullString

Set myrange = ActiveDocument.Range

For mm = ma To mz '12
lm = cm(mm + 1) - cm(mm)
lm1 = cm(mm) - cm(mm - 1)
daym = (dayj + cm(mm)) Mod 7
ll = (lm + daym) \ 7

myrange.SetRange Start:=ActiveDocument.Characters.count - 1, _
End:=ActiveDocument.Characters.count - 1

myrange.Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.InsertAfter vbCrLf
Selection.Font.Size = medfont '12
Selection.Collapse (wdCollapseEnd)
Selection.InsertAfter m(mm) & " " & Str$(y)
Selection.Font.Size = bigfont '48
Selection.Collapse (wdCollapseEnd)

myrange.SetRange Start:=ActiveDocument.Characters.count - 1, _
End:=ActiveDocument.Characters.count - 1
#If fiveday = False Then
Set mtables(mm) = ActiveDocument.Tables.Add(Range:=myrange, NumRows:=ll + 2, NumColumns:=8)
#Else
Set mtables(mm) = ActiveDocument.Tables.Add(Range:=myrange, NumRows:=ll + 2, NumColumns:=5)
#End If
mtables(mm).Borders.Enable = True
myrange.SetRange Start:=ActiveDocument.Characters.count - 1, _
End:=ActiveDocument.Characters.count - 1
mtables(mm).Range.Font.Size = smfont '10
mtables(mm).Rows(1).Range.Font.Size = medfont '12
If mm < mz Then
myrange.InsertBreak (wdPageBreak)
myrange.MoveEnd count:=-2 'get rid of cr
myrange.Delete count:=1

End If
For i = 2 To ll + 2
mtables(mm).Rows(i).SetHeight RowHeight:=InchesToPoints(1), _
    HeightRule:=wdRowHeightExactly
Next i
#If fiveday = False Then
mtables(mm).Columns(1).Width = InchesToPoints(0.2)
For i = 2 To 8
mtables(mm).Columns(i).Width = InchesToPoints(1.4)
Next
#Else

For i = 1 To 5

mtables(mm).Columns(i).Width = InchesToPoints(2.05)

Next

#End If
mtables(mm).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
mtables(mm).Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter

#If fiveday = False Then
For i = 1 To 7
mtables(mm).Cell(1, i + 1).Range.InsertAfter d(i) ' Left(d(i), 3)
Next
#Else
For i = 1 To 5
mtables(mm).Cell(1, i).Range.InsertAfter d(i + 1)  ' Left(d(i), 3)
Next
#End If
For ii = 0 To ll
For jj = 1 To 7
dd = 7 * ii + jj - daym
If dd < 1 Then

'end/start of month dates mm/dd
#If brit = False Then
zz = Format$((mm + 10) Mod 12 + 1, "##") & "/" & Format$(lm1 + dd, "##")
ElseIf dd <= lm Then zz = Str$(dd)
Else
zz = Format$(mm Mod 12 + 1, "##") & "/" & Format$(dd - lm, "##")
#Else
zz = Format$(lm1 + dd, "##") & "/" & Format$((mm + 10) Mod 12 + 1, "##")
ElseIf dd <= lm Then zz = Str$(dd)
Else
zz = Format$(dd - lm, "##") & "/" & Format$(mm Mod 12 + 1, "##")
#End If

End If
#If fiveday = False Then
mtables(mm).Cell(ii + 2, jj + 1).Range.InsertAfter zz & vbCrLf
#Else
If jj > 1 And jj < 7 Then
mtables(mm).Cell(ii + 2, jj - 1).Range.InsertAfter zz & vbCrLf
End If
#End If

Select Case dd
Case Is < 1
If mm = 1 Then
x = hol(0, dd + lm1)
Else
x$ = hol$((mm + 10) Mod 12 + 1, dd + lm1)
End If
Case Is > lm
If mm = 12 Then
x = hol(13, dd - lm)
Else
x$ = hol$(mm Mod 12 + 1, dd - lm)
End If

Case Else
x$ = hol$(mm, dd)
End Select

If Len(x$) > 0 Then
#If fiveday = False Then
mtables(mm).Cell(ii + 2, jj + 1).Range.Select

Selection.Font.Size = tinyfont '8
Selection.InsertAfter x$ & vbCrLf
#Else
If jj > 1 And jj < 7 Then
mtables(mm).Cell(ii + 2, jj - 1).Range.Select

Selection.Font.Size = tinyfont '8
Selection.InsertAfter x$ & vbCrLf
End If
#End If

End If

Next jj
#If fiveday = False Then
If twx = False Then
    If tw >= 0 Then
#If ucla Then
      If Len(wks(tw)) > 0 Then
#End If
      mtables(mm).Cell(ii + 2, 1).VerticalAlignment = wdCellAlignVerticalCenter
      mtables(mm).Cell(ii + 2, 1).Range.Select
      Selection.Font.Size = medfont '12
#If ucla Then
      Selection.InsertAfter wks(tw)
      End If
#Else
      Selection.InsertAfter tw
#End If
    End If
tw = tw + 1
End If
#End If
Next ii
tw = tw - 1

Next mm
#If fiveday = False Then
    zz = docdirec & "calxp" & Right$(Str$(y), 2) & ".doc"
#Else
zz = docdirec & "cal5" & Right$(Str$(y), 2) & ".doc"
#End If

For Each adoc In Documents
    If InStr(adoc.Name, zz) Then adoc.Close: Exit For
Next
If Len(Dir(zz)) > 0 Then
i = MsgBox(zz & " exists. Overwrite? (Cancel for new filename)", vbYesNoCancel)
If i = vbNo Then End
If i = vbCancel Then zz = InputBox("Enter new filename for calendar")
End If

caldoc.SaveAs FileName:=zz
End
500  Rem read data file
Dim k%, a%, b%, c$
Open datafile For Input As #1
While Not EOF(1)
k = k + 1
1570 Input #1, a, b, c$: If a = 0 Then GoTo 1570

hol$(a, b) = hol$(a, b) & c$ & vbCrLf
If a = 12 And b > 25 Then
hol$(0, b) = hol$(0, b) & c$ & vbCrLf
ElseIf a = 1 And b < 7 Then
hol$(13, b) = hol$(13, b) & c$ & vbCrLf
End If

1580 Wend
Close #1
#If ucla Then
For i = 2 To 15
If InStr(hol$(1, i), "Classes begin") Then
bd = i: Return
End If
Next i
MsgBox ("Winter quarter beginning date not found!"): twx = True
#End If
Return
End Sub


Function remain(x As Integer, y As Integer) As Integer
remain = x - y * Int(x / y)
End Function
Function g(y As Integer) As Integer
g = remain(y, 19) + 1
End Function
Function easter(x As Integer) As Date
Dim c%, s%, y%
y = x \ 100

c = Int(y / 4) + Int(8 * (y + 11) / 25) - y

s = remain(11 * g(x) + c, 30)
easter = "4/19/" & x
easter = easter - s

easter = easter + 8 - Weekday(easter)

If Month(easter) = 4 Then
If Day(easter) = 19 Then easter = easter - 1
ElseIf Day(easter) = 18 And g(x) >= 12 Then easter = easter - 1
End If
End Function
Function rosh(y As Integer) As Date
Dim n1 As Double, f As Double, n As Integer

n1 = Int(y / 100) - Int(y / 400) - 2 + 765433 * remain(12 * g(y), 19) / 492480 _
+ remain(y, 4) / 4 - (89081 + 313& * y) / 98496
n = Fix(n1)
f = n1 - n

rosh = "8/31/" & y
rosh = rosh + n
Select Case Weekday(rosh)
Case 1, 4, 6

rosh = rosh + 1
Case 2
If f > 23269 / 25920 And remain(12 * g(y), 19) > 11 Then rosh = rosh + 1
Case 3
If f > 1367 / 2160 And remain(12 * g(y), 19) > 6 Then rosh = rosh + 2
End Select

End Function
Function passo(x As Date) As Date
Dim d As Integer
' x is rosh hashonah
d = Day(x)

If Month(x) = 10 Then d = d + 30
passo = "3/21/" & Year(x)
passo = passo + d

End Function
Function hanukah(x As Date) As Date
Dim z%, r1&, d%
' x is rosh hashonah
z = Year(x)
r1 = rosh(z + 1)
d = Int(r1 - x)
If d > 360 Then d = d - 30
hanukah = x + 83
If d = 355 Then hanukah = hanukah + 1

End Function
Function presidents(y As Integer) As Date
presidents = holiday(y, 2, 3, 2)
End Function
Function mlk(y As Integer) As Date
mlk = holiday(y, 1, 3, 2)
End Function
Function mother(y As Integer) As Date
mother = holiday(y, 5, 2, 1)
End Function
Function father(y As Integer) As Date
father = holiday(y, 6, 3, 1)
End Function
Function labor(y As Integer) As Date
labor = holiday(y, 9, 1, 2)
End Function
Function elect(y As Integer) As Date
elect = holiday(y, 11, 1, 2) + 1
End Function
Function thanks(y As Integer) As Date
thanks = holiday(y, 11, 4, 5)
End Function
Function dec(y As Integer) As Date
Dim z%, a%
z = Weekday("5/31/" & y)
a = (z + 5) Mod 7
dec = "5/" & 31 - a & "/" & y

End Function
Function dayl1(y As Integer) As Date
dayl1 = holiday(y, 4, 1, 1)
End Function
Function dayl2(y As Integer) As Date
Dim z%, a%
z = Weekday("10/31/" & y)
a = (z + 6) Mod 7
dayl2 = "10/" & 31 - a & "/" & y
End Function
Function holiday(y As Integer, m As Integer, w As Integer, wkd As Integer) As Date
Dim z%, a%
z = Weekday(Trim$(Str$(m)) & "/" & Trim$(Str$(7 * w - 6)) & "/" & y)
a = (7 + wkd - z) Mod 7
holiday = Trim$(Str$(m)) & "/" & Trim$(Str$(7 * w - 6 + a)) & "/" & y
End Function
Function wq(y As Integer) As Date
If Weekday("1/1/" & y) < 4 Then
wq = holiday(y, 1, 1, 4) ' Wed - Mon
Else
wq = holiday(y, 1, 1, 2) ' Mon - Thu
End If
End Function

Sub yearcal(y%)
'1/10/00
Dim d$, lm%, dsp%(7), i%, mm%

dsp(0) = 0: dsp(1) = 4: dsp(2) = 8: dsp(3) = 12: dsp(4) = 16: dsp(5) = 20: dsp(6) = 24
d = " S  M  T  W  T  F  S"
cm(0) = -31: cm(1) = 0: cm(2) = 31: cm(3) = 59: cm(4) = 90: cm(5) = 120
cm(6) = 151: cm(7) = 181: cm(8) = 212: cm(9) = 243: cm(10) = 273
cm(11) = 304: cm(12) = 334: cm(13) = 365
m(1) = "January": m(2) = "February": m(3) = "March": m(4) = "April"
m(5) = "May": m(6) = "June": m(7) = "July": m(8) = "August"
m(9) = "September": m(10) = "October": m(11) = "November": m(12) = "December"

If y Mod 4 = 0 And Not (y Mod 100 = 0 And y Mod 400 <> 0) Then
For i = 3 To 13: cm(i) = cm(i) + 1: Next
End If
dayj = Weekday("1/1/" & y) - 1

Set cal0doc = Documents.Add
cal0doc.Activate
cal0doc.Content.Font.Name = myfont

With ActiveDocument.PageSetup
.Orientation = wdOrientPortrait
.LeftMargin = InchesToPoints(1.5)
    .RightMargin = InchesToPoints(1.5)
    .TopMargin = InchesToPoints(0)
    .BottomMargin = InchesToPoints(0)
    .HeaderDistance = 0
    .FooterDistance = 0
End With

ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text = vbNullString

Set myrange = ActiveDocument.Range
myrange.SetRange Start:=ActiveDocument.Characters.count - 1, _
End:=ActiveDocument.Characters.count - 1

myrange.Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.InsertAfter Trim$(Str$(y))
Selection.Font.Size = largefont '40
Selection.Collapse (wdCollapseEnd)

myrange.SetRange Start:=ActiveDocument.Characters.count - 1, _
End:=ActiveDocument.Characters.count - 1
myrange.InsertBreak Type:=wdSectionBreakContinuous
ActiveDocument.Sections(2).PageSetup.TextColumns.SetCount NumColumns:=1
ActiveDocument.Sections(2).PageSetup.TextColumns.Add Width:=InchesToPoints(1.5)
ActiveDocument.Sections(2).PageSetup.TextColumns(1).Width = InchesToPoints(1.5)

ActiveDocument.Sections(2).PageSetup.TextColumns(1).SpaceAfter = InchesToPoints(2.5)
ActiveDocument.Sections(2).Range.ParagraphFormat.FirstLineIndent = 0
ActiveDocument.Sections(2).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft

 For mm = 1 To 12
 lm = cm(mm + 1) - cm(mm)
 daym = (dayj + cm(mm)) Mod 7

myrange.SetRange Start:=ActiveDocument.Characters.count - 1, _
End:=ActiveDocument.Characters.count - 1
myrange.Select

Selection.Font.Name = myfont

Selection.Font.Size = mlfont '17
Selection.InsertAfter Space$(10 - 0.5 * (Len(m$(mm)))) & m$(mm) & vbCrLf '13-...
Selection.Collapse (wdCollapseEnd)
Selection.InsertAfter d & vbCrLf
Selection.Font.Size = bigmedfont '14
Selection.Collapse (wdCollapseEnd)
Selection.Font.Size = medfont '12
 
Selection.InsertAfter Space$(dsp(daym Mod 7)) '3*daym mod 7

For i = 1 To lm

Selection.Collapse (wdCollapseEnd)

If ((daym + i) Mod 7 <> 0) Or (i = lm) Then
Selection.InsertAfter Format$(i, "@@@")
Else
Selection.InsertAfter Format$(i, "@@@") & vbCrLf
End If
If i < 10 Then Selection.Font.Spacing = 0.5 Else Selection.Font.Spacing = 0
Next i
Selection.Collapse (wdCollapseEnd)
If mm < 12 Then Selection.InsertAfter vbCrLf
If mm = 6 Then

Selection.Font.Size = mlfont '17
Selection.InsertBreak (wdColumnBreak)

End If

Next mm

End Sub

- - - - - - - - - - - - - - - - - -

Eric Gans / gans@humnet.ucla.edu
Last updated: