Sub TestVormen()
Dim iSectionCount As Integer
Dim NextSectCount As Integer
Dim i As Integer
Dim SectShapes As Integer
Dim shp As Shape
Dim NewName As String
iSectionCount = ActiveDocument.Sections.Count
For i = 1 To iSectionCount
Selection.GoTo wdGoToSection, Which:=(i)
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
'Count the shapes in the headers of the current section
SectShapes = ActiveDocument.Sections(i).Headers(wdHeaderFooterFirstPage).Shapes.Count
If SectShapes > 0 Then
For Each shp In ActiveDocument.Sections(i).Headers(wdHeaderFooterFirstPage).Shapes
NewName = InputBox("Typ de nieuwe naam voor het object", "NieuweNaam", shp.Name)
With shp
.Name = NewName
.Height = 36
End With
If shp.Name Like "PowerPlusWatermarkDraft*" Then
shp.Height = 36
shp.Delete
End If
Next shp
End If
'Go to next header. If same section, must have "first page headers different" (or "Odd" and "Even" page headers)
'Could therefore have 2 headers in only 1 section (like letters)
'ActiveWindow.ActivePane.View.NextHeaderFooter
NextSectCount = Selection.Information(wdActiveEndSectionNumber)
If NextSectCount = i Then
SectShapes = ActiveDocument.Sections(i).Headers(wdHeaderFooterFirstPage).Shapes.Count
MsgBox "Section " & i & " contains " & SectShapes & " Shapes"
'reset nextSectCount for the next check it makes
NextSectCount = 0
End If
Next i
End Sub