[Toutes versions] effet mouse over sur les lignes d'un sheet

[patricktoulon]

bonjour a tous

je vous propose aujourdh'ui comme le titre du post l'indique l'effet mouse over
sur les lignes d'un sheets
j'ai commenté pratiquement chaque ligne du code pour plus de comprehention
utilisation de l'api de la souris dans la user 32 dll

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
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
'************************
'createur patricktoulon
'************************
'Objet: module pour donner l'effet mouse over au ligne d'un sheets
'********************************************************************
 
'MODULE STANDARD
 
Option Explicit
'Declaration de l'api pour la position du curseur
Public Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
 
Public Type PointAPI
    x As Long
    y As Long
End Type
Public PtCur As PointAPI
Public tourne As Boolean
 
Sub position()
Dim oldligne As Long, newligne As Long ' ici je declare le chiffre correspondant aux variables designant l'ancienne ligne et la nouvelle
Dim pos As Long, i As Long ' ici la variable qui va me servir a determiner la ligne
Do ' on comance une boucle perpetuelle
With Sheets(1) ' donc avec le sheets(1)
i = i + 1 ' on incremente la variable i a chaque boucle i va nouservir a comparer la variable "pos a "i"
 GetCursorPos PtCur ' on apelle la fonction par l'api
 
If PtCur.y - 187 > 0 Then pos = Round((PtCur.y - 187) * 0.75) 'si l'arrondi de  la position verticale -(187 qui represente la hauteur de mon ruban) _
* 0.75 pour convertir en point la position qui a la base sort en pixel
If pos > .Cells(i, 1).Top And pos < (.Cells(i, 1).Top + .Cells(i, 1).Height) Then ' donc si pos est plus grand quela celule.top en ligne"i" etsi pos est  plus petit que le top +le height de cette meme celule la variable "newligne prend la valeur de la celule .row
 
newligne = .Cells(i, 1).Row
End If
If newligne <> oldligne Then 'si la newligne est differente de la oldligne alors on met tout le sheets sans couleur et on colorie la ligne
.Cells.Interior.Color = xlNone 'on remet toutes les celule sans couleur
Rows(newligne & ":" & newligne).Interior.Color = vbRed 'ici tu met le code couleur que tu veux moi j'ai mis rouge
End If
DoEvents
End With
If i > 26 Then i = 0
oldligne = newligne ' ici on atribu a oldligne la valeur de newligne comme ca ca nous permet de controler si il y a mouvement avec la variable "pos plus haut dans la macro
Loop While tourne = True 'on continu tant que la variable booleenne est a true ' je rappelle que cette variable est modifiée a l'activate et le desactivate du sheets(1)
End Sub

'DANS LE MODULE DU SHEETS
''********************************

Code :

1
2
3
4
5
6
7
Private Sub Worksheet_Activate()
tourne = True
position
End Sub
Private Sub Worksheet_Deactivate()
tourne = False
End Sub

bonne utilisation

au plaisir

[Philippe JOCHMANS]

Bonjour

Merci pour cette contribution, mais lorsque vous mettrez du code sur le forum pensez à sa présentation, et entre autre à son indentation pour le rendre plus lisible.

Merci

Philippe

[patricktoulon]

bonjour philippe joshmans


je pensait avoir suffisament commenté le code pour qu'il soit inteligible

j'avoue que je comprend mal l'expression "indenter" puis je avoir des explications a ce sujet


merci d'avance

au plaisir

[Philippe JOCHMANS]

http://www.developpez.net/forums/d10...e/#post5994593

[patricktoulon]

rebonsoir philippe jochmans

ok j'ai compris "indenter" un simple decalage dans les boucles imbriquer par exemple enfin si j'ai bien compris

je te remercie pour ces indications

j'en profite pour ajouter une petite modification necessaire en cas d'utilisation de la scrollbar verticale

il faut remplacer

Code :

newligne = .Cells(i , 1).Row

par

Code :

newligne = .Cells(i + ActiveWindow.ScrollRow - 1, 1).Row

de facon a ce que ca fonctionne sur toutes les lignes de la feuille
encore merci

