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
131
132
133
134
135
136
|
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_
Dim coord As RECT
Dim nomclasse As String * 200
Dim newposition As Variant, oldposition As Variant
Dim couleur() As Long
Public tourne As Boolean
Dim oldcouleur As Long
Function pos_souris(choix As Variant, maplage As Variant, overcouleur As Variant)
Do
'recherche de la fenetre de la page active
pointeur = FindWindow("XLMAIN", vbNullString)
pointeur = GetWindow(pointeur, 5)
Do
GetClassName pointeur, nomclasse, 250
If LCase(Left(nomclasse, 6)) = "xldesk" Then Exit Do
pointeur = GetWindow(pointeur, 2)
Loop
'recherche de la position et taille de la fenetre
Call GetWindowRect(pointeur, coord)
échx = Application.UsableWidth / (coord.Right - coord.Left)
échy = Application.UsableHeight / (coord.Bottom - coord.Top)
'recherche de la position du curseur en points
GetCursorPos point
xpt = ((point.X - coord.Left) * échx) - 20 ' on enleve 20 pour la colonne de chiffre representant les lignes
ypt = ((point.Y - coord.Top) * échy) - 15 ' on enleve 15 pour la ligne des lettres
'position en lignes colonnes
'on commence a zero
lin = 0
col = 0
encorey:
lin = lin + 1
If ypt > Cells(lin + 1, 1).Top - Cells(ActiveWindow.ScrollRow, 1).Top Then GoTo encorey
encorex:
col = col + 1
If xpt > Cells(1, col + 1).Left - Cells(1, ActiveWindow.ScrollColumn).Left Then GoTo encorex
'résultat
pos_souris = Cells(lin, col).Address
newposition = pos_souris
' pas de couleur si le curseur se trouve hors de la grille
If ypt < 0 Or xpt < 0 Then
'Cells.Interior.Color = xlNone
Range(oldposition).Interior.Color = oldcouleur
newposition = oldposition
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
Else
'ici pour eviter le scintillement de la cellule on verifie si la position (adresse celule) a changé
If newposition <> oldposition Then
'on memorise la couleur initiale de la cellule des que oldposition a une valeur
If oldposition <> "" Then
If oldcouleur = vbWhite Then oldcouleur = xlNone ' si c'est blanc il n'y a pas de couleur
Range(oldposition).Interior.Color = oldcouleur
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
oldcouleur = Range(newposition).Interior.Color
If oldcouleur = vbWhite Then oldcouleur = xlNone
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 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 col >= maplage.Column And col <= maplage.Columns.Count + maplage.Column - 1 And lin >= maplage.Row And lin <= maplage.Rows.Count + maplage.Row - 1 Then
If overcouleur < 56 Then
Range(newposition).Interior.ColorIndex = overcouleur
Else
Range(newposition).Interior.Color = overcouleur
End If
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 col >= maplage.Column And col <= maplage.Columns.Count + maplage.Column - 1 And lin >= maplage.Row And lin <= maplage.Rows.Count + maplage.Row - 1 Then
If overcouleur < 56 Then' si le chiffre enoncé dans l'appel est plus petit que 56 on utilise le colorindex de office
Range(Cells(lin, maplage.Column).Address & ":" & Cells(lin, maplage.Columns.Count + maplage.Column - 1).Address).Interior.ColorIndex = overcouleur
Else
Range(Cells(lin, maplage.Column).Address & ":" & Cells(lin, maplage.Columns.Count + maplage.Column - 1).Address).Interior.Color = overcouleur
End If
End If
End Select
End If
End If
End If
DoEvents
oldposition = newposition ' on attribu a la variables olposition celle de la newposition pour la comparer a newposition l'ors de la prochaine boucle
Loop While tourne = True
End Function |
effet mouse over sur les lignes d'un sheet
Répondre avec citation
Partager