用这个吧。。
unit StretchHandle;
{ TStretchHandles is a transparent control to implement runtime grab handles
for Forms Designer-like projects. It paints the handles on its own canvas,
maintains a list of the controls it is supposed to manage, and traps mouse
and keyboard events to move/resize itself and its child controls. See the
accompanying README file for more information.
Distributed by the author as freeware, please do not sell.
Anthony Scott
CIS: 75567,3547 }
{ Fix Bug : OnMouseUp Event When Mouse Right Button No Respond Bug }
{ Modify By Tom Lee tom@libra.aaa.hinet.net 1996 OCT 1 }
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Menus, StdCtrls, Dialogs;
{ miscellaneous type declarations }
type
TDragStyle = (dsMove, dsSizeTopLeft, dsSizeTopRight, dsSizeBottomLeft, dsSizeBottomRight,
dsSizeTop, dsSizeLeft, dsSizeBottom, dsSizeRight);
TForwardMessage = (fmMouseDown, fmMouseUp);
GridValues = 1..32;
EBadChild = class(Exception);
{ TStretchHandle component declaration }
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
{ add the component to the 'Samples' tab }
RegisterComponents('Samples', [TStretchHandle]);
end;
constructor TStretchHandle.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{ create storage for child objects }
FChildList := TList.Create;
{ initialize default properties }
Width := 24;
Height := 24;
FPrimaryColor := clBlack;
FSecondaryColor := clGray;
{ a value of 1 is used to effectively disable the snap-to grid }
FGridX := 1;
FGridY := 1;
{ doesn't do anything until it is Attached to something else }
Enabled := False;
Visible := False;
end;
destructor TStretchHandle.Destroy;
begin
{ tidy up carefully }
FChildList.Free;
inherited Destroy;
end;
procedure TStretchHandle.CreateParams(var Params: TCreateParams);
begin
{ set default Params values }
inherited CreateParams(Params);
{ then add transparency; ensures correct repaint order }
Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
end;
procedure TStretchHandle.WMGetDLGCode(var Message: TMessage);
begin
{ get arrow key press events }
Message.Result := DLGC_WANTARROWS;
end;
procedure TStretchHandle.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
{ completely fake erase, don't call inherited, don't collect $200 }
Message.Result := 1;
end;
procedure TStretchHandle.Attach(ChildControl: TControl);
var
L, T, W, H: integer;
begin
{ definitely not allowed! }
if ChildControl is TForm then
raise EBadChild.Create('Handles can not be attached to a Form!');
{ add child component to unique list managed by TStretchHandle }
if (ChildControl <> nil) and (FChildList.IndexOf(TObject(ChildControl)) = -1) then
begin
{ make sure new child's Parent matches siblings }
if (FChildList.Count > 0) and (ChildControl.Parent <> Parent) then
Detach;
{ initialize when first child is attached }
if FChildList.Count = 0 then
begin
Parent := ChildControl.Parent;
{ only make it visible now, to avoid color flashing, & accept events }
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
{ set size to bound all children, plus room for handles }
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;
{ add to list of active Children }
FChildList.Add(TObject(ChildControl));
{ re-set DragStyle }
FDragStyle := dsMove;
{ use old BringToFront so as not to change Child's Z-order }
if not (csDesigning in ComponentState) then
begin
inherited BringToFront;
{ allow us to get Mouse events immediately! }
SetCapture(Handle);
{ get keyboard events }
if Visible and Enabled then
SetFocus;
end;
end;
end;
procedure TStretchHandle.Detach;
begin
{ remove all Child components from list }
if FChildList.Count > 0 then
with FChildList do
repeat
Delete(0);
until Count = 0;
{ disable & hide StretchHandle }
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
{ delete the Child if it exists in the list }
idx := FChildList.IndexOf(TObject(ChildControl));
if (ChildControl <> nil) and (idx >= 0) then
FChildList.Delete(idx);
{ disable & hide StretchHandle if no more children }
if FChildList.Count = 0 then
begin
FLocked := False;
Enabled := False;
Visible := False;
Parent := nil;
FDragRect := Rect(0, 0, 0, 0);
end
else
begin
{ set size to bound remaining children, plus room for handles }
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
{ simply pass on the result... }
Result := FChildList.IndexOf(TObject(ChildControl));
end;
procedure TStretchHandle.BringToFront;
var
i: integer;
begin
{ do nothing if not Attached }
if Attached then TControl(FChildList).BringToFront;
{ make sure keyboard focus is restored }
inherited BringToFront;
if Visible and Enabled then
SetFocus;
end;
procedure TStretchHandle.SendToBack;
var
i: integer;
begin
{ do nothing if not Attached }
if Attached and not Locked then
begin
{ take care of Children first, in Attach order }
for i := 0 to FChildList.Count - 1 do
begin
TControl(FChildList).SendToBack;
end;
{ Handles stay in front of everything, always }
inherited BringToFront;
if Visible and Enabled then
SetFocus;
end;
end;
procedure TStretchHandle.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
{ only process MouseDown if it is over a Child, else forward }
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.
{TStretchHandle V2.0
Author: Anthony Scott
CIS 75567,3547, Internet 75567.3547@compuserve.com
The TStretchHandle component for Delphi has been significantly improved over its early incarnation as an experimental first component. Version 2.0 has better support for manipulating multiple child components, features more consistent visual behaviour, and has been tested with both Windows(tm) 3.1 and Windows(tm) 95. Freeware, feel free to distribute but please don't sell it.
Overview:
TStretchHandle imitates those grabhandles you see when you manipulate components in Delphi's Forms Designer. It encapsulates drag/drop and resize functionality using the left mouse button and arrow keys. Simply drop an instance of TStretchHandle on your form, and attach the component(s) you want to manipulate at runtime by calling the Attach method. A typical way to do this would be to invoke Attach in the target control's OnMouseDown event handler:
procedure TForm1.Label1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
StretchHandle1.Attach(Label1);
end;
Grab handles will appear on the corner and sides of the target (child) control, and TStretchHandle does the rest. Despite the nomenclature, TStretchHandle does not become the Parent of the control(s) it manages; in fact, it will automatically adopt the Parent of the first 'child'. It will insist that all its children be siblings; when a control on a different Parent is attached, an implicit Detach will occur first. An individual child control can be released with a call to the ReleaseChild method, or Detach can be called to release all children at once. Properties are provided to control the color of the grab handle boxes, the cursor to use when dragging, and the granularity of the optional snap-to grid.
Notes:
* Unlike its predecessor, TStretchHandle V2.0 manages child controls via an internal array; the Child property has therefore been replaced by the runtime-only Children[] array property. Children[], ChildCount and Attached are readonly properties.
* TStretchHandle does not employ "real" drag/drop when dragging components - they are simply moved to a new position on the same Parent.
Installation:
The file HANDLES.ZIP contains:
README.DOC - this file (also in .TXT format)
HANDLES.DCR - the component palette icon for this component
HANDLES.PAS - the source for TStretchHandle
PROJECT1.DPR - a sample/demo project (3 files)
UNIT1.DFM
UNIT1.PAS
To install, unpack the .ZIP file and run HANDLES.PAS from Delphi's Options|Install Components, as per usual. It is always wise to back up COMPLIB.DCL before you install a new component. Make sure HANDLES.PAS and HANDLES.DCR are in the same directory.
A sample project is included; simply load and run PROJECT1.DPR from the Delphi IDE.
Properties: Methods: Events:
Attached Create(AOwner: TComponent) OnClick
ChildCount Destroy OnDblClick
Children[] Attach(ChildControl: TControl) OnMouseDown
Color Detach OnMouseMove
Cursor ReleaseChild(ChildControl: TControl) OnMouseUp
DragCursor IndexOf(ChildControl: TControl) OnKeyDown
Enabled BringToFront OnKeyUp
GridX SendToBack OnKeyPress
GridY SetBounds(ALeft, ATop, AWidth, AHeight: Integer)
Height SetColors(Color1, Color2: TColor)
HelpContext
Hint
Left
Locked Exceptions:
Name
ParentShowHint EBadChild (when you try to attach a Form - sorry, couldn't resist!)
PopupMenu
SecondaryColor
ShowHint
SnapToGrid
Tag
Top
Visible
Width
Known problems:
Yes, there are a couple. Notably, the handles component is sized to the bounding rectangle of all its children, and this has some side effects. Events in the transparent area (the space between multiple children) are still seen by the TStretchHandle component. MouseDown and MouseUp events are passed through to underlying controls, but MouseMove and DoubleClick events are not. This also affects the behaviour of the Hint and PopupMenu properties - hints and menus assigned to TStretchHandle may show up in seemingly vacant areas.
Support:
Any queries, suggestions or thoughts are welcome. My thanks to those folks who have already offered helpful feedback.
Please write or email:
CIS: 75567,3547
Anthony Scott
2001 S. Halsted
Chicago, IL, 60608 }
