How to extract headers and footers content into body by VBA?

[Sam1085]

Hi,

I tried to extract headers and footers content into the document body (End of the document).

Code:

Code: Select all

Sub ExtractHeadersAndFooters()
Dim i As Long

' Extract Header
For i = 1 To ActiveDocument.Sections.Count
    With ActiveDocument.Sections(i)
        .Headers(wdHeaderFooterPrimary).Range.Cut
        
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.EscapeKey
    Selection.EndKey Unit:=wdStory
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    End With
Next

' Extract Footer
For i = 1 To ActiveDocument.Sections.Count
    With ActiveDocument.Sections(i)
        .Footers(wdHeaderFooterPrimary).Range.Cut
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.EscapeKey
    Selection.EndKey Unit:=wdStory
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    End With
Next
End Sub

It works as I needed. But it will take 20-30 seconds. Any better way to do the same thing quickly?

Thank you!

[HansV]

Does this work better? It avoids activating and deactivating the header/footer.

Code: Select all

Sub ExtractHeadersAndFooters()
    Dim i As Long

    Application.ScreenUpdating = False

    ' Extract Header
    For i = 1 To ActiveDocument.Sections.Count
        ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range.Cut
        Selection.EndKey Unit:=wdStory
        Selection.Paste
    Next i

    ' Extract Footer
    For i = 1 To ActiveDocument.Sections.Count
        ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary).Range.Cut
        Selection.EndKey Unit:=wdStory
        Selection.Paste
    Next i

    Application.ScreenUpdating = True
End Sub

[Sam1085]

Thank you Hans,

As I tested no time differences between above two codes.

Actually I need this code to develop this macro. Current macro doesn't recognize text color in headers and footers. That's why I'm trying to extract headers and footers to document body.
Forum thread topic: How to determine all RGB color values in Word by a Macro
Forum thread URL: https://www.eileenslounge.com/viewtopic ... 26&t=25841" onclick="window.open(this.href);return false;

Please let me know if you have any better idea to do that.

Thank you!

[HansV]

The following code combines Macropod's code with Using a macro to replace text where ever it appears in a document. It will gather colours from all parts of a document.

Code: Select all

Dim StrClrArr As String
Dim col As Collection

Public Sub GetAllColours()
    Dim rngStory As Word.Range
    Dim lngJunk As Long
    Dim oShp As Shape
    Dim i As Long
    Application.ScreenUpdating = False
    Set col = New Collection
    StrClrArr = ""
    'Fix the skipped blank Header/Footer problem
    lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
    'Iterate through all story types in the current document
    For Each rngStory In ActiveDocument.StoryRanges
        'Iterate through all linked stories
        Do
            FindRGBColours rngStory
            On Error Resume Next
            Select Case rngStory.StoryType
                Case 6, 7, 8, 9, 10, 11 ' Headers and footers
                    If rngStory.ShapeRange.Count > 0 Then
                        For Each oShp In rngStory.ShapeRange
                            If oShp.TextFrame.HasText Then
                                FindRGBColours oShp.TextFrame.TextRange
                            End If
                        Next
                    End If
            End Select
            On Error GoTo 0
            'Get next linked story (if any)
            Set rngStory = rngStory.NextStoryRange
        Loop Until rngStory Is Nothing
    Next rngStory
    Application.ScreenUpdating = True
    For i = 1 To col.Count
        StrClrArr = StrClrArr & vbCrLf & col(i)
    Next i
    MsgBox "Colors:" & vbCrLf & StrClrArr
    Set col = Nothing
End Sub

Sub FindRGBColours(rng As Range)
    Dim StrClr As String, lngColor As Long
    With rng
        .Font.Hidden = False
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .MatchWildcards = True
            .Text = "?"
            .Forward = True
            .Format = True
            .Font.Hidden = False
            .Wrap = wdFindStop
            .Execute
        End With
        Do While .Find.Found
            lngColor = .Font.TextColor
            Select Case .Font.TextColor.Type
                Case msoColorTypeRGB
                    StrClr = GetRGB(.Font.TextColor.RGB)
                Case msoColorTypeScheme
                    StrClr = GetThemeColor(.Font.TextColor.ObjectThemeColor)
                Case Else
                    StrClr = "Other"
            End Select
            On Local Error Resume Next
            col.Add StrClr, StrClr
            On Local Error GoTo 0
            With .Duplicate.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Font.Color = lngColor
                .Replacement.Font.Hidden = True
                .Wrap = wdFindStop
                .Execute Replace:=wdReplaceAll
            End With
            .Collapse wdCollapseEnd
            .Find.Execute
        Loop
    End With
    rng.Font.Hidden = False
End Sub

Function GetRGB(RGBvalue As Long) As String
    Dim StrTmp As String
    If RGBvalue < 0 Or RGBvalue > 16777215 Then RGBvalue = 0
    StrTmp = "R: " & RGBvalue \ 256 ^ 0 Mod 256
    StrTmp = StrTmp & " G: " & RGBvalue \ 256 ^ 1 Mod 256
    StrTmp = StrTmp & " B: " & RGBvalue \ 256 ^ 2 Mod 256
    GetRGB = StrTmp
End Function

Function GetThemeColor(ThemeColor As Long) As String
    Select Case ThemeColor
        Case wdThemeColorAccent1
            GetThemeColor = "Accent color 1"
        Case wdThemeColorAccent2
            GetThemeColor = "Accent color 2"
        Case wdThemeColorAccent3
            GetThemeColor = "Accent color 3"
        Case wdThemeColorAccent4
            GetThemeColor = "Accent color 4"
        Case wdThemeColorAccent5
            GetThemeColor = "Accent color 5"
        Case wdThemeColorAccent6
            GetThemeColor = "Accent color 6"
        Case wdThemeColorBackground1
            GetThemeColor = "Background color 1"
        Case wdThemeColorBackground2
            GetThemeColor = "Background color 2"
        Case wdThemeColorHyperlink
            GetThemeColor = "Hyperlink color"
        Case wdThemeColorHyperlinkFollowed
            GetThemeColor = "Followed hyperlink color"
        Case wdThemeColorMainDark1
            GetThemeColor = "Dark main color 1"
        Case wdThemeColorMainDark2
            GetThemeColor = "Dark main color 2"
        Case wdThemeColorMainLight1
            GetThemeColor = "Light main color 1"
        Case wdThemeColorMainLight2
            GetThemeColor = "Light main color 2"
        Case wdThemeColorText1
            GetThemeColor = "Text color 1"
        Case wdThemeColorText2
            GetThemeColor = "Text color 2"
    End Select
End Function

The two declarations at the beginning should be at the top of the module.

[Sam1085]

Wow this is awesome!

I have customized this code to gather data to excel.

Thank you!