insert multiple documents into document retaining headers and foot

[Rocco]

question:
I know how to insert multiple documents and an example is also in the list
below.

Only problem is that when using this method headers and footers are not
retained.
this is caused by the sameasprevious when inserting a sectionbreaknextpage
at the end of of each document.

This means that when I insert for example the second document the header and
footer of the first are being used for the second document.
This is the code from steve lang, only thing adapted is the pagebreak that
is now a sectionbreak, this is needed to keep pagesettings correct:

Sub Foo()
Dim i As Long
Application.ScreenUpdating = False
Documents.Add
With Application.FileSearch
'Search in foldername
.LookIn = "C:\test"
.SearchSubFolders = False
.FileName = "*.doc"
.Execute
For i = 1 To .FoundFiles.Count
If InStr(.FoundFiles(i), "~") = 0 Then
Selection.InsertFile FileName:=(.FoundFiles(i)), _
ConfirmConversions:=False, Link:=False, Attachment:=False
Selection.InsertBreak Type:=wdsectionBreaknextpage
End If
Next i
End With
End Sub


turning off sameasprevious after inserting the doesn't help very much
because at that point the header and footer of the first document are already
used.

Maybe there is a way, that I don't know to bring them back into the previous
state
If been trying all kinds of stuff to get this to work, nothing seems to work
only thing that did work was using a maindocuments and add subdocuments to
it but this was way to slow when you need to append for example 1000
documents.

Please help me on this issue,

 

[Chuck]

Try replacing the InsertFile code:
Selection.InsertFile FileName:=(.FoundFiles(i)), _
ConfirmConversions:=False, Link:=False, Attachment:=False
Selection.InsertBreak Type:=wdsectionBreaknextpage
with the following (the variable declarations should go at the top of the
sub not in the loop of course) - it uses a range instead of selection and
inserts the section break and removes link to previous in the new section's
headers/footers before inserting the new file:

Dim rngRange As Range
Dim hdrHeader As HeaderFooter
Dim ftrFooter As HeaderFooter

With ActiveDocument
Set rngRange = .Range
With rngRange
.Collapse wdCollapseEnd
.InsertBreak _
Type:=wdSectionBreakNextPage
.Collapse wdCollapseEnd
End With
With .Sections(.Sections.Count)
For Each hdrHeader In .Headers
hdrHeader.LinkToPrevious = False
Next hdrHeader
For Each ftrFooter In .Footers
ftrFooter.LinkToPrevious = False
Next ftrFooter
End With
rngRange.InsertFile _
FileName:=(.FoundFiles(i)), _
ConfirmConversions:=False, _
Link:=False, _
Attachment:=False
End With

 

[Rocco]

hi chuck,

Thanx for the fast reply, but no luck this time.
this is the exact code :

MyWrd.Documents.Open(ParResultFile).Activate()
Dim rngRange As Range
Dim hdrHeader As HeaderFooter
Dim ftrFooter As HeaderFooter
With MyWrd.FileSearch
.NewSearch()
.LookIn = path
.SearchSubFolders = False
.FileName = file
.MatchTextExactly = True
.FileType =
Microsoft.Office.Core.MsoFileType.msoFileTypeWordDocuments
If
..Execute(SortBy:=Microsoft.Office.Core.MsoSortBy.msoSortByFileName,
SortOrder:=Microsoft.Office.Core.MsoSortOrder.msoSortOrderAscending) > 0 Then
MsgBox("There were " & .FoundFiles.Count & " file(s) found.")
If AppInteractive Then
frm1.Show()
progressbarform1 = frm1.ProgressBar1
progressbarform1.Maximum = (.FoundFiles.Count)
End If

For i = 1 To .FoundFiles.Count

If AppInteractive Then
frm1.Label1.Text = .FoundFiles(i)
frm1.Label1.Update()
progressbarform1.Value = i
End If
With MyWrd.ActiveDocument
rngRange = .Range
With rngRange

..Collapse(Direction:=WdCollapseDirection.wdCollapseEnd)
.InsertBreak(WdBreakType.wdSectionBreakNextPage)

..Collapse(Direction:=WdCollapseDirection.wdCollapseEnd)
End With
With .Sections.Item(.Sections.Count)
For Each hdrHeader In .Headers
hdrHeader.LinkToPrevious = False
Next hdrHeader
For Each ftrFooter In .Footers
ftrFooter.LinkToPrevious = False
Next ftrFooter
End With
End With
rngRange.InsertFile(.FoundFiles(i),
ConfirmConversions:=False, Link:=False, Attachment:=False)

Next i
Else
Exit Sub ' There were no files found.
End If
.Execute()

MyWrd = Nothing
FSO = Nothing
End With

End Sub


Thanks for thinking along sofar ;o)
If you have the time maybe you can come up with another sollution ?


I hope so cause I can hear the sound of my brain crackin'
================================

 

[Chuck]

Not sure why the code I posted didn't work for you because it works for me.
Are you sure the code you posted below (incorporating a version of what I
posted) is actually doing what it should? For instance, is the range
collapsing properly (I notice you've put parentheses around the .Collapse
argument which may not be helpful)? If you plug in the code as I posted it
(without editing it) does it work?

In any case here's an elaboration of the code I posted. Note the extra
variables. It sets objects pointing to the source and target documents and
then loops through each header in the target to make it equal to the
corresponding header in the source. However the code I posted only takes the
headers from section 1 of the source and if you're inserting a document that
has more than one section and different headers/footers for each of its
sections, then the subsequent section headers/footers (ie sections 2+) won't
be transferred. You could write code extending what I've posted below if you
wanted to capture those possible following headers/footers from the source
doc, but it would get complicated.

There may be a better way but I really don't see why the code I posted
yesterday shouldn't work for you because like I said it works for me...

Dim rngRange As Range
Dim hdrHeader As HeaderFooter
Dim ftrFooter As HeaderFooter
Dim docSource As Document
Dim docTarget As Document
Dim i As Long

'set docTarget first so activedocument
'is not .FoundFiles(i)
Set docTarget = ActiveDocument
Set docSource = Documents.Open(.FoundFiles(i))

With docTarget
Set rngRange = .Range
With rngRange
.Collapse wdCollapseEnd
.InsertBreak _
Type:=wdSectionBreakNextPage
.Collapse wdCollapseEnd
End With
With .Sections(.Sections.Count)
For Each hdrHeader In .Headers
hdrHeader.LinkToPrevious = False
i = hdrHeader.Index
hdrHeader.Range = docSource.Sections(1).Headers(i).Range
Next hdrHeader
For Each ftrFooter In .Footers
ftrFooter.LinkToPrevious = False
i = ftrFooter.Index
ftrFooter.Range = docSource.Sections(1).Headers(i).Range
Next ftrFooter
End With
rngRange.InsertFile _
FileName:=(.FoundFiles(i)), _
ConfirmConversions:=False, _
Link:=False, _
Attachment:=False
End With

docSource.Close wdDoNotSaveChanges