VBA - vorhandenes Wasserzeichen per VBA aus / WZ wieder ein// Probl. mit Abschnittsumbruch

[Hias]

Hallo Zusammen,

ich beschäftige mich nun seit 2 Stunden mit einen Thema, wo ich anfangs dachte es ist sehr schnell und einfach zu realisieren
Aber anscheinend habe ich doch sehr starke Probleme.



1. Ich habe eine .dotm Vorlage mit einen Wasserzeichen "DRAFT" auf jeder Seite (manuell erstellt)

2. Mit Makro Nr. 1 möchte ich das Wasserzeichen löschen

3. Mit Makro Nr. 2 möchte ich das Wasserzeichen wieder einfügen


Dazu habe ich meine manuellen Schritte einfach aufgenommen:

Code:

Sub Wasser_Ein()


'Wasserzeichen "DRAFT" einfügen
    ActiveDocument.Sections(1).Range.Select
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.HeaderFooter.Shapes.AddTextEffect( _
        PowerPlusWaterMarkObject10685288, "DRAFT", "Segoe UI", 1, False, False, _
         0, 0).Select
    Selection.ShapeRange.Name = "PowerPlusWaterMarkObject10685288"
    Selection.ShapeRange.TextEffect.NormalizedHeight = False
    Selection.ShapeRange.Line.Visible = False
    Selection.ShapeRange.Fill.Visible = True
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(192, 192, 192)
    Selection.ShapeRange.Fill.Transparency = 0.5
    Selection.ShapeRange.Rotation = 315
    Selection.ShapeRange.LockAspectRatio = True
    Selection.ShapeRange.Height = CentimetersToPoints(5.64)
    Selection.ShapeRange.Width = CentimetersToPoints(16.91)
    Selection.ShapeRange.WrapFormat.AllowOverlap = True
    Selection.ShapeRange.WrapFormat.Side = wdWrapNone
    Selection.ShapeRange.WrapFormat.Type = 3
    Selection.ShapeRange.RelativeHorizontalPosition = _
        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.RelativeVerticalPosition = _
        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.Left = wdShapeCenter
    Selection.ShapeRange.Top = wdShapeCenter
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

End Sub

Sub Wasser_Aus()


'Wasserzeichen "DRAFT" entfernen
ActiveDocument.Sections(1).Range.Select
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.HeaderFooter.Shapes("PowerPlusWaterMarkObject10685288").Select
Selection.Delete
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

End Sub

Nachdem ich die Vorlage mit dem vorhandenen Wasserzeichen geöffnet habe, will ich nun das Wasserzeichen löschen. So Problem Nr. 1 ist meiner Vermutung nach die rot markierte Zahl. Da die Datei von der Vorlage ursprünglich manuell nicht mit dieser Zahl angelegt wurde.

Gibt es keinen Code der mir einfach alle Wasserzeichen löscht und vorher am besten noch überprüft ob welche vorhanden sind?


Problem Nr. 2 ist, dass die manuelle Setzung des Wasserzeichens einwandfrei und schnell funktioniert, die automatische Setzung kommt aber mit meinen Abschnittsumbruch auf Seite 1 nicht klar und setzt das Wasserzeichen nur auf der ersten Seite.



Ich hoffe mein Text ist jetzt nicht zu lang und zu ausführlich.

Vielleicht habt Ihr einen Tipp für mich.

Danke im Voraus!

Grüße Hias



_____________________________________________________________

Ich habe mich auch schon an folgenden Thread orientiert, leider funktioniert dieser nicht:
http://www.ms-office-forum.net/forum...d.php?t=182212

In dieser Zeile meckert er weil Variable nicht definiert

Code:

Function Wasserzeichen_vorhanden_alle(WasserzeichenObjektName As String) As Boolean

[Hias]

Nachtrag zu dem verlinkten Thread:

Mit Option Explicit ausgeklammert arbeitet das Makro.


