[AC-2003] Contrôle qui suit le curseur sur clic [Résolu]

[Glherbier]

Bonjour,

Je viens vous adresser un petit message, parce que là, je sèche.

En fait, j'aimerais faire un contrôle, qui, sur clic de la souris suit cette souris, et si l'utilisateur reclique dessus, le controle arrête de suivre la souris (équivalent plus complexe : le contrôle suit la souris si elle est down, et arrête de la suivre quand elle est up), le tout sur un formulaire.

Voilà où j'en suis :

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
 'Je crée mon contrôle
 
Public Function creer_form()
 
[...]
 
Set ctr_test = CreateControl(frm.Name, acLabel, , "", "", gauche, decal_haut, largeur_std, hauteur)
ctr_test.BackStyle = 1
ctr_test.BorderStyle = 1
ctr_test.Name = "ctr_test"
ctr_test.OnClick = "=suivre_souris()"
 
[...]
 
End Function
 
'Et ici la fonction qui est censée gérer les déplacements
 
Public Function suivre_souris()
 
Dim frm As Form
Dim ctr As control
Dim Hold As POINTAPI
 
Set frm = Forms("Formulaire1")
Set ctr = frm.Controls("ctr_test")
 
If ctr.Tag = "1" Then
    ctr.Tag = "0"
Else
    ctr.Tag = "1"
End If
 
Do While ctr.Tag = "1"
    GetCursorPos Hold
    DoEvents
 
    frm.Controls("ctr_test").Left = Hold.X_Pos
    DoEvents
    frm.Controls("ctr_test").Top = Hold.Y_Pos
    DoEvents
 
Loop
 
End Function

Ca ne marche pas fort. Pour l'instant, sur clic, le contrôle suit bien la souris (bien qu'il faut encore que je trouve la fonction qui converti les API en pixels).
Mais il est impossible d'arrêter cette boucle malgré tous mes efforts... J'ai beau cliquer sur le contrôle pour passer son tag à 0, ca ne marche pas, je pense que l'action n'est pas prise en compte car windows est resté sur ma boucle infinie...

Que faire?

[Glherbier]

J'ai réussi à écrire le code faisant exactement ce que je voulais. Je l'inscris ici pour ceux qui en ont besoin (je pense d'ailleurs qu'un tuto sur ce sujet pourrait être intéressant).

La fonction suivre_souris permet à l'utilisateur, en cliquant sur un contrôle (et en maintenant le clic), de déplacer son contrôle sur le formulaire.

Enjoy!

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
Option Compare Database
 
'Type POINTAPI, nécessaire pour l'output de la function API GetCursorPos
      Type POINTAPI
         X_Pos As Long
         Y_Pos As Long
      End Type
 
'Déclaration des arguments
Declare Function GetCursorPos Lib "user32" _
      (lpPoint As POINTAPI) As Long
 
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long
 
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
  ByVal hdc As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
  ByVal nIndex As Long) As Long
 
Const HWND_DESKTOP As Long = 0
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
 
Public Function ouvrir_formulaire()
 
Dim frm As Form
Dim ctr_test As control
 
Set frm = CreateForm()
 
'On instancie le contrôle de test
Set ctr_test = CreateControl(frm.Name, acLabel, , "", "",  100, 100, 500, 250)
ctr_test.BackStyle = 1
ctr_test.BorderStyle = 1
ctr_test.Name = "ctr_test"
'Sur souris pressée, le code suivre_souris s'exécute
ctr_test.OnMouseDown = "=suivre_souris(" & Chr(34) & frm.Name & Chr(34) & "," & Chr(34) & ctr_test.Name & Chr(34) & ")"
 
DoCmd.OpenForm frm.Name
DoCmd.MoveSize 0, 0, 12000, 4000
 
End Function
 
Public Function suivre_souris(frm_name As String, ctr_name As String)
 
Dim frm As Form
Dim ctr As control
Dim Hold As POINTAPI
Dim VK_LBUTTON As Integer
 
'VK_LBUTTON est le code virtuel de la touche "souris gauche"
VK_LBUTTON = 1
 
'On récupère le formulaire et le contrôle
Set frm = Forms(frm_name)
Set ctr = frm.Controls(ctr_name)
 
'On récupère la position de la souris au moment du clic
GetCursorPos Hold
 
'TwipsPerPixel() est un entier donne le nombre de pixels par twips (on a donc la position de la souris en pixels)
souris_0_x = Hold.X_Pos * TwipsPerPixelX()
souris_0_y = Hold.Y_Pos * TwipsPerPixelY()
 
'Et la position par défaut du contrôle
ctr_0_x = frm.Controls("ctr_test").Left
ctr_0_y = frm.Controls("ctr_test").Top
 
'On regarde si le clic gauche de la souris est enfoncé. Si non, k = 0
k = GetAsyncKeyState(VK_LBUTTON)
 
Do While k <> 0
 
    'On récupère la nouvelle valeur du clic gauche, pour sortir de la boucle quand k vaut 0
    k = GetAsyncKeyState(VK_LBUTTON)
 
    'On récupère la nouvelle valeur du curseur
    GetCursorPos Hold
 
    'On place le contrôle à sa nouvelle position
    frm.Controls("ctr_test").Left = Hold.X_Pos * TwipsPerPixelX() - (souris_0_x - ctr_0_x)
    frm.Controls("ctr_test").Top = Hold.Y_Pos * TwipsPerPixelY() - (souris_0_y - ctr_0_y)
 
 
'On effectue quelques tests pour vérifier que le contrôle n'est pas sorti du formulaire. Si c'est le cas, on le remet à l'intérieur
If frm.Controls("ctr_test").Top < 40 Then
    frm.Controls("ctr_test").Top = 45
    Exit Do
End If
 
If frm.Controls("ctr_test").Top > frm.Section(0).Height - 400 Then
    frm.Controls("ctr_test").Top = frm.Controls("ctr_test").Top - 420
    Exit Do
End If
 
If frm.Controls("ctr_test").Left < 60 Then
    frm.Controls("ctr_test").Left = 65
    Exit Do
End If
 
If frm.Controls("ctr_test").Left > frm.Width - 400 Then
    frm.Controls("ctr_test").Left = frm.Controls("ctr_test").Left - 420
    Exit Do
End If
 
'On actualise les actions à l'écran
DoEvents
 
Loop
 
End Function
 
'--------------------------------------------------
Function TwipsPerPixelX() As Single
'--------------------------------------------------
'Returns the width of a pixel, in twips.
'--------------------------------------------------
  Dim lngDC As Long
  lngDC = GetDC(HWND_DESKTOP)
  TwipsPerPixelX = 1440& / GetDeviceCaps(lngDC, LOGPIXELSX)
  ReleaseDC HWND_DESKTOP, lngDC
End Function
 
'--------------------------------------------------
Function TwipsPerPixelY() As Single
'--------------------------------------------------
'Returns the height of a pixel, in twips.
'--------------------------------------------------
  Dim lngDC As Long
  lngDC = GetDC(HWND_DESKTOP)
  TwipsPerPixelY = 1440& / GetDeviceCaps(lngDC, LOGPIXELSY)
  ReleaseDC HWND_DESKTOP, lngDC
End Function