哪位兄弟有在运行期可拖动的控件的啊，记得以前有一个shape似的可在运行期拖动，现在不见了(50分)

其他的也行，TKS

写一段事件就OK了。

呵呵，写拖放得到控件的父控件的dragover事件，我想控件自带有可拖功能，以前有个控件有的，现在不在了，谁有啊

你的Email?

http://vbeden.xg88.com/learner/secondary/list/page2.htm#bm4
这有一些关于拖放的例子
去看看，有没有些收获吧

我自己写了一个类似的，事先给诸葛白痴看过了，
里面有个问题，快速拖动的时候感觉速度跟不上样的。
有兴趣的看看下面的代码，发现问题的原因或另有解决方法，敬请指教！
unit U_DevImg_Class;

interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, QuickRpt, jpeg, Buttons;

type
TImgState=(imDrag,imDesign,imNormal);
TDevImg=class;

TmaShape=class(TShape)
private
fCursorOrigin:Tpoint;
fOwner:TDevImg;
protected
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;
var Accept: Boolean); override;
procedure DragDrop(Source: TObject; X, Y: Integer); override;
end;

TDevImg=class(TImage)
private
fImgState:TImgState;
fTopLeftP:Tshape;
fTopMidP :Tshape;
fTopRhtP :Tshape;
fMidLeftP:Tshape;
fMidRgtP :Tshape;
fBtmLeftP:Tshape;
fBtmMidP :Tshape;
fBtmRgtP :Tshape;
fAroundLine:TmaShape;
fCursorOrigin:Tpoint;
fImgFileName:String;
procedure SetImgState(value:TImgState);
procedure createAroundPoint;
procedure createAroundLine;
function createPoint(aleft,aTop:integer):Tshape;
procedure SetImgFileName(const Value: String);
protected
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;
var Accept: Boolean); override;
procedure DragDrop(Source: TObject; X, Y: Integer); override;
public
constructor create(AOwner:TComponent);overload;override;
constructor create(AOwner:TComponent;Aleft,aTop:integer);overload;virtual;
published
property ImgState:TImgState read fImgState write setImgState default imNormal;
property ImgFileName:String read fImgFileName write SetImgFileName;
end;

implementation

{ TDevImg }

constructor TDevImg.create(AOwner: TComponent);
begin
inherited;

end;

constructor TDevImg.create(AOwner: TComponent; Aleft, aTop: integer);
begin
inherited create(AOwner);
parent:=TWinControl(Aowner);
Left:=aLeft;
Top:=aTop;
width:=32;
height:=32;
Stretch:=true;
createAroundPoint;
createAroundLine;
setImgState(imNormal);
end;

procedure TDevImg.createAroundLine;
begin
fAroundLine:=TmaShape.Create(self);
with fAroundLine do
begin
Parent:=self.Parent;
fOwner:=self;
Left:=self.Left;
Top:=self.Top;
Width := 32;
Height := 32;
Brush.Style := bsClear;
Pen.Mode := pmBlack;
Pen.Width := 2;
end;
end;

procedure TDevImg.createAroundPoint;
var
vMid,hMid,Rgt,Btm:integer;
begin
hMid:=Left+ Width div 2;//水平中点
Rgt:=Left+ Width;// 最右
vMid:=Top+ Height div 2; //垂直中点
Btm:=Top+Height; //最下

fTopLeftP:=CreatePoint(Left-2,top-2);
fTopMidP :=CreatePoint(hMid-2,top-2);
fTopRhtP :=CreatePoint(Rgt-2, top-2);
fMidLeftP:=CreatePoint(Left-2,vMid-2);
fMidRgtP :=CreatePoint(Rgt-2, vmid-2);
fBtmLeftP:=CreatePoint(Left-2,Btm-2);
fBtmMidP :=CreatePoint(hMid-2,Btm-2);
fBtmRgtP :=CreatePoint(Rgt-2, Btm-2);
end;

function TDevImg.createPoint(aleft,aTop:integer): Tshape;
begin
result:=Tshape.Create(self);
with result do
begin
parent:=self.parent;
Width:=5;
height:=5;
left:=aLeft;
Top:=aTop;
Brush.Color:=clBlack;
end;
end;

procedure TDevImg.DragDrop(Source: TObject; X, Y: Integer);
var
hStep,vStep:integer;
ImgOrigin:TPoint;
begin
inherited;
ImgOrigin:=point(Left,Top);
Left:=fAroundLine.Left;
top:=fAroundLine.Top;
hStep:=Left-ImgOrigin.X;
vStep:=Top-ImgOrigin.Y;
fTopLeftP.Left:=fTopLeftP.Left+hStep;
fTopMidP.Left :=fTopMidP.Left +hStep;
fTopRhtP.Left :=fTopRhtP.Left +hStep;
fMidLeftP.Left:=fMidLeftP.Left+hStep;
fMidRgtP.Left :=fMidRgtP.Left +hStep;
fBtmLeftP.Left:=fBtmLeftP.Left+hStep;
fBtmMidP.Left :=fBtmMidP.Left +hStep;
fBtmRgtP.Left :=fBtmRgtP.Left +hStep;
fTopLeftP.Top:=fTopLeftP.Top+vStep;
fTopMidP.Top :=fTopMidP.Top +vStep;
fTopRhtP.Top :=fTopRhtP.Top +vStep;
fMidLeftP.Top:=fMidLeftP.Top+vStep;
fMidRgtP.Top :=fMidRgtP.Top +vStep;
fBtmLeftP.Top:=fBtmLeftP.Top+vStep;
fBtmMidP.Top :=fBtmMidP.Top +vStep;
fBtmRgtP.Top :=fBtmRgtP.Top +vStep;
EndDrag(true);
imgState:=imDesign;
end;

