diff --git a/.gitattributes b/.gitattributes index f3aa33f9a7..7d74969ee3 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/components/gtk/gtkglarea/gtkglareacontrol.pas b/components/gtk/gtkglarea/gtkglareacontrol.pas index ffa9bf3876..4573189458 100644 --- a/components/gtk/gtkglarea/gtkglareacontrol.pas +++ b/components/gtk/gtkglarea/gtkglareacontrol.pas @@ -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; diff --git a/components/jpeg/lazjpeg.pas b/components/jpeg/lazjpeg.pas index 6a55f1a4b6..eedb521f9a 100644 --- a/components/jpeg/lazjpeg.pas +++ b/components/jpeg/lazjpeg.pas @@ -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); diff --git a/examples/gtkglarea/exampleform.pp b/examples/gtkglarea/exampleform.pp index abfca9e0d5..57f6549f3c 100644 --- a/examples/gtkglarea/exampleform.pp +++ b/examples/gtkglarea/exampleform.pp @@ -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} diff --git a/examples/gtkglarea/gtkglarea_demo.lpi b/examples/gtkglarea/gtkglarea_demo.lpi index cbbffa698b..179a15e894 100644 --- a/examples/gtkglarea/gtkglarea_demo.lpi +++ b/examples/gtkglarea/gtkglarea_demo.lpi @@ -1,70 +1,21 @@ - + - + + </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> diff --git a/lcl/comctrls.pp b/lcl/comctrls.pp index 1070dc3677..7c490e6849 100644 --- a/lcl/comctrls.pp +++ b/lcl/comctrls.pp @@ -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 diff --git a/lcl/controls.pp b/lcl/controls.pp index dad2e96cc3..edf17a50e5 100644 --- a/lcl/controls.pp +++ b/lcl/controls.pp @@ -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 diff --git a/lcl/graphtype.pp b/lcl/graphtype.pp index 30c6d5ebf6..4594c5fcf8 100644 --- a/lcl/graphtype.pp +++ b/lcl/graphtype.pp @@ -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 diff --git a/lcl/imglist.pp b/lcl/imglist.pp index a2ff041e70..0296b5b318 100644 --- a/lcl/imglist.pp +++ b/lcl/imglist.pp @@ -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 diff --git a/lcl/include/application.inc b/lcl/include/application.inc index a2b7687e0b..08b097f53e 100644 --- a/lcl/include/application.inc +++ b/lcl/include/application.inc @@ -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 diff --git a/lcl/include/basedragcontrolobject.inc b/lcl/include/basedragcontrolobject.inc index 25135b4790..db006a88c1 100644 --- a/lcl/include/basedragcontrolobject.inc +++ b/lcl/include/basedragcontrolobject.inc @@ -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; diff --git a/lcl/include/bitmap.inc b/lcl/include/bitmap.inc index 1c9a335c11..e6f375fca6 100644 --- a/lcl/include/bitmap.inc +++ b/lcl/include/bitmap.inc @@ -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 diff --git a/lcl/include/buttons.inc b/lcl/include/buttons.inc index cb5f4156d4..5fec866060 100644 --- a/lcl/include/buttons.inc +++ b/lcl/include/buttons.inc @@ -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 diff --git a/lcl/include/canvas.inc b/lcl/include/canvas.inc index 5ea5e4c001..7cfed233b0 100644 --- a/lcl/include/canvas.inc +++ b/lcl/include/canvas.inc @@ -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 diff --git a/lcl/include/control.inc b/lcl/include/control.inc index d073d6007d..5edfee6812 100644 --- a/lcl/include/control.inc +++ b/lcl/include/control.inc @@ -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 diff --git a/lcl/include/customform.inc b/lcl/include/customform.inc index abf9f80bcf..56634fc0c8 100644 --- a/lcl/include/customform.inc +++ b/lcl/include/customform.inc @@ -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 diff --git a/lcl/include/dragdock.inc b/lcl/include/dragdock.inc new file mode 100644 index 0000000000..c005ceecf3 --- /dev/null +++ b/lcl/include/dragdock.inc @@ -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 + + +} diff --git a/lcl/include/dragobject.inc b/lcl/include/dragobject.inc index 4a9e896d16..5c2022de30 100644 --- a/lcl/include/dragobject.inc +++ b/lcl/include/dragobject.inc @@ -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 } diff --git a/lcl/include/imglist.inc b/lcl/include/imglist.inc index 212c1cbdaa..b389f156f7 100644 --- a/lcl/include/imglist.inc +++ b/lcl/include/imglist.inc @@ -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 diff --git a/lcl/include/intfbaselcl.inc b/lcl/include/intfbaselcl.inc index b439c9d476..527865f561 100644 --- a/lcl/include/intfbaselcl.inc +++ b/lcl/include/intfbaselcl.inc @@ -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 diff --git a/lcl/include/speedbutton.inc b/lcl/include/speedbutton.inc index be62618635..0abcbf7cbb 100644 --- a/lcl/include/speedbutton.inc +++ b/lcl/include/speedbutton.inc @@ -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 diff --git a/lcl/include/treeview.inc b/lcl/include/treeview.inc index 66702a2f69..320b6ed691 100644 --- a/lcl/include/treeview.inc +++ b/lcl/include/treeview.inc @@ -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 diff --git a/lcl/include/wincontrol.inc b/lcl/include/wincontrol.inc index 4abfa3389e..f6d82bca1c 100644 --- a/lcl/include/wincontrol.inc +++ b/lcl/include/wincontrol.inc @@ -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 diff --git a/lcl/interfaces/gtk/gtklclintf.inc b/lcl/interfaces/gtk/gtklclintf.inc index a47476ea49..15be657791 100644 --- a/lcl/interfaces/gtk/gtklclintf.inc +++ b/lcl/interfaces/gtk/gtklclintf.inc @@ -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 diff --git a/lcl/interfaces/gtk/gtkobject.inc b/lcl/interfaces/gtk/gtkobject.inc index 8ecdaba45a..db33d692c1 100644 --- a/lcl/interfaces/gtk/gtkobject.inc +++ b/lcl/interfaces/gtk/gtkobject.inc @@ -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 diff --git a/lcl/interfaces/gtk/gtkproc.inc b/lcl/interfaces/gtk/gtkproc.inc index a017744c0e..093b31ce52 100644 --- a/lcl/interfaces/gtk/gtkproc.inc +++ b/lcl/interfaces/gtk/gtkproc.inc @@ -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 diff --git a/lcl/interfaces/gtk/gtkproc.pp b/lcl/interfaces/gtk/gtkproc.pp index 1eb12263e6..e9ede7b6c9 100644 --- a/lcl/interfaces/gtk/gtkproc.pp +++ b/lcl/interfaces/gtk/gtkproc.pp @@ -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); diff --git a/lcl/interfaces/gtk/gtkwinapi.inc b/lcl/interfaces/gtk/gtkwinapi.inc index d83c066d53..5d541f9e7b 100644 --- a/lcl/interfaces/gtk/gtkwinapi.inc +++ b/lcl/interfaces/gtk/gtkwinapi.inc @@ -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 diff --git a/lcl/intfgraphics.pas b/lcl/intfgraphics.pas index bae8ae8f2f..4f91439762 100644 --- a/lcl/intfgraphics.pas +++ b/lcl/intfgraphics.pas @@ -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