--------------------------------------------------------------------------------
Добавлено сообщение
--------------------------------------------------------------------------------
Вот так можно скопировать в буфер обмена Office все верхние колонтитулы. Только при этом должен быть открыт Буфер обмена:
Код: Выделить всё
Sub CopyHeadersFooters()
Dim oSec As Section, oHeadr As HeaderFooter
For Each oSec In ActiveDocument.Sections
For Each oHeadr In oSec.Headers
oHeadr.Range.Copy
Next oHeadr
Next oSec
End Sub--------------------------------------------------------------------------------
Добавлено сообщение
--------------------------------------------------------------------------------
Вот насочинял (только делается при открытом буфере обмена):
Код: Выделить всё
Sub HeaderCopy()
On Error GoTo footercopy
Selection.HomeKey Unit:=wdStory
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Do
Selection.WholeStory
Selection.Copy
ActiveWindow.ActivePane.View.NextHeaderFooter
Loop
footercopy:
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Application.Run "footercopy"
End Sub
Sub footercopy()
On Error GoTo ExitSub
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Do
Selection.WholeStory
Selection.Copy
ActiveWindow.ActivePane.View.NextHeaderFooter
Loop
ExitSub:
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub