Sub Inserer_filigrane()
' Pose un filigrane sur les feuilles du classeur actif : un texte en diagonale, en gris
' clair, placé dans la partie centrale de l'en-tête. Il s'imprime derrière les données
' sur chaque page, et se voit en mode Mise en page, dans l'aperçu avant impression et
' dans un PDF, jamais en mode Normal.
' Attend : le texte, la couleur et l'inclinaison, sur les lignes « À MODIFIER ».
' Modifie : la partie centrale de l'en-tête des feuilles où elle est vide (et celle de
' la première page ou des pages paires quand elles ont leur propre en-tête),
' plus un nom masqué, FiligraneLeDojo, qui marque ces feuilles. Une feuille
' dont l'une de ces parties porte déjà un texte ou une image reste intacte.
' Aucune cellule ne change, et le classeur n'est pas enregistré.
' Pour enlever le filigrane, relance la macro avec retirer = True. Seules les feuilles
' qui portent la marque le perdent.
Const NOM_MARQUE As String = "FiligraneLeDojo"
Const NETTETE As Double = 2
Dim texte As String
Dim couleur As Long
Dim angle As Double
Dim toutesLesFeuilles As Boolean
Dim retirer As Boolean
Dim classeur As Workbook
Dim temporaire As Workbook
Dim feuilles As Collection
Dim feuille As Worksheet
Dim autres As Collection
Dim partie As Object
Dim graphique As Object
Dim nom As Name
Dim marque As Name
Dim zone As Shape
Dim images As Collection
Dim image As Variant
Dim cle As String
Dim libre As Boolean
Dim retire As Boolean
Dim largeurPage As Double
Dim hauteurPage As Double
Dim largeur As Double
Dim hauteur As Double
Dim radians As Double
Dim echelle As Double
Dim nbPosees As Long
Dim nbOccupees As Long
Dim nbRetirees As Long
Dim erreur As String
'À MODIFIER : le texte du filigrane, sa couleur, et son inclinaison en degrés
'(45 le fait monter de gauche à droite, 0 le laisse à l'horizontale).
texte = "CONFIDENTIEL"
couleur = RGB(217, 217, 217)
angle = 45
'À MODIFIER : False pour ne marquer que la feuille active.
toutesLesFeuilles = True
'À MODIFIER : True enlève le filigrane posé par cette macro, et rien d'autre.
retirer = False
Set classeur = ActiveWorkbook
If classeur Is Nothing Then
Application.StatusBar = "Inserer_filigrane : aucun classeur ouvert."
Exit Sub
End If
Set feuilles = New Collection
If toutesLesFeuilles Then
For Each feuille In classeur.Worksheets
feuilles.Add feuille
Next feuille
ElseIf TypeName(ActiveSheet) = "Worksheet" Then
feuilles.Add ActiveSheet
End If
Set images = New Collection
On Error GoTo Echec
Application.ScreenUpdating = False
For Each feuille In feuilles
With feuille.PageSetup
'Les parties centrales de la première page et des pages paires, quand
'elles ont leur propre en-tête.
Set autres = New Collection
If .DifferentFirstPageHeaderFooter Then autres.Add .FirstPage.CenterHeader
If .OddAndEvenPagesHeaderFooter Then autres.Add .EvenPage.CenterHeader
Set marque = Nothing
For Each nom In feuille.Names
If Mid$(nom.Name, InStrRev(nom.Name, "!") + 1) = NOM_MARQUE Then Set marque = nom
Next nom
If retirer Then
'Seule une feuille marquée perd son filigrane, et seulement dans les
'parties qui ne portent encore que l'image posée par la macro.
If Not marque Is Nothing Then
retire = False
If .CenterHeader = "&G" Then .CenterHeader = "": retire = True
For Each partie In autres
If partie.Text = "&G" Then partie.Text = "": retire = True
Next partie
marque.Delete
If retire Then nbRetirees = nbRetirees + 1
End If
Else
'Une partie est libre quand elle est vide, ou quand elle porte déjà le
'filigrane de la macro, qui est alors remplacé.
libre = (.CenterHeader = "" Or (.CenterHeader = "&G" And Not marque Is Nothing))
For Each partie In autres
If partie.Text <> "" And Not (partie.Text = "&G" And Not marque Is Nothing) Then libre = False
Next partie
If Not libre Then
nbOccupees = nbOccupees + 1
Else
'La zone imprimable de la page, d'après le format du papier. Un
'format absent de cette liste prend les dimensions de l'A4.
Select Case .PaperSize
Case xlPaperA3: largeurPage = 841.9: hauteurPage = 1190.6
Case xlPaperA5: largeurPage = 419.5: hauteurPage = 595.3
Case xlPaperLetter: largeurPage = 612: hauteurPage = 792
Case xlPaperLegal: largeurPage = 612: hauteurPage = 1008
Case Else: largeurPage = 595.3: hauteurPage = 841.9
End Select
If .Orientation = xlLandscape Then
largeur = largeurPage: largeurPage = hauteurPage: hauteurPage = largeur
End If
largeur = largeurPage - .LeftMargin - .RightMargin
hauteur = hauteurPage - 2 * .HeaderMargin
cle = Format$(largeur, "0") & "x" & Format$(hauteur, "0")
'Une image par taille de page, dessinée dans un classeur de travail :
'le texte dans une zone de texte, sur un graphique vide et transparent,
'à deux fois la taille voulue pour rester net à l'impression.
image = Empty
On Error Resume Next
image = images(cle)
On Error GoTo Echec
If IsEmpty(image) Then
If temporaire Is Nothing Then Set temporaire = Workbooks.Add(xlWBATWorksheet)
With temporaire.Worksheets(1).ChartObjects.Add(0, 0, largeur * NETTETE, hauteur * NETTETE).Chart
.ChartArea.Format.Fill.Visible = msoFalse
.ChartArea.Format.Line.Visible = msoFalse
Set zone = .Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 100, 50)
zone.Fill.Visible = msoFalse
zone.Line.Visible = msoFalse
With zone.TextFrame2
.WordWrap = msoFalse
.AutoSize = msoAutoSizeShapeToFitText
.MarginLeft = 0: .MarginRight = 0: .MarginTop = 0: .MarginBottom = 0
.TextRange.Text = texte
.TextRange.Font.Name = "Arial"
.TextRange.Font.Bold = msoTrue
.TextRange.Font.Size = 20
.TextRange.Font.Fill.ForeColor.RGB = couleur
.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.VerticalAnchor = msoAnchorMiddle
End With
'La taille de police qui fait tenir le texte incliné dans la page,
'd'après sa largeur et sa hauteur mesurées en corps 20.
radians = angle * Atn(1) / 45
echelle = 0.9 * largeur * NETTETE / (zone.Width * Abs(Cos(radians)) + zone.Height * Abs(Sin(radians)))
If 0.9 * hauteur * NETTETE / (zone.Width * Abs(Sin(radians)) + zone.Height * Abs(Cos(radians))) < echelle Then
echelle = 0.9 * hauteur * NETTETE / (zone.Width * Abs(Sin(radians)) + zone.Height * Abs(Cos(radians)))
End If
If echelle > 20 Then echelle = 20
'La zone couvre ensuite toute l'image, le texte centré au milieu, et
'elle tourne autour du centre de l'image.
zone.TextFrame2.AutoSize = msoAutoSizeNone
…