au plaisir

[AlainTech]

Petite explication pour l'indentation:
L'indentation est le fait de mettre en retrait d'un nombre de caractères fixe (VBE à une valeur de 4 par défaut) certaines lignes.
Les lignes à indenter sont celles qui se trouvent entre les limites de toute instruction ayant un début et une fin telles que:
Sub
Function
If
For
Do
While
With
Select
...

Trois exceptions:
Else (ou ElseIf) qui se met au même niveau que le If auquel il se rapporte.
Case qui n'a pas d'instruction de fin et dont la limite est le Case suivant.
Le If écrit sur une seule ligne (ce que je déconseille) qui n'a pas d'instruction de fin. Il n'y a donc rien à indenter.

Pour indenter facilement (pour autant que les paramètres de VBE aient été laissé dans leur configuration d'origine):
Placer le curseur devant une ligne ou, plus simple, sélectionner toute la ligne (ou plusieurs) et taper la touche Tab.
Pour désindenter une ligne, la sélectionner et taper Shift + Tab.

Si le curseur est à la fin d'une ligne indentée et qu'on tape Enter, la ligne suivante sera aussi indentée.
Pour taper une instruction de fin (End...) taper Backspace, le curseur se placera au niveau d'indentation précédent.

Exemple

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub Test()
  Dim i As Integer
 
  For i = 1 To 5
    Select Case i
      Case 1
        Traitement1
      Case 2
        Traitement2
      Case 3
        Traitement3
      Case Else
        Traitement4
    End Select
  Next i
End Sub

Sur les très longues procédures, si on veut savoir, par exemple, à quel If se rapporte un Else, il suffit de placer le curseur juste devant le E du Else et utiliser la flêche haute pour voir quel If est au même niveau d'indentation.

[patricktoulon]

bonsoir alaintech

merci pour ces indications supplémentaires

mis a part ça si vous avez une idée concernant la possibilité de rendre le calcul automatique de la dimension en hauteur du ruban de façon a remplacer le "-187" chez moi ,qui me sert a déterminer le niveau le plus haut en top
ça serais le bien venu


merci a tout les deux


au plaisir

[AlainTech]

N'est-il pas possible de repérer le Top de la cellule A1?

[patricktoulon]

rebonsoir

logiquement oui
mais si je fait

Code :

1
2
3
4
sub donne_le_top()
msgbox sheets(1).cells(1,1).top 
'ca me donne zero
end sub

j'avoue que je comprend pas


au plaisir

[fring]

Tu obtiens 0 parce Cells(x, x).Top te donne la coordonnée y de la cellule par rapport à la feuille et non par rapport à l'écran.
L'idéal serait de pouvoir obtenir les coordonnées d'une cellule par rapport au point 0,0 de l'écran ce qui permettrait de faire fonctionner l'API sans tenir compte de la fenêtre Excel (fenêtre réduite, étendue, plein écran, etc...) mais je ne sais pas si c'est réalisable.

[patricktoulon]

rebonjour fring


en fait j'ai commencer a trouvé une piste toute simple

je declare le height du ribbon et de la status bar

Code :

Application.CommandBars("Status Bar").Height + Application.CommandBars("Ribbon").Height

mais j'arrive a 172 il me manque comment trouver le height de la formulabar

et du activewindows.worktabs pour les onglets


je cherche je cherche


au plaisir

[patricktoulon]

bonjour

j'ai apporté quelques modification au code

en effet maintenant lorsque l'on sort de la grille excel plus de couleur!!!

j'ai indenter le code pour plus de lisibilité comme me la conseillé philippe jochmans

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
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
'************************
'createur patricktoulon
'************************
'Objet: module pour donner l'effet mouse over au ligne d'un sheets
'********************************************************************
 
'MODULE STANDARD
 
Option Explicit
'Declaration de l'api pour la position du curseur
Public Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
 
Public Type PointAPI
    x As Long
    y As Long
End Type
Public PtCur As PointAPI
Public tourne As Boolean
 
Sub position()
Dim oldligne As Long, newligne As Long ' ici je declare le chiffre correspondant aux variables designant l'ancienne ligne et la nouvelle
Dim pos As Long, i As Long ' ici les variables qui va me servir a determiner la ligne
Do ' on comance une boucle perpetuelle
  With Sheets(1) ' donc avec le sheets(1)
   i = i + 1 ' on incremente la variable i a chaque boucle i va nouservir a comparer la variable "pos a "i"
   GetCursorPos PtCur ' on apelle la fonction par l'apiqui nous donne la position du curseur
 
     If PtCur.y < 187 Or PtCur.x < 15 Then 'si ptcur.y est plus petit que 187 (187 represente la hauteur de mon ruban)ou pcur.xest plus petit que 15 aucune ligne de couleur
       .Cells.Interior.Color = xlNone
     Else
     pos = Round((PtCur.y - 187) * 0.75)  'arrondi de  la position verticale -(187 qui represente la hauteur de mon ruban) _
     * 0.75 pour convertir en point la position qui a la base sort en pixel 'on a maintenant la position du curseur en point excel
     .Cells(1, 1) = pos
 
       'si la position du curseur en point ext plus grand que la cellule (i,1).topet plus petit que la celule(i,1).top plus sa hauteur alors _
       le numero de ligne est la celule(i,1).row(i incremmenté a chaque boucle)
       If pos > .Cells(i, 1).Top And pos < (.Cells(i, 1).Top + .Cells(i, 1).Height) Then ' donc si pos est plus grand quela celule.top en ligne"i" etsi pos est  plus petit que le top +le height de cette meme celule la variable "newligne alors prend la valeur de la celule(i,1) .row
       newligne = .Cells(i + ActiveWindow.ScrollRow - 1, 1).Row
       '.Cells(1, 2) = newligne
       End If
     End If
 
        If newligne <> oldligne Then 'si la newligne est differente de la oldligne alors on met tout le sheets sans couleur et on colorie la ligne
        .Cells.Interior.Color = xlNone 'on remet toutes les celule sans couleur
        Rows(newligne & ":" & newligne).Interior.Color = vbRed 'ici tu met le code couleur que tu veux moi j'ai mis rouge
        End If
                 DoEvents ' permet de ne pas bloquer le reste du fichier voir des autres macros
  End With
        If i > 100 Then i = 0 ' ici la limite est a 10 lignes bien que je doute qu'un ecran propose l'affichage de 100 lignes en general entre 25 et 35 lignes selon la resolution de votre ecran
        oldligne = newligne ' ici on atribu a oldligne la valeur de newligne comme ca ca nous permet de controler si il y a mouvement avec la variable "pos plus haut dans la macro
Loop While tourne = True 'on continu tant que la variable booleenne est a true ' je rappelle que cette variable est modifiée a l'activate et le desactivate du sheets(1)
End Sub

'DANS LE MODULE DU SHEETS
''********************************

Code :

1
2
3
4
5
6
7
Private Sub Worksheet_Activate()
tourne = True
position
End Sub
Private Sub Worksheet_Deactivate()
tourne = False
End Sub

au plaisir

[patricktoulon]

bonsoir a tous

je vous propose aujourd'hui la version qui donne l'effet sur une cellule et plus la ligne entière

il vous suffi de remplacer la macro "position" par celle ci le code est largement commenté et indenté

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
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
Sub position()
Dim oldligne As Long, newligne As Long, newcol As Long, oldcol As Long ' ici je declare le chiffre correspondant aux variables designant l'ancienne ligne et la nouvelle
Dim posy As Long, posx As Long, i As Long, col As Long ' ici les variables qui va me servir a determiner la ligne
newligne = 1  ' on incremente la variable i a chaque boucle i va nouservir a comparer la variable "pos a "i"
col = 1
i = 1
Do ' on comance une boucle perpetuelle
  With Sheets(1) ' donc avec le sheets(1)
 
   GetCursorPos PtCur ' on appelle la fonction par l'api qui nous donne la position du curseur
 
     If PtCur.y < 187 Or PtCur.x < 20 Then 'si ptcur.y est plus petit que 187 (187 represente la hauteur de mon ruban)ou pcur.xest plus petit que 15 aucune ligne de couleur
       .Cells.Interior.Color = xlNone
    newcol = 0
     Else
    'arrondi de  la position verticale -(187 qui represente la hauteur de mon ruban) _
     * 0.75 pour convertir en point la position qui a la base sort en pixel 'on a maintenant la position du curseur en point excel
     posy = Round((PtCur.y - 187) * 0.75)
     .Cells(1, 1) = posy
     'idem pour l'horizontale
     posx = Round((PtCur.x - 25) * 0.75)
     .Cells(1, 2) = posx
 
 
       'si la position du curseur en point ext plus grand que la cellule (i,1).topet plus petit que la celule(i,1).top plus sa hauteur alors _
       le numero de ligne est la celule(i,1).row(i incremmenté a chaque boucle)
       If posy > .Cells(i, 1).Top And posy < (.Cells(i, 1).Top + .Cells(i, 1).Height) Then ' donc si pos est plus grand quela celule.top en ligne"i" etsi pos est  plus petit que le top +le height de cette meme celule _
       la variable "newligne alors prend la valeur de la celule(i,1) .row
       newligne = .Cells(i + ActiveWindow.ScrollRow - 1, 1).Row
       .Cells(2, 1) = newligne
       End If
 
        If posx > .Cells(1, col).Left And posx < (.Cells(1, col).Left + .Cells(1, col).Width) Then ' donc si pos est plus grand quela celule.top en ligne"i" etsi pos est  plus petit que le top +le height de cette meme celule
        'la variable "newcol alors prend la valeur de la celule(i,1) .column
        newcol = .Cells(1, col + (ActiveWindow.ScrollColumn - 1)).Column
        .Cells(2, 2) = newcol
        End If
 
 
 
           'on teste si on change de ligne
           If newligne <> oldligne Then  'si la newligne est différente de la oldligne alors on met tout le sheets sans couleur et on colorie la ligne
           .Cells.Interior.Color = xlNone 'on remet toutes les cellules sans couleur
           .Cells(newligne, newcol).Interior.Color = vbRed  'ici tu met le code couleur que tu veux moi j'ai mis rouge
           End If
             'on teste si on change de colonne
             If newcol <> oldcol Then  'si la newligne est différente de la oldligne alors on met tout le sheets sans couleur et on colorie la ligne
             .Cells.Interior.Color = xlNone 'on remet toutes les celule sans couleur
             .Cells(newligne, newcol).Interior.Color = vbRed  'ici tu met le code couleur que tu veux moi j'ai mis rouge
             End If
 
 
 
     End If
                 DoEvents ' permet de ne pas bloquer le reste du fichier voir des autres macros
  End With
 
 
         If i > 100 Then i = 0 ' ici la limite est a 100 lignes bien que je doute qu'un ecran propose l'affichage de 100 lignes en general entre 25 et 35 lignes selon la resolution de votre ecran
         If col > 100 Then col = 0 ' idem pour les colones
        oldligne = newligne ' ici on atribu a oldligne la valeur de newligne comme ca ca nous permet de controler si il y a mouvement avec la variable "pos plus haut dans la macro
        oldcol = newcol ' idem  que oldligne
 i = i + 1 ' on incremente la variable i a chaque boucle i va nouservir a comparer la variable "posy a "i"
   col = col + 1 ' on incremente la variable i a chaque boucle i va nouservir a comparer la variable "posx a "col"
 
   Loop While tourne = True 'on continu tant que la variable booleenne est a true ' je rappelle que cette variable est modifiée a l'activate et le desactivate du sheets(1)
End Sub

je ne suis pas contre une amélioration notament pour remplacer le "187" par un calcul auto du height du ruban

au plaisir

[patricktoulon]

bonjours a tous
j'ai glané sur la toile un code qui cherchait a faire la même chose
je l'ai un peu arrangé

en effet le problème de l'ancienne version était de pouvoir délimiter la grille comme base et non pas tout le sheet y compris le ruban

l'expression "application.usableheight" et width resou le probleme

je vous le laisse découvrir

le nouveau code du module

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
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
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
Public tourne As Boolean
Function pos_souris()
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) - 19 ' on enleve 19 pour la colonne de chiffre representant les lignes
      ypt = ((point.Y - coord.Top) * échy) - 15 ' on enleve 15 pour la ligne des lettres
 
