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 |
Partager