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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
| Option Explicit ' Chart avec deux series de valeurs
Public Const colorFillBlue = 34
Public Const colorFillPaleBlue = 37
Public Const colorFillGray = 48
' Création d'un graphique à deux courbes
Sub CurveNew()
Dim chartObj As ChartObject, rngAbscisse As Range, rngOrdonnee1 As Range, rngOrdonnee2 As Range
Application.ScreenUpdating = False
Set rngAbscisse = Range("A2:A6")
Set rngOrdonnee1 = Range("B2:B6")
Set rngOrdonnee2 = Range("C2:C6")
Set chartObj = ActiveSheet.ChartObjects.Add(Left:=50, Width:=500, Top:=100, Height:=300)
With chartObj.Chart
.ChartType = xlXYScatterSmoothNoMarkers ' Déclarer le type en premier
CleanSeriesColl chartObj.Chart ' dans le cas où il y a des series par défaut
CurveSeries chartObj.Chart, rngAbscisse, rngOrdonnee1, rngOrdonnee2, _
"Ordonnée 1", "Ordonnée 2"
.HasTitle = True
.ChartTitle.Characters.Text = "Chart Title"
.HasDataTable = False
.PlotArea.Interior.ColorIndex = 0 'White
CurveAxis chartObj.Chart, "Category (X) axis", "Value (Y) axis"
' .HasLegend = False
.HasLegend = True
.Legend.Position = xlLegendPositionBottom
' .Legend.LegendEntries(1).Delete ' Pour effacer 'Ordonnée 1' de la légende
End With
Application.ScreenUpdating = True
End Sub
' Définition des deux séries de données
Sub CurveSeries(chartThis As Chart, rngX As Range, rngY1 As Range, rngY2 As Range, _
ByVal strTitleY1 As String, ByVal strTitleY2 As String)
Dim serie1 As Series, serie2 As Series
With chartThis.SeriesCollection
Set serie1 = .NewSeries
With serie1
.Values = rngY1
.XValues = rngX
.Name = strTitleY1
.Border.Weight = xlMedium
End With
Set serie2 = .NewSeries
With serie2
.Values = rngY2
.XValues = rngX
.Name = strTitleY2
.Border.Weight = xlMedium
End With
End With
End Sub
' Axes du graphique
Sub CurveAxis(chartThis As Chart, ByVal strTitleX As String, ByVal strTitleY As String)
Dim axisAbscisse As Axis, axisOrdonnee As Axis
With chartThis
Set axisOrdonnee = .Axes(xlValue, xlPrimary)
With axisOrdonnee
.MaximumScale = 10
.MinimumScale = 1
.HasTitle = True
.AxisTitle.Characters.Text = strTitleX
.MajorGridlines.Border.LineStyle = xlDot
.MajorGridlines.Border.ColorIndex = colorFillGray
.MajorTickMark = xlTickMarkCross
End With
Set axisAbscisse = .Axes(xlCategory, xlPrimary)
With axisAbscisse
.HasTitle = True
.AxisTitle.Characters.Text = strTitleY
.MajorTickMark = xlTickMarkInside
.TickLabelPosition = xlTickLabelPositionLow
.MinorTickMark = xlTickMarkNone
.TickLabels.Orientation = xlHorizontal
End With
End With
End Sub
' Afficher tous les noms et n° des séries dans le graphique de n° indChartObj
Sub CurveSerieDisplay(ByVal indChartObj As Integer)
Dim chartObj As ChartObject, chartThis As Chart, serieThis As Series, indSerie As Integer
If indChartObj < 0 Or indChartObj > ActiveSheet.ChartObjects.Count Then
Warning "2000: CurveSerieDisplay : " & vbCrLf & _
"L'indice de ChartObjects n° " & indChartObj & " n'existe pas": Exit Sub
End If
Set chartObj = ActiveSheet.ChartObjects(indChartObj)
Set chartThis = chartObj.Chart
Debug.Print "Les séries dans le ChartObject n° " & indChartObj & " de nom """ & chartObj.Name & """ sont :"
For indSerie = 1 To chartThis.SeriesCollection.Count
Set serieThis = chartThis.SeriesCollection(indSerie)
Debug.Print """" & serieThis.Name & """ a pour n° " & indSerie
Next
End Sub
' Efface la série n° indSerieToHide dans le ChartObject n° indChartObj
Sub CurveSerieHide(ByVal indChartObj As Integer, ByVal indSerieToHide As Integer)
Dim serieToHide As Series, chartObj As ChartObject, chartThis As Chart
If indChartObj < 0 Or indChartObj > ActiveSheet.ChartObjects.Count Then
Warning "1000: CurveSerieHide : " & vbCrLf & _
"L'indice de ChartObjects n° " & indChartObj & " n'existe pas": Exit Sub
End If
Set chartObj = ActiveSheet.ChartObjects(indChartObj)
Set chartThis = chartObj.Chart
If indSerieToHide < 0 Or indSerieToHide > chartThis.SeriesCollection.Count Then
Warning "1100: CurveSerieHide : " & vbCrLf & _
"L'indice de series n° " & indSerieToHide & " n'existe pas dans " & chartObj.Name: Exit Sub
End If
Set serieToHide = chartThis.SeriesCollection(indSerieToHide)
If chartThis.SeriesCollection.Count = 1 Then
Debug.Print "Il n'y a plus de séries dans le graphique """ & chartObj.Name & """ !"
Debug.Print "Ce graphique a été effacé."
CurveDeleteNum indChartObj
Else
Debug.Print "La série n° " & indSerieToHide & " de nom """ & serieToHide.Name & """ a été effacée"
serieToHide.Delete
End If
End Sub
' Effacer la collection des séries dans le graphique
Private Sub CleanSeriesColl(chartThis As Chart)
With chartThis
On Error Resume Next
Do
.SeriesCollection(1).Delete
If Err.Number > 0 Then Exit Do
Loop Until False
On Error GoTo 0
End With
End Sub
' Efface le ChartObject de n° indChartObj
Sub CurveDeleteNum(ByVal indChartObj As Integer)
If indChartObj < 0 Or indChartObj > ActiveSheet.ChartObjects.Count Then
Warning "9000: CurveDel : " & vbCrLf & _
"L'indice de ChartObjects n° " & indChartObj & " n'existe pas": Exit Sub
End If
With ActiveSheet.ChartObjects
CleanSeriesColl .Item(indChartObj).Chart
.Item(indChartObj).Delete
End With
End Sub
' Effacer toutes les courbes
Sub CurveDeleteAll()
With ActiveSheet.ChartObjects
While .Count > 0
CurveDeleteNum 1 ' Premier ChartObject de la collection
Wend
End With
End Sub
' Common error management
Sub Warning(ByVal strMsg As String)
Const lenErr = 4 ' Number of digits of the error code beginning the message
If Err.Number <> 0 Then
strMsg = strMsg + vbCrLf + "Error " + Str(Err.Number) + ": " + Err.Description
End If
MsgBox Mid(strMsg, lenErr + 3), vbExclamation, "Graphic warning " + Left(strMsg, lenErr)
End Sub |
