paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-03 05:32:55 +01:00
Code Issues Packages Projects Releases Wiki Activity

fixed CreateComponent for buttons, implemented basic Drag And Drop

Browse Source 
git-svn-id: trunk@5238 -
This commit is contained in:
mattias 2004-02-28 00:34:36 +00:00
parent 701648af1a
commit 277581d567
29 changed files with 1009 additions and 593 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -956,6 +956,7 @@ lcl/include/dbtext.inc svneol=native#text/pascal
lcl/include/defaultbitbtnimages.inc svneol=native#text/pascal
lcl/include/docktree.inc svneol=native#text/pascal
lcl/include/dockzone.inc svneol=native#text/pascal
lcl/include/dragdock.inc svneol=native#text/pascal
lcl/include/dragobject.inc svneol=native#text/pascal
lcl/include/edit.inc svneol=native#text/pascal
lcl/include/filectrl.inc svneol=native#text/pascal

9
components/gtk/gtkglarea/gtkglareacontrol.pas
View File

@ -37,7 +37,7 @@ type
protected
procedure WMPaint(var Message: TLMPaint); message LM_PAINT;
function GetWidget: PGtkGLArea;
procedure CreateComponent(TheOwner: TComponent); override;
function CreateWindowHandle(const AParams: TCreateParams): THandle; override;
procedure UpdateFrameTimeDiff;
public
constructor Create(TheOwner: TComponent); override;
@ -177,15 +177,16 @@ begin
Result:=nil;
end;
procedure TCustomGTKGLAreaControl.CreateComponent(TheOwner: TComponent);
function TCustomGTKGLAreaControl.CreateWindowHandle(const AParams: TCreateParams
): THandle;
var
NewWidget: Pointer;
begin
if csDesigning in ComponentState then
inherited CreateComponent(TheOwner)
Result:=inherited CreateWindowHandle(AParams)
else begin
NewWidget:=gtk_gl_area_new(Plongint(@InitAttrList));
Handle := longint(NewWidget);
Result:=longint(NewWidget);
TGtkObject(InterfaceObject).FinishComponentCreate(Self,NewWidget,true);
end;
end;

7
components/jpeg/lazjpeg.pas
View File

@ -37,7 +37,7 @@ type
procedure InitFPImageReader(ImgReader: TFPCustomImageReader); override;
procedure FinalizeFPImageReader(ImgReader: TFPCustomImageReader); override;
procedure InitFPImageWriter(ImgWriter: TFPCustomImageWriter); override;
procedure ReadStream(Stream: TStream; Size: Longint); override;
procedure ReadStream(Stream: TStream; UseSize: boolean; Size: Longint); override;
procedure WriteStream(Stream: TStream; WriteSize: Boolean); override;
public
constructor Create; override;
@ -119,9 +119,10 @@ begin
Result:=TFPWriterJPEG;
end;
procedure TJPEGImage.ReadStream(Stream: TStream; Size: Longint);
procedure TJPEGImage.ReadStream(Stream: TStream; UseSize: boolean;
Size: Longint);
begin
ReadStreamWithFPImage(Stream,Size,TFPReaderJPEG);
ReadStreamWithFPImage(Stream,UseSize,Size,TFPReaderJPEG);
end;
procedure TJPEGImage.WriteStream(Stream: TStream; WriteSize: Boolean);

7
examples/gtkglarea/exampleform.pp
View File

@ -29,7 +29,8 @@ interface
uses
Classes, SysUtils, GTKGlArea, GTKGLArea_Int, Forms, LResources, Buttons,
StdCtrls, Dialogs, gtk, glib, NVGL, Linux;
StdCtrls, Dialogs, gtk, glib, NVGL, {$IFDEF VER1_0}Linux{$ELSE}Unix{$ENDIF},
GTKGLAreaControl;
type
TglTexture = class
@ -608,7 +609,7 @@ begin
LoadglTexture('data/texture2.bmp',MyglTextures[1]);
LoadglTexture('data/texture3.bmp',MyglTextures[2]);
glGenTextures(3, textures[0]);
glGenTextures(3, @textures[0]);
for i:=0 to 2 do begin
glBindTexture(GL_TEXTURE_2D, Textures[i]);
glTexParameterf(GL_TEXTURE_2D,GL_TEXTURE_WRAP_S,GL_CLAMP);
@ -616,7 +617,7 @@ begin
glTexParameteri(GL_TEXTURE_2D,GL_TEXTURE_MAG_FILTER,GL_LINEAR);
glTexParameteri(GL_TEXTURE_2D,GL_TEXTURE_MIN_FILTER,GL_LINEAR);
glTexImage2D(GL_TEXTURE_2D,0,3,MyglTextures[i].Width,MyglTextures[i].Height,0
,GL_RGB,GL_UNSIGNED_BYTE,MyglTextures[i].Data^);
,GL_RGB,GL_UNSIGNED_BYTE,MyglTextures[i].Data);
end;
glTexEnvf(GL_TEXTURE_ENV,GL_TEXTURE_ENV_MODE,GL_MODULATE);
{instead of GL_MODULATE you can try GL_DECAL or GL_BLEND}

77
examples/gtkglarea/gtkglarea_demo.lpi
View File

@ -1,70 +1,21 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<Version Value="2"/>
<Version Value="3"/>
<General>
<ProjectType Value="Program"/>
<Flags>
<SaveOnlyProjectUnits Value="True"/>
</Flags>
<MainUnit Value="0"/>
<ActiveEditorIndexAtStart Value="2"/>
<ActiveEditorIndexAtStart Value="1"/>
<IconPath Value="./"/>
<TargetFileExt Value=""/>
<Title Value="gtkglarea_demo"/>
</General>
<JumpHistory Count="12" HistoryIndex="11">
<Position1>
<Filename Value="exampleform.pp"/>
<Caret Line="53" Column="15" TopLine="32"/>
</Position1>
<Position2>
<Filename Value="exampleform.pp"/>
<Caret Line="255" Column="33" TopLine="233"/>
</Position2>
<Position3>
<Filename Value="exampleform.pp"/>
<Caret Line="44" Column="27" TopLine="32"/>
</Position3>
<Position4>
<Filename Value="/home/mattias/pascal/wichtig/lazarus/components/gtk/gtkglarea/gtkglarea.pp"/>
<Caret Line="23" Column="56" TopLine="1"/>
</Position4>
<Position5>
<Filename Value="/home/mattias/pascal/wichtig/lazarus/components/gtk/gtkglarea/gtkglarea.pp"/>
<Caret Line="37" Column="56" TopLine="1"/>
</Position5>
<Position6>
<Filename Value="/home/mattias/pascal/wichtig/lazarus/components/gtk/gtkglarea/gtkglarea.pp"/>
<Caret Line="84" Column="40" TopLine="45"/>
</Position6>
<Position7>
<Filename Value="/home/mattias/pascal/wichtig/lazarus/components/gtk/gtkglarea/gtkglarea.pp"/>
<Caret Line="23" Column="47" TopLine="1"/>
</Position7>
<Position8>
<Filename Value="/home/mattias/pascal/wichtig/lazarus/components/gtk/gtkglarea/gtkglarea.pp"/>
<Caret Line="84" Column="54" TopLine="45"/>
</Position8>
<Position9>
<Filename Value="/home/mattias/pascal/wichtig/lazarus/components/gtk/gtkglarea/gtkglarea.pp"/>
<Caret Line="83" Column="5" TopLine="45"/>
</Position9>
<Position10>
<Filename Value="/home/mattias/pascal/wichtig/lazarus/components/gtk/gtkglarea/gtkglarea.pp"/>
<Caret Line="68" Column="23" TopLine="45"/>
</Position10>
<Position11>
<Filename Value="/home/mattias/pascal/wichtig/lazarus/components/gtk/gtkglarea/gtkglarea.pp"/>
<Caret Line="68" Column="17" TopLine="46"/>
</Position11>
<Position12>
<Filename Value="/home/mattias/pascal/wichtig/lazarus/components/gtk/gtkglarea/gtkglarea.pp"/>
<Caret Line="69" Column="22" TopLine="51"/>
</Position12>
</JumpHistory>
<Units Count="2">
<Unit0>
<CursorPos X="7" Y="26"/>
<CursorPos X="15" Y="18"/>
<EditorIndex Value="0"/>
<Filename Value="gtkglarea_demo.pp"/>
<IsPartOfProject Value="True"/>
@ -74,19 +25,18 @@
<UsageCount Value="22"/>
</Unit0>
<Unit1>
<CursorPos X="24" Y="44"/>
<CursorPos X="30" Y="629"/>
<EditorIndex Value="1"/>
<Filename Value="exampleform.pp"/>
<IsPartOfProject Value="True"/>
<Loaded Value="True"/>
<TopLine Value="32"/>
<TopLine Value="599"/>
<UnitName Value="ExampleForm"/>
<UsageCount Value="22"/>
</Unit1>
</Units>
<PublishOptions>
<Version Value="2"/>
<DestinationDirectory Value="$(TestDir)/publishedproject/"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
<RunParams>
@ -95,13 +45,22 @@
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e bash -i -c '$(TargetCmdLine)'"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="GTKOpenGL"/>
</Item2>
</RequiredPackages>
</ProjectOptions>
<CompilerOptions>
<SearchPaths>
<OtherUnitFiles Value="$(LazarusDir)/lcl/units;$(LazarusDir)/lcl/units/gtk;$(LazarusDir)/components/gtk/gtkglarea"/>
<CompilerPath Value="$(CompPath)"/>
<LCLWidgetType Value="gtk"/>
<SrcPath Value="$(LazarusDir)/lcl;$(LazarusDir)/lcl/interfaces/gtk"/>
<SrcPath Value="$(LazarusDir)/lcl/;$(LazarusDir)/lcl/interfaces/gtk/"/>
</SearchPaths>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

8
lcl/comctrls.pp
View File

