Thanks for taking a look.
You asked for it. The sections that I am concerned with are tagged with
'*****
Public Sub AWFC_Word_Doc2()
Dim strSQL As String, varCriteria As Variant
Dim rs As DAO.Recordset, rs_Sub As DAO.Recordset
Dim intLoopCount As Integer
Dim strText As String
Dim bDuplex As Boolean, bUseColors As Boolean
Dim appWord As Object
Dim wdDoc As Object
Dim oRng As Object
Dim bWordWasOpen As Boolean
Dim lngErr As Long
On Error GoTo ProcError
'Open the form for selecting some of the document options
DoCmd.OpenForm "frm_Word_Doc_Options", , , , , acDialog
If IsLoaded("frm_Word_Doc_Options") = False Then
Exit Sub
Else
bDuplex = Form_frm_Word_Doc_Options.chk_Duplex
bUseColors = Form_frm_Word_Doc_Options.chk_Use_Colors
DoCmd.Close acForm, "frm_Word_Doc_Options"
End If
'Open Word (Error handler takes care of situation where Word is not
already open
bWordWasOpen = True
Set appWord = GetObject(, "Word.Application")
appWord.Visible = True
Set wdDoc = appWord.Documents.Add(, , , True)
'Set the top and bottom margins to 1/2"
With wdDoc.Application.Selection
' With wdDoc.ActiveWindow.Selection
.PageSetup.TopMargin = 36
.PageSetup.BottomMargin = 36
End With
'Set the paragraph line formatting
With wdDoc.Application.Selection.ParagraphFormat
' With wdDoc.ActiveWindow.Selection.ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
End With
'Set the page footer formatting
Set oRng = wdDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
With wdDoc.Fields
.Add Range:=oRng, Type:=wdFieldPage
With oRng
.Collapse Direction:=wdCollapseEnd
.InsertBefore Text:=vbTab
.Collapse Direction:=wdCollapseEnd
End With
.Add Range:=oRng, Type:=wdFieldDate
End With
'Open thre recordset of AWFCs, based on the items selected in the list
varCriteria = Null
varCriteria = "[LD_ID] " +
fnMultiList(Form_frm_LD_Wizard.lst_Reports_AWFCs_and_LDs)
strSQL = "SELECT * FROM qry_rpt_AWFC_Word_Doc " & ("WHERE " +
varCriteria)
Set rs = CurrentDb.OpenRecordset(strSQL, , dbFailOnError)
While Not rs.EOF
DoEvents
With wdDoc.Application.Selection
' With wdDoc.ActiveWindow.Selection
Call BoldUnderText(wdDoc, "AWFC #:")
.TypeText Text:=" " & Nz(rs("LD_NUM"), "")
.TypeParagraph
.TypeParagraph
Call BoldUnderText(wdDoc, "AWFC Title:")
.TypeText Text:=" " & Nz(rs("LD_Name"), "")
.TypeParagraph
.TypeParagraph
Call BoldUnderText(wdDoc, "Warfighting Function/Focus area:")
.TypeText Text:=" " & Nz(rs("Learning_Objective"), "")
.TypeParagraph
.TypeParagraph
Call BoldUnderText(wdDoc, "Statement:")
.TypeParagraph
.TypeText Text:=Nz(rs("LD_Desc"), "")
.TypeParagraph
.TypeParagraph
Call BoldUnderText(wdDoc, "Lead:")
.TypeText Text:=" " & Nz(rs("Lead_Org"), "")
.TypeParagraph
.TypeParagraph
Call BoldUnderText(wdDoc, "Support:")
.TypeText Text:=" " & Nz(rs("Spt_Org"), "")
.TypeParagraph
.TypeParagraph
'Get the learning demands for this AWFC
'Color code them based on status (Accepted-black, Rejected-Red,
Other-blue)
Call BoldUnderText(wdDoc, "Learning Demands:")
.TypeParagraph
intLoopCount = 0
strSQL = "SELECT [LD_DESC], [Status], [ColorCode] " _
& "FROM tbl_Learning_Demands LEFT JOIN
tbl_lookup_LD_Status " _
& "ON tbl_Learning_Demands.Status_ID =
tbl_lookup_LD_Status.Status_ID " _
& "WHERE [Parent_ID] = " & rs("LD_ID")
Set rs_Sub = CurrentDb.OpenRecordset(strSQL, , dbFailOnError)
While Not rs_Sub.EOF
intLoopCount = intLoopCount + 1
If bUseColors = True Then .Font.Color = rs_Sub("ColorCode")
.TypeText Text:=intLoopCount & ". " & rs_Sub("LD_Desc")
.Font.Color = 0
.TypeParagraph
.TypeParagraph
rs_Sub.MoveNext
Wend
rs_Sub.Close
Set rs_Sub = Nothing
'*****
'Get the reference info
Call BoldUnderText(wdDoc, "Source/Reference for AWFC:")
intLoopCount = 0
If IsNullOrBlank(Replace(Nz(rs("LD_Strat"), ""), ".", "")) =
False Then
.TypeText Text:=vbCrLf & "Strategic Documents: " &
rs("LD_Strat")
intLoopCount = 1
End If
If IsNullOrBlank(Replace(Nz(rs("LD_Concept"), ""), ".", "")) =
False Then
.TypeText Text:=vbCrLf & "Concepts: " & rs("LD_Concept")
intLoopCount = 1
End If
If IsNullOrBlank(Replace(Nz(rs("LD_SptDoc"), ""), ".", "")) =
False Then
.TypeText Text:=vbCrLf & "Other: " & rs("LD_SptDoc")
intLoopCount = 1
End If
If intLoopCount = 0 Then .TypeText Text:=" None listed"
.TypeParagraph
.TypeParagraph
'*****
'Get the existing efforts for this learning demand
Call BoldUnderText(wdDoc, "Existing Efforts:")
intLoopCount = 0
strSQL = "SELECT Solution FROM tbl_LD_Solutions WHERE [LD_ID] =
" & rs("LD_ID") _
& " ORDER BY tbl_LD_Solutions.Created"
Set rs_Sub = CurrentDb.OpenRecordset(strSQL, , dbFailOnError)
While Not rs_Sub.EOF
If IsNullOrBlank(rs_Sub("Solution")) = False Then
intLoopCount = intLoopCount + 1
.TypeText Text:=vbCrLf & intLoopCount & ". " &
rs_Sub("Solution")
End If
rs_Sub.MoveNext
Wend
If intLoopCount = 0 Then .TypeText Text:=" None provided"
rs_Sub.Close
Set rs_Sub = Nothing
.TypeParagraph
.TypeParagraph
'*****
Call BoldUnderText(wdDoc, "Assessment:")
.TypeParagraph
.TypeParagraph
Call BoldUnderText(wdDoc, "Drafted by:")
.TypeText Text:=" " & Nz(rs("POC"), "")
.TypeParagraph
rs.MoveNext
'Insert a page break to start each AWFC on a new page
'Make sure that each AWFC starts on an odd page number (for
duplex printing)
If rs.EOF Then
'dont add any more pagebreaks
ElseIf (bDuplex = True) And
(.Information(wdActiveEndPageNumber) Mod 2 = 1) Then
.InsertBreak Type:=wdPageBreak
.InsertBreak Type:=wdPageBreak
Else
.InsertBreak Type:=wdPageBreak
End If
End With
Wend
ProcExit:
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
If Not rs_Sub Is Nothing Then
rs_Sub.Close
Set rs_Sub = Nothing
End If
If Not wdDoc Is Nothing Then Set wdDoc = Nothing
If Not appWord Is Nothing Then Set appWord = Nothing
MsgBox "Done!"
Exit Sub
ProcError:
If Err.Number = 429 Then
bWordWasOpen = False
Set appWord = CreateObject("Word.Application")
Resume Next
Else
Debug.Print Err.Number, Err.Description
MsgBox Err.Number & vbCrLf & Err.Description
Resume ProcExit
End If
End Sub
Doug Robbins - Word MVP said:
Better if you show use the code that you are using.
--
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, originally posted via msnews.microsoft.com
I'm creating a Word document via Access VBA.