Leider aber nicht für meine Bedürfnisse. Das bestehende, manuell erzeugte Wasserzeichen kann nicht gelöscht werden.

Und dann ist da wieder das Problem das er bei einem Abschnittsumbruch stoppt mit dem Wasserzeichen...


Grüße Hias

[Luschi]

Hallo Hias,

schau Dir mal dieses Makro an: h i e r
Da wird ab Codezeile 50 gezeigt, wie man Wasserzeichen löscht.

Gruß von Luschi
aus klein-Paris

[Hias]

Guten Morgen luschi,

dieses Makro ab Zeile 50 funktioniert leider nicht

Fehlermeldung: Die Methode 'Select All' für das Objekt 'Shapes' ist fehlgeschlagen.

Code:

Sub WZ_löschen()


'Wasserzeichen entfernen
'ActiveDocument.Sections(1).Range.Select
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.HeaderFooter.Shapes.SelectAll
Selection.Delete
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

End Sub

Des Weiteren habe ich immer noch die Probleme mit dem Abschnittsumbruch.. Gibt es denn hier keine Möglichkeiten?


Danke und
Viele Grüße
Hias

[Hias]

hat denn keiner Hilfe für mich?

Oder komme ich hier mit den Möglichkeiten langsam an die Grenze?


Wäre sehr dankbar, wenn man dieses Problem lösen könnte!
(Würde mich auch erkenntlich zeigen, mit z.B. einer kleinen Spende an Wikipedia, DKMS, o.ä. )



Viele Grüße
Hias

[Gerhard H]

Hallo Hias,

Nachstehendes hab ich im Wesentlichen in der VBA-Hilfe unter dem Stichwort Shapes.AddTextEffekt gefunden.

msotexteffekt gibts von 1 bis 30 und entspricht den WordArt-Formaten, die du in den WordArt-Tools unter WordArt-Formate findest.

Wenn du das Wasserzeichen nur im Abschnitt 2 haben willst, so musst du vorher in den Kopf- und Fußzeilentools die Schaltfläche Mit voheriger verknüpfen im Abschnitt 2 deaktivieren.

Das Makro fügt ein Wasserzeichen in die Kopfzeile des zweiten Abschnitts ein. Ist da schon eins drin, wird es vorher gelöscht. Hier der Code (ist im angehängten Musterdokument enthalten):

Code:

Sub wasserzeichenRein()
Dim wassZ As Shape
'Erst mal prüfen, ob es überhaupt zwei Abschnitte gibt
    If ActiveDocument.Sections.Count < 2 Then
        MsgBox "Diese Dokument hat nur einen Abschnitt"
        Exit Sub
    End If
   
'dann prüfen, ob schon ein Wasserzeichen im Abschnitt 2 drin ist
 With ActiveDocument.Sections(2)
    If .Headers(wdHeaderFooterPrimary).Shapes.Count > 0 Then
        'falls mehr als 1 drin sein können, Schleife machen, ansonsten genügt:
        .Headers(wdHeaderFooterPrimary).Shapes(1).Delete
    End If
    
   'neues Wasserzeichen einfügen
   Set wassZ = .Headers(wdHeaderFooterPrimary).Shapes.AddTextEffect(PresetTextEffect:=msoTextEffect7, _
     Text:="Entwurf", FontName:="Tahoma", FontSize:=15, FontBold:=msoTrue, FontItalic:=msoFalse, _
     Left:=120, Top:=120)
End With
     'weitere Anpassungen, z.B.:
     With wassZ
        'Breite und Höhe
        .Width = 300
        .Height = 200
        'Textfarbe
        .Line.ForeColor.RGB = RGB(100, 10, 10)
        .Fill.BackColor.RGB = RGB(100, 100, 100)
    End With

End Sub

[Hias]

Guten Abend Gerhard,

ich habe in meiner Word-Vorlage zwei Unterschiedliche Kopf- und Fußzeilen, darum habe ich den Abschnittsumbruch auch überhaupt eingebaut.

