怎样实现用鼠标对控件的拖拉(100分)

  • 主题发起人 主题发起人 陈锡震
  • 开始时间 开始时间

陈锡震

Unregistered / Unconfirmed
GUEST, unregistred user!
怎样实现用鼠标对任何控件的拖拉(在程序运行的时候)?
 
每一个可是化的空间都有一个属性是控制其是否可被拖动。大概是dragable吧
我记不清了。自己看看,
设置该属性后,你的空间就可以拖动了。
 
例如

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button <> mbRight then
begin
ReleaseCapture;
Form1.Perform(WM_SysCommand, $f017, 0);
end;
end;

 
如果要象Form设计时的状态,就用下面这个控件吧

unit Sizer;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
TSizer = class(TCustomControl)
private
{ Private declarations }
FControl:TControl;
FRectList:array[1..8] of Trect;
FPosList:Array[1..8] of integer;
protected
{ Protected declarations }
public
{ Public declarations }
Constructor Create(Aowner:TComponent;AControl:TControl);
procedure CreateParams(Var Params:TCreateParams);override;
Procedure CreateHandle;override;
Procedure WNNCHITTEST(var msg:Twmnchittest);message wm_nchittest;
procedure wmsize(var msg:Twmsize);message wm_size;
procedure WmLbuttonDown(var msg:twmlbuttondown);message wm_lbuttondown;
procedure wmmove(var msg:twmmove);message wm_move;
procedure paint;override;
procedure sizercontrolexit(sender:tobject);
published
{ Published declarations }
end;

procedure Register;

implementation

procedure Register;
begin
RegisterNoicon([Tsizer]);
end;

{ TSizer }

constructor TSizer.Create(Aowner: TComponent; AControl: TControl);
var
r:trect;
begin
inherited create(Aowner);
FControl:=Acontrol;
onexit:=sizercontrolexit;
r:=fcontrol.BoundsRect;
inflaterect(r,2,2);
boundsrect:=r;
parent:=fcontrol.Parent;
fposlist[1]:=httopleft;
fposlist[2]:=httop;
fposlist[3]:=httopRight;
fposlist[4]:=htRight;
fposlist[5]:=htBottomRight;
fposlist[6]:=htBottom;
fposlist[7]:=htBottomleft;
fposlist[8]:=htleft;
end;

procedure TSizer.CreateHandle;
begin
inherited createhandle;
setfocus;
end;

procedure TSizer.CreateParams(var Params: TCreateParams);
begin
inherited createparams(params);
params.ExStyle:=params.ExStyle+ws_ex_transparent
end;

procedure TSizer.paint;
var
i:integer;
begin
Canvas.Brush.Color:=clblack;
for i:=1 to 8 do
canvas.Rectangle(Frectlist.left,frectlist.top,frectlist.right,frectlist.bottom);
end;

procedure TSizer.sizercontrolexit(sender: tobject);
begin
free;
end;

procedure TSizer.WmLbuttonDown(var msg: twmlbuttondown);
begin
perform(wm_syscommand,$f012,0);
end;

procedure TSizer.wmmove(var msg: twmmove);
var
r:trect;
begin
r:=boundsrect;
inflaterect(r,-2,-2);
fcontrol.BoundsRect:=r;
fcontrol.Invalidate;
end;

procedure TSizer.wmsize(var msg: Twmsize);
var
r:trect;
begin
r:=boundsrect;
inflaterect(r,-2,-2);
fcontrol.BoundsRect:=r;
frectlist[1]:=rect(0,0,5,5);
frectlist[2]:=rect(width div 2-3,0,width div 2+2,5);
frectlist[3]:=rect(width-5,0,width,5);
frectlist[4]:=rect(width-5,height div 2-3,width,height div 2+2);
frectlist[5]:=rect(width -5,height-5,width,height);
frectlist[6]:=rect(width div 2-3,height-5,width div 2+2,height);
frectlist[7]:=rect(0,height-5,5,height);
frectlist[8]:=rect(0,height div 2-3,5,height div 2+2);
end;

procedure TSizer.WNNCHITTEST(var msg: Twmnchittest);
var
pt:tpoint;
i:integer;
begin
pt:=point(msg.XPos,msg.YPos);
pt:=screentoclient(pt);
msg.Result:=0;
for i:=1 to 8 do
if ptinrect(frectlist,pt) then
msg.Result:=fposlist;
if msg.Result=0 then
inherited;
end;

end.

//拖动控件

当控件被点到时,执行

tsizer.create(self,tcontrol(sender));

 
to 小猪:是dragmode吧,不行的
to wjiachun:你说的方法是拖动整个form的,我是指只拖动控件,而form不动。
to djdsz:你的控件安装后不能使用,系统报错。

大家还有什么好方法吗????!!
 
陈锡震:
我举一例子而已,你何必这么懒呢?
在一个控件的MouseDown中这样试试:
if ssLeft in Shift then begin
ReleaseCapture;
Perform(WM_SYSCOMMAND,$F012,0);
end;

 
老猫的方法改一下不就行了吗?

if Button <> mbRight then
begin
ReleaseCapture;
<font color="#0000A0">Panel1</font>.Perform(WM_SysCommand, $f017, 0);
end;
 
多人接受答案了。
 
可怜我才5分?叫人勤快不好么?再说我比Fyx先给出答案啊 :-(
/
 
后退
顶部