Microsoft Office Forums - View Single Post - [Solved] Macro to Add Text and Page Number to Top of Each Page Within Text

macropod · 12-07-2012, 08:13 PM

Try the following macro:

Code:

Sub ApplyPageNos()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long, StrTxt As String
StrTxt = "Page: "
With ActiveDocument
  .Fields.Unlink
  For i = (.ComputeStatistics(wdStatisticPages) - 1) To 1 Step -1
    Set Rng = .GoTo(What:=wdGoToPage, Name:=i)
    Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
    With Rng
      .End = .End - 1
      If .Characters.Last.Text <> Chr(13) Then
        .Characters.Last.InsertAfter vbCr
      End If
      .InsertAfter vbCr & StrTxt & i + 1
    End With
  Next
  .Range.InsertBefore vbCr & StrTxt & "1"
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

Note that it's necessary to unlink fields in the document; otherwise fields that span page breaks will invalidate the code for those pages. Even so, this doesn't convert bibliographies & citations to plain text. Likewise, the code won't work with endnotes (and even footnotes spanning page breaks won't be handled properly). You may also get odd results if a table spans a page break.

In reality, probably the safest way to do what you're after would be to convert the documents, with page #s in the headers, to PDF, then extract the content from there.