Cells(1, 1) = ypt
Cells(1, 2) = xpt
'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
Cells(1, 3) = newposition
 
' pas de couleur si le curseur se trouve hors de la grille
        If ypt < 0 Or xpt < 0 Then
        Cells.Interior.Color = xlNone
        newposition = ""
        Else
          'ici pour eviter le scintillement de la cellule on verifie si la position (adresse celule) a changé
          If newposition <> oldposition Then
          Cells.Interior.Color = xlNone
          'ici on remplie de rouge la cellule survolée
          Range(pos_souris).Interior.Color = vbRed
 
          'ou on remplie de rouge la ligne survolée
          'Rows(lin & ":" & lin).Interior.Color = vbRed
          End If
        End If
DoEventsoldposition = 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

maintenant l'effet n'est plus abstret

au plaisir

[patricktoulon]

bonjour a tous

apres reflection je me suis appercu que la macro fonctionnait dans une page blanche

mais si la feuille contient une presentation (celule coloriée) alors la a chaque boucle les couleurs disparaissait

j'ai donc ajouté la memorisation de la couleur de la celule survolé
et l'ors du changement de cellule la precedente reprend sa couleur initiale

voila
le code du module

celui du sheets ne change pas

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
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
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
Public tourne As Boolean
Dim oldcouleur As Long
Function pos_souris()
 
 
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 19 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
        newposition = ""
        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 ' si c'est blanc il n'y a pas de couleur
                     Range(oldposition).Interior.Color = xlNone
                    ' sinon on applique la couleur
                   Else
                   Range(oldposition).Interior.Color = oldcouleur
                   End If
                 End If
 
               If Range(newposition).Interior.Color = vbWhite Then
               oldcouleur = xlNone
                             Else
               oldcouleur = Range(newposition).Interior.Color
               End If
          'Cells.Interior.Color = xlNone
          'ici on remplie de rouge la cellule survolée
          Range(newposition).Interior.Color = vbRed
          'ou on remplie de rouge la ligne survolée
          'Rows(lin & ":" & lin).Interior.Color = vbRed
          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

