Word 2K: Mixed font size within table cell

[CharterOak]

I am creating a birthday calendar using VBA. Each day (cell) in the calendar
(table) contains a number for the day-of-month followed by the names of any
persons having a b-day on that day. Each name appears on a separate line
within the cell. I want to reduce the font size used for the names in order
to prevent them from wrapping within the cell. I then want to return to the
previous font size when moving to the next cell and inserting the next
day-of-month number. How do I accomplish this?

 

[Doug Robbins - Word MVP]

It would be easier to give appropriate advice if you provided the code from
your macro. Copy and paste it into a message that you post back here.

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

 

[CharterOak]

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