paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-03 21:38:21 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: undo docking patch

Browse Source 
git-svn-id: trunk@13349 -
This commit is contained in:
mattias 2007-12-16 11:00:25 +00:00
parent 767859d068
commit fd641213fc
15 changed files with 515 additions and 769 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
ide/uniteditor.pp
View File

@ -1518,15 +1518,6 @@ Begin
ecFindPrevWordOccurrence:
FindNextWordOccurrence(false);
ecSetFreeBookmark:
FSourceNoteBook.BookMarkSetFreeClicked(Self);
ecPrevBookmark:
FSourceNoteBook.BookMarkPrevClicked(Self);
ecNextBookmark:
FSourceNoteBook.BookMarkNextClicked(Self);
ecSelectionEnclose:
EncloseSelection;

18
lcl/comctrls.pp
View File

@ -219,6 +219,7 @@ type
property Width stored False;
end;
{ TPageControl }
TPageControl = class(TCustomNotebook)
@ -239,7 +240,6 @@ type
property ActivePageIndex: Integer read GetActivePageIndex
write SetActivePageIndex;
property Pages[Index: Integer]: TTabSheet read GetTabSheet;
procedure DockDrop(DockObject: TDragDockObject; X, Y: Integer); override;
published
property ActivePage: TTabSheet read GetActiveTabSheet write SetActiveTabSheet;
property Align;
@ -247,9 +247,9 @@ type
property BorderSpacing;
//property BiDiMode;
property Constraints;
property DockSite;
//property DockSite;
property DragCursor;
property DragKind;
//property DragKind;
property DragMode;
property Enabled;
property Font;
@ -275,25 +275,25 @@ type
property OnChange: TNotifyEvent read fOnPageChanged write fOnPageChanged;
property OnChanging;
property OnContextPopup;
property OnDockDrop;
property OnDockOver;
//property OnDockDrop;
//property OnDockOver;
property OnDragDrop;
property OnDragOver;
//property OnDrawTab;
property OnEndDock;
//property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetImageIndex;
property OnGetSiteInfo;
//property OnGetSiteInfo;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnPageChanged;
property OnResize;
property OnStartDock;
//property OnStartDock;
property OnStartDrag;
property OnUnDock;
//property OnUnDock;
end;

66
lcl/controls.pp
View File