Dein Ansatz geht auf jeden Fall schon mal in die richtige Richtung! Super

Ich möchte das Wasserzeichen auf jeder Seite einfügen, egal wie viele Abschnittsumbrüche gesetzt sind (auch wenn keiner gesetzt ist).


Und dann möchte ich alles wieder mit einem Makro löschen können.

Habe es mit diesen Makro versucht, dieses arbeitet aber nur wenn man den Cursor in den ersten Abschnitt setzt, das Makro ausführt, den Cursor in den zweiten Abschnitt setzt und das Makro wieder ausführt:

Code:

Sub wasserzeichenRaus()




With ActiveDocument.Sections(1)
    If .Headers(wdHeaderFooterPrimary).Shapes.Count > 0 Then
        .Headers(wdHeaderFooterPrimary).Shapes(1).Delete
    End If

End With


With ActiveDocument.Sections(2)
    If .Headers(wdHeaderFooterPrimary).Shapes.Count > 0 Then
        .Headers(wdHeaderFooterPrimary).Shapes(1).Delete
    End If

End With


End Sub

Danke für deine Hilfe

[Gerhard H]

Hallo Hias,

dann musst du halt die Sections durchschleifen, etwa so:

Code:

Sub wasserzeichenRaus()
dim i as long

with activedocument
	for i = 1 to .sections.count
		If .sections(i).Headers(wdHeaderFooterPrimary).Shapes.Count > 0 Then
        		.sections(i).Headers(wdHeaderFooterPrimary).Shapes(1).Delete
    		End If
	next i
end with
end sub

Das hab ich jetzt ungeprüft hingeschludert. Das Prinzip sollte aber klar geworden sein. Wenns Fehler gibt, kannst du sie vielleicht selber beheben, ansonsten fragen, unter Nennung der Fehlermeldung.

[Hias]

Hallo Gerhard,

ich denke ich habe nun das Grundprinzip kapiert. Danke.

Aber es läuft nicht.. Leider..

Egal wie viel Abschnittsumbrüche gesetzt sind, das Makro macht es immer nur in der letzten Section.

Ich kann die Kopfzeilen nicht miteinander verknüpfen da in einer ein anderer Inhalt steht als in der anderen.
Ich hänge das File nocheinmal an.

Code:

Sub WZ_EIN()
Dim wassZ1 As Shape
Dim i As Long

With ActiveDocument
    For i = 1 To .Sections.Count
        'Überprüfen ob schon ein WZ vorhanden ist, wenn ja dann löschen
        If .Sections(i).Headers(wdHeaderFooterPrimary).Shapes.Count > 0 Then
                .Sections(i).Headers(wdHeaderFooterPrimary).Shapes(1).Delete
        End If
            
        'neues Wasserzeichen einfügen
           With .Sections(i)
                 Set wassZ1 = .Headers(wdHeaderFooterPrimary).Shapes.AddTextEffect(PresetTextEffect:=msoTextEffect2, _
                 Text:="DRAFT", FontName:="SEGOE UI", FontSize:=28, FontBold:=msoTrue, FontItalic:=msoFalse, _
                 Left:=1, Top:=120)
                 'weitere Anpassungen, z.B.:
                     With wassZ1
                        'Breite und Höhe
                        .Width = 500
                        .Height = 400
                        'Textfarbe
                        .Line.ForeColor.RGB = RGB(192, 192, 192)
                        .Fill.BackColor.RGB = RGB(192, 192, 192)
                     End With
           End With
            
    Next i
End With


End Sub



Sub WZ_AUS()
Dim i As Long

With ActiveDocument
    For i = 1 To .Sections.Count
        If .Sections(i).Headers(wdHeaderFooterPrimary).Shapes.Count > 0 Then
                .Sections(i).Headers(wdHeaderFooterPrimary).Shapes(1).Delete
            End If
    Next i
End With

End Sub

Danke

[Gerhard H]

