how to create a calendar in word

  • Thread starter Thread starter Guest
  • Start date Start date
Yellowle,
There is a wizard available in Word that will do that for you. Don't know
what version you use but you will find it via the new document task pane and
the link for templates, look for the other documents tab.
Luc
 
Yellowle,
Also on the same taskpane there is a link to templates provided from
Microsoft. Download one and you are in business.
Luc
 
Run the following macro to create a "Planner" type calendar.

' Macro created 11/14/98 by Doug Robbins to make calendar
' Modified 11/29/98 to add shading to weekends and "non-date" cells. '
Dim Message, Title, Default, Calyear, Thisyear, nyday
Thisyear = Year(Date)
Message = "Enter the year for which you want to create a calendar" '
Set prompt.
Title = "Calendar Maker" ' Set title.
Default = Thisyear ' Set default.
Calyear = InputBox(Message, Title, Default)
With ActiveDocument.PageSetup
.Orientation = wdOrientLandscape
.TopMargin = CentimetersToPoints(2)
.BottomMargin = CentimetersToPoints(1)
.LeftMargin = CentimetersToPoints(1.5)
.RightMargin = CentimetersToPoints(1)
End With
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=13,
NumColumns _
:=38
Selection.Tables(1).Select
Selection.Cells.SetHeight RowHeight:=38, HeightRule:=wdRowHeightExactly
Selection.Cells.SetWidth ColumnWidth:=CentimetersToPoints(0.65), RulerStyle
_
:=wdAdjustNone
Selection.Rows.SpaceBetweenColumns = CentimetersToPoints(0)
Selection.Font.Size = 8
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.SelectRow
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.SelectColumn
With Selection.Cells
With .Shading
.BackgroundPatternColorIndex = wdTurquoise
End With
End With
Counter = 1
While Counter < 6
Selection.MoveRight Unit:=wdCharacter, Count:=6
Selection.Extend
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.SelectColumn
With Selection.Cells
With .Shading
.BackgroundPatternColorIndex = wdTurquoise
End With
End With
Counter = Counter + 1
Wend
Selection.MoveLeft Unit:=wdCharacter, Count:=36
Dim days$(7)
days$(0) = "Sat": days$(1) = "Sun": days$(2) = "Mon": days$(3) = "Tue":
days$(4) = "Wed": days$(5) = "Thu": days$(6) = "Fri" ': days$(7) = "Sat"

Dim mon$(12)
mon$(1) = "January": mon$(2) = "February": mon$(3) = "March": mon$(4) =
"April": mon$(5) = "May": mon$(6) = "June": mon$(7) = "July": mon$(8) =
"August": mon$(9) = "September": mon$(10) = "October": mon$(11) =
"November": mon$(12) = "December"
Dim monthdays$(12)
If ((Calyear Mod 4 = 0 And Calyear Mod 400 = 0) Or (Calyear Mod 4 = 0
And Calyear Mod 100 <> 0)) Then
monthdays$(1) = "32": monthdays$(2) = "30": monthdays$(3) = "32":
monthdays$(4) = "31": monthdays$(5) = "32": monthdays$(6) = "31":
monthdays$(7) = "32": monthdays$(8) = "32": monthdays$(9) = "31":
monthdays$(10) = "32": monthdays$(11) = "31": monthdays$(12) = "32" Else
monthdays$(1) = "32": monthdays$(2) = "29": monthdays$(3) = "32":
monthdays$(4) = "31": monthdays$(5) = "32": monthdays$(6) = "31":
monthdays$(7) = "32": monthdays$(8) = "32": monthdays$(9) = "31":
monthdays$(10) = "32": monthdays$(11) = "31": monthdays$(12) = "32" End
If
Colno = 1
rowno = 1
While Colno < 38
ActiveDocument.Tables(1).Cell(1, Colno + 1).Range.InsertBefore
days$(Colno Mod 7)
Colno = Colno + 1
Wend
While rowno < 13
ActiveDocument.Tables(1).Cell(rowno + 1, 1).Range.InsertBefore
Left(mon$(rowno), 3)
rowno = rowno + 1
Wend
rowno = 1
While rowno < 13
Counter = 1
dayone = WeekDay(mon$(rowno) & " 1," & Calyear) If dayone
Mod 7 = 0 Then
Colno = 8
Else
Colno = (dayone Mod 7) + Counter
End If
Painter = 2
While Painter < Colno
ActiveDocument.Tables(1).Cell(rowno + 1,
Painter).Shading.BackgroundPatternColorIndex = wdTurquoise
Painter = Painter + 1
Wend
While Counter < Val(monthdays$(rowno))
ActiveDocument.Tables(1).Cell(rowno + 1,
Colno).Range.InsertBefore Counter
Colno = Colno + 1
Counter = Counter + 1
Wend
While Colno < 39
ActiveDocument.Tables(1).Cell(rowno + 1,
Colno).Shading.BackgroundPatternColorIndex = wdTurquoise
Colno = Colno + 1
Wend
rowno = rowno + 1
Wend
Selection.SelectRow
Selection.Cells.HeightRule = wdRowHeightAuto
Selection.InsertRows 1
Selection.Cells.Merge
Selection.Font.Size = 18
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.InsertAfter Calyear



--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP
 
Back
Top