Discussion :

[chtrousselle]

Bonjour,

Tout est dans le titre...

Je sais changer la couleur d'une forme...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Sub test()
 
ActiveSheet.Shapes("1").DrawingObject.Interior.ColorIndex = 3
 
End Sub

...Mais je ne n'arrive pas le faire au survol de la souris. Quelqu'un aurait-il une solution?

Merci d'avance

[Philippe Tulliez]

Bonjour,
Je suppose d'après le code que c'est un objet placé sur une feuille.
Je me suis penché il y a quelques mois sur ce problème pour faire un tuto dynamique et il me semble que l'on ne sait pas le gérer avec le survol d'une souris sauf en utilisant une API.
On peut le faire avec un objet sur un UserForm mais pas sur une feuille, je vais essayer de retrouver le classeur en question pour confirmer.

[mercatog]

Bonjour
Directement, ce n'est pas possible, mais on pourra faire un détour pour cela avec une conception spéciale de la feuille de calcul à l'aide de la formule LIEN_HYPERTEXT jumelée à une fonction personnalisée appropriée.
Si tu as un fichier exemple, je pourrai vous guider et d'ailleurs je pense faire une petite contribution dans ce sens.

[chtrousselle]

Merci pour vos réponses

Voilà un fichier d'exemple

[Philippe Tulliez]

Bonjour,
Je viens de retrouver mon classeur.
J'ai détourné le problème en insérant une image dans un objet CommandButton.
J'ai un lien (en anglais) qui m'a mis sur la piste

Bonjour,
Je joins un extrait de mon classeur qui te permettra peut-être d'avancer dans ton projet.

[chtrousselle]

Merci beaucoup, je vais regarder tout ça

[patricktoulon]

bonsoir

il y apeut etre une solution
un peu tarasbiscoté mais efficace
il faudrait pour cela utiliser les api
getcursor(x,y)
rangefrompoint

ensuite déterminer l'emplacement de ton shapes(dans quelle cellule ou groupe de cellule il se trouve)
l'idée serait
nommer cette plage de cellule du même nom que le shapes par exemple

et dans une boucle do loop agrémentée d'une variable booleenne pour l'arrêter boucler sur la position du curseur avec getcursor
si on tombe sur cette plage on change la couleur

mais c'est assez complexe

si tu fait une recherche dans les contributions tu trouvera comment je change la couleur des ligne d'un sheets au passage de la souris
tu pourrais adapter ce code a ton shapes

il te suffirais alors de determiner l'emplacement de ton shapes et de nommer la plage de cellules ou il se trouve

au plaisir

re bonjour
un peu comme ceci

ouvre un nouveau fichier
met un controlbouton et un shape

met ce code dans le sheet pour le bouton

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Private Sub CommandButton1_Click()
If tourne = True Then
 
tourne = False
Else
tourne = True
ou_ce_trouve_la_souris
End If
End Sub

ajoute un module standard
et met i ça:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare Sub WaitMessage Lib "user32" ()
Type POINTAPI
    X As Long
    Y As Long
End Type
Public tourne As Boolean
Dim point As POINTAPI
Dim obj As Object
Sub ou_ce_trouve_la_souris()
    lieux_du_shape = ""
 
    lieux_du_shape = ActiveSheet.Shapes("Rectangle 1").TopLeftCell.Address & ":" & ActiveSheet.Shapes("rectangle 1").BottomRightCell.Address
    Do
        WaitMessage    'en attente d'un message (en l'occurence dans le cas présent  si j'ai bien compris "nothing ou range")
        DoEvents    'permet au reste du fichier de fonctionner
        GetCursorPos point    'trouve les coordonnées du curseur
        Set obj = ActiveWindow.RangeFromPoint(point.X, point.Y)    'trouve l'object sous le curseur(en l'occurence "Range ou nothing")
        If TypeName(obj) = "Range" Then    ' si l'object sous le curseur est un range
            'on teste l'intersection de l'adresse de l'object avec l'adress qu'occupe le shape
            Set isect = Application.Intersect(Range(obj.Address), Range(lieux_du_shape))
            If isect Is Nothing Then
                DoEvents    'si les deux adresse se croise pas  on met en bleu
                ActiveSheet.Shapes("Rectangle 1").Fill.ForeColor.RGB = (vbBlue)
            Else
                DoEvents    'si les deux adresse se croisent on met en rouge
                ActiveSheet.Shapes("rectangle 1").Fill.ForeColor.RGB = (vbRed)
            End If
        End If
    Loop While tourne = True
End Sub

bien sur adapte les noms de ta shape et de ton bouton
donc verifie bien si ton shape s'appelle bien "Rectangle 1" et ton bouton "CommandButton1"

ferme l'éditeur vba
clique 1 fois sur le bouton et amuse toi a te promener sur le shape avec la souris
clique une 2eme fois et l'effet ne se fait plus
si tu reclique sur le bouton l'effet reviens etc......

voila au plaisir

[patricktoulon]

bonsoir
depuis hier j'ai un petit peut améliorer le truc

en effet si ton shape fait environ la largeur de 2 colonne et demie

l'adresse prise en compte sera trop grande et donc l'effet sera fait trop tot

j'ai donc revu la copie

et j'ai utilisé un autre stratagème

pour commencer on utilisera pratiquement que les apis

le principe
déterminer la hauteur du ruban car en effet quand le shape est en a1 par exemple son top est de zéro hors la position de la souris t'indique une autre mesure pour la simple et bonne raison que getcursor te donne la position par rapport a l'écran et non la fenêtre

ceci fait on déduit donc la hauteur du ruban a la position de la souris ainsi on aura des valeurs identique le tout converti en pixels bien sur

bon allez j'arrette de parler regarde ce code et remplace l'ancien
dans le code la feuille

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
 
Private Sub CommandButton1_Click()
If tourne = True Then
 
tourne = False
Else
tourne = True
recherche_du_rectanglegrille
End If
End Sub

et dans le module standard

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Option Explicit
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINT_) As Long
Type POINT_
    X As Long
    Y As Long
