DRAG'N DROP OU CLICK SUR UN MÊME COMPOSANT.
cs_sergejb
Messages postés
20
Date d'inscription
mercredi 16 octobre 2002
Statut
Membre
Dernière intervention
12 juin 2006
-
13 déc. 2005 à 08:49
crevaille Messages postés 1 Date d'inscription mardi 21 mars 2006 Statut Membre Dernière intervention 21 mars 2006 - 21 mars 2006 à 14:03
crevaille Messages postés 1 Date d'inscription mardi 21 mars 2006 Statut Membre Dernière intervention 21 mars 2006 - 21 mars 2006 à 14:03
Cette discussion concerne un article du site. Pour la consulter dans son contexte d'origine, cliquez sur le lien ci-dessous.
https://codes-sources.commentcamarche.net/source/35058-drag-n-drop-ou-click-sur-un-meme-composant
https://codes-sources.commentcamarche.net/source/35058-drag-n-drop-ou-click-sur-un-meme-composant
21 mars 2006 à 14:03
Petite remarque tout de même : ne permet pas de distinguer clic droit et gauche et réagit donc comme un clic sur les 2 boutons. Pas très pratique si l'on a un popupmenu sur le composant.
Mais un seul test règle le problème, if(Button = mbLeft)
23 déc. 2005 à 13:18
SIMPLICITE => EFFICACITE
Merci de nous le rappeler ;)
Je n'ai pas le temps d'appliquer la méthode de Icebird pour le moment, mais ça me semble prometteur à priori...
C'est vrai, MAURICIO. Il serait sans doute intéressant de rapprocher ces codes.
Joyeuses fêtes à tous et merci pour vos commentaires.
23 déc. 2005 à 10:26
Comme je n'ai pas bien pigé comment appliquer le truc de IceBird, j'en suis revenu à ma bonne vieille méthode MouseDown/Move/Up, simple et efficace que je vous livre ci-après dans le rôle de la démo de Caribensila :
var
XsurLab,YsurLab : integer;
oldX,oldY : integer;
Sliping : boolean;
procedure TForm1.Label1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Sliping := true;
oldX := Label1.Left;
oldY := Label1.Top;
XsurLab := X;
YsurLab := Y;
end;
procedure TForm1.Label1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if not Sliping then exit;
Label1.Left := Label1.Left + (X - XsurLab);
Label1.Top := Label1.Top + (Y - YsurLab);
end;
procedure TForm1.Label1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if not Sliping then exit;
Sliping := false;
if (Abs(Label1.Left - oldX) < 4) and // Mettre 15 ou + pour "parkinson"
(Abs(Label1.Top - oldY) < 4) then // ou autre contrôle, selon le cas
begin
Label1.Left := oldX;
Label1.Top := oldY;
Label1.Caption :'Action Click';
end
else Label1.Caption :'Action Déplacement';
end;
22 déc. 2005 à 16:33
State: TDragState; var Accept: Boolean);
var
tempPoint:TPoint;
begin
getcursorpos(tempPoint);
with (Source as TControl) do begin
Top:=(Parent as TControl).screentoclient(tempPoint).Y;
Left:=(Parent as TControl).screentoclient(tempPoint).X;
end;
Accept:=true;
end;
En remplacant le X et Y fournit par OnDragOver par un GetCursorPos en conjonction avec un ScreenToClient, on évite tous les désagréments. Il suffit de lier cette procédure à tous les evenements OnDragOver des contrôles que l'on souhaite déplacer ou sur lesquels on veut déplacer quelque chose, et c'est bon.
Du moins c'est ce que j'ai trouvé. Dites-moi si vous y voyez un défaut.
16 déc. 2005 à 11:06
Je n'avais jamais approfondi le drag'age, car la plupart du temps ce sont des bitmap's posés sur une paintbox (carte à jouer par exemple) que j'ai à déplacer. Mais cela m'ouvre des horizons... Merci.
13 déc. 2005 à 08:49