Hallo nochmal,

aber jetzt sollte es gehen:

Code:

Sub WZ_EIN()
Dim wassZ1 As Shape
Dim i As Long

For i = 1 To ActiveDocument.Sections.Count
    
    With ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range
            'Überprüfen ob schon ein WZ vorhanden ist, wenn ja dann löschen
            If .ShapeRange.Count > 0 Then
                .ShapeRange(1).Delete
            End If
     End With
        
        'neues Wasserzeichen einfügen
       With ActiveDocument.Sections(i)
             Set wassZ1 = .Headers(wdHeaderFooterPrimary).Shapes.AddTextEffect(PresetTextEffect:=msoTextEffect2, _
             Text:="DRAFT", FontName:="SEGOE UI", FontSize:=28, FontBold:=msoTrue, FontItalic:=msoFalse, _
             Left:=1, Top:=120)
       End With
    
        'weitere Anpassungen, z.B.:
        With wassZ1
           'Breite und Höhe
           .Width = 500
           .Height = 400
           'Textfarbe
           .Line.ForeColor.RGB = RGB(192, 192, 192)
           .Fill.BackColor.RGB = RGB(192, 192, 192)
        End With
           
    Next i

End Sub

Sub WZ_AUS()
Dim i As Long

For i = 1 To ActiveDocument.Sections.Count
    With ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range
        If .ShapeRange.Count > 0 Then
            .ShapeRange(1).Delete
        End If
    End With
Next i
End Sub

[Hias]

Guten Morgen Gerhard,

das war es Danke! du hast mir die Woche gerettet.

Ich wollte noch das Firmenlogo einfügen und damit es nicht gelöscht wird habe ich den Code folgendermaßen bearbeitet (rot markiert). Das hat funktioniert.

Code:

Sub WZ_EIN()
Dim wassZ1 As Shape
Dim i As Long

For i = 1 To ActiveDocument.Sections.Count
    
    With ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range
            'Überprüfen ob schon ein WZ vorhanden ist, wenn ja dann löschen
            If .ShapeRange.Count > 1 Then
                .ShapeRange(2).Delete
            End If
     End With
        
        'neues Wasserzeichen einfügen
       With ActiveDocument.Sections(i)
             Set wassZ1 = .Headers(wdHeaderFooterPrimary).Shapes.AddTextEffect(PresetTextEffect:=msoTextEffect2, _
             Text:="DRAFT", FontName:="SEGOE UI", FontSize:=28, FontBold:=msoTrue, FontItalic:=msoFalse, _
             Left:=1, Top:=120)
       End With
    
        'weitere Anpassungen, z.B.:
        With wassZ1
           'Breite und Höhe
           .Width = 500
           .Height = 400
           'Textfarbe
           .Line.ForeColor.RGB = RGB(192, 192, 192)
           .Fill.BackColor.RGB = RGB(192, 192, 192)
        End With
           
    Next i

End Sub

Sub WZ_AUS()
Dim i As Long

For i = 1 To ActiveDocument.Sections.Count
    With ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range
        If .ShapeRange.Count > 1 Then
            .ShapeRange(2).Delete
        End If
    End With
Next i
End Sub

10 € gingen auch gerade an die DKMS




Eine kleine Feinheit hätte ich aber noch:

Und zwar im Thema Format: Laut meiner Vorgabe muss das WZ groß mittig und diagonal auf der Seite angebracht werden. Und auch halbtransparent.

Mit msoTextEffect2 komm ich da am nächsten hin, leider ist es nicht halbtransparent wenn man es ausdruckt oder in eine PDF wandelt. Es verdeckt zuviel Textinhalt.

Gibt es hier noch Möglichkeiten?




Besten herzlichen Dank
und Grüße

[Gerhard H]

Hallo Hias,

die Transparenz kannst du einstellen über

Code:

.Fill.Transparency = 0.5

wobei 0 undurchsichtig und 1 voll transparent ist.