procedure TDevImg.DragOver(Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
inherited;
accept:=True;
end;

procedure TDevImg.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
imgState:=imDrag;
fAroundLine.MouseDown(Button,Shift,X,Y);
self.beginDrag(true);
end;

procedure TDevImg.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
end;


procedure TDevImg.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
imgState:=imDesign;
end;

procedure TDevImg.SetImgFileName(const Value: String);
begin
fImgFileName := Value;
try
self.Picture.LoadFromFile(fImgFileName);
except
showmessage('Load Picture Failed')
end;
end;

procedure TDevImg.setImgState(value: TImgState);
begin
case value of
imDrag: //拖动状态
begin
fTopLeftP.Visible:=false;
fTopMidP.Visible :=false;
fTopRhtP.Visible :=false;
fMidLeftP.Visible:=false;
fMidRgtP.Visible :=false;
fBtmLeftP.Visible:=false;
fBtmMidP.Visible :=false;
fBtmRgtP.Visible :=false;
fAroundLine.Visible:=true;
end;
imDesign: //设计状态
begin
fTopLeftP.Visible:=true;
fTopMidP.Visible :=true;
fTopRhtP.Visible :=true;
fMidLeftP.Visible:=true;
fMidRgtP.Visible :=true;
fBtmLeftP.Visible:=true;
fBtmMidP.Visible :=true;
fBtmRgtP.Visible :=true;
fAroundLine.Visible:=false;
end;
imNormal: //正常状态
begin
fTopLeftP.Visible:=false;
fTopMidP.Visible :=false;
fTopRhtP.Visible :=false;
fMidLeftP.Visible:=false;
fMidRgtP.Visible :=false;
fBtmLeftP.Visible:=false;
fBtmMidP.Visible :=false;
fBtmRgtP.Visible :=false;
fAroundLine.Visible:=false;
end;
end;
end;

{ TmaShape }

procedure TmaShape.DragDrop(Source: TObject; X, Y: Integer);
begin
inherited;
TDevImg(self.fOwner).DragDrop(TDevImg(self.fOwner),X,Y);
EndDrag(True);
end;

procedure TmaShape.DragOver(Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
var
hStep,vStep:Integer;
begin
inherited;
accept:=true;
hStep:=X-fCursorOrigin.X;
vstep:=Y-fCursorOrigin.Y;
Left:=Left+hStep;
Top:=Top+vStep;

TDevImg(self.fOwner).DragOver(TDevImg(self.fOwner),X,Y,State,Accept);
end;

procedure TmaShape.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
beginDrag(true);
fCursorOrigin.X:=X;
fCursorOrigin.Y:=y;
end;

procedure TmaShape.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
TDevImg(self.Parent).MouseMove(Shift,X,Y);
end;

procedure TmaShape.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
TDevImg(self.fOwner).MouseUp(Button,Shift,X,Y);
inherited;
end;

end.

用法:
fDevImg:=TDevImg.create(self,10,10);
fDevImg.ImgFileName:=extractFilePath(application.ExeName)+'XXX.BMP';
fDevImg.Show;

如果问题解决了，我另外200分酬谢

给你

unit Handles;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Menus, StdCtrls, Dialogs;
type
TDragStyle = (dsMove, dsSizeTopLeft, dsSizeTopRight, dsSizeBottomLeft, dsSizeBottomRight,
dsSizeTop, dsSizeLeft, dsSizeBottom, dsSizeRight);
TForwardMessage = (fmMouseDown, fmMouseUp);
GridValues = 1..32;
EBadChild = class(Exception);
type
TStretchHandle = class(TCustomControl)
private
FDragOffset: TPoint;
FDragStyle: TDragStyle;
FDragging: boolean;
FDragRect: TRect;
FLocked: boolean;
FPrimaryColor: TColor;
FSecondaryColor: TColor;
FGridX, FGridY: GridValues;
FChildList: TList;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMGetDLGCode(var Message: TMessage); message WM_GETDLGCODE;
procedure Rubberband(XPos, YPos: integer; ShowBox: boolean);
procedure ForwardMessage(FwdMsg: TForwardMessage; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure SetPrimaryColor(Color: TColor);
procedure SetSecondaryColor(Color: TColor);
procedure SetGridState(Value: boolean);
function GetGridState: boolean;
function GetChildCount: integer;
function GetChildControl(idx: integer): TControl;
function GetModifiedRect(XPos, YPos: integer): TRect;
function PointOverChild(P: TPoint): boolean;
function XGridAdjust(X: integer): integer;
function YGridAdjust(Y: integer): integer;
function IsAttached: boolean;
protected
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure KeyDown(var key: Word; Shift: TShiftState); override;
procedure CreateParams(var Params: TCreateParams); override;
procedure Paint; override;
property Canvas;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Attach(ChildControl: TControl);
procedure Detach;
procedure ReleaseChild(ChildControl: TControl);
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
procedure BringToFront;
procedure SendToBack;
procedure SetColors(Color1, Color2: TColor);
function IndexOf(ChildControl: TControl): integer;
{ new run-time only properties }
property Attached: boolean read IsAttached;
property ChildCount: integer read GetChildCount;
property Children[idx: integer]: TControl read GetChildControl;
published
{ new properties }
property Color: TColor read FPrimaryColor write SetPrimaryColor default clBlack;
property SecondaryColor: TColor read FSecondaryColor write SetSecondaryColor default clGray;
property Locked: boolean read FLocked write FLocked default False;
property GridX: GridValues read FGridX write FGridX default 8;
property GridY: GridValues read FGridY write FGridY default 8;
property SnapToGrid: boolean read GetGridState write SetGridState default False;
{ inherited properties }
property DragCursor;
property Enabled;
property Hint;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
{ defined events }
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnKeyDown;
property OnKeyUp;
property OnKeyPress;
end;

procedure Register;
function MinInt(a, b: integer): integer;
function MaxInt(a, b: integer): integer;

implementation

procedure Register;
begin
RegisterComponents('Samples', [TStretchHandle]);
end;

constructor TStretchHandle.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FChildList := TList.Create;
Width := 24;
Height := 24;
FPrimaryColor := clBlack;
FSecondaryColor := clGray;
FGridX := 1;
FGridY := 1;
Enabled := False;
Visible := False;
end;

destructor TStretchHandle.Destroy;
begin
FChildList.Free;
inherited Destroy;
end;

procedure TStretchHandle.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
end;

procedure TStretchHandle.WMGetDLGCode(var Message: TMessage);
begin
Message.Result := DLGC_WANTARROWS;
end;

procedure TStretchHandle.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;

procedure TStretchHandle.Attach(ChildControl: TControl);
var
L, T, W, H: integer;
begin
if ChildControl is TForm then
raise EBadChild.Create('Handles can not be attached to a Form!');
if (ChildControl <> nil) and (FChildList.IndexOf(TObject(ChildControl)) = -1) then
begin
if (FChildList.Count > 0) and (ChildControl.Parent <> Parent) then
Detach;
if FChildList.Count = 0 then
begin
Parent := ChildControl.Parent;
FDragRect := Rect(0, 0, 0, 0);
Enabled := True;
Visible := True;
inherited SetBounds(ChildControl.Left - 2, ChildControl.Top - 2, ChildControl.Width + 5, ChildControl.Height + 5);
end
else
begin
L := MinInt(Left, ChildControl.Left - 2);
T := MinInt(Top, ChildControl.Top - 2);
W := Maxint(Left + Width - 3, ChildControl.Left + ChildControl.Width) - L + 3;
H := Maxint(Top + Height - 3, ChildControl.Top + ChildControl.Height) - T + 3;
inherited SetBounds(L, T, W, H);
end;
FChildList.Add(TObject(ChildControl));
FDragStyle := dsMove;
if not (csDesigning in ComponentState) then
begin
inherited BringToFront;
SetCapture(Handle);
if Visible and Enabled then
SetFocus;
end;
end;
end;

procedure TStretchHandle.Detach;
begin
if FChildList.Count > 0 then
with FChildList do
repeat
Delete(0);
until Count = 0;
FLocked := False;
Width := 24;
Height := 24;
Enabled := False;
Visible := False;
Parent := nil;
FDragRect := Rect(0, 0, 0, 0);
end;

procedure TStretchHandle.ReleaseChild(ChildControl: TControl);
var
idx, L, T, W, H: integer;
AControl: TControl;
begin
idx := FChildList.IndexOf(TObject(ChildControl));
if (ChildControl <> nil) and (idx >= 0) then
FChildList.Delete(idx);
if FChildList.Count = 0 then
begin
FLocked := False;
Enabled := False;
Visible := False;
Parent := nil;
FDragRect := Rect(0, 0, 0, 0);
end
else
begin
L := TControl(FChildList.Items[0]).Left - 2;
T := TControl(FChildList.Items[0]).Top - 2;
W := TControl(FChildList.Items[0]).Width + 3;
H := TControl(FChildList.Items[0]).Height + 3;
for idx := 0 to FChildList.Count - 1 do
begin
AControl := TControl(FChildList.Items[idx]);
L := MinInt(L, AControl.Left - 2);
T := MinInt(T, AControl.Top - 2);
W := Maxint(L + W - 3, AControl.Left + AControl.Width) - L + 3;
H := Maxint(T + H - 3, AControl.Top + AControl.Height) - T + 3;
end;
inherited SetBounds(L, T, W, H);
end;
end;

function TStretchHandle.IndexOf(ChildControl: TControl): integer;
begin
Result := FChildList.IndexOf(TObject(ChildControl));
end;

procedure TStretchHandle.BringToFront;
var
i: integer;
begin
if Attached and not Locked then
begin
for i := 0 to FChildList.Count - 1 do
begin
TControl(FChildList).BringToFront;
end;
inherited BringToFront;
if Visible and Enabled then
SetFocus;
end;
end;

procedure TStretchHandle.SendToBack;
var
i: integer;
begin
if Attached and not Locked then
begin
for i := 0 to FChildList.Count - 1 do
begin
TControl(FChildList).SendToBack;
end;
inherited BringToFront;
if Visible and Enabled then
SetFocus;
end;
end;

procedure TStretchHandle.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if PointOverChild(Point(Left + X, Top + Y)) then
begin
if (Button = mbLeft) and not FLocked then
begin
FDragOffset := Point(X, Y);
FDragging := True;
end;
inherited MouseDown(Button, Shift, X, Y);
end
else
begin
Cursor := crDefault;
SetCursor(Screen.Cursors[Cursor]);
ForwardMessage(fmMouseDown, Button, Shift, Left + X, Top + Y);
end;

end;

procedure TStretchHandle.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
ARect: TRect;
begin
{ resize, reposition if anything changed }
if FDragging and (Button = mbLeft) then
begin
{ disallow drop off Parent }
if (Left + X) < 0 then
X := -Left;
if (Top + Y) < 0 then
Y := -Top;
if (Left + X) > Parent.Width then
X := Parent.Width - Left;
if (Top + Y) > Parent.Height then
Y := Parent.Height - Top;
{ force Paint when size doesn't change but position does }
if (X <> FDragOffset.X) or (Y <> FDragOffset.Y) then
begin
Invalidate;
ARect := GetModifiedRect(X, Y);
SetBounds(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
end;
{ clear drag outline }
RubberBand(0, 0, False);
{ seem to need this for keyboard events }
if Visible and Enabled then
SetFocus;

FDragging := False;
Cursor := crDefault;
ReleaseCapture;
{ perform default processing }
{ inherited MouseUp(Button, Shift, X, Y); Remove By Tom Lee }

end
else
ForwardMessage(fmMouseUp, Button, Shift, Left + X, Top + Y);

inherited MouseUp(Button, Shift, X, Y); { Modify By Tom Lee }
end;

procedure TStretchHandle.MouseMove(Shift: TShiftState; X, Y: Integer);
var
ARect: TRect;
DragStyle: TDragStyle;
begin
{ this may be a move immediately on Attach instead of MouseDown }
if (ssLeft in Shift) and not FDragging and not FLocked then
begin
FDragOffset := Point(X, Y);
FDragging := True;
end
{ only recognize move after simulated MouseDown }
else
begin
{ let's not hog mouse events unnecessarily }
if not (ssLeft in Shift) then
ReleaseCapture;
{ default to drag cursor only when dragging }
DragStyle := dsMove;
Cursor := crDefault;
{ disallow resize if multiple children }
if FChildList.Count = 1 then
begin

ARect := GetClientRect;
{ so I don't like long nested if statements... }
if ((Abs(X - ARect.Left) < 5) and (Abs(Y - ARect.Top) < 5)) then
begin
DragStyle := dsSizeTopLeft;
Cursor := crSizeNWSE;
end;

if ((Abs(X - ARect.Right) < 5) and (Abs(Y - ARect.Bottom) < 5)) then
begin
DragStyle := dsSizeBottomRight;
Cursor := crSizeNWSE;
end;

if ((Abs(X - ARect.Right) < 5) and (Abs(Y - ARect.Top) < 5)) then
begin
DragStyle := dsSizeTopRight;
Cursor := crSizeNESW;
end;

if ((Abs(X - ARect.Left) < 5) and (Abs(Y - ARect.Bottom) < 5)) then
begin
DragStyle := dsSizeBottomLeft;
Cursor := crSizeNESW;
end;

if ((Abs(X - trunc(ARect.Right - ARect.Left) / 2) < 3) and (Abs(Y - ARect.Top) < 5)) then
begin
DragStyle := dsSizeTop;
Cursor := crSizeNS;
end;

if ((Abs(X - trunc(ARect.Right - ARect.Left) / 2) < 3) and (Abs(Y - ARect.Bottom) < 5)) then
begin
DragStyle := dsSizeBottom;
Cursor := crSizeNS;
end;

if ((Abs(Y - trunc(ARect.Bottom - ARect.Top) / 2) < 3) and (Abs(X - ARect.Left) < 5)) then
begin
DragStyle := dsSizeLeft;
Cursor := crSizeWE;
end;

if ((Abs(Y - trunc(ARect.Bottom - ARect.Top) / 2) < 3) and (Abs(X - ARect.Right) < 5)) then
begin
DragStyle := dsSizeRight;
Cursor := crSizeWE;
end;

end;
{ if position-locked, override cursor change }
if FLocked then
Cursor := crNoDrop;

if FDragging then
begin
{ disallow drag off Parent }
if (Left + X) < 0 then
X := -Left;
if (Top + Y) < 0 then
Y := -Top;
if (Left + X) > Parent.Width then
X := Parent.Width - Left;
if (Top + Y) > Parent.Height then
Y := Parent.Height - Top;
{ display cursor & drag outline }
if FDragStyle = dsMove then
Cursor := DragCursor;
SetCursor(Screen.Cursors[Cursor]);
RubberBand(X, Y, True);

end
else
FDragStyle := DragStyle;

end;
{ perform default processing }
inherited MouseMove(Shift, X, Y);

end;

procedure TStretchHandle.ForwardMessage(FwdMsg: TForwardMessage; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
i: integer;
Found: boolean;
Msg: Word;
ARect: TRect;
AControl: TControl;
AMessage: TMessage;
begin
{ construct the message to be sent }
case FwdMsg of
fmMouseDown:
case Button of
mbLeft:
Msg := WM_LBUTTONDOWN;
mbMiddle:
Msg := WM_MBUTTONDOWN;
mbRight:
Msg := WM_RBUTTONDOWN;
end;
fmMouseUp:
case Button of
mbLeft:
Msg := WM_LBUTTONUP;
mbMiddle:
Msg := WM_MBUTTONUP;
mbRight:
Msg := WM_RBUTTONUP;
end;
end;

AMessage.WParam := 0;
{ determine whether X, Y is over any other windowed control }
Found := False;
for i := 0 to Parent.ControlCount - 1 do
begin
AControl := TControl(Parent.Controls);
if (AControl is TWinControl) and not (AControl is TStretchHandle) then
begin
ARect := Rect(AControl.Left,
AControl.Top,
AControl.Left + AControl.Width,
AControl.Top + AControl.Height);
{ X, Y are relative to Parent }
if PtInRect(ARect, Point(X, Y)) then
begin
Found := True;
break;
end;
end;
end;
{ forward the message to the control if found, else to the Parent }
if Found then
begin
AMessage.LParamLo := X - AControl.Left;
AMessage.LParamHi := Y - AControl.Top;
SendMessage(TWinControl(AControl).Handle, Msg, AMessage.WParam, AMessage.LParam);
end
else
begin
AMessage.LParamLo := X;
AMessage.LParamHi := Y;
SendMessage(Parent.Handle, Msg, AMessage.WParam, AMessage.LParam);
end;

end;

procedure TStretchHandle.KeyDown(var Key: Word; Shift: TShiftState);
begin
{ process arrow keys to move/resize Handles & Child, also move siblings }
case Key of
VK_UP:
begin
Invalidate;
SetBounds(Left, Top - 1, Width, Height);
end;
VK_DOWN:
begin
Invalidate;
SetBounds(Left, Top + 1, Width, Height);
end;
VK_LEFT:
begin
Invalidate;
SetBounds(Left - 1, Top, Width, Height);
end;
VK_RIGHT:
begin
Invalidate;
SetBounds(Left + 1, Top, Width, Height);
end;
end;

inherited KeyDown(Key, Shift);

end;

function TStretchHandle.GetModifiedRect(XPos, YPos: integer): TRect;
var
ARect: TRect;
begin
{ compute new position/size, depending on FDragStyle}
case FDragStyle of

dsSizeTopLeft:
begin
ARect.Left := XGridAdjust(Left + (XPos - FDragOffset.X)) - 2;
ARect.Top := YGridAdjust(Top + (YPos - FDragOffset.Y)) - 2;
ARect.Right := Width - (ARect.Left - Left);
ARect.Bottom := Height - (ARect.Top - Top);
end;

dsSizeTopRight:
begin
ARect.Left := Left;
ARect.Top := YGridAdjust(Top + (YPos - FDragOffset.Y)) - 2;
ARect.Right := XGridAdjust(Width + (XPos - FDragOffset.X)) - 3;
ARect.Bottom := Height - (ARect.Top - Top);
end;

dsSizeBottomLeft:
begin
ARect.Left := XGridAdjust(Left + (XPos - FDragOffset.X)) - 2;
ARect.Top := Top;
ARect.Right := Width - (ARect.Left - Left);
ARect.Bottom := YGridAdjust(Height + (YPos - FDragOffset.Y)) - 3;
end;

dsSizeBottomRight:
begin
ARect.Left := Left;
ARect.Top := Top;
ARect.Right := XGridAdjust(Width + (XPos - FDragOffset.X)) - 3;
ARect.Bottom := YGridAdjust(Height + (YPos - FDragOffset.Y)) - 3;
end;

dsSizeTop:
begin
ARect.Left := Left;
ARect.Top := YGridAdjust(Top + (YPos - FDragOffset.Y)) - 2;
ARect.Right := Width;
ARect.Bottom := Height - (ARect.Top - Top);
end;

dsSizeBottom:
begin
ARect.Left := Left;
ARect.Top := Top;
ARect.Right := Width;
ARect.Bottom := YGridAdjust(Height + (YPos - FDragOffset.Y)) - 3;
end;

dsSizeLeft:
begin
ARect.Left := XGridAdjust(Left + (XPos - FDragOffset.X)) - 2;
ARect.Top := Top;
ARect.Right := Width - (ARect.Left - Left);
ARect.Bottom := Height;
end;

dsSizeRight:
begin
ARect.Left := Left;
ARect.Top := Top;
ARect.Right := XGridAdjust(Width + (XPos - FDragOffset.X)) - 3;
ARect.Bottom := Height;
end;

else
{ keep size, move to new position }
ARect.Left := XGridAdjust(Left + (XPos - FDragOffset.X)) - 2;
ARect.Top := YGridAdjust(Top + (YPos - FDragOffset.Y)) - 2;
ARect.Right := Width;
ARect.Bottom := Height;

end;
{ impose a minimum size for sanity }
if ARect.Right < 5 then
ARect.Right := 5;
if ARect.Bottom < 5 then
ARect.Bottom := 5;

Result := ARect;

end;

procedure TStretchHandle.Rubberband(XPos, YPos: integer; ShowBox: boolean);
var
NewRect: TRect;
PtA, PtB: TPoint;
ScreenDC: HDC;
begin
{ outline is drawn over all windows }
ScreenDC := GetDC(0);
{ erase previous rectangle, if any, & adjust for handle's position }
if (FDragRect.Left <> 0) or (FDragRect.Top <> 0) or (FDragRect.Right <> 0) or (FDragRect.Bottom <> 0) then
begin
PtA := Parent.ClientToScreen(Point(FDragRect.Left + 2, FDragRect.Top + 2));
PtB := Parent.ClientToScreen(Point(FDragRect.Left + FDragRect.Right - 3, FDragRect.Top + FDragRect.Bottom - 3));
DrawFocusRect(ScreenDC, Rect(PtA.X, PtA.Y, PtB.X, PtB.Y));
FDragRect := Rect(0, 0, 0, 0);
end;
{ draw new rectangle unless this is a final erase }
if ShowBox then
begin
NewRect := GetModifiedRect(XPos, YPos);
PtA := Parent.ClientToScreen(Point(NewRect.Left + 2, NewRect.Top + 2));
PtB := Parent.ClientToScreen(Point(NewRect.Left + NewRect.Right - 3, NewRect.Top + NewRect.Bottom - 3));
DrawFocusRect(ScreenDC, Rect(PtA.X, PtA.Y, PtB.X, PtB.Y));
FDragRect := NewRect;
end
else
begin
Parent.Repaint;
Repaint;
end;

ReleaseDC(0, ScreenDC);

end;

procedure TStretchHandle.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
WasVisible: boolean;
i: integer;
AControl: TControl;
begin
{ hide & preserve fixed size in design mode }
WasVisible := Visible;
if csDesigning in ComponentState then
begin
Visible := False;
inherited SetBounds(ALeft, ATop, 24, 24);
end
else { move child also, if any (but only if not locked) }
if not FLocked then
begin
for i := 0 to FChildList.Count - 1 do
begin
AControl := FChildList;
AControl.SetBounds(AControl.Left - Left + ALeft,
AControl.Top - Top + ATop,
AControl.Width - Width + AWidth,
AControl.Height - Height + AHeight);
end;
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;
{ restore visibility }
if Visible = False then
Visible := WasVisible;

end;

procedure TStretchHandle.Paint;
var
AControl: TControl;
ARect, BoxRect: TRect;
i: integer;
begin

inherited Paint;
{ do it differently at design time... }
if csDesigning in ComponentState then
begin
Canvas.Brush.Color := FPrimaryColor;
BoxRect := Rect(0, 0, 5, 5);
Canvas.FillRect(BoxRect);
BoxRect := Rect(19, 0, 24, 5);
Canvas.FillRect(BoxRect);
BoxRect := Rect(19, 19, 24, 24);
Canvas.FillRect(BoxRect);
BoxRect := Rect(0, 19, 5, 24);
Canvas.FillRect(BoxRect);
end
else
begin
{ set color to primary if only one child, else secondary }
if FChildList.Count = 1 then
Canvas.Brush.Color := FPrimaryColor
else
Canvas.Brush.Color := FSecondaryColor;
{ draw resize handles for each child }
for i := 0 to FChildList.Count - 1 do
begin

AControl := TControl(FChildList.Items);
ARect := Rect(AControl.Left - Left - 2,
AControl.Top - Top - 2,
AControl.Left - Left + AControl.Width + 2,
AControl.Top - Top + AControl.Height + 2);

with Canvas do
begin
{ draw corner boxes (assuming Canvas is minimum 5x5) }
BoxRect := Rect(ARect.Left, ARect.Top, ARect.Left + 5, ARect.Top + 5);
FillRect(BoxRect);
BoxRect := Rect(ARect.Right - 5, ARect.Top, ARect.Right, ARect.Top + 5);
FillRect(BoxRect);
BoxRect := Rect(ARect.Right - 5, ARect.Bottom - 5, ARect.Right, ARect.Bottom);
FillRect(BoxRect);
BoxRect := Rect(ARect.Left, ARect.Bottom - 5, ARect.Left + 5, ARect.Bottom);
FillRect(BoxRect);
{ only for single Children, draw center boxes }
if FChildList.Count = 1 then
begin
BoxRect := Rect(ARect.Left + trunc((ARect.Right - ARect.Left) / 2) - 2,
ARect.Top,
ARect.Left + trunc((ARect.Right - ARect.Left) / 2) + 3,
ARect.Top + 5);
FillRect(BoxRect);
BoxRect := Rect(ARect.Left + trunc((ARect.Right - ARect.Left) / 2) - 2,
ARect.Bottom - 5,
ARect.Left + trunc((ARect.Right - ARect.Left) / 2) + 3,
ARect.Bottom);
FillRect(BoxRect);
BoxRect := Rect(ARect.Left,
ARect.Top + trunc((ARect.Bottom - ARect.Top) / 2) - 2,
ARect.Left + 5,
ARect.Top + trunc((ARect.Bottom - ARect.Top) / 2) + 3);
FillRect(BoxRect);
BoxRect := Rect(ARect.Right - 5,
ARect.Top + trunc((ARect.Bottom - ARect.Top) / 2) - 2,
ARect.Right,
ARect.Top + trunc((ARect.Bottom - ARect.Top) / 2) + 3);
FillRect(BoxRect);
end;

end;

end;

end;

end;

procedure TStretchHandle.SetPrimaryColor(Color: TColor);
begin
{ set single select color, repaint immediately }
FPrimaryColor := Color;
Repaint;

end;

procedure TStretchHandle.SetSecondaryColor(Color: TColor);
begin
{ set multiple select color, repaint immediately }
FSecondaryColor := Color;
Repaint;

end;

procedure TStretchHandle.SetColors(Color1, Color2: TColor);
begin
{ set single/multiple select colors, repaint }
FPrimaryColor := Color1;
FSecondaryColor := Color2;
Repaint;

end;

procedure TStretchHandle.SetGridState(Value: boolean);
begin
{ a value of 1 effectively disables a grid axis }
if Value then
begin
FGridX := 8;
FGridY := 8;
end
else
begin
FGridX := 1;
FGridY := 1;
end;

end;

function TStretchHandle.GetGridState: boolean;
begin

if (FGridX > 1) or (FGridY > 1) then
Result := True
else
Result := False;

end;

function TStretchHandle.GetChildCount: integer;
begin
Result := FChildList.Count;
end;

function TStretchHandle.GetChildControl(idx: integer): TControl;
begin

if (FChildList.Count > 0) and (idx >= 0) then
Result := FChildList[idx]
else
Result := nil;

end;

function TStretchHandle.IsAttached: boolean;
begin

if FChildList.Count > 0 then
Result := True
else
Result := False;

end;

function TStretchHandle.PointOverChild(P: TPoint): boolean;
var
i: integer;
ARect: TRect;
AControl: TControl;
begin
{ determine whether X, Y is over any child (for dragging) }
Result := False;
for i := 0 to FChildList.Count - 1 do
begin
AControl := TControl(FChildList);
ARect := Rect(AControl.Left - 2,
AControl.Top - 2,
AControl.Left + AControl.Width + 2,
AControl.Top + AControl.Height + 2);
{ P is relative to the Parent }
if PtInRect(ARect, P) then
begin
Result := True;
break;
end;
end;

end;

function TStretchHandle.XGridAdjust(X: integer): integer;
begin
Result := (X DIV FGridX) * FGridX;
end;

function TStretchHandle.YGridAdjust(Y: integer): integer;
begin
Result := (Y DIV FGridY) * FGridY;
end;

function MinInt(a, b: integer): integer;
begin
if a < b then
Result := a
else
Result := b;
end;

function MaxInt(a, b: integer): integer;
begin
if a > b then
Result := a
else
Result := b;
end;

end.

to zdwwf: hzg115@sina.com

李宝库兄的好东东，支持所有的，就是太大了，研究研究

有那么复杂吗？　程序运行时，运行中拖动一个元件的例子！
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Panel1: TPanel;
procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DragMove = $F012; { a magic number }
begin
ReleaseCapture;
panel1.perform(WM_SysCommand, SC_DragMove, 0);

end;

end.

to 张辉明,
你那个好象只能对panel有效，对 TImage,Tbutton等无效

自己写：
procedure TForm1.MyMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
m_Down:=(Button=mbleft) ;
if Button=mbleft then begin
MouseDownSpot.X:=X;
MouseDownSpot.Y:=Y;
end
end;

procedure TForm1.MyMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if m_Down then begin
(Sender as TControl).Left:=(Sender as TControl).Left-(MouseDownSpot.X-X);
(Sender as TControl).Top:=(Sender as TControl).Top-(MouseDownSpot.Y-Y);
end ;
end;

procedure TForm1.MyMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if m_Down then begin
ReleaseCapture ;
m_Down:=False ;
(Sender as TControl).Left:=(Sender as TControl).Left-(MouseDownSpot.X-X);
(Sender as TControl).Top:=(Sender as TControl).Top-(MouseDownSpot.Y-Y);
end ;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
panel1.OnMouseDown:=mymousedown;
panel1.OnMouseMove:=mymousemove;
panel1.OnMouseUp:=mymouseup;
end;

你不是去西安了嗎? 前段時間有找過你,不知你們的系統現在做得怎樣了?

在运行时可用dxfDesigner控件,在www.51delphi.com或www.playicq.com中有下载.
dxforumlibrary;
//////////////////////////////////////////////////////////////////////////////////////
constructor TSizerControl.myCreate(AOwner: TComponent; AControl: TControl);
var
R : TRect;
begin
inherited Create(AOwner);
FControl := AControl;
OnExit := SizeControlExit;

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 TSizerControl.Createhandle;
begin
inherited Createhandle;
SetFocus;
end;

procedure TSizerControl.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
//增加透明特性
Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
end;

procedure TSizerControl.paint;
var
i : integer;
begin
Canvas.Brush.Color := clBlack;
for i := 1 to 8 do
with FRectList do
Canvas.Rectangle(Left,Top,Right,Bottom);

end;

procedure TSizerControl.SizeControlExit(sender: TObject);
begin
Free;
end;

procedure TSizerControl.WmLButtonDown(var Msg: TWmLButtonDown);
begin
//执行拖动命令
Perform(wm_syscommand,sc_DragMove,0);
end;

procedure TSizerControl.WmMove(var Msg: TWmMove);
var
R : TRect;
begin
R := BoundsRect;
InflateRect(R,-2,-2);
FControl.Invalidate;
FControl.BoundsRect := R;
end;

procedure TSizerControl.WmNcHitTest(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;

procedure TSizerControl.WmSize(var Msg: TWmSize);
var
R : TRect;
begin
R := BoundsRect;
InflateRect(R,-2,-2);
FControl.BoundsRect := R;
//计算8个黑方框
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 Register;
begin
RegisterNoicon([TSizerControl]);
end;
end.
从前在别人的一个贴子上抄下来的，你可借鉴一下看看吧

呵呵，一直在出差，没办法
系统没做了，恐怕要OVER了，再找出路

已发