Here is my current code.

Sub ConstructCalendar()
'
' Macro1 Macro
' Macro recorded 4/12/2006 by Michael
'
   
   'Prepare SQL statement to extract names and birthday information
   'from Access database
   Dim strCurrMo As String
   Dim strSQL As String
   
   strCurrMo = DatePart("m", Now())
   strSQL = "SELECT FName, LName, DatePart('d',[DOB]) AS [Bday] "
   strSQL = strSQL & "FROM qryActiveMembersSrtd2 "
   strSQL = strSQL & "WHERE (((DatePart('m',[DOB]))= " & strCurrMo & ")) "
   strSQL = strSQL & "ORDER BY DatePart('d',[DOB]);"
   
   'Connect to Access database
   Dim strDBName As String
   Dim dbe As DAO.DBEngine
   Dim wks As DAO.Workspace
   Dim db As DAO.Database
   Dim rs As DAO.Recordset
   
   strDBName = "C:\Documents and Settings\username\My
Documents\AccessProjects\TOPS.mdb"
   Set dbe = CreateObject("DAO.DBEngine.36")
   Set wks = dbe.Workspaces(0)
   Set db = wks.OpenDatabase(strDBName)

   'Pull data from database into a snapshot recordset
   Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)

   'Create table for calendar and populate cells
   ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=7,
NumColumns:= _
       7, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
       wdAutoFitContent
   Selection.Tables(1).AutoFormat Format:=wdTableFormatElegant,
ApplyBorders _
       :=True, ApplyShading:=True, ApplyFont:=True, ApplyColor:=True, _
       ApplyHeadingRows:=True, ApplyLastRow:=False,
ApplyFirstColumn:=False, _
       ApplyLastColumn:=False, AutoFit:=True
   Selection.MoveRight Unit:=wdCharacter, Count:=7, Extend:=wdExtend
   Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
   Selection.MoveLeft Unit:=wdCharacter, Count:=7, Extend:=wdExtend
   Selection.TypeText Text:="Sunday"
   Selection.MoveRight Unit:=wdCell
   Selection.TypeText Text:="Monday"
   Selection.MoveRight Unit:=wdCell
   Selection.TypeText Text:="Tuesday"
   Selection.MoveRight Unit:=wdCell
   Selection.TypeText Text:="Wednesday"
   Selection.MoveRight Unit:=wdCell
   Selection.TypeText Text:="Thursday"
   Selection.MoveRight Unit:=wdCell
   Selection.TypeText Text:="Friday"
   Selection.MoveRight Unit:=wdCell
   Selection.TypeText Text:="Saturday"
   Selection.MoveRight Unit:=wdCell
   
   Dim str1stOfMo As String
   str1stOfMo = strCurrMo & "/01/06"
   
   Dim intDayOffset As Integer
   intDayOffset = DatePart("w", str1stOfMo) + 6
   
   Dim intDaysInMo As Integer
   Select Case strCurrMo
       Case 1, 3, 5, 7, 8, 10, 12
           intDaysInMo = 31
       Case 4, 6, 9, 11
           intDaysInMo = 30
       Case 2
           intDaysInMo = 28
       Case Else
           MsgBox "Invalid month number."
   End Select
   
   Dim strCellText As String
   Dim IntDay As Integer
   IntDay = 1
   Do While IntDay <= intDaysInMo
   
       'Assemble cell text
       Selection.Tables(1).Range.Cells(intDayOffset + IntDay).Range.Text =
Str(IntDay) & vbCrLf
       Do While Not rs.EOF
           If rs("Bday") = IntDay Then
               Selection.Tables(1).Range.Cells(intDayOffset +
IntDay).Range.Text = Selection.Tables(1).Range.Cells(intDayOffset +
IntDay).Range.Text & rs("FName") & " " & rs("LName") & vbCrLf
               rs.MoveNext
           Else
               Exit Do
           End If
       Loop
       IntDay = IntDay + 1
   Loop
   
   'Release resources acquired for database activities
   rs.Close
   db.Close
   wks.Close
   Set rs = Nothing
   Set db = Nothing
   Set wks = Nothing
       
End Sub