End Type
Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Dim point As POINT_, coord As RECT, coord2 As RECT, nomclasse As String * 200
Dim ruban As Long, leleft As Long, mintop As Long, maxtop As Long, minleft As Long, maxright As Long, posy As Long, posx As Long
Dim pointeur
Sub recherche_du_rectanglegrille()
'recherche de la fenetre de la page active avec l'api findwindow
    pointeur = FindWindow("XLMAIN", vbNullString)
    pointeur = GetWindow(pointeur, 5)
    Do
        'on cherche le handle de la grille
        DoEvents
        GetClassName pointeur, nomclasse, 250
        If LCase(Left(nomclasse, 6)) = "xldesk" Then Exit Do    'on sort de la boucle si le text de la fenetre est celui du bureau "desktop"
        pointeur = GetWindow(pointeur, 2)
        'on créé un rectangle virtuel '(tu ne le verra pas rassurre toi)ayant les dimentions de la grille(a1 a la derniere a droite que tu vois)
        Call GetWindowRect(pointeur, coord2)
    Loop
    ruban = coord2.Top    'donc la hauteur du ruban c'est le top de la grille
    leleft = coord2.Left  ' pareil pour le left de la grille
    'on determine le minimum et le maximum corespondant au chape rectangle 1 *4/3 pour des dimentions en pixels bien que c'est une formule aproximative cela peut changer selon les ecrans
    'son top
    mintop = ActiveSheet.Shapes("Rectangle 1").Top * 4 / 3
    ' son bottom
    maxtop = ActiveSheet.Shapes("Rectangle 1").Top * 4 / 3 + ActiveSheet.Shapes("Rectangle 1").Height * 4 / 3
    'son left
    minleft = ActiveSheet.Shapes("Rectangle 1").Left * 4 / 3
    'son right
    maxright = ActiveSheet.Shapes("Rectangle 1").Left * 4 / 3 + ActiveSheet.Shapes("Rectangle 1").Width * 4 / 3
    Do
        WaitMessage    'en attente d'un message (en l'occurence dans le cas présent  si j'ai bien compris "nothing ou range")
        DoEvents    'permet au reste du fichier de fonctionner
        GetCursorPos point    'trouve les coordonnées du curseur
        posy = point.Y - ruban - 20    'les coordonnées de la souris partent du haut de l'ecran on va donc enlever a y la hauteur du ruban - la formulabar
        posx = point.X - leleft - 20 - 5    'c'est apeu pres pareil pour le left
        DoEvents
        'maintenant en comparant la position de la souris avec les 4 mesures
        If posy > mintop And posy < maxtop And posx > minleft And posx < maxright Then
 
            DoEvents
            'si la souris est dans ce rectangle formé par les mesures il est rouge
            ActiveSheet.Shapes("rectangle 1").Fill.ForeColor.RGB = (vbRed)
        Else
            DoEvents
            'sinon il est blanc
            ActiveSheet.Shapes("Rectangle 1").Fill.ForeColor.RGB = (vbBlue)
 
 
        End If
    Loop While tourne = True 'la boucle tournera tant que tu n'a pas recliqué sur le bouton
End Sub

la c'est plus preci

au plaisir