Selection d'objet dans une forme libre

Version imprimable

29/05/2019, 13h21
remi_62

Selection d'objet dans une forme libre

Bonjour,

Ayant une légère connaissance en VB, je cherche à faire une macro qui me sélectionne l'ensemble des objets (msoShapeOval) à l'intérieur d'une forme libre sélectionné.

Exemple:
select des objets "nom des villes" dans la forme libre qui serait la France et pas les objets des pays voisins.

Le but final étant d'attribué des couleurs conditionnelles aux msoShapeOval à l'intérieur de leurs forme libre.

Merci d'avance pour vos conseils.
29/05/2019, 13h56
Menhir

Tous ces objets sont des Shape.
https://docs.microsoft.com/fr-fr/off...pi/excel.shape

Pour une Shape, les propriétés Top et Left permettent de connaitre respectivement les limites haute et gauche de la forme.
En leur additionnant les propriétés Height et Width, on peut connaitre les limites basse et droite.
Tout ça délimite donc la Shape.

Dans ta macro, tu commences par délimiter ta forme libre en conservant ses limites dans des variables.
Ensuite, tu fais une boucle For Each sur la collection Shapes et tu testes les limites de chacune pour savoir si elles sont à l'intérieur de la limite de ta forme libre.

Bonjour,

On pourrait commencer ainsi :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub selall()
Set myDocument = Worksheets(1)
myDocument.Shapes.SelectAll
 
Set france = Selection.ShapeRange
 
For Each ville In france
'Debug.Print ville.Name
  If Left(ville.Name, 4) = "Oval" Then
    ville.Fill.ForeColor.RGB = RGB(255, 100, 0)
  End If
Next
[A1].Select
 
End Sub

1 pièce(s) jointe(s)

re
menhir pas si simple

c'est un soucis que j'avais laisser tomber a l'époque n'ayant rien trouvé

Citation:

sélectionne l'ensemble des objets (msoShapeOval)

le problème est que le typemso est en écriture pas en lecture

je dis ca a ma connaissance bien sur

si c'est effectivement le cas car je n'ai toujours rien trouvé , il te faut repérer les shapes (OVALE) soit par leur nom,couleur,etc....
sinon apres c'est facile avec shape.range
une petite fonction qui va bien

Code:

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
Sub test()
    Dim maselectionShape(), maformelibre As Shape
    Set maformelibre = ActiveSheet.Shapes("carré")
    maselectionShape = AllShapesInOne(maformelibre)
    Set collectShapesOval = ActiveSheet.Shapes.Range(maselectionShape)
    'tu fait ce que tu veux apres avec ("collectShapesOval")
    'exemple je les selectionne toutes
    collectShapesOval.Select
End Sub
'
Function AllShapesInOne(shp As Shape)
'on recherche les msoShapeOval
    Dim tablo(), x As Boolean, oval As Shape
    For Each oval In shp.Parent.Shapes
        x = oval.Left > shp.Left And oval.Top > shp.Top And oval.Width < shp.Width And oval.Height < shp.Height
        If x = True Then
            '(If condition msoShapeOval Then)
            i = i + 1: ReDim Preserve tablo(1 To i): tablo(i) = oval.Name
            'MsgBox oval.MsoShapename 'marche pas existe pas
            'MsgBox oval.MsoShapeType 'marche pas en lecture
            'MsgBox oval.typeMso    'marche pas existe pas
            'etc..etc...
            '(End If)
        End If
    Next
    AllShapesInOne = tablo
End Function

Pièce jointe 479167

re
pour le coup j'ai trouvé
c'est pas msoAutoShapeType en lecture mais AutoShapeType

du coup la voila complète
seules les msoShapeOval seront selectionnées

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 
 
Sub test()
    Dim maselectionShape(), maformelibre As Shape
    Set maformelibre = ActiveSheet.Shapes("carré")
    maselectionShape = AllShapesInOne(maformelibre, msoShapeOval)
    Set collectShapesOval = ActiveSheet.Shapes.Range(maselectionShape)
    'tu fait ce que tu veux apres avec ("collectShapesOval")
    'exemple je les selectionne toutes
    collectShapesOval.Select
End Sub
'
'
Function AllShapesInOne(shp As Shape, typeMsoAuto As MsoAutoShapeType)
'on recherche les msoShapeOval
    Dim tablo(), x As Boolean, shap As Shape
    For Each shap In shp.Parent.Shapes
        x = shap.Left > shp.Left And shap.Top > shp.Top And shap.Width < shp.Width And shap.Height < shp.Height
        If x = True Then
            If x And shap.AutoShapeType = typeMsoAuto Then i = i + 1: ReDim Preserve tablo(1 To i): tablo(i) = shap.Name
             End If
    Next
    AllShapesInOne = tablo
End Function

je vais la garder celle la ;)

31/05/2019, 14h23
remi_62

Merci,

C'est une bonne base pour moi, je vais modifié pour

- les formes libre à la sélection car trop de nominatif

Code:

Set maformelibre = ActiveSheet.Shapes(selection.Name)

- vider le tablo car sélection de tous les objets précédent lors d'une autre exécution