@ -73,8 +73,6 @@ type
TControl = class;
TWinControlClass = class of TWinControl;
TControlClass = class of TControl;
TDragDockObject = class;
TDate = type TDateTime;
TTime = type TDateTime;
@ -103,13 +101,6 @@ type
Result: LRESULT;
End;
TCMFloat = packed record
Msg: Cardinal;
Reserved: Integer;
DockSource: TDragDockObject;
Result: Integer;
end;
TCMDialogChar = TLMKEY;
TCMDialogKey = TLMKEY;
@ -371,17 +362,17 @@ type
FMouseDeltaX: Double;
FMouseDeltaY: Double;
FCancelling: Boolean;
DragCapture: HWnd;
function Capture: HWND;
protected
procedure Capture;
procedure ReleaseCapture;
procedure MainWndProc(var Message: TLMessage);
procedure WndProc(var Msg: TLMessage); virtual;
procedure Finished(Target: TObject; X, Y: Integer; Accepted: Boolean); virtual;
function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; virtual;
function GetDragImages: TDragImageList; virtual;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual;
procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X, Y: Integer); virtual;
procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X, Y: Integer); virtual;
procedure CaptureChanged(OldCaptureControl: TControl); virtual;
procedure KeyDown(var Key: Word; Shift: TShiftState); virtual;
procedure KeyUp(var Key: Word; Shift: TShiftState); virtual;
public
destructor Destroy; override;
procedure Assign(Source: TDragObject); virtual;
@ -395,7 +386,7 @@ type
property DragPos: TPoint read FDragPos write FDragPos;
property DragTargetPos: TPoint read FDragTargetPos write FDragTargetPos;
property DragTarget: TControl read FDragTarget write FDragTarget;
property Dropped: Boolean read FDropped write FDropped;
property Dropped: Boolean read FDropped;
property MouseDeltaX: Double read FMouseDeltaX;
property MouseDeltaY: Double read FMouseDeltaX;
end;
@ -429,6 +420,8 @@ type
{ TDragDockObject }
TDragDockObject = class;
TDockOrientation = (
doNoOrient, // zone contains a TControl and no child zones.
doHorizontal, // zone's children are stacked top-to-bottom.
@ -453,7 +446,6 @@ type
FDockRect: TRect;
FDropAlign: TAlign;
FDropOnControl: TControl;
FEraseDockRect: TRect;
FFloating: Boolean;
FIncreaseDockArea: Boolean;
procedure SetBrush(Value: TBrush);
@ -470,38 +462,14 @@ type
procedure Assign(Source: TDragObject); override;
property Brush: TBrush read FBrush write SetBrush;
property DockRect: TRect read FDockRect write FDockRect;// screen coordinates
property DropAlign: TAlign read FDropAlign write FDropAlign;
property DropOnControl: TControl read FDropOnControl write FDropOnControl;
property DropAlign: TAlign read FDropAlign;
property DropOnControl: TControl read FDropOnControl;
property Floating: Boolean read FFloating write FFloating;
property FrameWidth: Integer read GetFrameWidth;
property IncreaseDockArea: Boolean read FIncreaseDockArea;
property EraseDockRect: TRect read FEraseDockRect write FEraseDockRect;
end;
{ TDragManager }
TDragManager = class(TPersistent)
public
procedure RegisterDockSite(Site: TWinControl; DoRegister: Boolean); virtual;
procedure BeginDrag(AControl: TControl; AImmediate: Boolean; AThreshold: Integer);virtual;
function Dragging(AControl: TControl): boolean; virtual;
procedure DragTo(const APosition: TPoint); virtual;
procedure DragDone(ADrop: Boolean); virtual;
procedure CancelDrag; virtual;
end;
var
DragManager: TDragManager;
//Drag and Dock wrappers to stay fully compatible
procedure BeginDrag(AControl: TControl; AImmediate: Boolean; AThreshold: Integer);
function Dragging(AControl: TControl=nil): boolean;
procedure DragTo(const APosition: TPoint);
procedure DragDone(ADrop: Boolean);
procedure CancelDrag;
type
{ TDockManager is an abstract class for managing a dock site's docked
controls. See TDockTree below for the more info.
}
@ -1034,7 +1002,7 @@ type
procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP;
procedure WMRButtonUp(var Message: TLMRButtonUp); message LM_RBUTTONUP;
procedure WMMButtonUp(var Message: TLMMButtonUp); message LM_MBUTTONUP;
procedure CMFloat(var Message: TCMFloat); message CM_FLOAT;
procedure WMDragStart(Var Message: TLMessage); message LM_DRAGSTART;//not in delphi
procedure WMMove(var Message: TLMMove); message LM_MOVE;
procedure WMSize(var Message: TLMSize); message LM_SIZE;
procedure WMWindowPosChanged(var Message: TLMWindowPosChanged); message LM_WINDOWPOSCHANGED;
@ -1623,7 +1591,6 @@ type
function CanTab: Boolean; override;
procedure DoDragMsg(var DragMsg: TCMDrag); override;
procedure CMDrag(var Message: TCMDrag); message CM_DRAG;
procedure CMFloat(var Message: TCMFloat); message CM_FLOAT;
procedure CMShowingChanged(var Message: TLMessage); message CM_SHOWINGCHANGED;
procedure CMVisibleChanged(var TheMessage: TLMessage); message CM_VISIBLECHANGED;
procedure DoSendShowHideToInterface; virtual;
@ -2222,6 +2189,8 @@ var
procedure SetCaptureControl(AWinControl: TWinControl; const Position: TPoint);
procedure SetCaptureControl(Control: TControl);
function GetCaptureControl: TControl;
procedure CancelDrag;
procedure DragDone(Drop: Boolean);
var
NewStyleControls: Boolean;
@ -2262,6 +2231,7 @@ var
// The interface knows, which TWinControl has the capture. This stores
// what child control of this TWinControl has actually the capture.
CaptureControl: TControl=nil;
DockSiteHash: TDynHashArray=nil;
procedure AdjustBorderSpace(var RemainingClientRect, CurBorderSpace: TRect;
Left, Top, Right, Bottom: integer);
@ -3366,11 +3336,11 @@ initialization
//DebugLn('controls.pp - initialization');
Mouse := TMouse.Create;
DefaultDockTreeClass := TDockTree;
DragManager := TDragManagerDefault.Create;
RegisterIntegerConsts(TypeInfo(TCursor), @IdentToCursor, @CursorToIdent);
finalization
FreeThenNil(DragManager);
FreeThenNil(DockSiteHash);
FreeThenNil(Mouse);
end.

22
lcl/extctrls.pp
View File

@ -1028,8 +1028,6 @@ type
{ TPanel }
TPanel = class(TCustomPanel)
public
property DockManager;
published
property Align;
property Alignment;
@ -1039,7 +1037,6 @@ type
property BevelInner;
property BevelOuter;
property BevelWidth;
//property BiDiMode;
property BorderWidth;
property BorderStyle;
property Caption;
@ -1048,20 +1045,12 @@ type
property ClientWidth;
property Color;
property Constraints;
//property Ctl3D;
property UseDockManager default True;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FullRepaint;
property Font;
//property Locked;
//property ParentBiDiMode;
//property ParentBackground;
property FullRepaint;
property ParentColor;
//property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
@ -1069,27 +1058,18 @@ type
property TabOrder;
property TabStop;
property Visible;
//property OnCanResize;
property OnClick;
//property OnConstrainedResize;
//property OnContextPopup;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetSiteInfo;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
end;
{ TCustomTrayIcon }

4
lcl/forms.pp
View File

@ -375,7 +375,6 @@ type
FKeyPreview: Boolean;
FMenu: TMainMenu;
FModalResult: TModalResult;
FOldBorderStyle: TFormBorderStyle;
FOnActivate: TNotifyEvent;
FOnClose: TCloseEvent;
FOnCloseQuery: TCloseQueryEvent;
@ -431,7 +430,6 @@ type
procedure WMShowWindow(var message: TLMShowWindow); message LM_SHOWWINDOW;
procedure WMSize(var message: TLMSize); message LM_Size;
procedure CMBiDiModeChanged(var Message: TLMessage); message CM_BIDIMODECHANGED;
procedure LMDragStart(Var Message: TLMessage); message LM_DRAGSTART;//not in delphi
procedure AddHandler(HandlerType: TFormHandlerType;
const Handler: TMethod; AsLast: Boolean);
procedure RemoveHandler(HandlerType: TFormHandlerType;
@ -604,8 +602,6 @@ type
property ClientWidth;
property Color;
property Constraints;
property DragKind;
property DragMode;
property DockSite;
property Enabled;
property Font;

158
lcl/include/control.inc
View File

@ -62,8 +62,30 @@ end;
starts immediately.
------------------------------------------------------------------------------}
procedure TControl.BeginDrag(Immediate: Boolean; Threshold: Integer);
var
P : TPoint;
begin
DragManager.BeginDrag(Self, Immediate, Threshold);
// start a drag operation, if not already running
if (DragControl = nil) then begin
// if the last mouse down was not followed by a mouse up, simulate a
// mouse up. This way applications need only to react to mouse up to
// clean up.
{$IFDEF VerboseDrag}
DebugLn('TControl.BeginDrag ',DbgSName(Self),' Immediate=',dbgs(Immediate));
{$endif}
if Immediate then
SetCaptureControl(nil);
if csLButtonDown in ControlState then begin
GetCursorPos(p);
P := ScreenToClient(p);
Perform(LM_LBUTTONUP, 0, Integer(PointToSmallPoint(p)));
end;
if Threshold < 0 then
Threshold := Mouse.DragThreshold;
DragInitControl(Self,Immediate,Threshold);
end;
end;
{------------------------------------------------------------------------------
@ -71,7 +93,7 @@ end;
------------------------------------------------------------------------------}
procedure TControl.BeginAutoDrag;
begin
DragManager.BeginDrag(Self, Mouse.DragImmediate,Mouse.DragThreshold);
BeginDrag(Mouse.DragImmediate,Mouse.DragThreshold);
end;
{------------------------------------------------------------------------------
@ -1093,7 +1115,6 @@ end;
------------------------------------------------------------------------------}
Procedure TControl.DoDragMsg(var DragMsg: TCMDrag);
var
Target: TWinControl;
Accepts: Boolean;
Src: TObject;
P: TPoint;
@ -1103,7 +1124,6 @@ Begin
{$ENDIF}
Src := DragMsg.Dragrec^.Source;
P:=ScreenToClient(DragMsg.Dragrec^.Pos);
Target := TWinControl(DragMsg.Dragrec^.Target);
{$IFDEF VerboseDrag}
DebugLn('TControl.DoDragMsg ',Name,':',ClassName,' DragMsg.Dragrec^.Pos=',IntToStr(DragMsg.Dragrec^.Pos.X),',',IntToStr(DragMsg.Dragrec^.Pos.Y),' -> P=',IntToStr(P.X),IntToStr(P.Y));
//if P.X<0 then RaiseGDBException('');
@ -1116,19 +1136,21 @@ Begin
dmDragEnter, dmDragLeave, dmDragMove:
begin
Accepts := True;
if Src is TDragDockObject
then Target.DockOver(TDragDockObject(Src),P.X,P.Y,TDragState(DragMsg.DragMessage),Accepts)
else DragOver(Src,P.X,P.Y,TDragState(DragMsg.DragMessage),Accepts);
DragMsg.Result := Ord(Accepts);
case DragMsg.DragMessage of
dmDragEnter: DragOver(Src,P.X,P.Y,dsDragEnter,Accepts);
dmDragLeave: DragOver(Src,P.X,P.Y,dsDragLeave,Accepts);
dmDragMove : DragOver(Src,P.X,P.Y,dsDragMove,Accepts);
end;
if Accepts then
DragMsg.Result := 1
else
DragMsg.Result := 0;
end;
dmDragDrop: begin
if Src is TDragDockObject
then Target.DockDrop(TDragDockObject(Src), P.X, P.Y)
else DragDrop(Src, P.X, P.Y);
end;
dmDragDrop:
DragDrop(Src, P.X, P.Y);
end;
end; //case
end;
{------------------------------------------------------------------------------
@ -1158,9 +1180,6 @@ begin
If Assigned(FOnDragDrop) then FOnDragDrop(Self, Source,X,Y);
end;
{------------------------------------------------------------------------------
TControl Method SetColor "Sets the default color and tells the widget set"
------------------------------------------------------------------------------}
@ -1187,7 +1206,7 @@ end;
------------------------------------------------------------------------------}
Function TControl.Dragging: Boolean;
Begin
Result := DragManager.Dragging(Self);
Result := (DragControl = self);
end;
{------------------------------------------------------------------------------
@ -2400,27 +2419,6 @@ begin
end;
end;
procedure TControl.CMFloat(var Message: TCMFloat);
var
P: TPoint;
FloatHost: TWinControl;
begin
if Floating and (Parent <> nil)then
begin
P := Parent.ClientToScreen(Point(Left, Top));
with Message.DockSource.DockRect do begin
Parent.BoundsRect := Bounds(Left + Parent.Left - P.X, Top + Parent.Top - P.Y,
Right - Left + Parent.Width - Width, Bottom - Top + Parent.Height - Height);
end;
end else begin
FloatHost := CreateFloatingDockSite(Message.DockSource.DockRect);
if FloatHost <> nil then begin
Message.DockSource.DragTarget := FloatHost;
Message.DockSource.DragHandle := FloatHost.Handle;
end;
end;
end;
{------------------------------------------------------------------------------
TControl GetText
------------------------------------------------------------------------------}
@ -2916,37 +2914,10 @@ end;
{------------------------------------------------------------------------------
TControl DefaultDockImage
------------------------------------------------------------------------------}
procedure TControl.DefaultDockImage(DragDockObject: TDragDockObject; Erase: Boolean);
var DrawRect: TRect;
PenSize: Integer;
ACanvas: TCanvas;
DC: HDC;
procedure TControl.DefaultDockImage(DragDockObject: TDragDockObject;
Erase: Boolean);
begin
with DragDockObject do begin
if Erase
then DrawRect := EraseDockRect
else DrawRect := DockRect;
PenSize := FrameWidth;
end;
DC := GetDC(0);
ACanvas:= TCanvas.Create;
try
ACanvas.Handle:= DC;
ACanvas.Pen.Mode := pmXOR;
ACanvas.Pen.Color := clWhite;
ACanvas.Pen.Width := PenSize;
with DrawRect do begin
ACanvas.MoveTo(Left+PenSize, Top+PenSize);
ACanvas.LineTo(Right-PenSize,Top+PenSize);
ACanvas.LineTo(Right-PenSize, Bottom-PenSize);
ACanvas.LineTo(Left+PenSize,Bottom-PenSize);
ACanvas.LineTo(Left+PenSize, Top+PenSize);
end;
finally
ACanvas.Free;
ReleaseDC(0, DC);
end;
// ToDo Dock: draw or erase dock image
end;
{------------------------------------------------------------------------------
@ -3155,6 +3126,15 @@ begin
FPopupMenu := Value;
end;
{------------------------------------------------------------------------------
TControl WMDragStart
------------------------------------------------------------------------------}
Procedure TControl.WMDragStart(Var Message: TLMessage);
Begin
//do this here?
BeginDrag(true);
end;
{------------------------------------------------------------------------------
TControl WMMouseMove
------------------------------------------------------------------------------}
@ -3176,6 +3156,7 @@ End;
Procedure TControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
P: TPoint;
Form: TCustomForm;
begin
if (not (Self is TWinControl)) or (not TWinControl(Self).CanFocus) then begin
@ -3184,6 +3165,10 @@ begin
Form.ActiveControl.EditingDone;
end;
if (Button in [mbLeft,mbRight]) and (DragObject<>nil) then begin
P:=ClientToScreen(Point(X,Y));
DragObject.MouseDown(Button,Shift,P.X,P.Y);
end;
if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X,Y);
end;
@ -3191,7 +3176,17 @@ end;
TControl MouseMove
------------------------------------------------------------------------------}
Procedure TControl.MouseMove(Shift: TShiftState; X, Y: Integer);
var
P: TPoint;
DragObjectDragging : Boolean;
begin
if DragObject <> nil then
DragObjectDragging := true else
DragObjectDragging := false;
if DragObjectDragging then begin
P:=ClientToScreen(Point(X,Y));
DragObject.MouseMove(Shift,P.X,P.Y);
end;
if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X,Y);
end;
@ -3200,7 +3195,17 @@ end;
------------------------------------------------------------------------------}
Procedure TControl.MouseUp(Button: TMouseButton; Shift:TShiftState;
X, Y: Integer);
var
P: TPoint;
DragObjectDragging : Boolean;
begin
if DragObject <> nil then
DragObjectDragging := true else
DragObjectDragging := false;
if (Button in [mbLeft,mbRight]) and DragObjectDragging then begin
P:=ClientToScreen(Point(X,Y));
DragObject.MouseUp(Button,Shift,P.X,P.Y);
end;
if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X,Y);
end;
@ -3218,10 +3223,11 @@ end;
{------------------------------------------------------------------------------
procedure TControl.CaptureChanged;
now handled by dragobject
------------------------------------------------------------------------------}
procedure TControl.CaptureChanged;
begin
if (DragObject<>nil) then DragObject.CaptureChanged(Self);
end;
{------------------------------------------------------------------------------
@ -3475,8 +3481,6 @@ begin
DockRect := Bounds(NewPosition.X,NewPosition.Y,Width,Height);
end;
// map from screen coordinates to new HostSite coordinates
if (NewDockSite is TCustomForm) then
TCustomForm(NewDockSite).HandleNeeded;
NewPosition:=NewDockSite.ScreenToClient(NewPosition);
// DockDrop
DebugLn('TControl.ManualDock DOCKDROP ',Name,' DockRect=',dbgs(DockObject.DockRect),' NewPos=',dbgs(NewPosition));
@ -3708,14 +3712,7 @@ begin
// make sure the capture is released
MouseCapture := false;
Application.ControlDestroyed(Self);
if (FHostDockSite <> nil) and not (csDestroying in FHostDockSite.ComponentState) then
begin
FHostDockSite.Perform(CM_UNDOCKCLIENT, 0, Integer(Self));
SetParent(nil);
//TODO:Dock(NullDockSite, BoundsRect);
FHostDockSite := nil;
end else
SetParent(nil);
SetParent(nil);
FreeThenNil(FActionLink);
for Side:=Low(FAnchorSides) to High(FAnchorSides) do
FreeThenNil(FAnchorSides[Side]);
@ -3769,7 +3766,6 @@ begin
FColor := clWindow;
FVisible := true;
FParentShowHint := True;
FParentFont := True;
FParentColor := True;
FWindowProc := @WndProc;
FCursor := crDefault;

2
lcl/include/customcombobox.inc
View File

@ -431,7 +431,7 @@ var
UserDropDown: boolean;
begin
Skip := False;
UserDropDown := ((Shift *[ssAlt] = [ssAlt]) and (Key = VK_DOWN));
UserDropDown := ((Shift *[ssCtrl] = [ssCtrl]) and (Key = VK_DOWN));
if AutoDropDown or UserDropDown or FReturnArrowState then
begin

30
lcl/include/customform.inc
View File

@ -940,17 +940,16 @@ begin
{$ENDIF}
LCLIntf.SetFocus(FocusHandle);
if not ContainsForm(Self) then exit;
//LCLIntf.SetFocus(Self.Handle);
end;
end;
end;
CM_EXIT:
begin
if HostDockSite <> nil then DeActivate;
//TODO: deal with docking if HostDockSite <> nil then DeActivate;
end;
CM_ENTER:
begin
if HostDockSite <> nil then Activate;
//TODO: Deal with docking if HostDockSite <> nil then Activate;
end;
LM_WINDOWPOSCHANGING:
if ([csLoading, csDesigning] * ComponentState = [csLoading])
@ -1027,18 +1026,9 @@ begin
end;
procedure TCustomForm.DoDock(NewDockSite: TWinControl; var ARect: TRect);
//Save or restore the form borderstyle before its (un)docked
begin
if (NewDockSite <> HostDockSite) and ((NewDockSite = nil) or Floating) then
begin
if NewDockSite = nil then
//Restore the form borderstyle
FFormBorderStyle := FOldBorderStyle
else begin
//Save the borderstyle & set new bordertype
FOldBorderStyle := FFormBorderStyle;
FFormBorderStyle := bsNone;
end;
if (NewDockSite<>HostDockSite) then begin
end;
inherited DoDock(NewDockSite, ARect);
end;
@ -1438,6 +1428,7 @@ begin
inherited Create(AOwner);
Visible := False;
fCompStyle:= csForm;
FMenu:= nil;
ControlStyle := ControlStyle + [csAcceptsControls, csCaptureMouse,
@ -1456,8 +1447,6 @@ begin
FAllowDropFiles := False;
End;
{------------------------------------------------------------------------------
TCustomForm CreateParams
------------------------------------------------------------------------------}
@ -1468,7 +1457,7 @@ begin
begin
if (Parent = nil) {and (ParentWindow = 0)} then
begin
//WndParent := Application.Handle;
// WndParent := Application.Handle;
{ TODO : No application handle }
Style := Style and not Cardinal(WS_GROUP or WS_TABSTOP);
if Parent=nil then
@ -2102,13 +2091,6 @@ begin
inherited Dock(NewDockSite, ARect);
end;
procedure TCustomForm.LMDragStart(var Message: TLMessage);
begin
if (Message.wParam = HTCAPTION) and (DragKind = dkDock) and
not (csDesigning in ComponentState) and(WindowState <> wsMinimized)
then DragManager.BeginDrag(Self, not Floating, -1);
end;
//==============================================================================
{ TForm }

1
lcl/include/custompanel.inc
View File

@ -43,7 +43,6 @@ begin
Color:=clBtnFace;// clBackground;
SetInitialBounds(0,0,GetControlClassDefaultSize.X,GetControlClassDefaultSize.Y);
ParentColor := True;
UseDockManager := True;
end;
procedure TCustomPanel.SetAlignment(const Value: TAlignment);

765
lcl/include/dragdock.inc
View File

@ -14,6 +14,16 @@
*****************************************************************************
}
var
DragControl: TControl=nil; // control, that started the drag
DragObject: TDragObject; // the drag information object
DragObjectAutoFree: Boolean; // True, if DragObject was auto created
DragStartPos: TPoint; // mouse position at start of drag
ActiveDrag: TDragOperation;// current phase of drag operation
DragThreshold: Integer;// treshold before the drag becomes activated
DragImages: TDragImageList; // DragObject.GetDragImages
Procedure DragTo(const Position: TPoint); forward;
{-------------------------------------------------------------------------------
function HostDockSiteManagerAvailable(HostDockSite: TWinControl): boolean;
@ -24,382 +34,42 @@ begin
and (HostDockSite.DockManager<>nil);
end;
{ TDragManager }
procedure TDragManager.BeginDrag(AControl: TControl; AImmediate: Boolean; AThreshold: Integer);
begin
//Nothing, only avoiding abstract errors the dirty way
end;
procedure TDragManager.DragTo(const APosition: TPoint);
begin
//Nothing, only avoiding abstract errors the dirty way
end;
procedure TDragManager.CancelDrag;
begin
//Nothing, only avoiding abstract errors the dirty way
end;
procedure TDragManager.DragDone(ADrop: Boolean);
begin
//Nothing, only avoiding abstract errors the dirty way
end;
function TDragManager.Dragging(AControl: TControl): boolean;
begin
//Nothing, only avoiding abstract errors the dirty way
Result := false;
end;
procedure TDragManager.RegisterDockSite(Site: TWinControl; DoRegister: Boolean);
begin
//Nothing, only avoiding abstract errors the dirty way
end;
//Drag and Drop wrappers
{-------------------------------------------------------------------------------
procedure RegisterDockSite(Site: TWinControl; DoRegister: Boolean);
-------------------------------------------------------------------------------}
procedure RegisterDockSite(Site: TWinControl; DoRegister: Boolean);
begin
DragManager.RegisterDockSite(Site, DoRegister);
end;
procedure BeginDrag(AControl: TControl; AImmediate: Boolean; AThreshold: Integer);
begin
DragManager.BeginDrag(AControl, AImmediate, AThreshold);
end;
function Dragging(AControl: TControl=nil): boolean;
begin
Result:=DragManager.Dragging(AControl);
end;
function Dragging: boolean;
begin
Result:=DragManager.Dragging(nil);
end;
procedure DragTo(const APosition: TPoint);
begin
DragManager.DragTo(APosition);
end;
procedure DragDone(ADrop: Boolean);
begin
DragManager.DragDone(ADrop);
end;
procedure CancelDrag;
begin
DragManager.CancelDrag;
end;
type
TDragManagerDefault = class(TDragManager)
private
FDockingPoints: TList;
FDragControl: TWinControl; //control that started the drag
FDragObject: TDragObject; // the drag information object
FActiveDrag: TDragOperation; // current phase of drag operation
FDragStartPos: TPoint; // mouse position at start of drag
FDragThreshold: Integer;// treshold before the drag becomes activated
FDragObjectAutoFree: Boolean; //Free the dragobject
FDragImageList: TDragImageList; //Images
protected
function SendCmDragMsg(DragMsg: TDragMessage): Boolean;
function SendDragMessage(MsgTarget: TControl; Msg: TDragMessage; Source: TDragObject; Target: TControl; const Position: TPoint): LRESULT;
protected
procedure RegisterDockSite(Site: TWinControl; DoRegister: Boolean);override;
procedure BeginDrag(AControl: TControl; AImmediate: Boolean; AThreshold: Integer); override;
function Dragging(AControl: TControl): boolean; override;
procedure DragTo(const APosition: TPoint); override;
procedure DragDone(Drop: Boolean); override;
procedure CancelDrag; override;
public
destructor Destroy; override;
end;
{ TDragManagerDefault }
destructor TDragManagerDefault.Destroy;
begin
FDockingPoints.Free;
inherited Destroy;
end;
function TDragManagerDefault.Dragging(AControl: TControl): boolean;
//No need to let a TControl know the contents of dragmanager
begin
if AControl = nil
then Result := FActiveDrag <> dopNone
else Result := FDragControl=AControl;
end;
function TDragManagerDefault.SendCmDragMsg(DragMsg: TDragMessage): Boolean;
//Send a CM_DRAG message to the window..
begin
if FDragObject.DragTarget <> nil
then Result := boolean(SendDragMessage(FDragObject.DragTarget, DragMsg, FDragObject, FDragObject.DragTarget, FDragObject.DragPos))
else Result := false;
end;
procedure TDragManagerDefault.BeginDrag(AControl: TControl; AImmediate: Boolean; AThreshold: Integer);
//Start a drag operation, if not already running
var ADragObject: TDragObject;
begin
if FDragControl = nil then begin
ADragObject:=nil;
GetCursorPos(FDragStartPos);
FDragObjectAutoFree := false;
try
if AImmediate
then SetCaptureControl(nil);
//Use default value when Threshold < 0
if AThreshold >= 0
then FDragThreshold := AThreshold
else FDragThreshold := Mouse.DragThreshold; //Mayby move it to DragManager? (same for DragImmediate)
//From DragInitControl(AControl,AImmediate,AThreshold); ======================
if AControl is TWinControl
then FDragControl := TWinControl(AControl)
else raise Exception.CreateFmt('Dragged control %s is not a TWinControl',[AControl.Name]);
if AControl.DragKind = dkDrag then begin
AControl.DoStartDrag(ADragObject);
if ADragObject = nil then begin
ADragObject := TDragControlObject.Create(AControl);
FDragObjectAutoFree := true;
end
end else begin
AControl.DoStartDock(ADragObject);
if ADragObject = nil then begin
ADragObject := TDragDockObject.Create(AControl);
FDragObjectAutoFree := true;
end;
with TDragDockObject(ADragObject)do begin
if AControl is TWinControl
then GetWindowRect(TWinControl(AControl).Handle, DockRect)
else begin
if(AControl.Parent = nil)and not(AControl is TWinControl)
then GetCursorPos(DockRect.TopLeft)
else DockRect.TopLeft := AControl.ClientToScreen(Point(0, 0));
DockRect.BottomRight := Point(DockRect.Left + AControl.Width,DockRect.Top + AControl.Height);
end;
EraseDockRect := DockRect;
end;
end;
//From DragInit(ADragObject, AImmediate, AThreshold); ======================
FDragObject := ADragObject;
FDragObject.DragTarget := nil;
FDragObject.DragPos := FDragStartPos;
SetCaptureControl(AControl);
FDragObject.Capture;
if FDragObject is TDragDockObject then begin
with TDragDockObject(FDragObject), DockRect do begin
if AImmediate then begin
FActiveDrag := dopDock;
DrawDragDockImage;
end
else FActiveDrag := dopNone;
end;
end else begin
if AImmediate
then FActiveDrag := dopDrag
else FActiveDrag := dopNone;
end;
FDragImageList := FDragObject.GetDragImages; //crash?
if FDragImageList <> nil
then with FDragStartPos do FDragImageList.BeginDrag(0, X, Y);
if FActiveDrag <> dopNone
then DragTo(FDragStartPos);
except
FDragControl := nil;
raise;
end;
end;
end;
procedure TDragManagerDefault.DragTo(const APosition: TPoint);
function GetDropControl: TControl;
//Select a control where the dragged control will be docked
var ADragTarget: TWinControl;
AControl: TControl;
i: integer;
begin
Result := nil;
ADragTarget := TWinControl(FDragObject.DragTarget);
if ADragTarget <> nil then begin
if ADragTarget.UseDockManager then begin
if ADragTarget.DockClientCount > 0 then begin
//Did the user drop it on the same positon? ?
AControl := ADragTarget.DockClients[0];
if (ADragTarget.DockClientCount = 1)and (AControl = FDragControl)
then Exit;
AControl := FindDragTarget(FDragObject.DragPos, false);
while(AControl <> nil)and(AControl <> ADragTarget)do begin
for i:=0 to ADragTarget.DockClientCount-1 do begin
if ADragTarget.DockClients[i]=AControl then begin
Result := ADragTarget.DockClients[i];
Exit;
end;
end;
AControl := AControl.Parent;
end;
end;
end;
end;
end;
function IsControlChildOfClient(AControl:TWinControl): Boolean;
begin
Result := False;
while Assigned(AControl) do begin
if AControl=FDragControl then begin
Result:=true;
exit;
end;
AControl:=AControl.Parent;
end;
end;
function FindDockSiteAtPosition: TWinControl;
var
AControl: TWinControl;
CanDock: Boolean;
QualifyingSites:TList;
ARect: TRect;
I: Integer;
begin
Result:=nil;
if FDragControl=nil then exit;
if FDockingPoints=nil then exit;
QualifyingSites:=TList.Create;
try
for i:=0 to FDockingPoints.Count - 1 do begin
AControl:=TWinControl(FDockingPoints[i]);
//Sanity checks..
if AControl=FDragControl then continue;
if not AControl.Showing then continue;
if not AControl.Enabled then continue;
if not AControl.Visible then continue;
if IsControlChildOfClient(AControl) then continue;
if (FDragControl.HostDockSite <> AControl) or (AControl.VisibleDockClientCount > 1) then begin
CanDock := True;
AControl.GetSiteInfo(FDragControl, ARect, APosition, CanDock);
if CanDock and PtInRect(ARect, APosition)
then QualifyingSites.Add(AControl);
end;
end;
if QualifyingSites.Count > 0 then begin
Result := TWinControl(QualifyingSites[0]); //.GetTopSite; TODO!!!
//if not ValidDockTarget(Result) TODO!!!
//then Result := nil; TODO!!!
end;
finally
QualifyingSites.Free;
end;
end;
var ATarget: TControl;
DragCursor: TCursor;
AErasePrevious: boolean;
begin
if(FActiveDrag <> dopNone)or(Abs(FDragStartPos.X - APosition.X) >= FDragThreshold)or(Abs(FDragStartPos.Y - APosition.Y) >= FDragThreshold) then begin
if FDragControl.DragKind=dkDock then begin
ATarget:=FindDockSiteAtPosition;
if (Site <> nil) then begin
if DockSiteHash = nil then DockSiteHash := TDynHashArray.Create;
if DoRegister then begin
if not DockSiteHash.Contains(Site) then
DockSiteHash.Add(Site);
end else begin
ATarget := FindControlAtPosition(APosition,false);
ATarget := TControl(SendDragMessage(ATarget,dmFindTarget,FDragObject,nil,APosition));
end;
if(FActiveDrag = dopNone)and(FDragImageList <> nil)
then with FDragStartPos do FDragImageList.BeginDrag(0, X, Y);
if FDragControl.DragKind = dkDrag then begin
FActiveDrag := dopDrag;
AErasePrevious := false;
end else begin
AErasePrevious := FActiveDrag <> dopNone;
FActiveDrag := dopDock;
end;
//Inform user of entering and leaving
if ATarget <> FDragObject.DragTarget then begin
SendCmDragMsg(dmDragLeave);
FDragObject.DragTarget := TWinControl(ATarget);
if ATarget is TWinControl
then FDragObject.DragHandle := TWinControl(ATarget).Handle
else if (ATarget<>nil) and (ATarget.Parent<>nil)
then FDragObject.DragHandle := ATarget.Parent.Handle;
FDragObject.DragPos := APosition;
SendCmDragMsg(dmDragEnter);
end;
FDragObject.DragPos := APosition;
if FDragObject.DragTarget <> nil
then FDragObject.DragTargetPos := TControl(FDragObject.DragTarget).ScreenToClient(APosition);
DragCursor := FDragObject.GetDragCursor(SendCmDragMsg(dmDragMove),APosition.X, APosition.Y);
if FDragImageList <> nil then begin
if(ATarget = nil)or(csDisplayDragImage in ATarget.ControlStyle) then begin
FDragImageList.DragCursor := DragCursor;
if not FDragImageList.Dragging
then FDragImageList.BeginDrag(0, APosition.X, APosition.Y)
else FDragImageList.DragMove(APosition.X, APosition.Y);
end
else FDragImageList.EndDrag;
end;
WidgetSet.SetCursor(Screen.Cursors[DragCursor]);
//Draw borders for the docking section or the boundaries of the dragged form
if FActiveDrag = dopDock then begin
with TDragDockObject(FDragObject)do begin
if DragTarget = nil
then FDragControl.DockTrackNoTarget(TDragDockObject(FDragObject), APosition.X, APosition.Y)
else begin
DropOnControl := GetDropControl;
if DropOnControl = nil
then with FDragObject do DropAlign := DragTarget.GetDockEdge(DragTargetPos)
else DropAlign := DropOnControl.GetDockEdge(DropOnControl.ScreenToClient(APosition));
end;
//Draw the form outlines when the position has changed
if not CompareMem(@DockRect, @EraseDockRect, SizeOf(TRect)) then begin
if AErasePrevious
then EraseDragDockImage;
DrawDragDockImage;
EraseDockRect := DockRect;
end;
end;
if DockSiteHash.Contains(Site) then
DockSiteHash.Remove(Site);
end;
end;
end;
function TDragManagerDefault.SendDragMessage(MsgTarget: TControl; Msg: TDragMessage; Source: TDragObject; Target: TControl; const Position: TPoint): LRESULT;
var DragRec: TDragRec;
{-------------------------------------------------------------------------------
Function SendDragMessage(MsgTarget: TControl; Msg: TDragMessage;
Source: TDragObject; Target: TControl; const Pos: TPoint): longint;
Send a CM_DRAG (TCMDrag) message to MsgTarget.
-------------------------------------------------------------------------------}
Function SendDragMessage(MsgTarget: TControl; Msg: TDragMessage;
Source: TDragObject; Target: TControl; const Position: TPoint): LRESULT;
var
DragRec: TDragRec;
DragMsg: TCMDrag;
begin
Begin
Result := 0;
if MsgTarget = nil then exit;
DragRec.Pos := Position;
DragRec.Target := Target;
DragRec.Source := Source;
DragRec.Docking := FActiveDrag = dopDock;
DragRec.Docking := False;//TODO: not supported at this point
FillChar(DragMsg,SizeOf(DragMsg),0);
DragMsg.Msg:=CM_DRAG;
@ -411,112 +81,315 @@ begin
Result:=DragMsg.Result;
end;
procedure TDragManagerDefault.CancelDrag;
{-------------------------------------------------------------------------------
function SendDragOver(DragMsg: TDragMessage): Boolean;
Send a DragOver message to DragObject.DragTarget.
-------------------------------------------------------------------------------}
function SendDragOver(DragMsg: TDragMessage): Boolean;
begin
DragDone(false);
FDragControl := nil;
Result := False;
if (DragObject.DragTarget = nil) then exit;
if not (DragObject.DragTarget is TControl) then begin
RaiseGDBException('invalid DragTarget');
end;
Result := LongBool(SendDragMessage(DragObject.DragTarget, DragMsg,
DragObject, DragObject.DragTarget, DragObject.DragPos));
end;
procedure TDragManagerDefault.DragDone(Drop : Boolean);
var DockObject:TDragDockObject;
ADragObjectCopy:TDragObject;
ParentForm: TCustomForm;
DragMsg: TDragMEssage;
Accepted: Boolean;
TargetPos: TPoint;
{-------------------------------------------------------------------------------
procedure CancelDrag;
Aborts dragging.
-------------------------------------------------------------------------------}
procedure CancelDrag;
begin
DragDone(False);
DragControl := nil;
end;
{-------------------------------------------------------------------------------
procedure ClearDragObject;
Set the global variable DragObject to nil.
If DragObjectAutoFree is set, then the DragObject was auto created by the LCL
and is freed here.
-------------------------------------------------------------------------------}
procedure ClearDragObject;
begin
if DragObjectAutoFree then begin
DragObjectAutoFree:=false;
FreeThenNil(DragObject);
end else
DragObject := nil;
end;
{-------------------------------------------------------------------------------
Procedure DragInitControl(Control : TControl; Immediate : Boolean;
Threshold: Integer);
Initializes the dragging. If Immediate=True it starts the dragging, otherwise
it will be started when the user moves the mouse more than DragThreshold
pixel.
-------------------------------------------------------------------------------}
Procedure DragInitControl(Control: TControl; Immediate: Boolean;
Threshold: Integer);
var
ok: boolean;
begin
{$IFDEF VerboseDrag}
DebugLn('DragDone Drop=',dbgs(Drop));
DebugLn('DragInitControl ',Control.Name,':',Control.ClassName,' Immediate=', dbgs(Immediate));
{$ENDIF}
Accepted:=false;
DockObject := nil;
if FDragObject = nil
then Exit;
if FDragObject.Cancelling
then Exit;
ADragObjectCopy:=FDragObject;
ClearDragObject;
DragControl := Control;
ok:=false;
try
FDragObject.Dropped := Drop;
FDragObject.Cancelling := true;
FDragObject.ReleaseCapture;
SetCaptureControl(nil);
Accepted := FDragObject.DragTarget <> nil;
if FActiveDrag = dopDock then begin
DockObject := FDragObject as TDragDockObject;
DockObject.EraseDragDockImage;
DockObject.Floating := DockObject.DragTarget = nil;
if Drop then begin
if FDragControl.HostDockSite <> nil
then Accepted := FDragControl.HostDockSite.DoUnDock(TWinControl(FDragObject.DragTarget), FDragControl)
else if DockObject.DragTarget = nil
then Accepted := true
else if FDragControl.HostDockSite = nil
then Accepted := true;
end;
if Control.fDragKind = dkDrag then begin
// initialize the DragControl. Note: This can change the DragControl
Control.DoStartDrag(DragObject);
// check if initialization was successful
if DragControl = nil then Exit;
// initialize DragObject, if not already done
if DragObject = nil then Begin
DragObject := TDragControlObject.Create(Control);
DragObjectAutoFree := True;
End;
end else if Control.fDragKind = dkDock then begin
// ToDo: docking
RaiseGDBException('not yet implemented');
end;
if (FDragObject.DragTarget <> nil) and (FDragObject.DragTarget is TControl)
then TargetPos := FDragObject.DragTargetPos //controls can override the position
else TargetPos := FDragObject.DragPos; //otherwise take the current position
Accepted := Accepted and (((FActiveDrag = dopDock) and DockObject.Floating) or
((FActiveDrag <> dopNone) and SendCmDragMsg(dmDragLeave))) and Drop;
// init the global drag variables
DragObject.DragTarget := nil;
GetCursorPos(DragStartPos);
DragObject.DragPos := DragStartPos;
DragImages := DragObject.GetDragImages;
if FActiveDrag = dopDock then begin
if Accepted and DockObject.Floating then begin
ParentForm := GetParentForm(DockObject.Control);
if (ParentForm <> nil) and (ParentForm.ActiveControl = DockObject.Control)
then ParentForm.ActiveControl := nil;
FDragControl.Perform(CM_FLOAT, 0, Integer(FDragObject));
//DragCapture := DragObject.Capture;
DragThreshold := Threshold;
if DragObject is TDragDockObject then begin
with TDragDockObject(DragObject), FDockRect do
begin
if Right > Left then
FMouseDeltaX := (DragPos.x - Left) / (Right - Left)
else
FMouseDeltaX := 0;
if Bottom > Top then
FMouseDeltaY := (DragPos.y - Top) / (Bottom - Top)
else
FMouseDeltaY := 0;
if Immediate then
begin
ActiveDrag := dopDock;
//DrawDragDockImage;
end
else
ActiveDrag := dopNone;
end;
end else begin
if FDragImageList <> nil
then FDragImageList.EndDrag;
WidgetSet.SetCursor(Screen.Cursors[Screen.Cursor]);
if Immediate then
ActiveDrag := dopDrag
else
ActiveDrag := dopNone;
end;
FDragObject:=nil;
if ActiveDrag <> dopNone then DragTo(DragStartPos);
//drop
if ADragObjectCopy.DragTarget <> nil then begin
DragMsg := dmDragDrop;
if not Accepted then begin
TargetPos.X := 0;
TargetPos.Y := 0;
DragMsg := dmDragCancel;
ADragObjectCopy.DragPos.X := 0;
ADragObjectCopy.DragPos.Y := 0;
end;
SendDragMessage(ADragObjectCopy.DragTarget, DragMsg,ADragObjectCopy,ADragObjectCopy.DragTarget, ADragObjectCopy.DragPos);
end;
//release the OldDragObject
ADragObjectCopy.Finished(TObject(ADragObjectCopy.DragTarget),TargetPos.X,TargetPos.Y,Accepted);
ok:=true;
finally
//erase global variables (dragging stopped)
if FDragObjectAutoFree
then ADragObjectCopy.Free
else ADragObjectCopy.Cancelling := false;
FDragObject:=nil;
FDragThreshold:=0;
FDragControl := nil;
FDragImageList := nil;
FActiveDrag := dopNone;
if not ok then begin
DragControl := nil;
ClearDragObject;
end;
end;
end;
{-------------------------------------------------------------------------------
procedure RegisterDockSite(Site: TWinControl; DoRegister: Boolean);
function GetDragTargetAt(const Position: TPoint; DragKind: TDragKind;
Client: TControl): Pointer;
Search a control at position and ask for a dragging/docking target.
Client is the Source control.
-------------------------------------------------------------------------------}
procedure TDragManagerDefault.RegisterDockSite(Site: TWinControl; DoRegister: Boolean);
function GetDragTargetAt(const Position: TPoint; DragKind: TDragKind;
Client: TControl): TControl;
begin
if (Site <> nil) then begin
if FDockingPoints = nil
then FDockingPoints := TList.Create;
if DoRegister
then FDockingPoints.Add(Site)
else FDockingPoints.Remove(Site)
Result:=nil;
if DragKind = dkDrag then
begin
Result:=FindControlAtPosition(Position,false);
Result := TControl(SendDragMessage(Result,dmFindTarget,DragObject,nil,
Position));
if (Result<>nil) and (not (Result is TControl)) then
RaiseGDBException('invalid DragTarget');
end
else begin
// ToDo: docking
RaiseGDBException('not implemented yet');
end;
end;
{-------------------------------------------------------------------------------
Procedure DragTo(const Position: TPoint);
-------------------------------------------------------------------------------}
Procedure DragTo(const Position: TPoint);
var
TargetControl: TControl;
ADragCursor: TCursor;
AAccepted: Boolean;
Begin
{$IFDEF VerboseDrag}
DebugLn('DragTo P=', IntToStr(Position.X), ',', IntToStr(Position.Y));
{$ENDIF}
if (DragControl = nil) or ((ActiveDrag = dopNone) and
(Abs(DragStartPos.X - Position.X) < DragThreshold) and
(Abs(DragStartPos.Y - Position.Y) < DragThreshold)) then
begin
// dragging not yet started
// or CancelDrag happened (DragControl = nil)
exit;
end;
TargetControl := GetDragTargetAt(Position, DragControl.DragKind, DragControl);
if DragControl.DragKind = dkDrag then
ActiveDrag := dopDrag
else
ActiveDrag := dopDock;
if TargetControl <> DragObject.DragTarget then
begin
// Target changed => send dmDragLeave to old target and dmDragEnter to new
SendDragOver(dmDragLeave);
if DragObject = nil then Exit;
DragObject.DragTarget := TargetControl;
if TargetControl is TWinControl then
DragObject.DragHandle := TWinControl(TargetControl).Handle
else if (TargetControl<>nil) and (TargetControl.Parent<>nil) then
DragObject.DragHandle := TargetControl.Parent.Handle;
DragObject.DragPos := Position;
SendDragOver(dmDragEnter);
if DragObject = nil then Exit;
end else
begin
// same target => send dmDragMove
DragObject.DragPos := Position;
AAccepted := SendDragOver(dmDragMove);
// on DragMove someone can call CancelDrag and this cause crash w/o this check
if DragObject = nil then Exit;
ADragCursor := DragObject.GetDragCursor(AAccepted, Position.X, Position.Y);
if DragImages <> nil then
begin
if (DragObject.DragTarget = nil) or (csDisplayDragImage in DragObject.DragTarget.ControlStyle) or
(DragObject.AlwaysShowDragImages) then
begin
DragImages.DragLock(0, Position.X, Position.Y);
DragImages.DragCursor := ADragCursor;
DragImages.DragMove(Position.X, Position.Y);
end else
begin
// we can hide drag image
DragImages.DragUnLock;
end;
end;
WidgetSet.SetCursor(Screen.Cursors[ADragCursor]);
if DragObject = nil then Exit;
end;
// update Position
DragObject.DragPos := Position;
if DragObject.DragTarget <> nil then
DragObject.DragTargetPos := DragObject.DragTarget.ScreenToClient(Position);
// ToDo: docking
end;
{-------------------------------------------------------------------------------
Procedure DragDone(Drop : Boolean);
Ends the current dragging operation.
Invokes DragMessage,
Frees the DragObject if autocreated by the LCL,
Finish: DragSave.Finished
-------------------------------------------------------------------------------}
Procedure DragDone(Drop : Boolean);
var
Accepted: Boolean;
OldDragObject: TDragObject;
OldDragAutoFree: Boolean;
DragMsg: TDragMEssage;
TargetPos: TPoint;
Begin
{$IFDEF VerboseDrag}
DebugLn('DragDone Drop=',dbgs(Drop));
{$ENDIF}
Accepted:=false;
if (DragObject = nil) or DragObject.Cancelling then Exit;
// take over the DragObject
// (to prevent auto destruction during the next operations)
OldDragObject := DragObject;
OldDragAutoFree:=DragObjectAutoFree;
DragObjectAutoFree:=false;
try
// mark DragObject for end phase of drag
DragObject.Cancelling := True;
DragObject.FDropped := Drop;
ReleaseCapture;
if ActiveDrag = dopDock then
begin
RaiseGDBException('not implemented yet');
end;
if (DragObject.DragTarget <> nil)
and (TObject(DragObject.DragTarget) is TControl) then
// controls can override the target position
TargetPos := DragObject.DragTargetPos
else
// otherwise just take the current drag position
TargetPos := DragObject.DragPos;
// last DragOver message (make sure, there is at least one)
Accepted:=(ActiveDrag <> dopNone) and SendDragOver(dmDragLeave) and Drop;
if DragImages <> nil then
DragImages.EndDrag;
WidgetSet.SetCursor(Screen.Cursors[Screen.Cursor]);
// erase global variables (dragging stopped)
DragControl := nil;
DragObject := nil;
DragImages := nil;
// drop
if (OldDragObject<>nil) and (OldDragObject.DragTarget <> nil) then
Begin
DragMsg := dmDragDrop;
if not Accepted then begin
DragMsg := dmDragCancel;
OldDragObject.FDragPos.X := 0;
OldDragObject.FDragPos.Y := 0;
TargetPos.X := 0;
TargetPos.Y := 0;
end;
SendDragMessage(OldDragObject.DragTarget, DragMsg,
OldDragObject, OldDragObject.DragTarget, OldDragObject.DragPos);
end;
// release the OldDragObject
OldDragObject.Cancelling := False;
OldDragObject.Finished(TObject(OldDragObject.DragTarget),
TargetPos.X,TargetPos.Y,Accepted);
finally
DragControl := nil;
if OldDragAutoFree then
OldDragObject.Free;
DragObject:=nil;
end;
end;

126
lcl/include/dragobject.inc
View File

@ -31,67 +31,10 @@ begin
FAlwaysShowDragImages := Source.FAlwaysShowDragImages;
end;
procedure TDragObject.WndProc(var Msg: TLMessage);
//Some drag&dock handling
var P: TPoint;
function TDragObject.Capture: HWND;
begin
try
case Msg.Msg of
LM_MOUSEMOVE: begin
P := SmallPointToPoint(TLMMouseMove(Msg).Pos);
ClientToScreen(DragCapture, P);
DragManager.DragTo(P);
end;
LM_CAPTURECHANGED: DragManager.DragDone(false);
LM_LBUTTONUP, LM_RBUTTONUP: DragManager.DragDone(True);
{ Forms.IsKeyMsg sends WM_KEYxxx messages here (+CN_BASE) when a
TPUtilWindow has the mouse capture. }
CN_KEYUP:
//TODO: This is never called! Missing code?
if Msg.WParam = VK_CONTROL
then DragManager.DragTo(DragPos);
CN_KEYDOWN:begin
//TODO: This is never called! Missing code?
case Msg.WParam of
VK_CONTROL: DragManager.DragTo(DragPos);
VK_ESCAPE:begin
{ Consume keystroke and cancel drag operation }
Msg.Result := 1;
DragManager.DragDone(false);
end;
end;
end;
end;
except
DragManager.DragDone(false);
Application.HandleException(Self);
end;
end;
procedure TDragObject.MainWndProc(var Message: TLMessage);
begin
try
WndProc(Message);
except
Application.HandleException(Self);
end;
end;
procedure TDragObject.Capture;
begin
if DragCapture=0 then begin
DragCapture := WidgetSet.AllocateHWnd(@MainWndProc);
WidgetSet.SetCapture(DragCapture);
end;
end;
procedure TDragObject.ReleaseCapture;
begin
if DragCapture<>0 then begin
WidgetSet.ReleaseCapture;
WidgetSet.DeallocateHWnd(DragCapture);
DragCapture := 0;
end;
Result:=0;
//SetCapture(Result);
end;
procedure TDragObject.Finished(Target: TObject; X, Y: Integer; Accepted: Boolean);
@ -109,6 +52,67 @@ begin
Result := nil;
end;
procedure TDragObject.MouseMove(Shift: TShiftState; X, Y: Integer);
var
P: TPoint;
begin
P:=Point(X,Y);
DragTo(P);
end;
procedure TDragObject.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
end;
procedure TDragObject.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
DragDone(True);
end;
procedure TDragObject.CaptureChanged(OldCaptureControl: TControl);
var
i: integer;
IsDragging: Boolean;
begin
// if this is TWinControl, and it have controls (not TWinControls)
// then we should check Dragging in those controls
IsDragging := OldCaptureControl.Dragging;
if (not IsDragging) and (OldCaptureControl is TWinControl) then
begin
for i := 0 to TWinControl(OldCaptureControl).ControlCount - 1 do
begin
IsDragging := IsDragging or TWinControl(OldCaptureControl).Controls[i].Dragging;
if IsDragging then
break;
end;
end;
DragDone(IsDragging);
end;
procedure TDragObject.KeyDown(var Key: Word; Shift: TShiftState);
begin
case Key of
VK_CONTROL:
DragTo(DragObject.DragPos);
VK_ESCAPE:
begin
Key:=VK_UNKNOWN; // Consume keystroke and cancel drag operation
DragDone(False);
end;
end;
end;
procedure TDragObject.KeyUp(var Key: Word; Shift: TShiftState);
begin
if Key = VK_CONTROL then DragTo(DragObject.DragPos);
end;
destructor TDragObject.Destroy;
begin
{$IFDEF VerboseDrag}
@ -217,8 +221,6 @@ end;
constructor TDragDockObject.Create(AControl: TControl);
begin
inherited Create(AControl);
FBrush:=TBrush.Create;
FBrush.Color:=clGray;
end;
destructor TDragDockObject.Destroy;

2
lcl/include/mouse.inc
View File

@ -72,7 +72,7 @@ end;
function TMouse.GetIsDragging: Boolean;
begin
Result := Dragging;
Result := ActiveDrag <> dopNone;
end;
// included by controls.pp

22
lcl/include/pagecontrol.inc
View File

@ -113,27 +113,5 @@ begin
if NextPage<>nil then ActivePage:=NextPage;
end;
procedure TPageControl.DockDrop(DockObject: TDragDockObject; X, Y: Integer);
var DockObjectVisible: Boolean;
FNewDockTabSheet: TTabSheet;
begin
FNewDockTabSheet := TTabSheet.Create(Self);
FNewDockTabSheet.Parent := Self;
try
FNewDockTabSheet.PageControl := Self;
if DockObject.Control is TCustomForm then
FNewDockTabSheet.Caption := TCustomForm(DockObject.Control).Caption;
DockObject.Control.Dock(FNewDockTabSheet, DockObject.DockRect);
DockObject.Control.Align := alClient;
except
FNewDockTabSheet.Free;
raise;
end;
DockObjectVisible := DockObject.Control.Visible;
FNewDockTabSheet.TabVisible := DockObjectVisible;
if DockObjectVisible
then ActivePage := FNewDockTabSheet;
end;
// included by comctrls.pp

45
lcl/include/wincontrol.inc
View File

@ -4617,7 +4617,6 @@ begin
AWinControl.DestroyHandle;
end;
end;
DestroyWnd;
Exclude(FControlState, csDestroyingHandle);
end;
@ -4794,19 +4793,14 @@ end;
------------------------------------------------------------------------------}
procedure TWinControl.GetSiteInfo(Client: TControl; var InfluenceRect: TRect;
MousePos: TPoint; var CanDock: Boolean);
const
ADockMargin = 10;
begin
GetWindowRect(Handle,InfluenceRect);
//Margins to test docking
InfluenceRect.Left:= InfluenceRect.Left-ADockMargin;
InfluenceRect.Top:= InfluenceRect.Top-ADockMargin;
InfluenceRect.Right:= InfluenceRect.Right+ADockMargin;
InfluenceRect.Bottom:= InfluenceRect.Bottom+ADockMargin;
// VCL inflates the docking rectangle. Do we need this too? Why?
//InflateRect(InfluenceRect,?,?);
if Assigned(FOnGetSiteInfo) then
FOnGetSiteInfo(Self,Client,InfluenceRect,MousePos,CanDock);
end;
{------------------------------------------------------------------------------
procedure TWinControl.ReloadDockedControl(const AControlName: string;
var AControl: TControl);
@ -4882,21 +4876,6 @@ Begin
end;
end;
procedure TWinControl.CMFloat(var Message: TCMFloat);
var WasVisible: Boolean;
begin
if FloatingDockSiteClass = ClassType then begin
WasVisible := Visible;
try
Dock(nil, Message.DockSource.FDockRect);
finally
if WasVisible
then BringToFront;
end;
end
else inherited;
end;
{------------------------------------------------------------------------------
TWinControl KeyDown
------------------------------------------------------------------------------}
@ -5037,6 +5016,13 @@ begin
if CharCode = VK_UNKNOWN then Exit;
ShiftState := KeyDataToShiftState(KeyData);
// let drag object handle the key
if Dragging and (DragObject<>nil) then
begin
DragObject.KeyDown(CharCode, ShiftState);
if CharCode = VK_UNKNOWN then Exit;
end;
// let user handle the key
if not (csNoStdEvents in ControlStyle) then
begin
@ -5266,6 +5252,12 @@ begin
begin
ShiftState := KeyDataToShiftState(KeyData);
if Dragging and (DragObject<>nil) then
begin
DragObject.KeyUp(CharCode, ShiftState);
if CharCode = VK_UNKNOWN then exit;
end;
if not (csNoStdEvents in ControlStyle)
then begin
KeyUpBeforeInterface(CharCode, ShiftState);
@ -5821,9 +5813,6 @@ begin
n := ControlCount;
end;
if FDockSite then
DragManager.RegisterDocksite(Self, false);
FreeThenNil(FBrush);
FreeThenNil(FChildSizing);
FreeThenNil(FDockClients);
@ -6964,7 +6953,7 @@ begin
if FDockSite=NewDockSite then exit;
FDockSite := NewDockSite;
if not (csDesigning in ComponentState) then begin
DragManager.RegisterDockSite(Self,NewDockSite);
RegisterDockSite(Self,NewDockSite);
if not NewDockSite then begin
FreeAndNil(FDockClients);
FDockClients := nil;

14
lcl/interfaces/win32/win32callback.inc
View File

@ -1812,20 +1812,10 @@ begin
end;
end;
end;
WM_NCLBUTTONDOWN:begin
WM_NCLBUTTONDOWN:
begin
NotifyUserInput := True;
Assert(False, 'Trace:WindowProc - Got WM_NCLBUTTONDOWN');
//Drag&Dock support TCustomForm => Start BeginDrag()
if lWinControl <> nil then begin
LMessage.Msg := LM_DRAGSTART;
LMessage.WParam := WParam;
LMessage.LParam := LParam;
DeliverMessage(lWinControl, PLMsg^);
//no need to deliver this message later on..
LMessage.Msg := LM_NULL;
end;
end;
WM_NOTIFY:
begin