Office: Wasserzeichen mit VBA auf allen Seiten in allen Abschnitten einfügen

Hallo!

In einem Word Dokument mit mehreren Abschnitten (je nach Dokument 3 bis 7) ist jeweils die Option "Erste Seite anders" ausgewählt. Es gibt auf der ersten Seite immer einen Briefkopf und eine Fußzeile, die jedoch nur auf der ersten Seite zu sehen sein soll. In der Fußzeile der restlichen Seiten der Abschnitte wird jeweils die Seitenzahl angezeigt.

Das Wasserzeichen wird mit nachflgenden Code zwar eingefügt, aber nicht auf allen Seiten. Dies liegt vermutlich an der Option "Erste Seite anders". Diese Option soll aber aus den obigen Gründen nicht ausgeschaltet werden.

Kennt jemand eine Möglichkeit das Wasserzeichen trotz "Erste Seite anders" auf allen Seiten einzufügen?

Hier der Code, den ich aktuell verwende. Der Code soll dann in einer Vorlage verwendet werden, deshalb die Zeilen am Anfang.

Code:

Sub Entwurf()
  ' Den Benutzernamen des aktuellen Benutzers abrufen
    Dim userName As String
    userName = Environ("USERNAME")

    ' Der Pfad zur Vorlage mit den Building Blocks
    Dim templatePath As String
    templatePath = "C:\Users\" & userName & "\AppData\Roaming\Microsoft\Document Building Blocks\1031\16\Built-In Building Blocks.dotx"

    ' Die ID des Building Blocks, den du einfügen möchtest
    Dim buildingBlockID As String
    buildingBlockID = "ENTWURF 1"

    ' Den Building Block aus der Vorlage einfügen
    Application.Templates(templatePath).BuildingBlockEntries(buildingBlockID).Insert Where:=Selection.Range, _
        RichText:=True

    ' Zum Kopfbereich der aktuellen Seite wechseln
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

    ' Das benutzerdefinierte Wasserzeichenobjekt auswählen
    On Error Resume Next ' Fehler ignorieren, falls das Wasserzeichenobjekt nicht existiert
    Selection.HeaderFooter.Shapes("ENTWURF").Select
    On Error GoTo 0 ' Fehler wieder aktivieren

    ' Wenn das Wasserzeichenobjekt gefunden wurde, Einstellungen vornehmen
    If Selection.Type = wdSelectionShape Then
        With Selection.ShapeRange
            .Name = "ENTWURF"
            .TextEffect.NormalizedHeight = False
            .Line.Visible = False
            .Fill.Visible = True
            .Fill.Solid
            .Fill.ForeColor.RGB = RGB(192, 192, 192)
            .Fill.Transparency = 0.5
            .Rotation = 315
            .LockAspectRatio = True
            .Height = CentimetersToPoints(6.15)
            .Width = CentimetersToPoints(16.41)
            .WrapFormat.AllowOverlap = True
            .WrapFormat.Side = wdWrapNone
            .WrapFormat.Type = 3
            .RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
            .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
            .Left = wdShapeCenter
            .Top = wdShapeCenter
        End With
    End If

    ' Zum Hauptdokument zurückkehren
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

lg Alex

 

Hallo Alex

deiner Beschreibung nach hast du mindestens 2 verschiedene Kopfzeilen:
Diejenige für die erste Seite, und diejenige für die Folgeseiten. Und, da du mehrere Abschnitte hast, das ganze möglicherweise mal 2. "Möglicherweise" ist nur dann der Fall, wenn du die Verknüpfung ("wie vorherige") zwischen den Abschnitten aufgehoben hast .

Die frohe Botschaft ist indes:
Um diese Kopfzeilen zu erreichen, musst du gar nicht - so wie es der Makrorekorder vorschlägt - per Selection reinhüpfen (ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader), sondern du kannst die direkt als Ranges ansprechen so dass der relevante Teil deines Makros (hier mit Schleife) so eingedampft werden kann:

