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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
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
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public tourne As Boolean
Dim point As POINTAPI
Dim newposition As Variant, oldposition As Variant
Dim couleur() As Long
Dim obj As Object
Sub pos_souris(choix As Variant, maplage As Variant, overcouleur As Variant)
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 le type d'object est un "range" on va a la ligne "go
GoTo go '
Else 'autrement on va a la ligne "fin"
DoEvents
GoTo fin
End If
'****************************************
go:
'résultat
newposition = obj.Address
' pas de couleur si le curseur se trouve hors de la grille car la variable obj donne "nothing en dehors de la grille
If TypeName(obj) = "Nothing" Then
newposition = oldposition
End If
'ici pour eviter le scintillement de la cellule on verifie si la position (adresse celule) a changé
If newposition <> oldposition Then
If oldposition <> "" Then
'ici on boucle sur toutes les colones de la plage delimité sur la ligne survolée et on remet toutes les couleurs de chaques cellules de cette ligne
For i = maplage.Column To maplage.Columns.Count + maplage.Column - 1
If couleur(i) = vbWhite Then couleur(e) = xlNone
Cells(Range(oldposition).Row, i).Interior.Color = couleur(i)
Next
End If
'on memorise la couleur initiale de la cellule des que oldposition a une valeur
For i = maplage.Column To maplage.Columns.Count + maplage.Column - 1
ReDim Preserve couleur(i)
If Cells(Range(newposition).Row, i).Interior.Color = vbWhite Then
couleur(i) = xlNone
Else
couleur(i) = Cells(Range(newposition).Row, i).Interior.Color
End If
Next
If Not Intersect(maplage, Range(newposition)) Is Nothing Then
If choix <> "" Then
Select Case choix
Case "celule"
'ici on remplie de rouge la cellule survoléesi les condition de debut et de fin de colonne et debut et et de fin de ligne
If overcouleur < 56 Then
Range(newposition).Interior.ColorIndex = overcouleur
Else
Range(newposition).Interior.Color = overcouleur
End If
' on remplie une partie de la ligne
Case "ligne"
'ici on remplie de rouge la ligne survolée dans la zone si les condition de debut et de fin de colonne et debut et et de fin de ligne
If overcouleur <= 56 Then
Range(Cells(Range(newposition).Row, maplage.Column).Address & ":" & Cells(Range(newposition).Row, maplage.Columns.Count + maplage.Column - 1).Address).Interior.ColorIndex = overcouleur
Else
Range(Cells(Range(newposition).Row, maplage.Column).Address & ":" & Cells(Range(newposition).Row, maplage.Columns.Count + maplage.Column - 1).Address).Interior.Color = overcouleur
End If
End Select
End If
End If
End If
oldposition = newposition ' on attribu a la variables olposition celle de la newposition pour la comparer a newposition l'ors de la prochaine boucle
fin:
'dès que l'on sort de la grille et que (l'obj)deviens "Nothing" on remet les couleurs de la derniere ligne survolée
'et on donne une valeur vide a oldposition car la condition pour que le changement soit effectif _
c'est que la newposition soit différente de la oldposition comme ca si on revient sur la meme cellule l'effet sera actif
If TypeName(obj) = "Nothing" Then
oldposition = newposition
For i = maplage.Column To maplage.Columns.Count + maplage.Column - 1
If couleur(i) = vbWhite Then couleur(i) = xlNone
Cells(Range(oldposition).Row, i).Interior.Color = couleur(i)
Next
oldposition = ""
End If
DoEvents
Loop While tourne = True
End Sub |
re
Répondre avec citation
Envoyé par patricktoulon
Remarque 1 :
sa simplifie la tache en plus il s'integre dans le menu edition du vbe !! tres bien!!
Partager