1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
| Sub InitializeLabels()
Dim i As Long
Dim shGraph As Object
Dim lbl As Object
' Boucle sur les Graphs de la feuille
For Each shGraph In ActiveSheet.ChartObjects
''' ajout des légendes automatiques
''' --- elles serviront à récupérer les coordonnées des étiquettes
shGraph.Chart.ApplyDataLabels AutoText:=True, LegendKey:=False, _
HasLeaderLines:=False, ShowSeriesName:=False, ShowCategoryName:=True, _
ShowValue:=False, ShowPercentage:=False, ShowBubbleSize:=False
With shGraph.Chart.SeriesCollection(1).DataLabels
.Font.Name = "Arial Narrow"
.Font.Size = 8
End With
''' suppression des anciens labels
For Each lbl In shGraph.Chart.Shapes
If lbl.Name Like "Label*" Then
shGraph.Chart.Shapes(lbl.Name).Delete
End If
Next lbl
''' création des textbox qui émulent les DataLabels
For i = 1 To shGraph.Chart.SeriesCollection(1).Points.Count
With shGraph.Chart.TextBoxes.Add(10 * i, 10 * i, 50, 20)
.AutoSize = True
''' ici on lie le contenu de la textbox à la cellule qui contient le nom de la série
.Formula = "=" & Replace(Range(Split(shGraph.Chart.SeriesCollection(1).FormulaLocal, ";")(1)).Cells(i).Address(True, True, , True), _
"[" & ThisWorkbook.Name & "]", _
"")
With .Font
.ColorIndex = 0
.Size = 8
.Name = "Arial Narrow"
End With
.Name = "Label" & i
''' application des coordonnées des étiquettes automatiques
.Top = shGraph.Chart.SeriesCollection(1).DataLabels(i).Top
.Left = shGraph.Chart.SeriesCollection(1).DataLabels(i).Left
End With
Next i
''' suppression des légendes automatiques
shGraph.Chart.ApplyDataLabels AutoText:=False, LegendKey:=False, _
HasLeaderLines:=False, ShowSeriesName:=False, ShowCategoryName:=False, _
ShowValue:=False, ShowPercentage:=False, ShowBubbleSize:=False
Next shGraph
Set lbl = Nothing
Set shGraph = Nothing
End Sub |
Partager