@ -1016,6 +1016,8 @@ type
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseEnter;
property OnMouseLeave;
property OnResize;
property OnChangeBounds;
property OnStartDrag;
@ -1845,7 +1847,6 @@ type
procedure CanvasChanged(Sender: TObject);
procedure CMDrag(var AMessage: TCMDrag); message CM_DRAG;
procedure EditWndProc(var Message: TLMessage);
procedure DoDragOver(Source: TDragObject; X, Y: Integer; CanDrop: Boolean);
function GetAutoExpand: boolean;
function GetBottomItem: TTreeNode;
function GetChangeDelay: Integer;
@ -1936,6 +1937,8 @@ type
procedure Delete(Node: TTreeNode); dynamic;
procedure DestroyWnd; override;
procedure DoEndDrag(Target: TObject; X, Y: Integer); override;
procedure DragOver(Source: TObject; X,Y: Integer; State: TDragState;
var Accept: Boolean); override;
procedure DoPaint; virtual;
procedure DoPaintNode(Node: TTreeNode); virtual;
procedure DoStartDrag(var DragObject: TDragObject); override;
@ -2238,6 +2241,9 @@ end.
{ =============================================================================
$Log$
Revision 1.117 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.116 2004/02/27 00:42:41 marc
* Interface CreateComponent splitup
* Implemented CreateButtonHandle on GTK interface

290
lcl/controls.pp
View File

@ -336,7 +336,12 @@ type
TDragState = (dsDragEnter, dsDragLeave, dsDragMove);
TDragMode = (dmManual , dmAutomatic);
TDragKind = (dkDrag, dkDock);
TDragOperation = (dopNone, dopDrag, dopDock);
TDragOperation = (
dopNone, // not dragging or Drag initialized, but not yet started.
// Waiting for mouse move more then Treshold.
dopDrag, // Dragging
dopDock // Docking
);
TDragMessage = (dmDragEnter, dmDragLeave, dmDragMove, dmDragDrop,
dmDragCancel,dmFindTarget);
TDragOverEvent = Procedure(Sender, Source: TObject;
@ -350,22 +355,22 @@ type
TDragRec = record
Pos: TPoint;
Source: TDragObject;
Target: Pointer;
Target: TControl;
Docking: Boolean;
end;
TCMDrag = packed record
Msg: Cardinal;
DragMessage: TDragMessage;
Reserved1: Byte;
Reserved2: Word;
Reserved1: Byte; // for Delphi compatibility
Reserved2: Word; // for Delphi compatibility
DragRec: PDragRec;
Result: Longint;
end;
TDragObject = class(TObject)
private
FDragTarget: Pointer;
FDragTarget: TControl;
FDragHandle: HWND;
FDragPos: TPoint;
FDragTargetPos: TPoint;
@ -374,13 +379,18 @@ type
FMouseDeltaY: Double;
FCancelling: Boolean;
function Capture: HWND;
procedure MouseMsg(var Msg: TLMessage);
procedure ReleaseCapture(Handle: HWND);
protected
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;
function GetName: string; virtual;
procedure HideDragImage; virtual;
@ -390,7 +400,7 @@ type
property DragHandle: HWND read FDragHandle write FDragHandle;
property DragPos: TPoint read FDragPos write FDragPos;
property DragTargetPos: TPoint read FDragTargetPos write FDragTargetPos;
property DragTarget: Pointer read FDragTarget write FDragTarget;
property DragTarget: TControl read FDragTarget write FDragTarget;
property Dropped: Boolean read FDropped;
property MouseDeltaX: Double read FMouseDeltaX;
property MouseDeltaY: Double read FMouseDeltaX;
@ -451,7 +461,6 @@ type
FDockRect: TRect;
FDropAlign: TAlign;
FDropOnControl: TControl;
//FEraseDockRect: TRect;
FFloating: Boolean;
procedure SetBrush(Value: TBrush);
protected
@ -755,7 +764,6 @@ type
procedure CheckMenuPopup(const P : TSmallPoint);
procedure DoBeforeMouseMessage;
procedure DoConstrainedResize(var NewWidth, NewHeight : integer);
procedure DoDragMsg(var Dragmsg : TCMDrag);
procedure DoMouseDown(var Message: TLMMouse; Button: TMouseButton; Shift:TShiftState);
procedure DoMouseUp(var Message: TLMMouse; Button: TMouseButton);
procedure SetBorderSpacing(const AValue: TControlBorderSpacing);
@ -859,6 +867,7 @@ type
procedure DblClick; dynamic;
procedure TripleClick; dynamic;
procedure QuadClick; dynamic;
procedure DoDragMsg(var DragMsg: TCMDrag); virtual;
procedure DoStartDrag(var DragObject: TDragObject); dynamic;
procedure DragOver(Source: TObject; X,Y: Integer; State: TDragState;
var Accept: Boolean); dynamic;
@ -1277,6 +1286,7 @@ type
AControlList: TList; var ARect: TRect): Boolean; virtual;
procedure DoChildSizingChange(Sender: TObject); virtual;
Function CanTab: Boolean; override;
procedure DoDragMsg(var DragMsg: TCMDrag); override;
Procedure CMDrag(var Message : TCMDrag); message CM_DRAG;
procedure CMShowingChanged(var Message: TLMessage); message CM_SHOWINGCHANGED;
procedure CMVisibleChanged(var TheMessage: TLMessage); message CM_VISIBLECHANGED;
@ -1662,7 +1672,7 @@ const
function CNSendMessage(LM_Message: integer; Sender: TObject; data: pointer) : integer;
Function FindDragTarget(const Pos: TPoint; AllowDisabled: Boolean): TControl;
Function FindControlAtPosition(const Position: TPoint; AllowDisabled: Boolean): TControl;
Function FindLCLWindow(const ScreenPos : TPoint) : TWinControl;
Function FindControl(Handle: hwnd): TWinControl;
Function FindOwnerControl(Handle: hwnd): TWinControl;
@ -1674,6 +1684,7 @@ Procedure MoveWindowOrg(dc : hdc; X,Y : Integer);
procedure SetCaptureControl(Control : TControl);
function GetCaptureControl : TControl;
procedure CancelDrag;
procedure DragDone(Drop: Boolean);
var
NewStyleControls : Boolean;
@ -1689,31 +1700,27 @@ function GetKeyShiftState: TShiftState;
procedure Register;
implementation
uses
Forms, Math;
Forms, // the circle can't be broken without breaking Delphi compatibility
Math; // Math is in RTL and only a few functions are used.
var
// The interface knows, which TWinControl has the capture. This stores
// what child control of this TWinControl has actually the capture.
CaptureControl: TControl;
DragCapture: HWND;
DragControl: TControl;
DragObjectAutoFree: Boolean;
DragObject: TDragObject;
//DragSaveCursor: HCURSOR;
DragStartPos: TPoint;
DragThreshold: Integer;
ActiveDrag: TDragOperation;
procedure Register;
begin
RegisterComponents('Common Controls',[TImageList]);
end;
{------------------------------------------------------------------------------}
{ CNSendMessage }
{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------
CNSendMessage - To be replaced
------------------------------------------------------------------------------}
function CNSendMessage(LM_Message: integer; Sender: TObject;
Data: pointer): integer;
begin
@ -1723,9 +1730,13 @@ end;
{------------------------------------------------------------------------------
FindControl
Returns the TWinControl owning the Handle. Handle can also be a child handle,
and does not need to be the Handle property of the Result.
Returns the TWinControl associated with the Handle.
This is very interface specific. Better use FindOwnerControl.
Handle can also be a child handle, and does not need to be the Handle
property of the Result.
IMPORTANT: So, in most cases: Result.Handle <> Handle in the params.
------------------------------------------------------------------------------}
function FindControl(Handle: hwnd): TWinControl;
begin
@ -1734,6 +1745,13 @@ begin
else Result := nil;
end;
{------------------------------------------------------------------------------
FindOwnerControl
Returns the TWinControl owning the Handle. Handle can also be a child handle,
and does not need to be the Handle property of the Result.
IMPORTANT: So, in most cases: Result.Handle <> Handle in the params.
------------------------------------------------------------------------------}
function FindOwnerControl(Handle: hwnd): TWinControl;
begin
While Handle<>0 do begin
@ -1744,6 +1762,12 @@ begin
Result:=nil;
end;
{------------------------------------------------------------------------------
FindLCLControl
Returns the TControl that it at the moment at the visible screen position.
This is not reliable during resizing.
------------------------------------------------------------------------------}
function FindLCLControl(const ScreenPos: TPoint) : TControl;
var
AWinControl: TWinControl;
@ -1764,6 +1788,11 @@ begin
Result:=LCLProc.SendApplicationMessage(Msg,WParam,LParam);
end;
procedure MoveWindowOrg(dc : hdc; X, Y : Integer);
begin
MoveWindowOrgEx(DC,X,Y);
end;
function CompareRect(R1, R2: PRect): Boolean;
begin
Result:=(R1^.Left=R2^.Left) and (R1^.Top=R2^.Top) and
@ -1774,187 +1803,22 @@ begin
end;}
end;
Procedure MoveWindowOrg(dc : hdc; X,Y : Integer);
begin
MoveWindowOrgEx(dc,X,Y);
end;
{-------------------------------------------------------------------------------
function DoControlMsg(Handle: hwnd; var Message) : Boolean;
Find the owner wincontrol and Perform the Message.
-------------------------------------------------------------------------------}
function DoControlMsg(Handle: hwnd; var Message) : Boolean;
var
Control : TWinControl;
AWinControl: TWinControl;
begin
Result := False;
Control := FindOwnerControl(Handle);
if Control <> nil then
AWinControl := FindOwnerControl(Handle);
if AWinControl <> nil then begin
with TLMessage(Message) do
Begin
Control.Perform(Msg + CN_BASE, WParam, LParam);
DoControlMsg := True;
end;
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 DragInit(aDragObject: TDragObject; Immediate: Boolean;
Threshold: Integer);
Set the global variable DragObject.
-------------------------------------------------------------------------------}
Procedure DragInit(aDragObject: TDragObject; Immediate: Boolean;
Threshold: Integer);
Begin
if DragObject<>ADragObject then
ClearDragObject;
DragObject := ADragObject;
DragObject.DragTarget := nil;
GetCursorPos(DragStartPos);
DragObject.DragPos := DragStartPos;
DragCapture := DragObject.Capture;
DragThreshold := Threshold;
end;
{-------------------------------------------------------------------------------
Procedure DragInitControl(Control : TControl; Immediate : Boolean;
-------------------------------------------------------------------------------}
Procedure DragInitControl(Control: TControl; Immediate: Boolean;
Threshold: Integer);
var
DragObject: TDragObject;
ok: boolean;
begin
{$IFDEF VerboseDrag}
writeln('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
end;
DragInit(DragObject,Immediate,Threshold);
ok:=true;
finally
if not ok then begin
DragControl := nil;
ClearDragObject;
end;
end;
end;
{-------------------------------------------------------------------------------
Procedure DragTo(const P : TPoint);
-------------------------------------------------------------------------------}
Procedure DragTo(const P: TPoint);
Begin
{$IFDEF VerboseDrag}
writeln('DragTo P=',P.X,',',P.Y);
{$ENDIF}
if (ActiveDrag = dopNone)
and (Abs(DragStartPos.X - P.X) < DragThreshold)
and (Abs(DragStartPos.Y - P.Y) < DragThreshold) then
exit;
end;
Function DragMessage(Handle: HWND; Msg: TDragMessage; Source: TDragObject;
Target: Pointer; const Pos: TPoint): longint;
var
DragRec : TDragRec;
Begin
Result := 0;
if Handle <> 0 then Begin
DragRec.Pos := Pos;
DragRec.Target := Target;
DragRec.Source := Source;
DragRec.Docking := False;//TODO: not supported at this point
Result := SendMessage(Handle, CM_DRAG,longint(msg),Longint(@DragRec));
end;
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;
DragSave : TDragObject;
DragMsg : TDragMEssage;
TargetPos : TPoint;
DragSaveAutoFree: Boolean;
Begin
{$IFDEF VerboseDrag}
writeln('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)
DragSave := DragObject;
DragSaveAutoFree:=DragObjectAutoFree;
DragObjectAutoFree:=false;
try
DragObject.Cancelling := True;
DragObject.ReleaseCapture(DragCapture);
if DragObject.DragTarget <> nil then
Begin
dragMsg := dmDragDrop;
if not Accepted then begin
DragMsg := dmDragCancel;
DragSave.FDragPos.X := 0;
DragSave.FDragPos.Y := 0;
TargetPos.X := 0;
TargetPos.Y := 0;
end;
// this can change DragObject
DragMessage(DragSave.DragHandle,DragMsg,DragSave,
DragSave.DragTarget,DragSave.DragPos);
end;
DragSave.Cancelling := False;
DragSave.Finished(TObject(DragSave.DragTarget),TargetPos.X,TargetPos.Y,Accepted);
finally
DragControl := nil;
if DragSaveAutoFree then begin
if DragSave=DragObject then
DragObject:=nil;
DragSave.Free;
end;
AWinControl.Perform(Msg + CN_BASE, WParam, LParam);
Result:= True;
end;
end;
@ -1973,26 +1837,24 @@ begin
end;
{------------------------------------------------------------------------------
Function: FindDragTarget
Function: FindControlAtPosition
Params:
Returns:
------------------------------------------------------------------------------}
function FindDragTarget(const Pos : TPoint; AllowDisabled: Boolean): TControl;
function FindControlAtPosition(const Position: TPoint;
AllowDisabled: Boolean): TControl;
var
WinControl: TWinControl;
Control: TControl;
begin
Result := nil;
WinControl := FindLCLWindow(Pos);
WinControl := FindLCLWindow(Position);
if WinControl <> nil
then begin
Result := WinControl;
Control := WinControl.ControlAtPos(WinControl.ScreenToClient(pos),
AllowDisabled,
true);
Control := WinControl.ControlAtPos(WinControl.ScreenToClient(Position),
AllowDisabled,true);
if Control <> nil then Result := Control;
end;
end;
@ -2060,12 +1922,6 @@ begin
SetCapture(TWinControl(NewCaptureWinControl).Handle);
end;
procedure CancelDrag;
begin
if DragObject <> nil then DragDone(False);
DragControl := nil;
end;
function GetKeyShiftState: TShiftState;
begin
Result:=[];
@ -2146,6 +2002,7 @@ end;
{$ENDIF}
{$I sizeconstraints.inc}
{$I dragdock.inc}
{$I basedragcontrolobject.inc}
{$I controlsproc.inc}
{$I controlcanvas.inc}
@ -2374,6 +2231,9 @@ end.
{ =============================================================================
$Log$
Revision 1.186 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.185 2004/02/27 00:42:41 marc
* Interface CreateComponent splitup
* Implemented CreateButtonHandle on GTK interface

5
lcl/graphtype.pp
View File

@ -207,7 +207,7 @@ begin
exit;
end;
Result:=false;
// slow test
if TestPixels then begin
Width:=RawImage^.Description.Width;
@ -529,6 +529,9 @@ end.
{ =============================================================================
$Log$
Revision 1.27 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.26 2004/02/21 01:01:03 mattias
added uninstall popupmenuitem to package graph explorer

8
lcl/imglist.pp
View File

@ -101,7 +101,8 @@ type
TCustomImageList = Class(TComponent)
private
FDrawingStyle: TDrawingStyle;
FImageList : TList; //shane
FImageList: TList; //shane
FMaskList: TList;
FBitmap: TBitmap;
FImageType: TImageType;
FMaskBitmap: TBitmap;
@ -158,7 +159,7 @@ type
constructor CreateSize(AWidth, AHeight: Integer);
procedure Delete(Index: Integer);
destructor Destroy; override;
procedure Draw(Canvas: TCanvas; X, Y, Index: Integer; Enabled: Boolean{=True});
procedure Draw(Canvas: TCanvas; X, Y, Index: Integer; Enabled: Boolean{$IFNDEF VER1_0}=True{$ENDIF});
procedure GetBitmap(Index: Integer; Image: TBitmap);
procedure GetInternalImage(Index: integer; var Image, Mask: TBitmap);
function GetHotSpot: TPoint; virtual;
@ -209,6 +210,9 @@ end.
{
$Log$
Revision 1.17 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.16 2004/02/25 11:12:06 marc
+ Added delphi stream reading support

5
lcl/include/application.inc
View File

@ -341,7 +341,7 @@ var
P: TPoint;
begin
GetCursorPos(P);
Result := FindDragTarget(P, True);
Result := FindControlAtPosition(P, True);
if (Result <> nil) and (csDesigning in Result.ComponentState) then
Result := nil;
end;
@ -1176,6 +1176,9 @@ end;
{ =============================================================================
$Log$
Revision 1.76 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.75 2004/02/23 23:15:13 mattias
improved FindDragTarget

3
lcl/include/basedragcontrolobject.inc
View File

@ -43,6 +43,9 @@ end;
procedure TBaseDragControlObject.EndDrag(Target: TObject; X,Y : Integer);
Begin
{$IFDEF VerboseDrag}
writeln('TBaseDragControlObject.EndDrag ',ClassName,' XY=',X,',',Y);
{$ENDIF}
FControl.DoEndDrag(Target,X,Y);
end;

5
lcl/include/bitmap.inc
View File

@ -456,7 +456,7 @@ begin
StreamType:=bnWinBitmap;
ReaderClass:=nil;
case StreamType of
bnWinBitmap: ReaderClass:=TFPReaderBMP;
bnWinBitmap: ReaderClass:=TLazReaderBMP;
bnXPixmap: ReaderClass:=TLazReaderXPM;
else
RaiseInvalidBitmapHeader;
@ -1106,6 +1106,9 @@ end;
{ =============================================================================
$Log$
Revision 1.74 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.73 2004/02/27 00:42:41 marc
* Interface CreateComponent splitup
* Implemented CreateButtonHandle on GTK interface

8
lcl/include/buttons.inc
View File

@ -41,7 +41,10 @@ end;
function TButton.CreateWindowHandle(const AParams: TCreateParams): THandle;
begin
Result := ButtonCreateHandle(Self, APArams);
if fCompStyle=csButton then
Result := ButtonCreateHandle(Self, APArams)
else
Result := inherited CreateWindowHandle(AParams);
end;
{------------------------------------------------------------------------------
@ -148,6 +151,9 @@ end;
{ =============================================================================
$Log$
Revision 1.22 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.21 2004/02/27 00:42:41 marc
* Interface CreateComponent splitup
* Implemented CreateButtonHandle on GTK interface

8
lcl/include/canvas.inc
View File

@ -67,7 +67,6 @@ Procedure TCanvas.CopyRect(const Dest: TRect; SrcCanvas: TCanvas;
var
SH, SW, DH, DW: Integer;
Begin
Assert(False, Format('Trace:==> [TCanvas.CopyRect] ', []));
if SrcCanvas= nil then exit;
SH := Source.Bottom - Source.Top;
@ -81,14 +80,12 @@ Begin
SrcCanvas.RequiredState([csHandleValid, csBrushValid]);
RequiredState([csHandleValid, csBrushValid]);
//writeln('TCanvas.CopyRect ',ClassName,' SRcCanvas=',SrcCanvas.ClassName,' ',
//writeln('TCanvas.CopyRect ',ClassName,' SrcCanvas=',SrcCanvas.ClassName,' ',
// ' Src=',Source.Left,',',Source.Top,',',SW,',',SH,
// ' Dest=',Dest.Left,',',Dest.Top,',',DW,',',DH);
StretchBlt(FHandle, Dest.Left, Dest.Top, DW, DH,
SrcCanvas.FHandle, Source.Left, Source.Top, SW, SH, CopyMode);
Changed;
Assert(False, Format('Trace:<== [TCanvas.CopyRect] ', []));
end;
{-----------------------------------------------}
{-- TCanvas.GetPixel --}
@ -1261,6 +1258,9 @@ end;
{ =============================================================================
$Log$
Revision 1.69 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.68 2004/02/23 08:19:04 micha
revert intf split

101
lcl/include/control.inc
View File

@ -48,13 +48,17 @@ end;
starts immediately.
------------------------------------------------------------------------------}
procedure TControl.BeginDrag(Immediate: Boolean; Threshold: Integer);
var
P : TPoint;
begin
if (Self is TCustomForm) and (FDragKind <> dkDock) then
raise EInvalidOperation.Create('Forms can not be dragged, only docked');
// start a drag operation, if not already running
if (DragControl = nil) or (Pointer(DragControl) = Pointer($FFFFFFFF)) then
Begin
DragControl := nil;
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
@ -67,8 +71,7 @@ begin
if Threshold < 0 then
Threshold := Mouse.DragThreshold;
if Pointer(DragControl) <> Pointer($FFFFFFFF) then
DragInitControl(Self,Immediate,Threshold);
DragInitControl(Self,Immediate,Threshold);
end;
end;
@ -794,6 +797,9 @@ end;
------------------------------------------------------------------------------}
procedure TControl.DragCanceled;
begin
{$IFDEF VerboseDrag}
writeln('TControl.DragCanceled');
{$ENDIF}
end;
{------------------------------------------------------------------------------
@ -802,6 +808,9 @@ end;
------------------------------------------------------------------------------}
procedure TControl.DoStartDrag(var DragObject: TDragObject);
begin
{$IFDEF VerboseDrag}
writeln('TControl.DoStartDrag ',Name,':',ClassName);
{$ENDIF}
if Assigned(FOnStartDrag) then FOnStartDrag(Self, DragObject);
end;
@ -810,6 +819,9 @@ end;
------------------------------------------------------------------------------}
Procedure TControl.DoEndDrag(Target: TObject; X,Y: Integer);
Begin
{$IFDEF VerboseDrag}
writeln('TControl.DoEndDrag ',Name,':',ClassName,' XY=',X,',',Y);
{$ENDIF}
if Assigned(FOnEndDrag) then FOnEndDrag(Self,Target,X,Y);
end;
@ -982,31 +994,43 @@ end;
{ TControl.DoDragMsg
}
{------------------------------------------------------------------------------}
Procedure TControl.DoDragMsg(var Dragmsg: TCMDrag);
Procedure TControl.DoDragMsg(var DragMsg: TCMDrag);
var
Accepts: Boolean;
S: TObject;
Src: TObject;
P: TPoint;
Begin
{$IFDEF VerboseDrag}
writeln('TControl.DoDragMsg DragMsg.DragMessage=',ord(DragMsg.DragMessage));
writeln('TControl.DoDragMsg ',Name,':',ClassName,' DragMsg.DragMessage=',ord(DragMsg.DragMessage));
{$ENDIF}
Src := DragMsg.Dragrec^.Source;
P:=ScreenToClient(DragMsg.Dragrec^.Pos);
{$IFDEF VerboseDrag}
writeln('TControl.DoDragMsg ',Name,':',ClassName,' DragMsg.Dragrec^.Pos=',DragMsg.Dragrec^.Pos.X,',',DragMsg.Dragrec^.Pos.Y,' -> P=',P.X,P.Y);
if P.X<0 then RaiseGDBException('');
{$ENDIF}
S := DragMsg.Dragrec^.Source;
Accepts := True;
P:=ScreenToClient(DragMsg.Dragrec^.pos);
case DragMsg.DragMessage of
dmDragEnter, dmDragLeave, dmDragMove:
begin
case DragMsg.DragMessage of
dmDragEnter: DragOver(S,P.X,P.Y,dsDragEnter,Accepts);
dmDragLeave: DragOver(S,P.X,P.Y,dsDragLeave,Accepts);
dmDragMove : DragOver(S,P.X,P.Y,dsDragMove,Accepts);
dmFindTarget:
DragMsg.Result := longint(Self);
dmDragEnter, dmDragLeave, dmDragMove:
begin
Accepts := True;
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;
if Accepts then
DragMsg.Result := 1
else
DragMsg.Result := 0;
end;
dmDragDrop:
DragDrop(Src, P.X, P.Y);
end; //case
end;
@ -1016,6 +1040,9 @@ end;
Procedure TControl.DragOver(Source: TObject; X,Y : Integer; State: TDragState;
var Accept:Boolean);
begin
{$IFDEF VerboseDrag}
writeln('TControl.DragOver ',Name,':',ClassName,' XY=',X,',',Y);
{$ENDIF}
Accept := False;
if Assigned(FOnDragOver) then begin
Accept := True;
@ -1028,6 +1055,9 @@ end;
------------------------------------------------------------------------------}
Procedure TControl.DragDrop(Source: TObject; X,Y : Integer);
begin
{$IFDEF VerboseDrag}
writeln('TControl.DragDrop ',Name,':',ClassName,' XY=',X,',',Y);
{$ENDIF}
If Assigned(FOnDragDrop) then FOnDragDrop(Self, Source,X,Y);
end;
@ -1312,7 +1342,6 @@ begin
LM_MOUSEMOVE:
begin
Application.HintMouseMessage(Self, TheMessage);
if Dragging then DragObject.MouseMsg(TheMessage);
end;
LM_LBUTTONDOWN,
@ -1337,7 +1366,6 @@ begin
LM_LBUTTONUP:
begin
Exclude(FControlState, csLButtonDown);
if Dragging then DragObject.MouseMsg(TheMessage);
end;
end;
end
@ -2362,7 +2390,13 @@ End;
Procedure TControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
P: TPoint;
begin
if (Button in [mbLeft,mbRight]) and Dragging 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;
@ -2370,8 +2404,14 @@ end;
TControl MouseMove
------------------------------------------------------------------------------}
Procedure TControl.MouseMove(Shift:TShiftState; X, Y: Integer);
Procedure TControl.MouseMove(Shift: TShiftState; X, Y: Integer);
var
P: TPoint;
begin
if Dragging and (DragObject<>nil) 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;
@ -2380,7 +2420,13 @@ end;
------------------------------------------------------------------------------}
Procedure TControl.MouseUp(Button: TMouseButton; Shift:TShiftState;
X, Y: Integer);
var
P: TPoint;
begin
if (Button in [mbLeft,mbRight]) and Dragging and (DragObject<>nil) 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;
@ -2400,7 +2446,7 @@ end;
------------------------------------------------------------------------------}
procedure TControl.CaptureChanged;
begin
// anything to do here?
if Dragging and (DragObject<>nil) then DragObject.CaptureChanged(Self);
end;
{------------------------------------------------------------------------------
@ -2836,6 +2882,9 @@ end;
{ =============================================================================
$Log$
Revision 1.175 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.174 2004/02/23 18:24:38 mattias
completed new TToolBar

13
lcl/include/customform.inc
View File

@ -1299,6 +1299,16 @@ begin
Result:=true;
if not (csFocusing in Control.ControlState) then begin
Control.ControlState := Control.ControlState + [csFocusing];
try
// change focus
finally
Control.ControlState := Control.ControlState + [csFocusing];
end;
end;
{
Inc(FocusCount);
@ -1582,6 +1592,9 @@ end;
{ =============================================================================
$Log$
Revision 1.129 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.128 2004/02/23 08:19:04 micha
revert intf split

343
lcl/include/dragdock.inc Normal file
View File

@ -0,0 +1,343 @@
// included by 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
//DragCapture: HWND; // old capture handle at start of dragging
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 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): longint;
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;
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}
writeln('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 FindDragTarget(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 FindDragTarget(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}
writeln('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 := FindDragTarget(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
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}
writeln('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.1 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
}

115
lcl/include/dragobject.inc
View File

@ -32,8 +32,8 @@ end;
function TDragObject.Capture: HWND;
begin
// ToDo
Result:=0;
//SetCapture(Result);
end;
procedure TDragObject.Finished(Target: TObject; X, Y: Integer; Accepted: Boolean);
@ -46,80 +46,85 @@ begin
Result := ClassName;
end;
procedure TDragObject.ReleaseCapture(Handle: HWND);
begin
end;
procedure TDragObject.MouseMsg(var Msg: TLMessage);
var
P: TPoint;
begin
Assert(False, 'Trace:******************8');
Assert(False, 'Trace:DRAGOBJECT.MOUSEMSG');
Assert(False, 'Trace:******************8');
try
case Msg.Msg of
LM_MOUSEMOVE:
begin
P := SmallPointToPoint(TLMMouse(Msg).Pos);
ClientToScreen(DragCapture, P);
DragTo(P);
end;
LM_LBUTTONUP, LM_RBUTTONUP: begin
Assert(False, 'Trace:******************');
Assert(False, 'Trace:******************');
DragDone(True);
Assert(False, 'Trace:******************');
Assert(False, 'Trace:******************');
end;
CN_KEYUP: Begin
if Msg.WParam = VK_CONTROL then DragTo(DragObject.DragPos);
end;
CN_KEYDOWN:
begin
case Msg.WParam of
VK_CONTROL: begin
DragTo(DragObject.DragPos);
end;
VK_ESCAPE:
begin
Msg.Result := 1;
DragDone(False);
end;
end;
end;
end;
except
if DragControl <> nil then DragDone(False);
raise;
end;
end;
function TDragObject.GetDragImages: TDragImageList;
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);
begin
DragDone(False);
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}
writeln('TDragObject.Destroy ',ClassName,' Self=',HexStr(Cardinal(Self),8));
{$ENDIF}
inherited Destroy;
end;
function TDragObject.GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor;
begin
if Accepted then Result := crDrag
else Result := crNoDrop;
if Accepted then
Result := crDrag
else
Result := crNoDrop;
end;
procedure TDragObject.HideDragImage;
begin
// do nothing
end;
function TDragObject.Instance: THandle;
begin
// ToDo
// exist only for compatibility
Result:=0;
end;
procedure TDragObject.ShowDragImage;
begin
// do nothing
end;
{ TDragControlObject }

98
lcl/include/imglist.inc
View File

@ -287,10 +287,12 @@ end;
------------------------------------------------------------------------------}
procedure TCustomImageList.Clear;
begin
if FCount=0 then exit;
While Count<>0 do
Delete(0);
FCount := 0;
FImageList.Clear;
FMaskList.Clear;
Change;
end;
@ -307,6 +309,7 @@ begin
FHeight := 16;
FWidth := 16;
FImageList := TList.Create; //shane
FMaskList := TList.Create;
Initialize;
end;
@ -324,6 +327,7 @@ begin
FHeight := AHeight;
FWidth := AWidth;
FImageList := TList.Create; //shane
FMaskList := TList.Create;
Initialize;
end;
@ -375,6 +379,11 @@ begin
Obj.Free;
fImageList.Items[Index]:=nil;
fImageList.Pack;
Obj:=TObject(fMaskList.Items[Index]);
If Assigned(Obj) then
Obj.Free;
fMaskList.Items[Index]:=nil;
fMaskList.Pack;
// ShiftImages(FBitmap.Canvas, Index, 1);
// ShiftImages(FMaskBitmap.Canvas, Index, 1);
Change;
@ -397,8 +406,9 @@ begin
FMaskBitmap.Free;
FMaskBitmap:=nil;
for i:=0 to FImageList.Count-1 do TObject(FImageList[i]).Free;
FImageList.Free; //shane
FImageList:=nil;
for i:=0 to FMaskList.Count-1 do TObject(FMaskList[i]).Free;
FreeThenNil(FImageList); //shane
FreeThenNil(FMaskList); //shane
inherited Destroy;
FChangeLinkList.Free;
FChangeLinkList:=nil;
@ -422,7 +432,7 @@ var
begin
if (FCount = 0) or (Index >= FCount) then Exit;
aBitmap := TBitmap(FImageList[Index]);
// ToDo: Mask
Canvas.CopyRect(Rect(X, Y, X + FWidth, Y + FHeight), aBitmap.Canvas,
Rect(0, 0, FWidth, FHeight));
end;
@ -454,23 +464,9 @@ end;
Creates a copy of the index'th image.
------------------------------------------------------------------------------}
procedure TCustomImageList.GetBitmap(Index: Integer; Image: TBitmap);
Var Stream : TMemoryStream;
aBmp : TbitMap;
begin
if (FCount = 0) or (Image = nil) then Exit;
aBmp:=TBitMap(self.FImageList.Items[Index]);
if Assigned(aBmp) then
begin
Stream:=TMemoryStream.Create;
try
aBmp.SaveToStream(Stream);
Stream.Position:=0;
Image.LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
Image.Assign(TBitMap(FImageList.Items[Index]));
end;
{------------------------------------------------------------------------------
@ -484,7 +480,7 @@ procedure TCustomImageList.GetInternalImage(Index: integer; var Image,
Mask: TBitmap);
begin
Image:=TBitmap(FImageList[Index]);
Mask:=nil;
Mask:=TBitmap(FMaskList[Index]);
end;
{------------------------------------------------------------------------------
@ -632,6 +628,7 @@ begin
if (Image <> nil)
then begin
FImageList.Insert(Index,Image);
FMaskList.Insert(Index,Mask);
Change;
{ nCount := Image.Width div FWidth;
if nCount > 0
@ -751,6 +748,7 @@ procedure TCustomImageList.Move(CurIndex, NewIndex: Integer);
begin
if CurIndex <> NewIndex then begin
FImageList.Move(CurIndex,NewIndex);
FMaskList.Move(CurIndex,NewIndex);
Change;
end;
end;
@ -802,7 +800,7 @@ var
StreamPos: TStreamSeekType;
Image, Img, Mask, Msk: TBitmap;
n,m, Size, NewCount: Integer;
Row, Col, Size, NewCount: Integer;
SrcRect: TRect;
HasMask: Boolean;
begin
@ -827,18 +825,26 @@ begin
then begin
AStream.ReadWord; //Skip ?
NewCount := AStream.ReadWord;
//writeln('NewCount=',NewCount);
AStream.ReadWord; //Skip Capacity
AStream.ReadWord; //Skip Grow
FWidth := AStream.ReadWord;
//writeln('NewWidth=',FWidth);
FHeight := AStream.ReadWord;
FBKColor := AStream.ReadDWord;
//writeln('NewHeight=',FHeight);
FBKColor := TColor(AStream.ReadDWord);
HasMask := (AStream.ReadWord and 1) = 1;
AStream.ReadDWord; //Skip ?
AStream.ReadDWord; //Skip ?
Image.LoadFromStream(AStream);
if HasMask
then Mask.LoadFromStream(AStream);
//writeln('TCustomImageList.ReadData After Header ',FWidth,',',FHeight,' ',AStream.Position,'/',AStream.Size);
Image.ReadStream(AStream,false,0);
//Image.SaveToFile('output_test.bmp');
//writeln('TCustomImageList.ReadData After Image ',Image.Width,',',Image.Height,' Masked=',Image.MaskHandleAllocated,' StreamPos=',AStream.Position,'/',AStream.Size,' HasMask=',HasMask);
if HasMask then begin
Mask.ReadStream(AStream,false,0);
//writeln('TCustomImageList.ReadData After Mask ',Mask.Width,',',Mask.Height,' StreamPos=',AStream.Position,'/',AStream.Size,' ');
end;
end
else begin
// D2 has no signature, so restore original position
@ -846,34 +852,45 @@ begin
AStream.ReadBuffer(Size, SizeOf(Size));
AStream.ReadBuffer(NewCount, SizeOf(NewCount));
Image.LoadFromStream(AStream);
Image.ReadStream(AStream,false,0);
AStream.Position := StreamPos + Size;
Mask.LoadFromStream(AStream);
HasMask := True;
if HasMask then
Mask.ReadStream(AStream,false,0);
end;
SrcRect := Rect(0, 0, Width, Height);
// ATM we are creating one image/mask for each icon.
// But eventually there should only be one TBitmap.
SrcRect := Bounds(0, 0, Width, Height);
BeginUpdate;
try
for n := 0 to (Image.Height div Height) - 1 do
for Row := 0 to (Image.Height div Height) - 1 do
begin
if NewCount = 0 then Break;
for m := 0 to (Image.Width div Width) - 1 do
if NewCount <= 0 then Break;
for Col := 0 to (Image.Width div Width) - 1 do
begin
if NewCount = 0 then Break;
if NewCount <= 0 then Break;
Img := TBitmap.Create;
Img.Width := Width;
Img.Height := Height;
Img.Canvas.CopyRect(SrcRect, Image.Canvas,
Bounds(m * Width, n * Height, Width, Height));
Bounds(Col * Width, Row * Height, Width, Height));
Img.Canvas.Brush.Color:=clRed;
Img.Canvas.Fillrect(Rect(3,3,10,8));
//Img.SaveToFile('debug_imglist_i'+IntToStr(Count)+'.bmp');
Msk := TBitmap.Create;
Msk.Monochrome := True;
Msk.Width := Width;
Msk.Height := Height;
Msk.Canvas.CopyRect(SrcRect, Mask.Canvas,
Bounds(m * Width, n * Height, Width, Height));
if Mask<>nil then begin
Msk := TBitmap.Create;
Msk.Monochrome := True;
Msk.Width := Width;
Msk.Height := Height;
Msk.Canvas.CopyRect(SrcRect, Mask.Canvas,
Bounds(Col * Width, Row * Height, Width, Height));
//Msk.SaveToFile('debug_imglist_m'+IntToStr(Count)+'.bmp');
// ToDo: combine image and mask
end else
Msk:=nil;
AddDirect(Img, Msk);
Img := nil;
@ -1145,6 +1162,9 @@ end;
{
$Log$
Revision 1.26 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.25 2004/02/25 11:12:06 marc
+ Added delphi stream reading support

100
lcl/include/intfbaselcl.inc
View File

@ -28,13 +28,13 @@
function TInterfaceBase.AlignmentCreateHandle(const AAlignment: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ArrowCreateHandle(const AArrow: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
procedure TInterfaceBase.AttachMenuToWindow(AMenuObject: TComponent);
@ -44,19 +44,19 @@ end;
function TInterfaceBase.BitBtnCreateHandle(const ABitBtn: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ButtonCreateHandle(const AButton: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.CalendarCreateHandle(const ACalendar: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
procedure TInterfaceBase.CallDefaultWndHandler(Sender: TObject; var Message);
@ -66,13 +66,13 @@ end;
function TInterfaceBase.CheckboxCreateHandle(const ACheckBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.CheckListBoxCreateHandle(const ACheckListBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
// the clipboard functions are internally used by TClipboard
@ -112,19 +112,19 @@ end;
function TInterfaceBase.CListBoxCreateHandle(const ACListBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ColorDialogCreateHandle(const AColorDialog: TObject): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ComboBoxCreateHandle(const AComboBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ComboBoxDropDown(Handle: HWND;
@ -176,25 +176,25 @@ end;
function TInterfaceBase.EditCreateHandle(const AEdit: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.FileDialogCreateHandle(const AFileDialog: TObject): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.FontDialogCreateHandle(const AFontDialog: TObject): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.FormCreateHandle(const AForm: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.Frame(DC: HDC; const ARect: TRect) : integer;
@ -435,27 +435,26 @@ end;
function TInterfaceBase.GroupBoxCreateHandle(const AGroupBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.HintWindowCreateHandle(const AHintWindow: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ImageCreateHandle(const AImage: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.IntfCreateHandle(const AObject: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
Function TInterfaceBase.InvalidateFrame(aHandle : HWND; ARect : pRect;
bErase : Boolean; BorderWidth: integer) : Boolean;
@ -496,37 +495,37 @@ end;
function TInterfaceBase.LabelCreateHandle(const ALabel: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ListBoxCreateHandle(const AListBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ListViewCreateHandle(const AListView: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.MainMenuCreateHandle(const AMainMenu: TObject): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.MemoCreateHandle(const AMemo: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.MenuItemCreateHandle(const AMenuItem: TObject): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.MenuItemSetCheck(AMenuItem: TComponent): Boolean;
@ -592,19 +591,19 @@ end;
function TInterfaceBase.NotebookCreateHandle(const ANotebook: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.OpenFileDialogCreateHandle(const AOpenFileDialog: TObject): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.PageCreateHandle(const APage: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.PairSplitterAddSide(SplitterHandle, SideHandle: hWnd;
@ -616,7 +615,7 @@ end;
function TInterfaceBase.PairSplitterCreateHandle(const APairSplitter: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.PairSplitterGetInterfaceInfo: boolean;
@ -639,37 +638,37 @@ end;
function TInterfaceBase.PairSplitterSideCreateHandle(const APairSplitterSide: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.PanelCreateHandle(const APanel: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.PopupMenuCreateHandle(const APopupMenu: TObject): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.PreviewFileControlCreateHandle(const APreviewFileControl: TObject): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.PreviewFileDialogCreateHandle(const APreviewFileDialog: TObject): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ProgressBarCreateHandle(const AProgressBar: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
Function TInterfaceBase.PromptUser(const DialogCaption, DialogMessage : String;
@ -745,7 +744,7 @@ end;
function TInterfaceBase.RadioButtonCreateHandle(const ARadioButton: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.RadioMenuItemGroup(hndMenu: HMENU; bRadio: Boolean): Boolean;
@ -781,31 +780,31 @@ end;
function TInterfaceBase.SaveFileDialogCreateHandle(const ASaveFileDialog: TObject): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ScrollBarCreateHandle(const AScrollBar: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ScrollBoxCreateHandle(const AScrollBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ScrolledWindowCreateHandle(const AScrolledWindow: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.SelectDirectoryDialogCreateHandle(const ASelectDirectoryDialog: TObject): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
procedure TInterfaceBase.SendCachedLCLMessages;
@ -836,19 +835,19 @@ end;
function TInterfaceBase.SpeedButtonCreateHandle(const ASpeedButton: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.SpineditCreateHandle(const ASpinEdit: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.StatusBarCreateHandle(const AStatusBar: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
procedure TInterfaceBase.StatusBarPanelUpdate(StatusBar: TObject;
@ -876,37 +875,40 @@ end;
function TInterfaceBase.ToggleBoxCreateHandle(const AToggleBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ToolbarCreateHandle(const AToolbar: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.ToolButtonCreateHandle(const AToolButton: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.TrackBarCreateHandle(const ATrackBar: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
function TInterfaceBase.WincontrolCreateHandle(const AFixed: TObject; const AParams: TCreateParams): THandle;
begin
// Your default here
// Result :=
Result:=0;
end;
//##apiwiz##eps## // Do not remove
{ =============================================================================
$Log$
Revision 1.23 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.22 2004/02/27 00:42:41 marc
* Interface CreateComponent splitup
* Implemented CreateButtonHandle on GTK interface

5
lcl/include/speedbutton.inc
View File

@ -504,7 +504,7 @@ begin
if FFlat and Enabled
then begin
GetCursorPos(p);
FMouseInControl := (FindDragTarget(P, True) <> Self);
FMouseInControl := (FindControlAtPosition(P, True) <> Self);
if FMouseInControl
then Perform(CM_MOUSELEAVE,0,0)
else Perform(CM_MOUSEENTER,0,0);
@ -773,6 +773,9 @@ end;
{ =============================================================================
$Log$
Revision 1.50 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.49 2004/02/23 18:24:38 mattias
completed new TToolBar

71
lcl/include/treeview.inc
View File

@ -23,7 +23,6 @@
TTreeView for LCL
ToDo:
- Drag&Drop
- Editing
- Columns
}
@ -2602,7 +2601,6 @@ begin
FChangeTimer.Enabled := False;
FChangeTimer.Interval := 0;
FChangeTimer.OnTimer := @OnChangeTimer;
//FEditInstance := MakeObjectInstance(EditWndProc);
FImageChangeLink := TChangeLink.Create;
FImageChangeLink.OnChange := @ImageListChange;
FSelectedColor:=clHighlight;
@ -2620,36 +2618,19 @@ begin
FreeThenNil(FChangeTimer);
FreeThenNil(FSaveItems);
FreeThenNil(FDragImage);
//FMemStream.Free;
//FreeObjectInstance(FEditInstance);
FreeThenNil(FImageChangeLink);
FreeThenNil(FStateChangeLink);
inherited Destroy;
end;
procedure TCustomTreeView.CreateParams(var Params: TCreateParams);
{const
BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
LineStyles: array[Boolean] of DWORD = (0, TVS_HASLINES);
RootStyles: array[Boolean] of DWORD = (0, TVS_LINESATROOT);
ButtonStyles: array[Boolean] of DWORD = (0, TVS_HASBUTTONS);
EditStyles: array[Boolean] of DWORD = (TVS_EDITLABELS, 0);
HideSelections: array[Boolean] of DWORD = (TVS_SHOWSELALWAYS, 0);
DragStyles: array[TDragMode] of DWORD = (TVS_DISABLEDRAGDROP, 0);
RTLStyles: array[Boolean] of DWORD = (0, TVS_RTLREADING);
ToolTipStyles: array[Boolean] of DWORD = (TVS_NOTOOLTIPS, 0);
AutoExpandStyles: array[Boolean] of DWORD = (0, TVS_SINGLEEXPAND);
HotTrackStyles: array[Boolean] of DWORD = (0, TVS_TRACKSELECT);
RowSelectStyles: array[Boolean] of DWORD = (0, TVS_FULLROWSELECT);}
const
ScrollBar: array[TScrollStyle] of DWORD = (0, WS_HSCROLL, WS_VSCROLL,
WS_HSCROLL or WS_VSCROLL, WS_HSCROLL, WS_VSCROLL, WS_HSCROLL or WS_VSCROLL);
BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
ClassStylesOff = CS_VREDRAW or CS_HREDRAW;
begin
//InitCommonControl(ICC_TREEVIEW_CLASSES);
inherited CreateParams(Params);
//CreateSubClass(Params, WC_TREEVIEW);
with Params do begin
{$IFOPT R+}{$DEFINE RangeCheckOn}{$R-}{$ENDIF}
WindowClass.Style := WindowClass.Style and not Cardinal(ClassStylesOff);
@ -2661,42 +2642,12 @@ begin
ExStyle := ExStyle or WS_EX_CLIENTEDGE;
end;
end;
{with Params do begin
Style := Style or LineStyles[FShowLines] or BorderStyles[FBorderStyle] or
RootStyles[FShowRoot] or ButtonStyles[FShowButtons] or
EditStyles[FReadOnly] or HideSelections[FHideSelection] or
DragStyles[DragMode] or RTLStyles[UseRightToLeftReading] or
ToolTipStyles[FToolTips] or AutoExpandStyles[FAutoExpand] or
HotTrackStyles[FHotTrack] or RowSelectStyles[FRowSelect];
if Ctl3D and NewStyleControls and (FBorderStyle = bsSingle) then begin
Style := Style and not WS_BORDER;
ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
end;
WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;}
end;
procedure TCustomTreeView.CreateWnd;
begin
Exclude(FStates,tvsStateChanging);
inherited CreateWnd;
//TreeView_SetBkColor(Handle, ColorToRGB(Color));
//TreeView_SetTextColor(Handle, ColorToRGB(Font.Color));
{if FMemStream <> nil then begin
Items.ReadData(FMemStream);
Items.ReadExpandedState(FMemStream);
FMemStream.Destroy;
FMemStream := nil;
SetTopItem(Items.GetNodeFromIndex(FSaveTopIndex));
FSaveTopIndex := 0;
SetSelection(Items.GetNodeFromIndex(FSaveIndex));
FSaveIndex := 0;
end;}
//if (Images <> nil) and Images.HandleAllocated then
// SetImageList(Images.Handle, TVSIL_NORMAL);
//if (StateImages <> nil) and StateImages.HandleAllocated then
// SetImageList(StateImages.Handle, TVSIL_STATE);
end;
procedure TCustomTreeView.InitializeWnd;
@ -2939,9 +2890,6 @@ end;
procedure TCustomTreeView.SetDragMode(Value: TDragMode);
begin
// ToDo: implement Drag&Drop
//if Value <> DragMode then
// SetComCtlStyle(Self, TVS_DISABLEDRAGDROP, Value = dmManual);
inherited SetDragMode(Value);
end;
@ -4028,7 +3976,7 @@ var
P: TPoint;
begin
{$IFDEF VerboseDrag}
writeln('TCustomTreeView.DoStartDrag A ');
writeln('TCustomTreeView.DoStartDrag A ',Name,':',ClassName);
{$ENDIF}
inherited DoStartDrag(DragObject);
FLastDropTarget := nil;
@ -4047,27 +3995,25 @@ end;
procedure TCustomTreeView.DoEndDrag(Target: TObject; X, Y: Integer);
begin
{$IFDEF VerboseDrag}
writeln('TCustomTreeView.DoEndDrag A ');
writeln('TCustomTreeView.DoEndDrag A ',Name,':',ClassName);
{$ENDIF}
inherited DoEndDrag(Target, X, Y);
FLastDropTarget := nil;
end;
procedure TCustomTreeView.CMDrag(var AMessage: TCMDrag);
var
P: TPoint;
begin
inherited CMDrag(AMessage);
{$IFDEF VerboseDrag}
writeln('TCustomTreeView.CMDrag ',ord(AMessage.DragMessage));
writeln('TCustomTreeView.CMDrag ',Name,':',ClassName,' ',ord(AMessage.DragMessage));
{$ENDIF}
with AMessage, DragRec^ do
case DragMessage of
dmDragMove:
{dmDragMove:
begin
P:=ScreenToClient(Pos);
DoDragOver(Source, P.X, P.Y, AMessage.Result <> 0);
end;
end;}
dmDragLeave:
begin
TDragObject(Source).HideDragImage;
@ -4079,14 +4025,15 @@ begin
end;
end;
procedure TCustomTreeView.DoDragOver(Source: TDragObject; X, Y: Integer;
CanDrop: Boolean);
procedure TCustomTreeView.DragOver(Source: TObject; X,Y: Integer;
State: TDragState; var Accept: Boolean);
var
Node: TTreeNode;
begin
inherited DragOver(Source,X,Y,State,Accept);
Node := GetNodeAt(X, Y);
{$IFDEF VerboseDrag}
writeln('TCustomTreeView.DoDragOver ',Node<>nil,' ',Node <> DropTarget,' ',Node = FLastDropTarget);
writeln('TCustomTreeView.DragOver ',Name,':',ClassName,' ',Node<>nil,' ',Node <> DropTarget,' ',Node = FLastDropTarget);
{$ENDIF}
if (Node <> nil)
and ((Node <> DropTarget) or (Node = FLastDropTarget)) then

83
lcl/include/wincontrol.inc
View File

@ -625,29 +625,20 @@ begin
end;
end;
{------------------------------------------------------------------------------}
{ TWinControl CMDrag }
{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------
TWinControl CMDrag
------------------------------------------------------------------------------}
Procedure TWinControl.CMDrag(var Message: TCMDrag);
Begin
with Message, DragRec^ do
Begin
case DragMessage of
dmDragEnter, dmDragLeave,dmDragMove, dmDragDrop :
if target <> nil then TControl(target).DoDragMsg(Message);
dmFindTarget:
begin
Writeln('dmFindTarget');
Result := longint(ControlatPos(ScreentoClient(pos),False));
if Result = 0 then Result := longint(Self);
end;
end;//case
end;
{$IFDEF VerboseDrag}
writeln('TWinControl.CMDrag ',Name,':',ClassName,' ',ord(Message.DragMessage));
{$ENDIF}
DoDragMsg(Message);
end;
{------------------------------------------------------------------------------}
{ TWinControl CreateSubClass }
{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------
TWinControl CreateSubClass
------------------------------------------------------------------------------}
procedure TWinControl.CreateSubClass(var Params: TCreateParams;
ControlClassName: PChar);
(*
@ -817,6 +808,30 @@ begin
Result := True;
end;
procedure TWinControl.DoDragMsg(var DragMsg: TCMDrag);
var
TargetControl: TControl;
begin
case DragMsg.DragMessage of
dmFindTarget:
begin
{$IFDEF VerboseDrag}
Writeln('TWinControl.DoDragMsg dmFindTarget ',Name,':',ClassName,' Start DragMsg.DragRec^.Pos=',DragMsg.DragRec^.Pos.X,',',DragMsg.DragRec^.Pos.Y);
{$ENDIF}
TargetControl := ControlatPos(ScreentoClient(DragMsg.DragRec^.Pos),False);
if TargetControl = nil then TargetControl := Self;
{$IFDEF VerboseDrag}
Writeln('TWinControl.DoDragMsg dmFindTarget ',Name,':',ClassName,' End Result=',TargetControl.Name,':',TargetControl.ClassName);
{$ENDIF}
DragMsg.Result:=longint(TargetControl);
end;
else
inherited DoDragMsg(DragMsg);
end;
end;
{------------------------------------------------------------------------------}
{ TWinControl GetChildren }
{------------------------------------------------------------------------------}
@ -1802,22 +1817,6 @@ Begin
then CaptureControl.Perform(LM_CANCELMODE,0,0);
else
//TODO:Implement TMOUSE
{ with Mouse do
if WheelPresent and (RegWheelMessage <> 0) and (Message.Msg = RegWheelMessage) then
Begin
GetKeyboardState(KeyState);
with WheelMsg do
Begin
Msg := Message.Msg;
ShiftState := KeyboardStateToShiftState(KeyState);
WheelData :=Message.WParam;
Pos := TSmallPoint(Message.LPaream);
end;
MouseWheelHandler(TMessage(WheelMsg));
Exit;
end;
}
end;
inherited WndProc(Message);
@ -1998,6 +1997,10 @@ begin
begin
if CharCode = VK_UNKNOWN then Exit;
ShiftState := KeyDataToShiftState(KeyData);
if Dragging and (DragObject<>nil) then
DragObject.KeyDown(CharCode, ShiftState);
if not (csNoStdEvents in ControlStyle)
then begin
KeyDown(CharCode, ShiftState);
@ -2054,6 +2057,10 @@ begin
with Message do
begin
ShiftState := KeyDataToShiftState(KeyData);
if Dragging and (DragObject<>nil) then
DragObject.KeyUp(CharCode, ShiftState);
if not (csNoStdEvents in ControlStyle)
then begin
KeyUp(CharCode, ShiftState);
@ -2988,6 +2995,9 @@ begin
FCreatingHandle := True;
try
FHandle := CreateWindowHandle(Params);
FFlags:=FFlags-[wcfColorChanged,wcfFontChanged];
if not HandleAllocated then
RaiseGDBException('Handle creation failed');
finally
FCreatingHandle := False;
end;
@ -3418,6 +3428,9 @@ end;
{ =============================================================================
$Log$
Revision 1.210 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.209 2004/02/27 00:42:41 marc
* Interface CreateComponent splitup
* Implemented CreateButtonHandle on GTK interface

55
lcl/interfaces/gtk/gtklclintf.inc
View File

@ -38,6 +38,7 @@
function TGTKObject.AlignmentCreateHandle(const AAlignment: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -50,6 +51,7 @@ end;
function TGTKObject.ArrowCreateHandle(const AArrow: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -62,6 +64,7 @@ end;
function TGTKObject.BitBtnCreateHandle(const ABitBtn: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -71,7 +74,8 @@ end;
Returns:
------------------------------------------------------------------------------}
function TGTKObject.ButtonCreateHandle(const AButton: TObject; const AParams: TCreateParams): THandle;
function TGTKObject.ButtonCreateHandle(const AButton: TObject;
const AParams: TCreateParams): THandle;
var
Caption, Pattern: String;
AccelKey: Char;
@ -88,7 +92,7 @@ begin
Result := THandle(gtk_button_new_with_label(PChar(Caption)));
if Result = 0 then Exit;
gtk_label_set_pattern(PGtkLabel(Result), PChar(Pattern));
gtk_label_set_pattern(PGtkLabel(PGtkButton(Result)^.Child), PChar(Pattern));
Accelerate(Button, PGtkWidget(Result), Ord(AccelKey), 0, 'clicked');
WidgetInfo := CreateWidgetInfo(Result, Button, AParams);
@ -114,6 +118,7 @@ end;
function TGTKObject.CalendarCreateHandle(const ACalendar: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -126,6 +131,7 @@ end;
function TGTKObject.CheckboxCreateHandle(const ACheckBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -138,6 +144,7 @@ end;
function TGTKObject.CheckListBoxCreateHandle(const ACheckListBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -150,6 +157,7 @@ end;
function TGTKObject.CListBoxCreateHandle(const ACListBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -161,6 +169,7 @@ end;
function TGTKObject.ColorDialogCreateHandle(const AColorDialog: TObject): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -173,9 +182,9 @@ end;
function TGTKObject.ComboBoxCreateHandle(const AComboBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
function TGTKObject.DrawSplitter(DC: HDC; const ARect: TRect;
Horizontal: boolean): Integer;
@ -233,6 +242,7 @@ end;
function TGTKObject.EditCreateHandle(const AEdit: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -244,6 +254,7 @@ end;
function TGTKObject.FileDialogCreateHandle(const AFileDialog: TObject): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -255,6 +266,7 @@ end;
function TGTKObject.FontDialogCreateHandle(const AFontDialog: TObject): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -267,6 +279,7 @@ end;
function TGTKObject.FormCreateHandle(const AForm: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -497,6 +510,7 @@ end;
function TGTKObject.GroupBoxCreateHandle(const AGroupBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -509,6 +523,7 @@ end;
function TGTKObject.HintWindowCreateHandle(const AHintWindow: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -521,6 +536,7 @@ end;
function TGTKObject.ImageCreateHandle(const AImage: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -546,6 +562,7 @@ end;
function TGTKObject.LabelCreateHandle(const ALabel: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -558,6 +575,7 @@ end;
function TGTKObject.ListBoxCreateHandle(const AListBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -570,6 +588,7 @@ end;
function TGTKObject.ListViewCreateHandle(const AListView: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -581,6 +600,7 @@ end;
function TGTKObject.MainMenuCreateHandle(const AMainMenu: TObject): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -593,6 +613,7 @@ end;
function TGTKObject.MemoCreateHandle(const AMemo: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -604,6 +625,7 @@ end;
function TGTKObject.MenuItemCreateHandle(const AMenuItem: TObject): THandle;
begin
// Your code here
Result:=0;
end;
{$EndIf}
@ -670,6 +692,7 @@ end;
function TGTKObject.NotebookCreateHandle(const ANotebook: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -681,6 +704,7 @@ end;
function TGTKObject.OpenFileDialogCreateHandle(const AOpenFileDialog: TObject): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -693,6 +717,7 @@ end;
function TGTKObject.PageCreateHandle(const APage: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -705,6 +730,7 @@ end;
function TGTKObject.PairSplitterCreateHandle(const APairSplitter: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -717,6 +743,7 @@ end;
function TGTKObject.PairSplitterSideCreateHandle(const APairSplitterSide: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -729,6 +756,7 @@ end;
function TGTKObject.PanelCreateHandle(const APanel: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -740,6 +768,7 @@ end;
function TGTKObject.PopupMenuCreateHandle(const APopupMenu: TObject): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -751,6 +780,7 @@ end;
function TGTKObject.PreviewFileControlCreateHandle(const APreviewFileControl: TObject): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -762,6 +792,7 @@ end;
function TGTKObject.PreviewFileDialogCreateHandle(const APreviewFileDialog: TObject): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -774,6 +805,7 @@ end;
function TGTKObject.ProgressBarCreateHandle(const AProgressBar: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -786,6 +818,7 @@ end;
function TGTKObject.RadioButtonCreateHandle(const ARadioButton: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -797,6 +830,7 @@ end;
function TGTKObject.SaveFileDialogCreateHandle(const ASaveFileDialog: TObject): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -809,6 +843,7 @@ end;
function TGTKObject.ScrollBarCreateHandle(const AScrollBar: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -821,6 +856,7 @@ end;
function TGTKObject.ScrollBoxCreateHandle(const AScrollBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -833,6 +869,7 @@ end;
function TGTKObject.ScrolledWindowCreateHandle(const AScrolledWindow: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -844,6 +881,7 @@ end;
function TGTKObject.SelectDirectoryDialogCreateHandle(const ASelectDirectoryDialog: TObject): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -856,6 +894,7 @@ end;
function TGTKObject.SpeedButtonCreateHandle(const ASpeedButton: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -868,6 +907,7 @@ end;
function TGTKObject.SpineditCreateHandle(const ASpinEdit: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -880,6 +920,7 @@ end;
function TGTKObject.StatusBarCreateHandle(const AStatusBar: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -947,6 +988,7 @@ end;
function TGTKObject.ToggleBoxCreateHandle(const AToggleBox: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -959,6 +1001,7 @@ end;
function TGTKObject.ToolbarCreateHandle(const AToolbar: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -971,6 +1014,7 @@ end;
function TGTKObject.ToolButtonCreateHandle(const AToolButton: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -983,6 +1027,7 @@ end;
function TGTKObject.TrackBarCreateHandle(const ATrackBar: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
@ -995,6 +1040,7 @@ end;
function TGTKObject.WincontrolCreateHandle(const AFixed: TObject; const AParams: TCreateParams): THandle;
begin
// Your code here
Result:=0;
end;
//##apiwiz##eps## // Do not remove, no wizard declaration after this line
@ -1002,6 +1048,9 @@ end;
{ =============================================================================
$Log$
Revision 1.17 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.16 2004/02/27 00:42:41 marc
* Interface CreateComponent splitup
* Implemented CreateButtonHandle on GTK interface

41
lcl/interfaces/gtk/gtkobject.inc
View File

@ -2392,6 +2392,10 @@ var
MaskPixmap:=PGdiObject(Mask)^.GDIBitmapMaskObject;
if MaskPixmap=nil then
MaskPixmap:=SrcGDIBitmap^.GDIBitmapMaskObject;
{$IFDEF VerboseStretchCopyArea}
writeln('SrcDevBitmapToDrawable SrcPixmap=[',GetWindowDebugReport(SrcPixmap),']',
' MaskPixmap=[',GetWindowDebugReport(MaskPixmap),']');
{$ENDIF}
if (MaskPixmap=nil) and (not SizeChange) and (ROP=SRCCOPY)
then begin
@ -2399,10 +2403,8 @@ var
{$IFDEF VerboseStretchCopyArea}
writeln('SrcDevBitmapToDrawable Simple copy');
{$ENDIF}
BeginGDKErrorTrap;
gdk_window_copy_area(DestDevContext.Drawable, DestDevContext.GC, X, Y,
SrcPixmap, XSrc, YSrc, Width, Height);
EndGDKErrorTrap;
exit;
end;
@ -2709,13 +2711,33 @@ begin
TempMaskPixmap:=nil;
{$IFDEF VerboseStretchCopyArea}
writeln('TgtkObject.StretchCopyArea AFTER CLIPPING X=',X,' Y=',Y,' Width=',Width,' Height=',Height,
write('TgtkObject.StretchCopyArea AFTER CLIPPING X=',X,' Y=',Y,' Width=',Width,' Height=',Height,
' XSrc=',XSrc,' YSrc=',YSrc,' SrcWidth=',SrcWidth,' SrcHeight=',SrcHeight,
' SrcDrawable=',HexStr(Cardinal(TDeviceContext(SrcDC).Drawable),8),
' DestDrawable=',HexStr(Cardinal(TDeviceContext(DestDC).Drawable),8),
' Mask=',HexStr(Cardinal(Mask),8),' XMask=',XMask,' YMask=',YMask,
' SizeChange=',SizeChange,' ROpIsSpecial=',ROpIsSpecial,
' CopyingWholeSrc=',CopyingWholeSrc);
write(' ROp=');
case ROp of
SRCCOPY : writeln('SRCCOPY');
SRCPAINT : writeln('SRCPAINT');
SRCAND : writeln('SRCAND');
SRCINVERT : writeln('SRCINVERT');
SRCERASE : writeln('SRCERASE');
NOTSRCCOPY : writeln('NOTSRCCOPY');
NOTSRCERASE : writeln('NOTSRCERASE');
MERGECOPY : writeln('MERGECOPY');
MERGEPAINT : writeln('MERGEPAINT');
PATCOPY : writeln('PATCOPY');
PATPAINT : writeln('PATPAINT');
PATINVERT : writeln('PATINVERT');
DSTINVERT : writeln('DSTINVERT');
BLACKNESS : writeln('BLACKNESS');
WHITENESS : writeln('WHITENESS');
else
writeln('???');
end;
{$ENDIF}
If TDeviceContext(SrcDC).Drawable = nil then begin
@ -3192,8 +3214,8 @@ begin
pixmap := pgdkPixmap(
PgdiObject(TBitBtn(Sender).Glyph.Handle)^.GDIBitmapObject);
if (TBitBtn(Sender).Glyph.Width>1)
or (TBitBtn(Sender).Glyph.Height>1) then begin
if (TBitBtn(Sender).Glyph.Width>0)
or (TBitBtn(Sender).Glyph.Height>0) then begin
if PgdiObject(TBitBtn(Sender).Glyph.handle)^.GDIBitmapMaskObject <> nil
then begin
PixMapWid := gtk_pixmap_new(pixmap,
@ -3216,8 +3238,7 @@ begin
StrDispose(pStr);
end;
if (TBitBtn(Sender).Layout = blGlyphLeft)
or (TBitBtn(Sender).Layout = blGlyphRight) then
if (TBitBtn(Sender).Layout in [blGlyphLeft,blGlyphRight]) then
Begin
box1 := gtk_hbox_new(False,0);
end
@ -3225,8 +3246,7 @@ begin
box1 := gtk_vbox_new(False,0);
end;
if (TBitBtn(Sender).Layout = blGlyphLeft)
or (TBitBtn(Sender).Layout = blGlyphTop) then
if (TBitBtn(Sender).Layout in [blGlyphLeft,blGlyphTop]) then
begin
if PixMapWid<>nil then
gtk_box_pack_start(pGTKBox(Box1),PixMapWid,false,false,
@ -9248,6 +9268,9 @@ end;
{ =============================================================================
$Log$
Revision 1.474 2004/02/28 00:34:35 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.473 2004/02/27 00:42:41 marc
* Interface CreateComponent splitup
* Implemented CreateButtonHandle on GTK interface

64
lcl/interfaces/gtk/gtkproc.inc
View File

@ -640,24 +640,53 @@ function GetWindowDebugReport(AWindow: PGDKWindow): string;
var
p: Pgpointer;
Widget: PGtkWidget;
WindowType: TGdkWindowType;
Width: Integer;
Height: Integer;
Visual: PGdkVisual;
TypeAsStr: String;
begin
Result:=HexStr(Cardinal(AWindow),8);
if AWindow=nil then exit;
p:=nil;
gdk_window_get_user_data(AWindow,p);
if GtkWidgetIsA(PGTKWidget(p),GTK_WIDGET_TYPE) then begin
Widget:=PGTKWidget(p);
Result:=Result+'<Widget['+GetWidgetDebugReport(Widget)+']>';
end else begin
Result:=Result+'<Data='+HexStr(Cardinal(p),8)+']>';
end;
end;
function GetDrawableDebugReport(ADrawable: PGDKDrawable): string;
begin
Result:=HexStr(Cardinal(ADrawable),8);
if ADrawable=nil then exit;
// window type
WindowType:=gdk_window_get_type(AWindow);
case WindowType of
GDK_WINDOW_ROOT: TypeAsStr:='Root';
GDK_WINDOW_TOPLEVEL: TypeAsStr:='TopLvl';
GDK_WINDOW_CHILD: TypeAsStr:='Child';
GDK_WINDOW_DIALOG: TypeAsStr:='Dialog';
GDK_WINDOW_TEMP: TypeAsStr:='Temp';
GDK_WINDOW_PIXMAP: TypeAsStr:='Pixmap';
GDK_WINDOW_FOREIGN: TypeAsStr:='Foreign';
end;
Result:=Result+' Type='+TypeAsStr;
// user data
if WindowType in [GDK_WINDOW_ROOT,GDK_WINDOW_TOPLEVEL,GDK_WINDOW_CHILD,
GDK_WINDOW_DIALOG]
then begin
p:=nil;
gdk_window_get_user_data(AWindow,p);
if GtkWidgetIsA(PGTKWidget(p),GTK_WIDGET_TYPE) then begin
Widget:=PGTKWidget(p);
Result:=Result+'<Widget['+GetWidgetDebugReport(Widget)+']>';
end else begin
Result:=Result+'<UserData='+HexStr(Cardinal(p),8)+']>';
end;
end;
// size
gdk_window_get_size(AWindow,@Width,@Height);
Result:=Result+' Size='+IntToStr(Width)+'x'+IntToStr(Height);
// visual
Visual:=gdk_window_get_visual(AWindow);
if Visual<>nil then begin
if WindowType in [GDK_WINDOW_PIXMAP] then begin
Result:=Result+' Depth='+IntToStr(Visual^.bits_per_rgb);
end;
end;
end;
{------------------------------------------------------------------------------
@ -1013,9 +1042,9 @@ var
begin
{$IFDEF VerboseStretchCopyArea}
writeln('ScalePixmap ScaleGC=',HexStr(Cardinal(ScaleGC),8),
' SrcPixmap=',HexStr(Cardinal(SrcPixmap),8),
' SrcPixmap=[',GetWindowDebugReport(SrcPixmap),']',
' SrcX=',SrcX,' SrcY=',SrcY,' SrcWidth=',SrcWidth,' SrcHeight=',SrcHeight,
' NewPixmap=',HexStr(Cardinal(NewPixmap),8),
' NewPixmap=[',GetWindowDebugReport(NewPixmap),']',
' NewWidth=',NewWidth,' NewHeight=',NewHeight);
{$ENDIF}
Result := False;
@ -6603,6 +6632,9 @@ end;
{ =============================================================================
$Log$
Revision 1.263 2004/02/28 00:34:36 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.262 2004/02/27 00:42:41 marc
* Interface CreateComponent splitup
* Implemented CreateButtonHandle on GTK interface

1
lcl/interfaces/gtk/gtkproc.pp
View File

@ -254,7 +254,6 @@ function GtkWidgetIsA(Widget: PGtkWidget; AType: TGtkType): boolean;
function GetWidgetClassName(Widget: PGtkWidget): string;
function GetWidgetDebugReport(Widget: PGtkWidget): string;
function GetWindowDebugReport(AWindow: PGDKWindow): string;
function GetDrawableDebugReport(ADrawable: PGDKDrawable): string;
// gtk resources
procedure Set_RC_Name(Sender : TObject; AWidget: PGtkWidget);

7
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -891,6 +891,7 @@ begin
try
{$IFDEF VerboseRawImage}
writeln('TgtkObject.CreateBitmapFromRawImage A ',
' AlwaysCreateMask=',AlwaysCreateMask,
' Depth=',RawImage.Description.Depth,
' Width=',RawImage.Description.Width,
' Height=',RawImage.Description.Height,
@ -961,6 +962,9 @@ begin
// create mask
if (AlwaysCreateMask or (not RawImageMaskIsEmpty(@RawImage,true)))
and (RawImage.Mask<>nil) then begin
{$IFDEF VerboseRawImage}
writeln('TgtkObject.CreateBitmapFromRawImage creating mask .. ');
{$ENDIF}
GdiObject^.GDIBitmapMaskObject :=
gdk_bitmap_create_from_data(DefGdkWindow,PGChar(RawImage.Mask),
RawImage.Description.Width, RawImage.Description.Height);
@ -8687,6 +8691,9 @@ end;
{ =============================================================================
$Log$
Revision 1.335 2004/02/28 00:34:36 mattias
fixed CreateComponent for buttons, implemented basic Drag And Drop
Revision 1.334 2004/02/23 23:15:14 mattias
improved FindDragTarget

64
lcl/intfgraphics.pas
View File

@ -31,8 +31,8 @@ unit IntfGraphics;
interface
uses
Classes, SysUtils, fpImage, FPCAdds, AvgLvlTree, LCLType, LCLProc, GraphType,
LCLIntf;
Classes, SysUtils, fpImage, FPReadBMP, BMPComn, FPCAdds, AvgLvlTree, LCLType,
LCLProc, GraphType, LCLIntf;
type
{ TLazIntfImage }
@ -300,6 +300,17 @@ type
property NibblesPerSample: word read FNibblesPerSample
write SetNibblesPerSample;
end;
{$IFNDEF VER1_0_10}
{ TLazReaderBMP }
{ This is an imroved FPImage writer for bmp images. }
TLazReaderBMP = class(TFPReaderBMP)
protected
procedure SetupRead(nPalette, nRowBits: Integer; Stream : TStream); override;
procedure WriteScanLine(Row: Integer; Img: TFPCustomImage); override;
end;
{$ENDIF}
function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string;
@ -1318,6 +1329,12 @@ end;
procedure TLazIntfImage.SetInternalColor(x, y: integer; const Value: TFPColor);
begin
{if (x=0) and (y=0) then begin
// a common bug in the readers is that Alpha is reversed
writeln('TLazIntfImage.SetInternalColor ',x,',',y,' ',Value.Red,',',Value.Green,',',Value.Blue,',',Value.Alpha);
if Value.Alpha<>alphaOpaque then
RaiseGDBException('');
end;}
OnSetInternalColor(x,y,Value);
end;
@ -2804,6 +2821,49 @@ begin
Root.ConsistencyCheck;
end;
{$IFNDEF VER1_0_10}
{ TLazReaderBMP }
procedure TLazReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream: TStream
);
var
i: Integer;
begin
inherited SetupRead(nPalette, nRowBits, Stream);
// workaround for palette bug in FPReadBMP
for i:=0 to nPalette-1 do begin
FPalette[i].Alpha:=$ffff-FPalette[i].Alpha;
end;
end;
procedure TLazReaderBMP.WriteScanLine(Row: Integer; Img: TFPCustomImage);
// workaround for alpha value bug in FPReadBMP
function BmpRGBAToFPColor(Const RGBA: TColorRGBA) : TFPcolor;
var
NewAlpha: Byte;
begin
with Result, RGBA do
begin
Red :=(R shl 8) or R;
Green :=(G shl 8) or G;
Blue :=(B shl 8) or B;
NewAlpha:=255-A;
alpha :=(NewAlpha shl 8) or NewAlpha;
end;
end;
var
Column: Integer;
begin
if BFI.BitCount=32 then begin
for Column:=0 to img.Width-1 do
img.colors[Column,Row]:=BmpRGBAToFPColor(PColorRGBA(LineBuf)[Column]);
end else
inherited WriteScanLine(Row, Img);
end;
{$ENDIF}
//------------------------------------------------------------------------------
procedure InternalInit;
var