Code:

With ActiveDocument
    For i = 1 To ActiveDocument.Sections.Count
    
      'Kopfzeile erste Seite
      Application.Templates(templatePath).BuildingBlockEntries(buildingBlockID).Insert Where:= _
        .Sections(i).Headers(wdHeaderFooterFirstPage).Range
      
            'hier die Anpassungen, z.B.
            With ActiveDocument.Sections(i).Headers(wdHeaderFooterFirstPage).Range.ShapeRange(1)
                .Fill.ForeColor.RGB = RGB(192, 192, 192)
                '...
            End With
          
        'Kopfzeile Folgeseiten
        Application.Templates(templatePath).BuildingBlockEntries(buildingBlockID).Insert Where:= _
        .Sections(i).Headers(wdHeaderFooterPrimary).Range
      
        'hier die Anpassungen, z.B.
        With ActiveDocument.Sections(i).Headers(wdHeaderFooterFirstPage).Range.ShapeRange(1)
                .Fill.ForeColor.RGB = RGB(192, 192, 192)
                '...
            End With
    Next i
End With

Die Anpassungen der Shapes kannst du gern in eine eigene Prozedur stecken und vom Hauptmakro aus aufrufen

 

Lieber Gerhard!

Vielen vielen Dank!

Hier hab ich mich von den Abschnitten im Text iritieren lassen. Ich hab zwei verschiedene Kopfzeilen und mehrere Abschnittsumbrüche aber die Verknüpfung zwischen den Abschnitten nie aufgehoben.

Der Zugriff auf die BuildingBlockEntries hat bei mir über VBA leider nur dann funktioniert wenn das zuvor einmal manuell gemacht wurde (also das Wasserzeichen einmal über das Menüband Entwurf Wasserzeichen etc. eingefügt wurde).
Daher habe ich nun eine andere Vorgehensweise gewählt. Wenn jemand das gleiche Problem hat, hier der Code, der bei mir sehr gut funktioniert:

Code:

Sub Wasserzeichen(shapeName As String, headerType As WdHeaderFooterIndex)
    Dim watermarkText As String
    watermarkText = "ENTWURF"
    
    Dim wdShapeCenter As Long
    Dim wdRelativeHorizontalPositionMargin As Long
    Dim wdRelativeVerticalPositionMargin As Long
    
    wdShapeCenter = -999995
    wdRelativeHorizontalPositionMargin = 1
    wdRelativeVerticalPositionMargin = 1
    
    Application.ScreenUpdating = False
    
    With ActiveDocument.Sections(1).Headers(headerType).Shapes.AddTextEffect( _
            PresetTextEffect:=msoTextEffect1, _
            Text:=watermarkText, _
            FontName:="Calibri", _
            FontSize:=1, _
            FontBold:=msoFalse, _
            FontItalic:=msoFalse, _
            Left:=0, Top:=0)

        .Name = shapeName
        .TextEffect.NormalizedHeight = False
        .Line.Visible = False
        .Fill.Visible = True
        .Fill.Solid
        .Fill.ForeColor.RGB = RGB(192, 192, 192)
        .Fill.Transparency = 0.5
        .Rotation = 315
        .LockAspectRatio = True
        .Height = CentimetersToPoints(6.15)
        .Width = CentimetersToPoints(16.41)
        .WrapFormat.AllowOverlap = True
        .WrapFormat.Side = wdWrapNone
        .WrapFormat.Type = 3
        .RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
        .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
        .Left = wdShapeCenter
        .Top = wdShapeCenter
    End With
    
    Application.ScreenUpdating = True
    
End Sub

Sub Entwurf()
    ' Füge Wasserzeichen zur ersten Seite hinzu
    Wasserzeichen "WatermarkText_FirstPage", wdHeaderFooterFirstPage
    
    ' Füge Wasserzeichen zur Hauptseite hinzu
    Wasserzeichen "WatermarkText_MainPage", wdHeaderFooterPrimary
End Sub