Bonjour,
Je n'ai pas réussi à en venir à bout par "modification" de shapes existants...
Je suis passé par une re-création et j'obtiens le résultat final que je voulais... Mais par quels parcours!
Si une bonne âme pouvait m'aider à trouver plus simple, ce serait cool.
Merci
Mon code "création" actuel -Sub AireCercles()-pour mes 3 cercles concentriques (créés du plus grand au plus petit car en "fill.solid").
Sub CréerCercle1(ByVal X1 As Single, ByVal Y1 As Single, ByVal H1 As Single, ByVal L1 As Single)
'Création du cercle1
'Effacer Cercle1 s'il existe
On Error Resume Next
Sheets("Fan").Shapes("Cercle1").Delete
'Créer ou recréer cercle1
Sheets("Fan").Shapes.AddShape(msoShapeOval, X1, Y1, H1, L1).Select
With Selection
.Name = "Cercle1"
.ShapeRange.Fill.ForeColor.SchemeColor = 51 'couleur
.ShapeRange.Fill.Visible = msoTrue
.Fill.Solid
End With
End Sub
'======================================
Sub CréerCercle2(ByVal X2 As Single, ByVal Y2 As Single, ByVal H2 As Single, ByVal L2 As Single)
'Création du cercle2
'Effacer Cercle2 s'il existe
On Error Resume Next
Sheets("Fan").Shapes("Cercle2").Delete
'Créer ou recréer cercle2
Sheets("Fan").Shapes.AddShape(msoShapeOval, X2, Y2, H2, L2).Select
With Selection
.Name = "Cercle2"
.ShapeRange.Fill.ForeColor.SchemeColor = 12 'couleur
.ShapeRange.Fill.Visible = msoTrue
.Fill.Solid
End With
End Sub
'======================================
Sub CréerCercle3(ByVal X3 As Single, ByVal Y3 As Single, ByVal H3 As Single, ByVal L3 As Single)
'Création du cercle3
'Effacer Cercle3 s'il existe
On Error Resume Next
Sheets("Fan").Shapes("Cercle3").Delete
'Créer ou recréer cercle3
Sheets("Fan").Shapes.AddShape(msoShapeOval, X3, Y3, H3, L3).Select
With Selection
.Name = "Cercle3" 'nom
.ShapeRange.Fill.ForeColor.SchemeColor = 10 'couleur
.ShapeRange.Fill.Visible = msoTrue
.Fill.Solid
End With
End Sub
'======================================
Sub AireCercles()
Dim X1 As Single
Dim Y1 As Single
Dim X2 As Single
Dim Y2 As Single
Dim X3 As Single
Dim Y3 As Single
Dim H1 As Single
Dim L1 As Single
Dim H2 As Single
Dim L2 As Single
Dim H3 As Single
Dim L3 As Single
'hauteur des cercles
H1 = 40 'diamètre vertical cercle1
H2 = 10 'diamètre vertical cercle2
H3 = 20 'diamètre vertical cercle3
'largeur des cercles
L1 = 40 'diamètre horizontal cercle1
L2 = 10 'diamètre horizontal cercle2
L3 = 20 'diamètre horizontal cercle3
'coordonnées du centre
X1 = 100 - H1 / 2 'Abcisse1 moins rayon1
Y1 = 100 - H1 / 2 'Ordonnée1 moins rayon1
X2 = 100 - H2 / 2 'Abcisse2 moins rayon2
Y2 = 100 - H2 / 2 'Ordonnée2 moins rayon2
X3 = 100 - H3 / 2 'Abcisse3 moins rayon3
Y3 = 100 - H3 / 2 'Ordonnée3 moins rayon3
'création des cercles du plus grand au plus petit
If L1 > L2 And L1 > L3 Then
CréerCercle1 X1, Y1, H1, L1
If L2 > L3 Then
CréerCercle2 X2, Y2, H2, L2
CréerCercle3 X3, Y3, H3, L3
Else
CréerCercle3 X3, Y3, H3, L3
CréerCercle2 X2, Y2, H2, L2
End If
ElseIf L2 > L1 And L2 > L3 Then
CréerCercle2 X2, Y2, H2, L2
If L1 > L3 Then
CréerCercle1 X1, Y1, H1, L1
CréerCercle3 X3, Y3, H3, L3
Else
CréerCercle3 X3, Y3, H3, L3
CréerCercle1 X1, Y1, H1, L1
End If
Else
CréerCercle3 X3, Y3, H3, L3
If L1 > L2 Then
CréerCercle1 X1, Y1, H1, L1
CréerCercle2 X2, Y2, H2, L2
Else
CréerCercle2 X2, Y2, H2, L2
CréerCercle1 X1, Y1, H1, L1
End If
End If
End Sub
Cordialement
Rataxes64