MS-Office-Forum
Google
   

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Word
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads Der Renner, 11 Entwicklertools für Access, Tipps & Trick und offene Datenbanken zum einzigartigen Preis.
Themen-Optionen Ansicht
Alt 13.03.2018, 10:39   #1
Hias
MOF User
MOF User
Traurig VBA - vorhandenes Wasserzeichen per VBA aus / WZ wieder ein// Probl. mit Abschnittsumbruch

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

Geändert von Hias (13.03.2018 um 11:38 Uhr).
Hias ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.03.2018, 13:06   #2
Hias
Threadstarter Threadstarter
MOF User
MOF User
Standard

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
Hias ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 13.03.2018, 18:21   #3
Luschi
MOF Koryphäe
MOF Koryphäe
Standard

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
Luschi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 14.03.2018, 06:23   #4
Hias
Threadstarter Threadstarter
MOF User
MOF User
Standard

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 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2018, 07:02   #5
Hias
Threadstarter Threadstarter
MOF User
MOF User
Standard

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

Geändert von Hias (15.03.2018 um 07:30 Uhr).
Hias ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2018, 15:59   #6
Gerhard H
MOF Guru
MOF Guru
Standard

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
Angehängte Dateien
Dateityp: docm wasserzeichen.docm (31,9 KB, 2x aufgerufen)

__________________

Gruß
Gerhard
Gerhard H ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2018, 18:55   #7
Hias
Threadstarter Threadstarter
MOF User
MOF User
Standard

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

__________________

________________________________________________________________________________ _______________________________________________________________
Betriebssystem: Windows 7
MS-Office 2016
Hias ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2018, 20:39   #8
Gerhard H
MOF Guru
MOF Guru
Standard

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.

__________________

Gruß
Gerhard
Gerhard H ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2018, 23:26   #9
Hias
Threadstarter Threadstarter
MOF User
MOF User
Standard

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
Angehängte Dateien
Dateityp: docm wasserzeichen.docm (45,0 KB, 1x aufgerufen)

__________________

________________________________________________________________________________ _______________________________________________________________
Betriebssystem: Windows 7
MS-Office 2016

Geändert von Hias (15.03.2018 um 23:45 Uhr).
Hias ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 16.03.2018, 00:14   #10
Gerhard H
MOF Guru
MOF Guru
Standard

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

__________________

Gruß
Gerhard
Gerhard H ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 16.03.2018, 07:18   #11
Hias
Threadstarter Threadstarter
MOF User
MOF User
Standard

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
Angehängte Grafiken
Dateityp: jpg DKMS.JPG (36,9 KB, 3x aufgerufen)

__________________

________________________________________________________________________________ _______________________________________________________________
Betriebssystem: Windows 7
MS-Office 2016

Geändert von Hias (16.03.2018 um 07:21 Uhr).
Hias ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 16.03.2018, 08:51   #12
Gerhard H
MOF Guru
MOF Guru
Standard

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.

__________________

Gruß
Gerhard
Gerhard H ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 16.03.2018, 09:30   #13
EarlFred
MOF Guru
MOF Guru
Standard

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

__________________

Datum und Uhrzeit, Makrorekorder-Code entschlacken, {Matrixformeln}
Tutorials zu Pivottabellen: Kurzeinstieg; Dynamischer Datenbereich; Daten und Zeiten gruppieren
Für 5 meiner Beiträge haben sich die Hilfesuchenden mit einer Spende an Wikipedia, die Tafeln oder Hilfe für krebskranke Kinder eV bedankt (das entspricht 0,037% per 04.04.2018) - eine tolle Geste!
EarlFred ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 16.03.2018, 09:35   #14
EarlFred
MOF Guru
MOF Guru
Standard

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

__________________

Datum und Uhrzeit, Makrorekorder-Code entschlacken, {Matrixformeln}
Tutorials zu Pivottabellen: Kurzeinstieg; Dynamischer Datenbereich; Daten und Zeiten gruppieren
Für 5 meiner Beiträge haben sich die Hilfesuchenden mit einer Spende an Wikipedia, die Tafeln oder Hilfe für krebskranke Kinder eV bedankt (das entspricht 0,037% per 04.04.2018) - eine tolle Geste!
EarlFred ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 16.03.2018, 11:44   #15
Hias
Threadstarter Threadstarter
MOF User
MOF User
Standard

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

__________________

________________________________________________________________________________ _______________________________________________________________
Betriebssystem: Windows 7
MS-Office 2016
Hias ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 11:33 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.

Copyright ©2000-2010 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günther Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.
Beachten Sie bitte auch unsere Nutzungsbedingungen.