mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-29 22:22:47 +02:00
389 lines
13 KiB
PHP
389 lines
13 KiB
PHP
{%MainUnit ../controls.pp}
|
|
|
|
{*****************************************************************************
|
|
* *
|
|
* This file is part of the Lazarus Component Library (LCL) *
|
|
* *
|
|
* See the file COPYING.LCL, included in this distribution, *
|
|
* for details about the copyright. *
|
|
* *
|
|
* This program is distributed in the hope that it will be useful, *
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
|
|
* *
|
|
*****************************************************************************
|
|
}
|
|
|
|
var
|
|
DragControl: TControl; // 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
|
|
|
|
Procedure DragTo(const Position: TPoint); forward;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
function HostDockSiteManagerAvailable(HostDockSite: TWinControl): boolean;
|
|
-------------------------------------------------------------------------------}
|
|
function HostDockSiteManagerAvailable(HostDockSite: TWinControl): boolean;
|
|
begin
|
|
Result:=(HostDockSite<>nil) and HostDockSite.UseDockManager
|
|
and (HostDockSite.DockManager<>nil);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
procedure RegisterDockSite(Site: TWinControl; DoRegister: Boolean);
|
|
-------------------------------------------------------------------------------}
|
|
procedure RegisterDockSite(Site: TWinControl; DoRegister: Boolean);
|
|
begin
|
|
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
|
|
if DockSiteHash.Contains(Site) then
|
|
DockSiteHash.Remove(Site);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
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
|
|
Result := 0;
|
|
if MsgTarget = nil then exit;
|
|
|
|
DragRec.Pos := Position;
|
|
DragRec.Target := Target;
|
|
DragRec.Source := Source;
|
|
DragRec.Docking := False;//TODO: not supported at this point
|
|
|
|
FillChar(DragMsg,SizeOf(DragMsg),0);
|
|
DragMsg.Msg:=CM_DRAG;
|
|
DragMsg.DragMessage:=Msg;
|
|
DragMsg.DragRec:=@DragRec;
|
|
DragMsg.Result:=0;
|
|
|
|
MsgTarget.Dispatch(DragMsg);
|
|
Result:=DragMsg.Result;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
function SendDragOver(DragMsg: TDragMessage): Boolean;
|
|
|
|
Send a DragOver message to DragObject.DragTarget.
|
|
-------------------------------------------------------------------------------}
|
|
function SendDragOver(DragMsg: TDragMessage): Boolean;
|
|
begin
|
|
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 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('DragInitControl ',Control.Name,':',Control.ClassName,' Immediate=',Immediate);
|
|
{$ENDIF}
|
|
ClearDragObject;
|
|
DragControl := Control;
|
|
ok:=false;
|
|
try
|
|
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;
|
|
|
|
// init the global drag variables
|
|
DragObject.DragTarget := nil;
|
|
GetCursorPos(DragStartPos);
|
|
DragObject.DragPos := DragStartPos;
|
|
//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 Immediate then
|
|
ActiveDrag := dopDrag
|
|
else
|
|
ActiveDrag := dopNone;
|
|
end;
|
|
|
|
if ActiveDrag <> dopNone then DragTo(DragStartPos);
|
|
|
|
ok:=true;
|
|
finally
|
|
if not ok then begin
|
|
DragControl := nil;
|
|
ClearDragObject;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
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.
|
|
-------------------------------------------------------------------------------}
|
|
function GetDragTargetAt(const Position: TPoint; DragKind: TDragKind;
|
|
Client: TControl): TControl;
|
|
begin
|
|
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;
|
|
Begin
|
|
{$IFDEF VerboseDrag}
|
|
DebugLn('DragTo P=',Position.X,',',Position.Y);
|
|
{$ENDIF}
|
|
if (ActiveDrag = dopNone)
|
|
and (Abs(DragStartPos.X - Position.X) < DragThreshold)
|
|
and (Abs(DragStartPos.Y - Position.Y) < DragThreshold) then begin
|
|
// dragging not yet started
|
|
exit;
|
|
end;
|
|
|
|
TargetControl := GetDragTargetAt(Position,DragControl.DragKind,DragControl);
|
|
|
|
if DragControl.DragKind = dkDrag then
|
|
ActiveDrag := dopDrag
|
|
else
|
|
ActiveDrag := dopDock;
|
|
|
|
// if Target changed, send dmDragLeave to old target and dmDragEnter to new
|
|
if TargetControl <> DragObject.DragTarget then
|
|
begin
|
|
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;
|
|
|
|
// 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=',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);
|
|
|
|
// erase global variables (dragging stopped)
|
|
DragControl := nil;
|
|
DragObject := 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;
|
|
|
|
// included by controls.pp
|
|
|
|
{ =============================================================================
|
|
$Log$
|
|
Revision 1.8 2005/02/05 16:09:52 marc
|
|
* first 64bit changes
|
|
|
|
Revision 1.7 2005/01/13 00:13:36 mattias
|
|
fixed dragging over nil
|
|
|
|
Revision 1.6 2004/09/20 20:22:12 mattias
|
|
implemented Refactoring Tool: Find Identfier References
|
|
|
|
Revision 1.5 2004/06/01 09:58:35 mattias
|
|
implemented setting TCustomPage.PageIndex from Andrew Haines
|
|
|
|
Revision 1.4 2004/05/11 12:16:47 mattias
|
|
replaced writeln by debugln
|
|
|
|
Revision 1.3 2004/04/10 17:58:57 mattias
|
|
implemented mainunit hints for include files
|
|
|
|
Revision 1.2 2004/03/19 16:37:55 mattias
|
|
renamed internal FindDragTarget to GetDragTargetAt
|
|
|
|
Revision 1.1 2004/02/28 00:34:35 mattias
|
|
fixed CreateComponent for buttons, implemented basic Drag And Drop
|
|
}
|