Dim appWord As Word.Application
Dim doc As Word.Document
Dim rngWord As Word.Range
Dim rst As New ADODB.Recordset
Dim strSelect As String
Dim intMonth As Integer
Dim intCount As Integer
'check for null controls
If IsNull(Me.cboCustomer) Or IsNull(Me.lstYear) Then
MsgBox "You must pick the customer " _
& "and year you want to print.", vbOKOnly
GoTo ExitProfile
End If
On Error Resume Next
'set appWord to current Word instance or create new one
Set appWord = GetObject(, "Word.application")
If Err = 429 Then
Set appWord = New Word.Application
End If
On Error GoTo ErrorHandler
'create new document based on template and clear default text
appWord.Visible = True
appWord.ScreenUpdating = False
Set doc = appWord.Documents.Add
'Set document title
Set rngWord = doc.Range(0)
With rngWord
.Text = Me.cboCustomer.Column(1) _
& " " & Me.lstYear & " Customer Profile"
.Style = doc.Styles("Title")
.InsertParagraphAfter
End With
'insert blurb
rst.Open "SELECT ProfileHeading FROM tblHeading", _
CurrentProject.Connection, adOpenStatic
intCount = doc.Paragraphs.Count
Set rngWord = doc.Paragraphs(intCount).Range
With rngWord
.Style = doc.Styles("Normal")
.InsertAfter rst.Fields("ProfileHeading")
.InsertParagraphAfter
rst.Close
'replace placeholders
With .Find
.MatchWholeWord = True
.Text = "[CustomerName]"
.Replacement.Text = Me.cboCustomer.Column(1)
.Replacement.Font.Italic = True
.Execute Replace:=wdReplaceAll
.Text = "[Year]"
.Replacement.Text = Me.lstYear
.Replacement.Font.Italic = False
.Execute Replace:=wdReplaceAll
End With
End With
'retrieve sales
For intMonth = 1 To 12
intCount = doc.Paragraphs.Count
Set rngWord = doc.Paragraphs(intCount).Range
'add month heading in Word
With rngWord
.InsertParagraphAfter
.Move wdParagraph
.Style = doc.Styles("Heading 2")
.InsertAfter Format(intMonth & "/01/2000", "MMMM")
.InsertParagraphAfter
End With
strSelect = "SELECT ProductName, SumofQuantity FROM qryUnitsSold " _
& "WHERE CustomerID = """ & Me.cboCustomer & """ AND " _
& "SalesMonth = " & intMonth _
& " AND SalesYear = " & Me.lstYear
rst.Open strSelect, CurrentProject.Connection, adOpenDynamic
'add product sales info
If rst.EOF Then
With rngWord
.Move wdParagraph
.Style = doc.Styles("Caption")
.InsertAfter "No Sales To Customer During This Month"
.InsertParagraphAfter
End With
Else
With rngWord
.Move wdParagraph
.Style = doc.Styles("Normal")
.InsertAfter "Units Sold" & vbTab & "Product Name"
.Font.Bold = True
.InsertParagraphAfter
End With
Do While Not rst.EOF
With rngWord
.Move wdParagraph
.Style = doc.Styles("Normal")
.InsertAfter rst.Fields("SumOfQuantity") _
& vbTab & vbTab & rst.Fields("ProductName")
.InsertParagraphAfter
rst.MoveNext
End With
Loop
End If
rst.Close
Next intMonth
MsgBox "Profile Complete", vbOKOnly
appWord.ScreenUpdating = True
ExitProfile:
Set rst = Nothing
Set rngWord = Nothing
Set doc = Nothing
Set appWord = Nothing
Exit Sub
ErrorHandler:
If Err = 5941 Then
Resume Next
Else
MsgBox Err & Err.Description
Resume ExitProfile
End If