Option Explicit
Public Courbe As Series
Public Graphique As Chart
Sub Depart()
UserForm1.Show vbModeless
End Sub
Sub Suite()
Dim rgData As Range, tabData
Dim echelleX As Single, echelleY As Single
'Identification du graphique de la courbe
Set Graphique = Courbe.Parent.Parent
'récupération des données
On Error Resume Next
Set rgData = Application.InputBox("Sélectionnez les données relatives à la courbes" & _
vbLf & "(X, Y, Largeur, Hauteur) :?", Type:=8)
If rgData Is Nothing Then
MsgBox "Plage de données incorrecte => Echec"
Exit Sub
End If
On Error GoTo 0
'tableau des données
tabData = rgData.Value
'Quelques données
Dim tailAxeX, minX, maxX
Dim tailAxeY, minY, maxY
Dim LargeurX, HauteurY
echelleX = rgData(1, 1).Offset(-2)
echelleY = rgData(1, 1).Offset(-1)
tailAxeX = Graphique.PlotArea.Width
tailAxeY = Graphique.PlotArea.Height
minX = Graphique.Axes(xlCategory).MinimumScale
maxX = Graphique.Axes(xlCategory).MaximumScale
LargeurX = maxX - minX
minY = Graphique.Axes(xlValue).MinimumScale
maxY = Graphique.Axes(xlValue).MaximumScale
HauteurY = maxY - minY
' Tri du tableau des données
' on ajoute deux colonnes
Dim i&, j&, aux
ReDim Preserve tabData(1 To UBound(tabData), 1 To 7)
' on calcule la surface et on la rajoute au tableau
' ainsi que numéro du point
For i = 1 To UBound(tabData)
tabData(i, 6) = tabData(i, 4) * tabData(i, 5)
tabData(i, 7) = i
Next i
' on trie le tableau de la plus grande surface à la plus petite
' pour ensuite créer les formes dans cette ordre
Dim ech As Boolean
ech = False
Do
ech = False
For i = 1 To UBound(tabData) - 1
If tabData(i + 1, 6) > tabData(i, 6) Then
ech = True
For j = 1 To 7
aux = tabData(i, j)
tabData(i, j) = tabData(i + 1, j)
tabData(i + 1, j) = aux
Next j
End If
Next i
Loop Until Not ech
'Boucle sur les points de la série
Dim xpt As Point, xshp As Shape, Rect As Shape, xrg As Range
For i = 1 To UBound(tabData)
'on efface le rectangle existant
For Each xshp In Graphique.Shapes
If xshp.Name = "surf-" & tabData(i, 1) Then xshp.Delete
Next xshp
'on re-crée le rectangle correspondant
Set Rect = Graphique.Shapes.AddShape(msoShapeRectangle, 10, 10, 20, 10)
Rect.Name = "surf-" & tabData(i, 1)
'largeur du rectangle
Rect.Width = tabData(i, 4) / LargeurX * Graphique.Axes(xlCategory).Width * echelleX
'hauteur du rectangle
Rect.Height = tabData(i, 5) / HauteurY * Graphique.Axes(xlValue).Height * echelleY
'position Top du rectangle
Rect.Top = Courbe.Points(tabData(i, 7)).Top + Courbe.Points(tabData(i, 7)).Height / 2 - Rect.Height / 2
'position left du rectangle
Rect.Left = Courbe.Points(tabData(i, 7)).Left + Courbe.Points(tabData(i, 7)).Width / 2 - Rect.Width / 2
'Couleur de la forme
With Rect.Fill
Set xrg = rgData(tabData(i, 7), 1)
.ForeColor.RGB = xrg.Interior.Color
.Transparency = 0.33
End With
'Texte de la forme et sa couleur
Rect.TextFrame2.TextRange.Text = tabData(i, 1)
Rect.TextFrame2.TextRange.Characters(1, Len(tabData(i, 1))).Font.Fill.ForeColor.RGB = xrg.Font.Color
'positionnement du texte
Rect.TextFrame2.VerticalAnchor = msoAnchorMiddle
Rect.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
Rect.TextFrame2.TextRange.Font.Bold = msoTrue
Next i
Application.Goto ThisWorkbook.ActiveSheet.Range("A1"), True
End Sub
il faut être illuminé et quelque peu insensé pour se lancer dans de telles élucubrations...