voila maintenant il est complet et parfaitement fonctionnel


au plaisir

[patricktoulon]

bonsoir

c'est quand on croit que l'on a gravis toute le montagne qu'il nous reste encore quelques pas a faire

en effet il y a une éventualité que je n'avais pas envisagé et pourtant importante

j'ai donc revu le code pour avoir l'effet sur la cellule ou la ligne survolée

mais dans une zone précise

de façon par exemple a l'avoir sur un tableau (range) et non pas dans tout le sheets

du coup la macro qui appelle la fonction a un peu évolué la fonction aussi



maintenant dans l'appel a la fonction on précise si c'est la cellule ou la ligne
ensuite on détermine la 1ere colonne a partir du quel l'effet doit etre actif
ensuite la dernière colone ou l'effet s'arretera
la 1ere ligne a partir du quel l'effet sera actif
et enfin la derniere ligne ou l'effet s'arretera

voici le code qui appelle la fonction

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
 
 
Private Sub Worksheet_Activate()
tourne = True
 
' dans cet exemple l'effet sera effectif sur la cellule survolé dans la limite de la 'plage  
'commençant a la 4 eme colonne et se terminant a la 10 eme colonne
'et commençant par la 3 ligne et se terminant a la 20 eme ligne
 
                       pos_souris "celule", 4, 10, 3, 20
 
