Hallo HP,
ja das jabe ich gerade bemerkt.
Allerdings, reagiert die Komponente nicht auf Move.
Jens
Post by Hans-Peter DiettrichWenn das Formular in einer DLL liegt, dann enthält die eine komplette
Kopie der VCL/CLX und RTL, mit eigener Message-Schleife.
DoDi
unit SsCtrlSize;
interface
uses
{$IFDEF VER80}
WinTypes, WinProcs,
{$ELSE}
Windows,
{$ENDIF}
Forms, Messages, SysUtils, Classes, Graphics, Controls;
type
TssGrabHandlePosition = (ghTopLeft, ghTopMiddle, ghTopRight,
ghRightMiddle,
ghBottomRight, ghBottomMiddle, ghBottomLeft, ghLeftMiddle);
TssPositiveInteger = 0..MaxInt;
TssGrabEvent = procedure(Sender: TObject; sx, sy: integer) of object;
TssSizeAndMoveEvent = procedure(Sender: TObject; rct: TRect) of object;
TssGrabHandle = class(TCustomControl)
private
FCaptured: boolean;
FControl: TControl;
FHandlePosition: TssGrabHandlePosition;
FOnDrag: TssGrabEvent;
FOnEndDrag: TssGrabEvent;
FOnStartDrag: TssGrabEvent;
FVisible: boolean;
procedure SetControl(const c: TControl);
procedure SetHandlePosition(const p: TssGrabHandlePosition);
procedure SetPosition;
procedure SetVisible(const v: boolean);
protected
procedure Notification(AComponent: TComponent; AOperation:
TOperation); override;
procedure WmMouseDown(var msg: TWmLButtonDown); message WM_LBUTTONDOWN;
procedure WmMouseMove(var msg: TWmMouseMove); message WM_MOUSEMOVE;
procedure WmMouseUp(var msg: TWmLButtonUp); message WM_LBUTTONUP;
public
constructor Create(AOwner: TComponent); override;
procedure ResetPosition;
property Control: TControl read FControl write SetControl;
property HandlePosition: TssGrabHandlePosition read FHandlePosition
write SetHandlePosition;
property Visible: boolean read FVisible write SetVisible;
property OnDrag: TssGrabEvent read FOnDrag write FOnDrag;
property OnEndDrag: TssGrabEvent read FOnEndDrag write FOnEndDrag;
property OnStartDrag: TssGrabEvent read FOnStartDrag write
FOnStartDrag;
end;
TssControlSizer = class(TComponent)
private
FAllowMove: boolean;
FAllowResize: boolean;
FCanvas: TCanvas;
FControl: TControl;
FGrabHandles: array[TssGrabHandlePosition] of TssGrabHandle;
FLastSizeRect: TRect;
FLimitToParentRect: boolean;
FMinimumMove: TssPositiveInteger;
FMoved: boolean;
FMoving: boolean;
FNewWndProc: Pointer;
FOldWndProc: Pointer;
FOnEndMove: TNotifyEvent;
FOnEndSize: TNotifyEvent;
FOnStartMove: TNotifyEvent;
FOnStartSize: TNotifyEvent;
FParentControl: TWinControl;
FParentRect: TRect;
FStartMovePos: TPoint;
FOnSize: TssSizeAndMoveEvent;
FOnMove: TssSizeAndMoveEvent;
procedure DoSubclass;
procedure DrawMoveRect(const sx, sy: integer);
procedure DrawSizeRect(Sender: TObject; sx, sy: integer);
procedure EndMoveControl(const x, y: Smallint);
procedure FreeCanvas;
procedure GetCanvas;
function GetControlBoundsRect(Sender: TObject; sx, sy: integer): TRect;
function LimitPointToParent(const pt: TPoint): TPoint;
function LimitRectToParent(const rct: TRect): TRect;
procedure MoveControl(const x, y: Smallint);
procedure OnDragHandle(Sender: TObject; sx, sy: integer);
procedure OnEndDragHandle(Sender: TObject; sx, sy: integer);
procedure OnStartDragHandle(Sender: TObject; sx, sy: integer);
procedure SetAllowMove(const v: boolean);
procedure SetAllowResize(const v: boolean);
procedure SetControl(const c: TControl);
procedure SetVisible(const v: boolean);
procedure StartMoveControl(const x, y: Smallint);
procedure UnDoSubclass;
protected
procedure Notification(AComponent: TComponent; AOperation:
TOperation); override;
procedure ReSetHandles;
procedure SubclassProc(var msg: TMessage); virtual;
public
constructor Create(AOwner: TComponent); override;
published
property AllowMove: boolean read FAllowMove write SetAllowMove
default true;
property AllowResize: boolean read FAllowResize write
SetAllowResize default true;
property Control: TControl read FControl write SetControl;
property LimitToParentRect: boolean read FLimitToParentRect write
FLimitToParentRect default false;
property MinimumMove: TssPositiveInteger read FMinimumMove write
FMinimumMove default 3;
property OnStartSize: TNotifyEvent read FOnStartSize write
FOnStartSize;
property OnSize: TssSizeAndMoveEvent read FOnSize write FOnSize;
property OnEndSize: TNotifyEvent read FOnEndSize write FOnEndSize;
property OnStartMove: TNotifyEvent read FOnStartMove write
FOnStartMove;
property OnMove: TssSizeAndMoveEvent read FOnMove write FOnMove;
property OnEndMove: TNotifyEvent read FOnEndMove write FOnEndMove;
end;
procedure Register;
implementation
{$IFDEF WIN32}
{$R *.R32}
{$ELSE}
{$R *.R16}
{$ENDIF}
procedure Register;
begin
RegisterComponents('SadMan', [TssControlSizer]);
end;
function NormaliseRect(const rct: TRect): TRect;
begin
result := rct;
if rct.Left > rct.Right then begin
result.Left := rct.Right;
result.Right := rct.Left;
end;
if rct.Top > rct.Bottom then begin
result.Top := rct.Bottom;
result.Bottom := rct.Top;
end;
end;
function FindParent(const comp: TComponent): TWinControl;
function UpOne(const comp: TComponent): TComponent;
begin
if comp is TControl then
result := TControl(comp).Parent
else
result := comp.Owner;
end;
var
o: TComponent;
begin
result := nil;
if Assigned(comp) then begin
o := UpOne(comp);
while Assigned(o) and not (o is TWinControl) do
o := UpOne(o);
if o is TWinControl then
result := TWinControl(o);
end;
end;
{ TssGrabHandle }
const
HandleCursors: array[TssGrabHandlePosition] of TCursor = (
crSizeNWSE, crSizeNS,
crSizeNESW, crSizeWE,
crSizeNWSE, crSizeNS,
crSizeNESW, crSizeWE);
constructor TssGrabHandle.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Color := clBlack;
Cursor := HandleCursors[FHandlePosition];
Width := 5;
Height := 5;
inherited Visible := false;
FVisible := false;
FCaptured := false;
Parent := nil;
end;
procedure TssGrabHandle.Notification(AComponent: TComponent; AOperation:
TOperation);
begin
inherited Notification(AComponent, AOperation);
if (AComponent = FControl) and (AOperation = opRemove) then
Control := nil;
end;
procedure TssGrabHandle.ResetPosition;
begin
SetPosition;
end;
procedure TssGrabHandle.SetControl(const c: TControl);
begin
if csDestroying in ComponentState then exit;
if FControl <> c then begin
FControl := c;
if Assigned(FControl) then begin
Parent := FindParent(FControl);
HandleNeeded;
SetPosition;
end else begin
DestroyWindowHandle;
Parent := nil;
end;
end;
end;
procedure TssGrabHandle.SetHandlePosition(const p: TssGrabHandlePosition);
begin
if FHandlePosition <> p then begin
FHandlePosition := p;
Cursor := HandleCursors[FHandlePosition];
SetPosition;
end;
end;
procedure TssGrabHandle.SetPosition;
var
x, y: integer;
begin
if Assigned(FControl) then begin
with FControl do
case FHandlePosition of
ghTopMiddle: begin
x := Left + Width div 2;
y := Top;
end;
ghTopRight: begin
x := Left + Width;
y := Top;
end;
ghRightMiddle: begin
x := Left + Width;
y := Top + Height div 2;
end;
ghBottomRight: begin
x := Left + Width;
y := Top + Height;
end;
ghBottomMiddle: begin
x := Left + Width div 2;
y := Top + Height;
end;
ghBottomLeft: begin
x := Left;
y := Top + Height;
end;
ghLeftMiddle: begin
x := Left;
y := Top + Height div 2;
end;
else begin
x := Left;
y := Top;
end;
end;
Left := x - Width div 2;
Top := y - Height div 2;
inherited Visible := FVisible;
end else
inherited Visible := false;
end;
procedure TssGrabHandle.SetVisible(const v: boolean);
begin
if FVisible <> v then begin
FVisible := v;
inherited Visible := FVisible and Assigned(FControl);
end;
end;
procedure TssGrabHandle.WmMouseDown(var msg: TWmLButtonDown);
var
pt: TPoint;
begin
if not FCaptured and ((MK_LBUTTON and msg.keys) <> 0) then begin
SetCaptureControl(Self);
FCaptured := true;
if Assigned(FOnStartDrag) then begin
pt := ClientToScreen(Point(msg.xpos, msg.ypos));
FOnStartDrag(Self, pt.x, pt.y);
end;
end;
end;
procedure TssGrabHandle.WmMouseMove(var msg: TWmMouseMove);
var
pt: TPoint;
begin
inherited;
if FCaptured and Assigned(FOnDrag) then begin
pt := ClientToScreen(Point(msg.xpos, msg.ypos));
FOnDrag(Self, pt.x, pt.y);
end;
end;
procedure TssGrabHandle.WmMouseUp(var msg: TWmLButtonUp);
var
pt: TPoint;
begin
inherited;
if FCaptured then begin
pt := ClientToScreen(Point(msg.xpos, msg.ypos));
if (MK_LBUTTON and msg.keys) = 0 then begin
SetCaptureControl(nil);
FCaptured := false;
if Assigned(FOnEndDrag) then
FOnEndDrag(Self, pt.x, pt.y);
end;
end;
end;
{ TssControlSizer }
constructor TssControlSizer.Create(AOwner: TComponent);
var
h: TssGrabHandlePosition;
begin
inherited Create(AOwner);
FControl := nil;
FParentControl := nil;
FNewWndProc := nil;
FOldWndProc := nil;
FAllowResize := true;
FAllowMove := true;
FStartMovePos := Point(-1, -1);
FLimitToParentRect := false;
FMinimumMove := 3;
if not (csDesigning in ComponentState) then
for h := low(TssGrabHandlePosition) to High(TssGrabHandlePosition)
do begin
FGrabHandles[h] := TssGrabHandle.Create(Self);
with FGrabHandles[h] do begin
HandlePosition := h;
OnStartDrag := Self.OnStartDragHandle;
OnDrag := Self.OnDragHandle;
OnEndDrag := Self.OnEndDragHandle;
Control := Self.FControl;
Visible := Self.FAllowResize;
end;
end
else
for h := low(TssGrabHandlePosition) to High(TssGrabHandlePosition) do
FGrabHandles[h] := nil;
end;
procedure TssControlSizer.DoSubclass;
begin
if not (csDesigning in ComponentState) and (FControl is TWinControl)
then begin
UndoSubclass;
FNewWndProc := MakeObjectInstance(SubclassProc);
FOldWndProc := Pointer(GetWindowLong(TWinControl(FControl).Handle,
GWL_WNDPROC));
SetWindowLong(TWinControl(FControl).Handle, GWL_WNDPROC,
Longint(FNewWndProc));
end;
end;
procedure TssControlSizer.DrawMoveRect(const sx, sy: integer);
var
l, t: integer;
rct: TRect;
begin
if not Assigned(FControl) or
not Assigned(FCanvas) then exit;
l := FControl.Left + sx - FStartMovePos.x;
t := FControl.Top + sy - FStartMovePos.y;
rct := Rect(l, t, l + FControl.Width - 1, t + FControl.Height - 1);
if FLimitToParentRect then
rct := LimitRectToParent(rct);
with FParentControl, rct do begin
TopLeft := ClientToScreen(TopLeft);
BottomRight := ClientToScreen(BottomRight);
end;
with FCanvas do begin
with FLastSizeRect do
Rectangle(Left, Top, Right, Bottom);
with rct do
Rectangle(Left, Top, Right, Bottom);
end;
FLastSizeRect := rct;
if Assigned(FOnMove) then
FOnMove(self, rct);
end;
procedure TssControlSizer.DrawSizeRect(Sender: TObject; sx, sy: integer);
var
rct: TRect;
begin
if not Assigned(FControl) or
not Assigned(FCanvas) then exit;
rct := NormaliseRect(GetControlBoundsRect(sender, sx, sy));
if FLimitToParentRect then
with rct do begin
TopLeft := LimitPointToParent(TopLeft);
BottomRight := LimitPointToParent(BottomRight);
end;
with FParentControl, rct do begin
TopLeft := ClientToScreen(TopLeft);
BottomRight := ClientToScreen(BottomRight);
end;
with FCanvas do begin
with FLastSizeRect do
Rectangle(Left, Top, Right, Bottom);
with rct do
Rectangle(Left, Top, Right, Bottom);
end;
FLastSizeRect := rct;
if Assigned(FOnSize) then
FOnSize(self, rct);
end;
procedure TssControlSizer.EndMoveControl(const x, y: Smallint);
var
l, t: integer;
rct: TRect;
begin
if FMoving and FMoved then begin
DrawMoveRect(x, y);
FLastSizeRect := rect(-1, -1, -1, -1);
DrawMoveRect(x, y);
FreeCanvas;
l := FControl.Left + x - FStartMovePos.x;
t := FControl.Top + y - FStartMovePos.y;
rct := Rect(l, t, l + FControl.Width - 1, t + FControl.Height - 1);
if FLimitToParentRect then
rct := LimitRectToParent(rct);
with rct do begin
FControl.Left := Left;
FControl.Top := Top;
end;
ReSetHandles;
if Assigned(FOnEndMove) then
FOnEndMove(self);
end;
SetVisible(FAllowResize);
FMoving := false;
ReleaseCapture;
FStartMovePos := Point(-1, -1);
end;
procedure TssControlSizer.FreeCanvas;
var
h: THandle;
begin
if Assigned(FCanvas) then begin
h := FCanvas.Handle;
FCanvas.Handle := 0;
ReleaseDC(0, h);
FCanvas.Free;
FCanvas := nil;
end;
end;
procedure TssControlSizer.GetCanvas;
var
h: THandle;
begin
h := 0;
FCanvas := TCanvas.Create;
with FCanvas do try
h := GetDC(0);
Handle := h;
with Brush do begin
Color := clBlack;
Style := bsClear;
end;
with Pen do begin
Color := clBlack;
Style := psSolid;
Mode := pmNot;
Width := 2;
end;
except
Handle := 0;
if h <> 0 then
ReleaseDC(0, h);
Free;
FCanvas := nil;
end;
end;
function TssControlSizer.GetControlBoundsRect(Sender: TObject; sx, sy:
integer): TRect;
var
pt: TPoint;
begin
pt := FParentControl.ScreenToClient(Point(sx, sy));
result := FControl.BoundsRect;
with result do
case TssGrabHandle(Sender).FHandlePosition of
ghTopLeft: begin
Left := pt.x;
Top := pt.y;
end;
ghTopMiddle: begin
Top := pt.y;
end;
ghTopRight: begin
Right := pt.x;
Top := pt.y;
end;
ghRightMiddle: begin
Right := pt.x;
end;
ghBottomRight: begin
Right := pt.x;
Bottom := pt.y;
end;
ghBottomMiddle: begin
Bottom := pt.y;
end;
ghBottomLeft: begin
Left := pt.x;
Bottom := pt.y;
end;
ghLeftMiddle: begin
Left := pt.x;
end;
end;
end;
function TssControlSizer.LimitPointToParent(const pt: TPoint): TPoint;
begin
result := pt;
with result do begin
if X < FParentRect.Left then
X := FParentRect.Left;
if X > FParentRect.Right - 1 then
X := FParentRect.Right - 1;
if Y < FParentRect.Top then
Y := FParentRect.Top;
if Y > FParentRect.Bottom - 1 then
Y := FParentRect.Bottom - 1;
end;
end;
function TssControlSizer.LimitRectToParent(const rct: TRect): TRect;
begin
result := rct;
if result.Left < FParentRect.Left then begin
result.Left := FParentRect.Left;
result.Right := FParentRect.Left + FControl.Width;
end;
if result.Right > FParentRect.Right - 1 then begin
result.Left := FParentRect.Right - FControl.Width - 1;
result.Right := FParentRect.Right - 1;
end;
if result.Top < FParentRect.Top then begin
result.Top := FParentRect.Top;
result.Bottom := FParentRect.Top + FControl.Height;
end;
if result.Bottom > FParentRect.Bottom - 1 then begin
result.Top := FParentRect.Bottom - FControl.Height - 1;
result.Bottom := FParentRect.Bottom - 1;
end;
end;
procedure TssControlSizer.MoveControl(const x, y: Smallint);
begin
if not FMoving then exit;
if not FMoved then begin
FMoved := (abs(x - FStartMovePos.x) >= FMinimumMove) or
(abs(y - FStartMovePos.y) >= FMinimumMove);
if FMoved then begin
GetCanvas;
if Assigned(FOnStartMove) then
FOnStartMove(self);
end;
end;
if FMoved then
DrawMoveRect(x, y);
end;
procedure TssControlSizer.Notification(AComponent: TComponent;
AOperation: TOperation);
begin
inherited Notification(AComponent, AOperation);
if (AComponent = FControl) and (AOperation = opRemove) then
Control := nil;
end;
procedure TssControlSizer.OnDragHandle(Sender: TObject; sx, sy: integer);
begin
DrawSizeRect(Sender, sx, sy);
end;
procedure TssControlSizer.OnEndDragHandle(Sender: TObject; sx, sy: integer);
var
rct: TRect;
begin
if not Assigned(FControl) then exit;
DrawSizeRect(Sender, sx, sy);
FLastSizeRect := rect(-1, -1, -1, -1);
DrawSizeRect(Sender, sx, sy);
FreeCanvas;
rct := NormaliseRect(GetControlBoundsRect(sender, sx, sy));
if FLimitToParentRect then
with rct do begin
TopLeft := LimitPointToParent(TopLeft);
BottomRight := LimitPointToParent(BottomRight);
end;
with rct do
FControl.SetBounds(Left, Top, Right - Left, Bottom - Top);
ReSetHandles;
SetVisible(true); { must have been visible to start dragging }
if Assigned(FOnEndSize) then
FOnEndSize(Self);
end;
procedure TssControlSizer.OnStartDragHandle(Sender: TObject; sx, sy:
integer);
begin
if Assigned(FOnStartSize) then
FOnStartSize(Self);
SetVisible(false);
{ if Assigned(FControl.Parent) then}
FControl.Parent.Update; { to repaint under invisible GrabHandles }
FControl.Update; { to repaint under invisible GrabHandles }
FParentControl := FindParent(FControl);
if Assigned(FParentControl) then
FParentRect := FParentControl.ClientRect
else
FParentRect := rect(0, 0, 0, 0);
GetCanvas;
FLastSizeRect := rect(-1, -1, -1, -1);
DrawSizeRect(Sender, sx, sy);
end;
procedure TssControlSizer.ReSetHandles;
var
h: TssGrabHandlePosition;
begin
for h := low(TssGrabHandlePosition) to High(TssGrabHandlePosition) do
begin
if Assigned(FGrabHandles[h]) then
FGrabHandles[h].ResetPosition;
end;
end;
procedure TssControlSizer.SetAllowMove(const v: boolean);
begin
if FAllowMove <> v then begin
FAllowMove := v;
if not (csDesigning in ComponentState) then begin
if FAllowMove then
DoSubclass
else
UnDoSubclass;
end;
end;
end;
procedure TssControlSizer.SetAllowResize(const v: boolean);
begin
if FAllowResize <> v then begin
FAllowResize := v;
SetVisible(FAllowResize);
end;
end;
procedure TssControlSizer.SetControl(const c: TControl);
var
h: TssGrabHandlePosition;
begin
if csDestroying in ComponentState then exit;
if FControl <> c then begin
UnDoSubclass;
SetVisible(false);
FControl := c;
for h := low(TssGrabHandlePosition) to high(TssGrabHandlePosition) do
if Assigned(FGrabHandles[h]) then
FGrabHandles[h].Control := FControl;
DoSubclass;
SetVisible(FAllowResize);
end;
end;
procedure TssControlSizer.SetVisible(const v: boolean);
var
h: TssGrabHandlePosition;
begin
for h := low(TssGrabHandlePosition) to high(TssGrabHandlePosition) do
if Assigned(FGrabHandles[h]) then
FGrabHandles[h].Visible := v;
end;
procedure TssControlSizer.StartMoveControl(const x, y: Smallint);
begin
if FStartMovePos.X <> -1 then exit;
FStartMovePos := Point(x, y);
FParentControl := FindParent(FControl);
FParentControl := FindParent(FControl);
if Assigned(FParentControl) then
FParentRect := FParentControl.ClientRect
else
FParentRect := rect(0, 0, 0, 0);
FLastSizeRect := rect(-1, -1, -1, -1);
FMoved := false;
FMoving := true;
SetCapture(TWinControl(FControl).Handle);
SetVisible(false);
if FControl.Parent <> nil then
FControl.Parent.Update; { to repaint under invisible GrabHandles }
FControl.Update; { to repaint under invisible GrabHandles }
end;
procedure TssControlSizer.SubclassProc(var msg: TMessage);
begin
if FAllowMove and (msg.msg = WM_LBUTTONDOWN) then begin
{$R-}
StartMoveControl(LOWORD(msg.lParam), HIWORD(msg.lParam));
{$R+}
msg.Result := 1;
end else if FAllowMove and (msg.msg = WM_LBUTTONUP) then begin
{$R-}
EndMoveControl(LOWORD(msg.lParam), HIWORD(msg.lParam));
{$R+}
msg.Result := 1;
end else if FAllowMove and (msg.msg = WM_MOUSEMOVE) then begin
{$R-}
MoveControl(LOWORD(msg.lParam), HIWORD(msg.lParam));
{$R+}
msg.Result := 1;
end else
msg.Result := CallWindowProc(FOldWndProc,
TWinControl(FControl).Handle, Msg.Msg, Msg.wParam, Msg.lParam);
if msg.Msg = WM_DESTROY then
UndoSubclass
else if msg.Msg = WM_WINDOWPOSCHANGED then
ReSetHandles;
end;
procedure TssControlSizer.UndoSubclass;
begin
if (FControl is TWinControl) and Assigned(FNewWndProc) and
Assigned(FOldWndProc) then begin
SetWindowLong(TWinControl(FControl).Handle, GWL_WNDPROC,
Longint(FOldWndProc));
FreeObjectInstance(FNewWndProc);
FNewWndProc := nil;
FOldWndProc := nil;
end;
end;
end.