Felder aktualisieren (II)

In  Felder aktualisieren habe ich gezeigt, wie sich alle Felder in den verschiedenen Bereichen eines Dokumentes aktualisieren lassen.

Leider werden mit diesem Makro nicht die Felder in den Kopf- und Fußzeilen berücksichtigt, die sich in Textfeldern (TextFrame) befinden (über die Symbolleiste "Zeichnen" eingefügt).

Diese Textfelder gehören zum Shape-Objekt. Zählt man aber die Shapes in einem Dokument über

MsgBox ActiveDocument.Shapes.Count

werden die Textfelder in den Kopf- und Fußzeilen nicht mitberücksichtigt!
Auch der Versuch in den StoryRanges über das ShapeRange -Objekt diese Textfelder zu erfassen schlägt fehl.

Damit verbleibt nur der Weg alle Headers- und Footers-Objekte aller Dokumentabschnitte explizit zu durchlaufen und dort die Shapes zu zählen.

Da ein Shape-Objekt nicht zwangsläufig ein Textfeld zu beinhalten braucht, muss jedes Shape-Objekt noch dahingehend mit der HasText-Eigenschaft überprüft werden, ob es Text beinhaltet.

Das folgende Beispiel durchläuft nun neben dem gesamten Dokument auch die Kopf- und Fußzeilen, überprüft ob dort Textfelder mit Text enthalten sind und aktualisiert alle Felder auch in diesen Bereichen.

Sub AlleFelderMitTextfeldernAktualisieren()  
Dim rngDoc As Range
Dim oDoc As Document
Dim docSec As Section
Dim oHF As HeaderFooter
Dim shp As Shape
Set oDoc = ActiveDocument
For Each docSec In oDoc.Sections
  For Each oHF In docSec.Headers
    For Each shp In oHF.Shapes
        With shp.TextFrame
          If .HasText Then
            .TextRange.Fields.Update
          End If
        End With
    Next shp
  Next oHF
  For Each oHF In docSec.Footers
    For Each shp In oHF.Shapes
        With shp.TextFrame
          If .HasText Then
            .TextRange.Fields.Update
          End If
        End With
    Next shp
  Next oHF
  For Each rngDoc In oDoc.StoryRanges
    rngDoc.Fields.Update
    While Not (rngDoc.NextStoryRange Is Nothing)
      Set rngDoc = rngDoc.NextStoryRange
      rngDoc.Fields.Update
    Wend
  Next rngDoc
Next docSec
Set rngDoc = Nothing
Set oDoc = Nothing
End Sub