'si on veut avoir l'effet sur la ligne complete dans la limite de la zone on remplace "celule" par "ligne" dans l'appel  de la fonction
 
                                   ' exemple:
 
                        'pos_souris "ligne", 4, 10, 3, 20
 
 
end sub

et voici le code pour le module standard:

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
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
 
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, debucolone As Variant, nbcolone As Variant, debuligne As Variant, finligne As Variant)
 
 e = 0
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 19 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 = debucolone To nbcolone
 
                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 = debucolone To nbcolone
 
                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 = debucolone To nbcolone
              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 >= debucolone And col <= nbcolone And lin >= debuligne And lin <= finligne Then Range(newposition).Interior.Color = vbRed
                    ' 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 sont remplies
 
                        If col >= debucolone And col <= nbcolone And lin >= debuligne And lin <= finligne Then Range(Cells(lin, debucolone).Address & ":" & Cells(lin, nbcolone).Address).Interior.Color = vbRed
                     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

voila j'espere que le code est suffisament commenté

si vous avez des suggestions ou des questions n'esitez pas

au plaisir

[patricktoulon]

bonjour

apres plusieur suggestion sur d'autre forum

j'ai modifié le titre de la fonction et donc son appel

maintenant il suffi d'appeler la fonction comme ceci:

exemple pour avoir l'effet de survol de la celule uniquement dans la plage E3:j20

