View Single Post
  #2   Report Post  
Posted to microsoft.public.word.tables
Doug Robbins - Word MVP
 
Posts: n/a
Default Does anyone have a one page 2006 -2007 school year calendar?

You could use the following macro to create single page calendars for 2006
and 2007 and then delete the first six months from the 2006 calendar and
copy and paste the first six months from the 2007 onto the 2006 to get both
half years on the one calendar:

Sub CalendarMaker()
' 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
End Sub



--
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

"PTAMom" wrote in message
...
I am looking for a single page template for the 2006-2007 school year.
There
is a 2005-2006 school year template online that worked for last year - I
am
just looking for an update. Thanks!