Modifier taille d'un cercle (shape Oval)Résolu

Question

Bonjour à tous,

J'ai 3 cercles concentriques non pleins dont je veux pouvoir faire varier la taille de chacun en fonction d'une valeur d'une aire. Bien sûr ils doivent rester concentriques.

Une fois les cercles corrects tracés, je veux pouvoir remplir les différence de taille entre ces cercles de couleur (en leur affectant des transparences).

Mes recherches n'ont pas abouties, et l'enregistreur de macro ne donne pas le résultat attendu. voilà ce qu'il donne :

Sub Aire1()
'modification de la taille du cercle 1 (N°583)
    
    'sélection du shape
    Sheets("Data").Shapes("Oval 583").Select
        'mise à la taille valeur 1
        Selection.ShapeRange.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
        Selection.ShapeRange.ScaleHeight 1, msoFalse, msoScaleFromBottomRight
        'mise à la taille valeur 2
        Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
        Selection.ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromBottomRight
        'couleur du contour = 10 (rouge)
        Selection.ShapeRange.Line.ForeColor.SchemeColor = 10

End Sub

En fait, chaque fois que je lance la macro "Aire1", la taille du cercle double... Si je mets un point d'arrêt après taille "1", le cercle construit précédemment ne change pas.

Je pense donc que ce script ne convient pas du tout!

Une piste ? un conseil ?
Merci d'avance

Rataxes64

CerberusPau · Accepted Answer

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

ucfoutu · Answer

Bonjour,
Elan purement naturel, sans faire le moindre essai :
Mémoriser les dimensions avant agrandissement puis appliquer l'agrandissement sur la base de ces seules dimensions originelles.

________________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement vous dire ce qu'elle contient. Je n'interviendrai qu'en cas de nécessité de développ

CerberusPau · Answer

Bonjour Ucfoutu,

C'est effectivement ce que donne l'enregistreur...

Mes "moindres essais" sont toujours en cours, et toujours sans succès.

Je continue donc à patauger (en solitaire pour l'instant...) avec ceci (qui n'est évidemment pas correct).

Sub ModifCercle(ByVal C As Long, ByVal X As Single, ByVal Y As Single, ByVal H, ByVal L)
    Sheets("Data").Shapes(C, X, Y, H, L).Select
End Sub

'==================================

Sub AireCercle()
    Dim C As String
    Dim X As Single
    Dim Y As Single
    Dim H As Single
    Dim L As Single
    'Nom du cercle
    C = "Oval 583"
    'coordonnées du centre
    X = 100
    Y = 100
    'hauteur du cercle
    H = 10
    'largeur du cercle
    L = 10
    ModifCercle C, X, Y, H, L
End Sub

En espérant ne pas en rester là.

Rataxes64

Modifier taille d'un cercle (shape Oval)

3 réponses

Votre réponse

Discussions similaires