Code :

1
2
 
pos_souris " celule", range("E3:j20")

exemple pour avoir l'effet sur la ligne survolée uniquement dans la plage E3:j20

Code :

1
2
 
pos_souris " ligne", range("E3:j20")

le module gere mieux la restitution des couleurs d'origines l'ors du changement de celule

voila le nouveau code du module:

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
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
 
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)
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 + ligne1 - 1 Then Range(newposition).Interior.Color = vbRed
 
                       ' 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 Range(Cells(lin, maplage.Column).Address & ":" & Cells(lin, maplage.Columns.Count + maplage.Column - 1).Address).Interior.Color = vbRed
                       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

voila au plaisir

[patricktoulon]

bonjour

allez aujourd'hui je modifie encore le code

dans l'appel a la fonction

on détermine toujours le range pour la limite ou l'effet est effectif

on détermine l'effet sur la cellule ou ligne

(Nouveau) on choisi la couleur de l'effet a l'appel de la fonction

(nouveau)on peut utiliser l'index des couleurs prédéterminées dans office (de 1 a 56)

(nouveau)ou même en lettre du style vbred(rouge)

(nouveau)ou même du style 1236542 qui nous donne par exemple la couleur verte
code pour appeler la fonction sur la cellule survolée

Code :

1
2
3
4
5
6
7
 
Private Sub CommandButton1_Click()
 
tourne = True 'variable qui nous servira a arrêter la boucle dans la fonction
'l'effet sera effectif sur la cellule survolée uniquement dans la plage précisée(d3:j20)
pos_souris "celule", Range("D3:J20"), 1236542(donne une couleur verte)
end sub

Code :

1
2
3
4
5
Private Sub CommandButton2_Click()
tourne = True
'l'effet sera effectif sur la ligne survolée uniquement dans la plage precisée(d3:j20)
pos_souris "ligne", Range("D3:J20"), 1236542(donne une couleur verte)
End Sub

et le code de la fonction

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

voila et a la prochaine modif

au plaisir

[Arkham46]

bjr,

je ne sais pas pour les version précédentes, mais sur 2003 j'ai une méthode RangeFromPoint (à appliquer à ActiveWindow par exemple) qui m'a l'air utile pour éviter un algorithme de recherche de la cellule survolée

[patricktoulon]

bonjour arhkam46


je n'étais pas au courant ni entendu parler de

"méthode RangeFromPoint (à appliquer à ActiveWindow)"

je vais faire une recherche

je me suis intéressé a ce projet car je ne lavais pas trouvé sur dvp

si tu a un lien sur ta méthode je suis preneur aussi

tu a parler de la version 2003 mais je cherche a faire quelque chose de compatible de 2000 jusqu'à 2010 (32bit) et je pense y être parvenu
bien que je n'ai pas eu de retour

dailleur si de bons samaritains veulent bien me donner le retour j'en serais tre contents avec l'erreur si il y en a une
pour 2000,2003,2010

je te remercie pour ta suggestion j'étais un peu triste d'avoir fini cette fonction

ça va me donner du travail


au plaisir