Dann noch ein Tipp:
I

Code:

f .ShapeRange.Count > 1 Then
    .ShapeRange(2).Delete

Das ist ein bisschen Lotterie. Wer sagt denn, das das zweite Bild nicht auch mal dein Logo sein kann? Besser wäre es, das Logo gezielt zu identifizieren, beispielsweise über seine (vom Wasserzeichen abweichende) Höhe, oder seine Transparenz, oder sonstwas (nur der Name geht schlecht, da das gleiche Bild in jedem Abschnitt eine andere Nummer kriegt).

Die Höhe stellst du einmalig per Hifsmakro fest, indem du ein Logo markierst und abfragst:

Code:

MsgBox Selection.ShapeRange(1).height

Dann kannst du auswählen, welches Shape du gelöscht haben willst, z.B. so:

Code:

Sub WZ_EIN()
Dim wassZ1 As Shape
Dim i As Long, j As Long

For i = 1 To ActiveDocument.Sections.Count
    
    With ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range
            'Überprüfen ob schon ein WZ vorhanden ist, wenn ja dann löschen
            If .ShapeRange.Count > 1 Then
                 For j = .ShapeRange.Count To 1 Step -1
                    If .ShapeRange(j).Height > 93.95 Then .ShapeRange(j).Delete
                Next j
            End If
     End With
        
        'neues Wasserzeichen einfügen
	'Rest vom Makro

Nette Geste übrigens, deine Spende.

[EarlFred]

Hallo Gerhard,

Zitat:

nur der Name geht schlecht, da das gleiche Bild in jedem Abschnitt eine andere Nummer kriegt

Leg den Namen einfach selbst fest.

Mein rudimentäres Makro, das ich in meiner Sammlung gefunden habe, tut das auch:

Code:

Option Explicit

Sub Wasserzeichen_Entwurf_Ein()

With ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes.AddTextEffect( _
                                    PresetTextEffect:=msoTextEffect1, _
                                    Text:="ENTWURF", _
                                    FontName:="Calibri", _
                                    FontSize:=1, _
                                    FontBold:=msoFalse, _
                                    FontItalic:=msoFalse, _
                                    Left:=0, _
                                    Top:=0)
  .Name = "Wasserzeichen"
  .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 Sub
Sub Wasserzeichen_Entwurf_Aus()
On Error Resume Next
ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes("Wasserzeichen").Delete
On Error GoTo 0
End Sub

Der Name kann mit der Nummer der Section ergänzt werden:
"Wasserzeichen_" & i

Selbst wenn man pro Section die Shapes durchläuft, lässt sich das Wasserzeichen über die ersten Zeichen des Namens eindeutig auffinden.

Grüße
EarlFred

[EarlFred]

umgesetzt:

Code:

Option Explicit

Sub Wasserzeichen_Entwurf_Ein()

Dim i As Integer

For i = 1 To ActiveDocument.Sections.Count
  With ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Shapes.AddTextEffect( _
                                      PresetTextEffect:=msoTextEffect1, _
                                      Text:="ENTWURF", _
                                      FontName:="Calibri", _
                                      FontSize:=1, _
                                      FontBold:=msoFalse, _
                                      FontItalic:=msoFalse, _
                                      Left:=0, _
                                      Top:=0)
    .Name = "Wasserzeichen_" & i
    .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
Next i
  
End Sub
Sub Wasserzeichen_Entwurf_Aus()
Dim j As Integer, i As Integer

For i = 1 To ActiveDocument.Sections.Count
  For j = ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Shapes.Count To 1 Step -1
    With ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Shapes(j)
      If .Name Like "Wasserzeichen*" Then .Delete
    End With
  Next j
Next i

End Sub

[Hias]

Hallo zusammen,


ein sehr großes Dankeschön für die beiden Lösungen.

Das Makro wurde nun perfekt umgesetzt und wird in den täglichen Betrieb miteinfließen.


Grüße und schönes WE