Re: Wasserzeichen mit Word-Art
- From: "Thomas Gahler" <wurzel2.NO@xxxxxxxxxxxxxxxx>
- Date: Tue, 18 Apr 2006 21:13:18 +0200
Hallo Klaus
Leider lässt sich das Beispiel nicht eins zu eins aufNa das allein reicht ja eben auch nicht. Auch wenn man den Code total
Word-Art-Wasserzeichen übertragen, denn die NextStoryRange-Eigenschaft
liefert ein Range-Objekt, das man nur für externe Grafikdateien
verwenden kann. Für ein Word-Art-Wasserzeichen braucht man eine
HeaderFooter.Shapes-Auflistung.
umstellt, man schafft es doch nicht eine WordArt dort zu platzieren wo man
eigentlich denkt dass es hinsollte.
Kann ganz einfach kontrolliert werden, in dem anstelle eine WordArt eine
Textbox, ein Line oder sonst ein Shape-Objket eingefügt wird. Die kommen
alle so wie man will, nur eben das WordArt nicht :-(
So ist es auch nicht möglich das WordArt als InlineShape-Objekt einzufügen
und dann in ein Shape zukonvertieren, obwohl man das manuell möglich ist. Da
kann man sogar das InlineShape drehen, was man mit einem InlineShape ja gar
nicht machen kann. Also ziemlich widerspengstig das Ding, vor allem im
Zusammenhang mit VBA.
Kann mir jemand erklären, wie man in ein Dokument mit verschiedenenHmm, gar nicht so einfach. Nachstehend ein paar Versuche ein Wasserzeichen
Kopfzeilen (erste Seite anders, mehrere Abschnitte) ein Wasserzeichen
mit Word-Art einfügt?
zu generieren. Schau sie dir an und entscheide welches du nimmst. Ich
persönlich verwende eine Grafikdatei, da habe ich alles was ich will. Doch
mir ist klar, das WordArt hat ja eben den Vorteil, dass man keine externe
Grafikdatei benötigt.
Die Grafikdatei könnte ja einmalig erstellt werden. Neue Datei, WordArt
erstellen, als .html speichern und schon hat man ein .gif. Den rest einfach
wieder löschen. Nicht perfekt, aber wäre was.
Nachstehend ein paar Vorschläge was man so alles machen könnte. Schau mal
was für dich am besten passt.
' ---------- ---------- ---------- Start ---------- ---------- ----------
Option Explicit
'Leider nicht erfolgreich...
'- das Wordart-Objekt ist sehr wiederspengstig
Sub Vorschlag1()
Dim doc As Word.Document
Dim hdr As Word.HeaderFooter
Dim rng As Word.Range
Dim intHdr As WdHeaderFooterIndex
Set doc = ActiveDocument
For intHdr = wdHeaderFooterPrimary To wdHeaderFooterEvenPages
Set hdr = doc.Sections(1).Headers(intHdr)
Set rng = hdr.Range
procWordArt _
hdr:=hdr, _
rng:=rng
While Not (rng.NextStoryRange Is Nothing)
Set rng = rng.NextStoryRange
procWordArt _
hdr:=hdr, _
rng:=rng
Wend
Next intHdr
End Sub
Private Sub procWordArt( _
ByVal hdr As Word.HeaderFooter, _
ByVal rng As Word.Range)
Dim shp As Word.Shape
Set shp = hdr.Shapes.AddTextEffect( _
PresetTextEffect:=msoTextEffect1, _
Text:="Entwurf", _
FontName:="Arial", FontSize:=40, FontBold:=True, FontItalic:=True, _
Left:=100, Top:=100, _
Anchor:=rng)
With shp
.Name = "Wasserzeichen_" & CStr(Rnd())
.LockAnchor = True
.Rotation = -30
.ZOrder msoSendToBack
End With
End Sub
' ---------- ---------- ---------- Ende ---------- ---------- ----------
' ---------- ---------- ---------- Start ---------- ---------- ----------
Option Explicit
'Erfolgreich, aber ...
'- es wird mit Selection gearbeitet :-(
'- Wasserzeichen wird mehrmals gesetzt, wenn die Option «Wie vorherige»
' aktiv ist. Dies ist aber egal, solange das Wasserzeichen immer an
' der gleichen Position eingesetzt wird.
Sub Vorschlag2()
Dim doc As Word.Document
Dim hdr As Word.HeaderFooter
Dim rng As Word.Range
Dim intZ As Integer
Set doc = ActiveDocument
For intZ = 1 To doc.Sections.Count
For Each rng In doc.StoryRanges
Select Case True
Case (rng.StoryType = wdPrimaryHeaderStory)
If doc.Sections(intZ).Headers(wdHeaderFooterPrimary).Exists
Then
Set hdr =
doc.Sections(intZ).Headers(wdHeaderFooterPrimary)
Set rng = hdr.Range
procWordartEinfügen hdr:=hdr, rng:=rng
End If
Case (rng.StoryType = wdFirstPageHeaderStory)
If doc.Sections(intZ).Headers(wdHeaderFooterFirstPage).Exists
Then
Set hdr =
doc.Sections(intZ).Headers(wdHeaderFooterFirstPage)
Set rng = hdr.Range
procWordartEinfügen hdr:=hdr, rng:=rng
End If
Case (rng.StoryType = wdEvenPagesHeaderStory)
If doc.Sections(intZ).Headers(wdHeaderFooterEvenPages).Exists
Then
Set hdr =
doc.Sections(intZ).Headers(wdHeaderFooterEvenPages)
Set rng = hdr.Range
procWordartEinfügen hdr:=hdr, rng:=rng
End If
End Select
Next rng
Next intZ
End Sub
Private Sub procWordartEinfügen( _
ByVal hdr As Word.HeaderFooter, _
ByVal rng As Word.Range)
Dim shp As Word.Shape
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
hdr.Range.Select
Set shp = Selection.HeaderFooter.Shapes.AddTextEffect( _
PresetTextEffect:=msoTextEffect1, _
Text:="Entwurf", _
FontName:="Arial", FontSize:=40, FontBold:=True, FontItalic:=True, _
Left:=100, Top:=100) ', _
Anchor:=Selection.Range) 'Anchor: darf NICHT gesetzt werden!
With shp
.Name = "Wasserzeichen_" & CStr(Rnd())
'.LockAnchor = True
.Rotation = -30
.ZOrder msoSendToBack
End With
End Sub
' ---------- ---------- ---------- Ende ---------- ---------- ----------
' ---------- ---------- ---------- Start ---------- ---------- ----------
Option Explicit
'Erfolgreich, aber ...
'- es wird mit Selection gearbeitet :-(
'- Wasserzeichen wird mehrmals gesetzt, wenn die Option «Wie vorherige»
' aktiv ist. Dies ist aber egal, solange das Wasserzeichen immer an
' der gleichen Position eingesetzt wird.
'- aber es wird mit 'On Error' gearbeitet :-((
Sub Vorschlag3()
Dim doc As Word.Document
Dim rng As Word.Range
Dim shp As Word.Shape
Set doc = ActiveDocument
Set rng = Selection.Range
Selection.HomeKey Unit:=wdStory
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
On Error GoTo FEHLER
While True
Set shp = Selection.HeaderFooter.Shapes.AddTextEffect( _
PresetTextEffect:=msoTextEffect1, _
Text:="Entwurf", _
FontName:="Arial", FontSize:=40, FontBold:=True, FontItalic:=True,
_
Left:=100, Top:=100) ', _
Anchor:=Selection.Range) 'Anchor: darf NICHT gesetzt werden!
With shp
.Name = "Wasserzeichen_" & CStr(Rnd())
'.LockAnchor = True
.Rotation = -30
.ZOrder msoSendToBack
End With
ActiveWindow.ActivePane.View.NextHeaderFooter
Wend
FEHLER:
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
rng.Select
End Sub
' ---------- ---------- ---------- Ende ---------- ---------- ----------
' ---------- ---------- ---------- Start ---------- ---------- ----------
Option Explicit
'Erfolgreich, aber ...
'- mit der Textbox ist keine Drehung möglich :-(
Sub Vorschlag4()
Dim doc As Word.Document
Dim hdr As Word.HeaderFooter
Dim rng As Word.Range
Dim intHdr As WdHeaderFooterIndex
Set doc = ActiveDocument
For intHdr = wdHeaderFooterPrimary To wdHeaderFooterEvenPages
Set hdr = doc.Sections(1).Headers(intHdr)
Set rng = hdr.Range
procTextboxEinfügen _
hdr:=hdr, _
rng:=rng
While Not (rng.NextStoryRange Is Nothing)
Set rng = rng.NextStoryRange
procTextboxEinfügen _
hdr:=hdr, _
rng:=rng
Wend
Next intHdr
End Sub
Private Sub procTextboxEinfügen( _
ByVal hdr As Word.HeaderFooter, _
ByVal rng As Word.Range)
Dim shp As Word.Shape
Set shp = hdr.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=100, _
Top:=100, _
Width:=300, _
Height:=300, _
Anchor:=rng)
With shp.TextFrame.TextRange
.Text = "Entwurf"
With .Font
.Size = 50
.ColorIndex = wdGray50
.Outline = True
End With
End With
With shp
.Name = "Wasserzeichen_" & CStr(Rnd())
.LockAnchor = True
.ZOrder msoSendToBack
End With
End Sub
' ---------- ---------- ---------- Ende ---------- ---------- ----------
' ---------- ---------- ---------- Start ---------- ---------- ----------
Option Explicit
'Erfolgreich, aber ...
'- Zwischenablage wird verwendet
'- ein neues Dokument wird temporär benötigt
Sub Vorschlag5()
Dim doc As Word.Document
Dim hdr As Word.HeaderFooter
Dim rng As Word.Range
Dim intHdr As WdHeaderFooterIndex
Set doc = ActiveDocument
procWasserzeichenInClipboard
For intHdr = wdHeaderFooterPrimary To wdHeaderFooterEvenPages
Set hdr = doc.Sections(1).Headers(intHdr)
Set rng = hdr.Range
procTextboxEinfügen _
hdr:=hdr, _
rng:=rng
While Not (rng.NextStoryRange Is Nothing)
Set rng = rng.NextStoryRange
procTextboxEinfügen _
hdr:=hdr, _
rng:=rng
Wend
Next intHdr
End Sub
Private Sub procTextboxEinfügen( _
ByVal hdr As Word.HeaderFooter, _
ByVal rng As Word.Range)
Dim shp As Word.Shape
Set shp = hdr.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=100, _
Top:=100, _
Width:=300, _
Height:=300, _
Anchor:=rng)
With shp.TextFrame.TextRange
.Paste
End With
With shp
.Name = "Wasserzeichen_" & CStr(Rnd())
.LockAnchor = True
.ZOrder msoSendToBack
End With
End Sub
Sub procWasserzeichenInClipboard()
Dim doc As Word.Document
Dim shp As Word.Shape
Application.ScreenUpdating = False
Set doc = Documents.Add
Set shp = doc.Shapes.AddTextEffect(msoTextEffect22, _
"Entwurf", _
"Impact", 36#, _
msoFalse, msoFalse, 100, 100, _
Selection.Range)
With shp
.Rotation = -30
.LockAnchor = True
.Select
End With
Selection.Cut
doc.Saved = True
doc.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
' ---------- ---------- ---------- Ende ---------- ---------- ----------
' ---------- ---------- ---------- Start ---------- ---------- ----------
Option Explicit
'Erfolgreich, aber ...
'- es wird kein WordArt sondern eine Grafikdatei verwendet
Sub Vorschlag6()
Dim doc As Word.Document
Dim hdr As Word.HeaderFooter
Dim rng As Word.Range
Dim intHdr As WdHeaderFooterIndex
Set doc = ActiveDocument
For intHdr = wdHeaderFooterPrimary To wdHeaderFooterEvenPages
Set hdr = doc.Sections(1).Headers(intHdr)
Set rng = hdr.Range
procGrafikEinfügen hdr:=hdr, rng:=rng
While Not (rng.NextStoryRange Is Nothing)
Set rng = rng.NextStoryRange
procGrafikEinfügen hdr:=hdr, rng:=rng
Wend
Next intHdr
End Sub
Private Function procGrafikEinfügen( _
ByVal hdr As Word.HeaderFooter, _
ByVal rng As Word.Range)
Dim shp As Word.Shape
Set shp = hdr.Shapes.AddPicture(FileName:="F:\Temp\blau.bmp", Anchor:=rng)
With shp
.Name = "Wasserzeichen_" & CStr(Rnd())
.Left = 100
.Top = 100
.LockAnchor = True
.Rotation = -30
.ZOrder msoSendToBack
End With
End Function
' ---------- ---------- ---------- Ende ---------- ---------- ----------
--
Thomas Gahler
MVP für WordVBA
Co-Autor von »Microsoft Word-Programmierung.
Das Handbuch« (MS Press)
- Windows XP (SP2), Office XP (SP3)
.
- References:
- Wasserzeichen mit Word-Art
- From: Klaus Foerst
- Wasserzeichen mit Word-Art
- Prev by Date: Re: Grafik automatisch formatieren
- Next by Date: Re: Grafik automatisch formatieren
- Previous by thread: Wasserzeichen mit Word-Art
- Next by thread: Datei Einfügen Makro
- Index(es):
Relevant Pages
|
