Ajouter un filigranne par code sur word (vba)

Soyez le premier à donner votre avis sur cette source.

Snippet vu 10 775 fois - Téléchargée 27 fois

Contenu du snippet

J'en ai ch... mes grands dieux pour trouver une solution à ce problème. Quand vous faites une macro automatique, elle ne marche pas, elle est bourrée de bug.
J'ai donc décidé de partager mon code.
Ca ajoute un filigranne sur tout le document word.
Ma procédure n'est pas compatible avec celle par défaut de Word.

Source / Exemple :


Sub Filigranne(Texte As String)
    Dim Section As Section
    Dim Header As HeaderFooter

    Word.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    For Each Section In ActiveDocument.Sections
        For Each Header In Section.Headers
            AddFiligranne Texte, Header, Section
        Next
    Next
    Word.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

Private Sub AddFiligranne(Texte As String, Header As HeaderFooter, Section As Section)
    Dim ShapeName As String
    ShapeName = "Filigranne_" & Section.Index & "_" & Header.Index
    Header.Range.Select
    
    'détruit un éventuel filigranne précédent
    On Error Resume Next
    Set Shape = Header.Shapes(ShapeName)
    If Not Shape Is Nothing Then Shape.Delete
    If Texte = "" Then Exit Sub
    
    'ajoute le filigranne (c'est dans l'entete, et ça prend 1x1 point en haut à gauche de la page)
    Set Shape = Word.Selection.HeaderFooter.Shapes.AddTextEffect( _
        Office.MsoPresetTextEffect.msoTextEffect1, _
        Texte, "ARIAL", 1, False, False, _
        0, 0)
    Shape.Select
    'met en forme le filigranne pour prendre toute la page
    With Word.Selection.ShapeRange
        .Name = ShapeName
        .TextEffect.Text = Texte
        .TextEffect.FontName = "Arial"
        .TextEffect.FontSize = 1 'la taille de la police est fixé par le ratio
        .Line.Visible = False
        .Fill.Visible = True
        .Fill.Solid
        .Fill.ForeColor.RGB = WdColor.wdColorRed
        .Fill.Transparency = 0.7
        .Rotation = 305
        .LockAspectRatio = True
        .Height = CentimetersToPoints(3.22)
        .Width = CentimetersToPoints(19.34)
        .WrapFormat.AllowOverlap = True
        .WrapFormat.Side = wdWrapNone
        .WrapFormat.Type = 3
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        .RelativeVerticalPosition = wdRelativeHorizontalPositionPage
        .Left = wdShapeCenter
        .Top = wdShapeCenter
    End With
End Sub

Conclusion :


Il faut appeler Filigranne avec le texte à mettre en filigranne
Si vous ne mettez pas de texte, le filigranne est effacé.

A voir également

Ajouter un commentaire

Commentaires

Messages postés
2065
Date d'inscription
lundi 11 avril 2005
Statut
Membre
Dernière intervention
14 mars 2016
8
Bonjour,

L'enregistreur de macro fonctionne correctement au moins avec Word2003 : ce qui donne ce code :

=

Sub Macro1()
'
' Macro1 Macro
' Macro enregistrée le 27/06/2008 par Us
'
ActiveDocument.Sections(1).Range.Select
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.HeaderFooter.Shapes.AddTextEffect(PowerPlusWaterMarkObject1, _
"BROUILLON", "Times New Roman", 1, False, False, 0, 0).Select
Selection.ShapeRange.Name = "PowerPlusWaterMarkObject1"
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(4.1)
Selection.ShapeRange.Width = CentimetersToPoints(18.46)
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

=

Attention toutefois, il faut partir d'un document vierge (ne supporte pas le double filigramme)...

Amicalement,
Us.
Messages postés
178
Date d'inscription
mercredi 8 octobre 2003
Statut
Membre
Dernière intervention
25 septembre 2008

Bravo,
Rien à redire....

Xav.

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.