Code:
Private Sub Command0_Click()
Dim WordApp As Word.Application
Dim doc As Word.Document
Dim db As DAO.Database
Dim rst1 As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim fld As Field
Dim intLoop As Integer
Dim intLoop2 As Integer
Dim x As Integer
'Check to see if Word is already running and either Get or Create a new instance
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set WordApp = CreateObject("Word.Application")
End If
Set doc = WordApp.Documents.Add
With WordApp
.Visible = True
.Activate
.WindowState = wdWindowStateNormal
End With
'Set line spacing and alignment
With WordApp.Selection.ParagraphFormat
.LeftIndent = InchesToPoints(0)
.RightIndent = InchesToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = InchesToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
End With
WordApp.Selection.Font.Name = "Calibri"
WordApp.Selection.Font.Size = 11
Set db = CurrentDb()
Set rst1 = db.OpenRecordset("SessionsList_Qry")
Set rst2 = db.OpenRecordset("PresenterData_Query")
x = 1
xy = x + 1
'Outer Loop
If rst1.RecordCount = 0 Then Exit Sub
rst1.MoveFirst
Do Until rst1.EOF
Set Para1 = doc.Content.Paragraphs.Add
Para1.Range.InsertParagraphAfter
Para1.Range.Font.Size = "14"
Para1.Range.Font.Bold = True
Para1.Range.Text = "Session Proof Report"
Para1.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
Set Para2 = doc.Content.Paragraphs.Add
Para2.Range.InsertParagraphAfter
Para2.Range.Font.Size = "12"
Para2.Range.Font.Bold = True
Para2.Range.Text = "2013 National Pharmacy Preceptors Conference"
Para2.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
'Insert a blank line between previous paragraph and table
Set Para3 = doc.Content.Paragraphs.Add
Para3.Range.Font.Size = "11"
Para3.Range.Font.Bold = False
Para3.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
'Insert Table
Set Para4 = doc.Content.Paragraphs.Add
Para4.Range.InsertParagraphAfter
Para4.Range.Tables.Add Range:=Para4.Range, NumRows:=7, NumColumns:= _
2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
False
With Para4.Range.Tables(1)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
'Add Text to Table
intLoop = x
With WordApp.ActiveDocument.Tables(intLoop)
.Columns(1).SetWidth ColumnWidth:=144, RulerStyle:=wdAdjustProportional
.Cell(1, 1).Range.Bold = True
.Cell(1, 1).Range.InsertAfter "Session Number:"
.Cell(1, 2).Range.InsertAfter Nz((rst1![SessionNum]), "")
.Cell(2, 1).Range.Bold = True
.Cell(2, 1).Range.InsertAfter "Project Manager:"
.Cell(2, 2).Range.InsertAfter Nz((rst1![PM]), "")
.Cell(3, 1).Range.Bold = True
.Cell(3, 1).Range.InsertAfter "Session Title:"
.Cell(3, 2).Range.InsertAfter Nz((rst1![SessionTitle]), "")
.Cell(4, 1).Range.Bold = True
.Cell(4, 1).Range.InsertAfter "Day/Time:"
.Cell(4, 2).Range.InsertAfter Nz((Format(rst1![Date], "Long Date")), "") & " | " & Nz((Format(rst1![StartTime], "h:nn AM/PM")), "") & " - " & Nz((Format(rst1![EndTime], "h:nn AM/PM")), "")
.Cell(5, 1).Range.Bold = True
.Cell(5, 1).Range.InsertAfter "Repeat Day/Time:"
.Cell(5, 2).Range.InsertAfter Nz((rst1![Repeat_Span]), "")
.Cell(6, 1).Range.Bold = True
.Cell(6, 1).Range.InsertAfter "ACPE Activity #:"
.Cell(6, 2).Range.InsertAfter Nz((rst1![ACPE_Formatted]), "")
.Cell(7, 1).Range.Bold = True
.Cell(7, 1).Range.InsertAfter "Learning Objectives:"
.Cell(7, 2).Range.InsertAfter Nz((rst1![LO1]), "") & vbCrLf & vbCrLf & Nz((rst1![LO2]), "") & vbCrLf & vbCrLf & Nz((rst1![LO3]), "") & vbCrLf & vbCrLf & Nz((rst1![LO4]), "") & vbCrLf & vbCrLf & Nz((rst1![LO5]), "")
End With
'Inner Loop
If rst2.RecordCount = 0 Then Exit Sub
rst2.MoveFirst
Do Until rst2.EOF
If rst1![SessionID] = rst2![SessionID] Then
'Insert second table
Set Para5 = doc.Content.Paragraphs.Add
Para5.Range.InsertParagraphAfter
Para5.Range.Tables.Add Range:=Para5.Range, NumRows:=3, NumColumns:= _
2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
False
With Para5.Range.Tables(2)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
'Add Text to Table
intLoop2 = xy
With WordApp.ActiveDocument.Tables(intLoop2)
.Columns(1).SetWidth ColumnWidth:=144, RulerStyle:=wdAdjustProportional
.Cell(1, 1).Range.Bold = True
.Cell(1, 1).Range.InsertAfter "Presenter:"
.Cell(1, 2).Range.InsertAfter Nz((rst2![FullName_Credentials]), "")
.Cell(2, 1).Range.Bold = True
.Cell(2, 1).Range.InsertAfter "Email:"
.Cell(2, 2).Range.InsertAfter Nz((rst2![Email]), "")
.Cell(3, 1).Range.Bold = True
.Cell(3, 1).Range.InsertAfter "Primary Position:"
.Cell(3, 2).Range.InsertAfter Nz((rst2![Primary_Position]), "")
End With
End If
rst2.MoveNext
xy = xy + 1
Loop
'Page Break
Set Para9 = doc.Content.Paragraphs.Add
Para9.Range.InsertParagraphAfter
Para9.Range.InsertBreak Type:=wdPageBreak
rst1.MoveNext
x = xy + 1
Loop
rst1.Close
rst2.Close
Set rst1 = Nothing
Set rst2 = Nothing
Set db = Nothing
Set doc = Nothing
Set WordApp = Nothing
End Sub