| Home |
| Search |
| Today's Posts |
|
#1
Posted to microsoft.public.word.docmanagement,microsoft.public.word.vba.general
|
|||
|
|||
Keeping text together on page (Office 2007)
I'm creating a Word document via Access VBA.
I have several instances where I want to ensure the text at the end of a section is on the same page as the header of that section, and the text in each section should never exceed a full page. I've figured out how to use .Information( ) to get the line number of the cursor as I build the document, so I can save the line number of the 'section header' and then check to see whether the line number at the end of the section is greater than that of the header. If not, I can assume the text has wrapped over a page break. What I'm looking for is an way to back my cursor up when this happens and then insert lines (or a page break) until the 'section header' line starts at the top of the next page. ---- Dale |
|
#2
Posted to microsoft.public.word.docmanagement,microsoft.public.word.vba.general
|
|||
|
|||
|
Keeping text together on page (Office 2007)
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 "Dale Fye" wrote in message ... I'm creating a Word document via Access VBA. I have several instances where I want to ensure the text at the end of a section is on the same page as the header of that section, and the text in each section should never exceed a full page. I've figured out how to use .Information( ) to get the line number of the cursor as I build the document, so I can save the line number of the 'section header' and then check to see whether the line number at the end of the section is greater than that of the header. If not, I can assume the text has wrapped over a page break. What I'm looking for is an way to back my cursor up when this happens and then insert lines (or a page break) until the 'section header' line starts at the top of the next page. ---- Dale |
|
#3
Posted to microsoft.public.word.docmanagement,microsoft.public.word.vba.general
|
|||
|
|||
|
Keeping text together on page (Office 2007)
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).R ange 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_a nd_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" wrote in message ... 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 "Dale Fye" wrote in message ... I'm creating a Word document via Access VBA. I have several instances where I want to ensure the text at the end of a section is on the same page as the header of that section, and the text in each section should never exceed a full page. I've figured out how to use .Information( ) to get the line number of the cursor as I build the document, so I can save the line number of the 'section header' and then check to see whether the line number at the end of the section is greater than that of the header. If not, I can assume the text has wrapped over a page break. What I'm looking for is an way to back my cursor up when this happens and then insert lines (or a page break) until the 'section header' line starts at the top of the next page. ---- Dale |
|
#4
Posted to microsoft.public.word.docmanagement,microsoft.public.word.vba.general
|
|||
|
|||
|
Keeping text together on page (Office 2007)
Try something like this (just one of your sections modified)
'***** Set oRng = wdDoc.Range oRng.Collapse wdCollapseEnd strText = "" 'Get the reference info Call BoldUnderText(wdDoc, "Source/Reference for AWFC:") intLoopCount = 0 If IsNullOrBlank(Replace(Nz(rs("LD_Strat"), ""), ".", "")) = False Then strText = strText & vbCrLf & "Strategic Documents: " & rs("LD_Strat") intLoopCount = 1 End If If IsNullOrBlank(Replace(Nz(rs("LD_Concept"), ""), ".", "")) = False Then strText = strText & vbCrLf & "Concepts: " & rs("LD_Concept") intLoopCount = 1 End If If IsNullOrBlank(Replace(Nz(rs("LD_SptDoc"), ""), ".", "")) = False Then strText = strText & vbCrLf & "Other: " & rs("LD_SptDoc") intLoopCount = 1 End If If intLoopCount = 0 Then strText = strText & " None listed" strText = strText & vbCr & vbCr oRng.Text = strText For i = 1 To oRng.Paragraphs.Count - 1 oRng.Paragraphs(i).KeepWithNext = True Next i oRng.Paragraphs(i + 1).KeepWithNext = False It will be a lot easier to get the syntax correct if you use Early rather than Late Binding as for example, oRng.Collapse wdCollapseEnd may not be the correct syntax for use with Late Binding -- 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 "Dale Fye" wrote in message ... 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).R ange 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_a nd_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" wrote in message ... 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 "Dale Fye" wrote in message ... I'm creating a Word document via Access VBA. I have several instances where I want to ensure the text at the end of a section is on the same page as the header of that section, and the text in each section should never exceed a full page. I've figured out how to use .Information( ) to get the line number of the cursor as I build the document, so I can save the line number of the 'section header' and then check to see whether the line number at the end of the section is greater than that of the header. If not, I can assume the text has wrapped over a page break. What I'm looking for is an way to back my cursor up when this happens and then insert lines (or a page break) until the 'section header' line starts at the top of the next page. ---- Dale |
|
#5
Posted to microsoft.public.word.docmanagement,microsoft.public.word.vba.general
|
|||
|
|||
|
Keeping text together on page (Office 2007)
Hi Doug,
I have another question in a similar subject... I am creating a word document from an access database. I have different styles to each column I am inserting to the word document from accress. for example: The title style is: Hebterm the text style is: Hebtext How do I create a situation (with macro) that if the title is at the end of a page and the text is in the next page - moove the title to the same page of the text? thank you for your help Iris "Doug Robbins - Word MVP" wrote: Try something like this (just one of your sections modified) '***** Set oRng = wdDoc.Range oRng.Collapse wdCollapseEnd strText = "" 'Get the reference info Call BoldUnderText(wdDoc, "Source/Reference for AWFC:") intLoopCount = 0 If IsNullOrBlank(Replace(Nz(rs("LD_Strat"), ""), ".", "")) = False Then strText = strText & vbCrLf & "Strategic Documents: " & rs("LD_Strat") intLoopCount = 1 End If If IsNullOrBlank(Replace(Nz(rs("LD_Concept"), ""), ".", "")) = False Then strText = strText & vbCrLf & "Concepts: " & rs("LD_Concept") intLoopCount = 1 End If If IsNullOrBlank(Replace(Nz(rs("LD_SptDoc"), ""), ".", "")) = False Then strText = strText & vbCrLf & "Other: " & rs("LD_SptDoc") intLoopCount = 1 End If If intLoopCount = 0 Then strText = strText & " None listed" strText = strText & vbCr & vbCr oRng.Text = strText For i = 1 To oRng.Paragraphs.Count - 1 oRng.Paragraphs(i).KeepWithNext = True Next i oRng.Paragraphs(i + 1).KeepWithNext = False It will be a lot easier to get the syntax correct if you use Early rather than Late Binding as for example, oRng.Collapse wdCollapseEnd may not be the correct syntax for use with Late Binding -- 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 "Dale Fye" wrote in message ... 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).R ange 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_a nd_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" wrote in message ... 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 "Dale Fye" wrote in message ... I'm creating a Word document via Access VBA. |
|
#6
Posted to microsoft.public.word.docmanagement
|
|||
|
|||
|
Keeping text together on page (Office 2007)
Add keep with next to the settings in the title style.
Pam iris wrote: Hi Doug, I have another question in a similar subject... I am creating a word document from an access database. I have different styles to each column I am inserting to the word document from accress. for example: The title style is: Hebterm the text style is: Hebtext How do I create a situation (with macro) that if the title is at the end of a page and the text is in the next page - moove the title to the same page of the text? thank you for your help Iris Try something like this (just one of your sections modified) [quoted text clipped - 273 lines] I'm creating a Word document via Access VBA. -- Message posted via http://www.officekb.com |
|
#7
Posted to microsoft.public.word.docmanagement,microsoft.public.word.vba.general
|
|||
|
|||
|
Keeping text together on page (Office 2007)
The Hebterm style should be defined so that it is Kept with next (via the
paragraph formatting dialog). Then you do not need a macro. -- 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 "iris" wrote in message ... Hi Doug, I have another question in a similar subject... I am creating a word document from an access database. I have different styles to each column I am inserting to the word document from accress. for example: The title style is: Hebterm the text style is: Hebtext How do I create a situation (with macro) that if the title is at the end of a page and the text is in the next page - moove the title to the same page of the text? thank you for your help Iris "Doug Robbins - Word MVP" wrote: Try something like this (just one of your sections modified) '***** Set oRng = wdDoc.Range oRng.Collapse wdCollapseEnd strText = "" 'Get the reference info Call BoldUnderText(wdDoc, "Source/Reference for AWFC:") intLoopCount = 0 If IsNullOrBlank(Replace(Nz(rs("LD_Strat"), ""), ".", "")) = False Then strText = strText & vbCrLf & "Strategic Documents: " & rs("LD_Strat") intLoopCount = 1 End If If IsNullOrBlank(Replace(Nz(rs("LD_Concept"), ""), ".", "")) = False Then strText = strText & vbCrLf & "Concepts: " & rs("LD_Concept") intLoopCount = 1 End If If IsNullOrBlank(Replace(Nz(rs("LD_SptDoc"), ""), ".", "")) = False Then strText = strText & vbCrLf & "Other: " & rs("LD_SptDoc") intLoopCount = 1 End If If intLoopCount = 0 Then strText = strText & " None listed" strText = strText & vbCr & vbCr oRng.Text = strText For i = 1 To oRng.Paragraphs.Count - 1 oRng.Paragraphs(i).KeepWithNext = True Next i oRng.Paragraphs(i + 1).KeepWithNext = False It will be a lot easier to get the syntax correct if you use Early rather than Late Binding as for example, oRng.Collapse wdCollapseEnd may not be the correct syntax for use with Late Binding -- 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 "Dale Fye" wrote in message ... 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).R ange 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_a nd_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" wrote in message ... 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 "Dale Fye" wrote in message ... I'm creating a Word document via Access VBA. |
| Reply |
| Thread Tools | |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| how do i fix broken text in office 2007 like in office 2003? | New Users | |||
| Keeping word template to 1 page, each record to start on new page | Mailmerge | |||
| Keeping Text Together | Microsoft Word Help | |||
| Keeping text together | Microsoft Word Help | |||
| Keeping text together on column or page in merged directory. | Mailmerge | |||
Linear Mode
