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

lcl:

Browse Source 
- add rubberband component
- add qt rubberband implementation

git-svn-id: trunk@11954 -
This commit is contained in:
paul 2007-09-07 16:39:27 +00:00
parent ca365cd4ff
commit 297ed60657
7 changed files with 290 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -2588,6 +2588,7 @@ lcl/include/radiogroup.inc svneol=native#text/pascal
lcl/include/reginifile.inc svneol=native#text/pascal
lcl/include/region.inc svneol=native#text/pascal
lcl/include/replacedialog.inc svneol=native#text/plain
lcl/include/rubberband.inc svneol=native#text/plain
lcl/include/screen.inc svneol=native#text/pascal
lcl/include/scrollbar.inc svneol=native#text/pascal
lcl/include/scrollbox.inc svneol=native#text/pascal
@ -2846,6 +2847,7 @@ lcl/interfaces/qt/qtwscomctrls.pp svneol=native#text/pascal
lcl/interfaces/qt/qtwscontrols.pp svneol=native#text/pascal
lcl/interfaces/qt/qtwsdbctrls.pp svneol=native#text/pascal
lcl/interfaces/qt/qtwsdbgrids.pp svneol=native#text/pascal
lcl/interfaces/qt/qtwsdesigner.pp svneol=native#text/pascal
lcl/interfaces/qt/qtwsdialogs.pp svneol=native#text/pascal
lcl/interfaces/qt/qtwsdirsel.pp svneol=native#text/pascal
lcl/interfaces/qt/qtwseditbtn.pp svneol=native#text/pascal
@ -2986,6 +2988,7 @@ lcl/postscriptcanvas.pas svneol=native#text/pascal
lcl/postscriptprinter.pas svneol=native#text/pascal
lcl/printers.pas svneol=native#text/pascal
lcl/propertystorage.pas svneol=native#text/pascal
lcl/rubberband.pas svneol=native#text/pascal
lcl/spin.pp svneol=native#text/pascal
lcl/stdactns.pas svneol=native#text/pascal
lcl/stdctrls.pp svneol=native#text/pascal
@ -3042,6 +3045,7 @@ lcl/widgetset/wscomctrls.pp svneol=native#text/pascal
lcl/widgetset/wscontrols.pp svneol=native#text/pascal
lcl/widgetset/wsdbctrls.pp svneol=native#text/pascal
lcl/widgetset/wsdbgrids.pp svneol=native#text/pascal
lcl/widgetset/wsdesigner.pp svneol=native#text/pascal
lcl/widgetset/wsdialogs.pp svneol=native#text/pascal
lcl/widgetset/wsdirsel.pp svneol=native#text/pascal
lcl/widgetset/wseditbtn.pp svneol=native#text/pascal

5
lcl/alllclunits.pp
View File

@ -50,6 +50,7 @@ uses
PropertyStorage, IniPropStorage, XMLPropStorage, Chart, LDockTree, LDockCtrl,
CalendarPopup, Themes,
LCLMessageGlue,
RubberBand,
// widgetset skeleton
WSActnList, WSArrow, WSButtons, WSCalendar,
WSCheckLst, WSCListBox, WSComCtrls, WSControls,
@ -58,7 +59,8 @@ uses
WSForms, WSGrids, WSImgList, WSMaskEdit,
WSMenus, WSPairSplitter, WSSpin, WSStdCtrls,
WSToolwin,
WSProc
WSProc,
WSDesigner
{$ifdef TRANSLATESTRING}
,DefaultTranslator
{$ENDIF};
@ -69,3 +71,4 @@ end.

42
lcl/include/rubberband.inc Normal file
View File

@ -0,0 +1,42 @@
{%MainUnit ../RubberBand.pas}
{******************************************************************************
TCustomRubberBand
******************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL, 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. *
* *
*****************************************************************************
}
{ TCustomRubberBand }
function TCustomRubberBand.GetShape: TRubberBandShape;
begin
Result := FShape;
end;
procedure TCustomRubberBand.SetShape(const AValue: TRubberBandShape);
begin
if FShape = AValue then
Exit;
FShape := AValue;
if HandleAllocated then
TWsCustomRubberBandClass(WidgetsetClass).SetShape(Self, FShape);
end;
constructor TCustomRubberBand.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FShape := rbsLine;
end;

1
lcl/interfaces/qt/qtint.pp
View File

@ -172,6 +172,7 @@ uses
// QtWSToolwin,
QtCaret,
QtThemes,
QtWsDesigner,
////////////////////////////////////////////////////
Graphics, buttons, Menus,
// Bindings

104
lcl/interfaces/qt/qtwsdesigner.pp Normal file
View File

@ -0,0 +1,104 @@
{ $Id: qtwsdesigner.pp 11897 2007-09-01 02:46:24Z marc $}
{
*****************************************************************************
* QtWSDesigner.pp *
* ------------ *
* *
* *
*****************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL, 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. *
* *
*****************************************************************************
}
unit QtWSDesigner;
{$mode objfpc}{$H+}
interface
////////////////////////////////////////////////////
// I M P O R T A N T
////////////////////////////////////////////////////
// 1) Only class methods allowed
// 2) Class methods have to be published and virtual
// 3) To get as little as posible circles, the uses
// clause should contain only those LCL units
// needed for registration. WSxxx units are OK
// 4) To improve speed, register only classes in the
// initialization section which actually
// implement something
// 5) To enable your XXX widgetset units, look at
// the uses clause of the XXXintf.pp
////////////////////////////////////////////////////
uses
// Bindings
{$ifdef USE_QT_4_3}
qt43,
{$else}
qt4,
{$endif}
qtwidgets,
// LCL
Classes, Controls, RubberBand, LCLType,
// Widgetset
WsLCLClasses, WsControls, WsDesigner, WsProc;
type
{ TWsCustomRubberBand }
{ TQtWsCustomRubberBand }
TQtWsCustomRubberBand = class(TWsCustomRubberBand)
class function CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle; override;
class procedure SetShape(ARubberBand: TCustomRubberBand; AShape: TRubberBandShape); override;
end;
implementation
const
RubberBandShapeMap: array[TRubberBandShape] of QRubberBandShape =
(
QRubberBandLine,
QRubberBandRectangle
);
{ TQtWsCustomRubberBand }
class function TQtWsCustomRubberBand.CreateHandle(
const AWinControl: TWinControl; const AParams: TCreateParams
): TLCLIntfHandle;
var
QtRubberBand: TQtRubberBand;
begin
QtRubberBand := TQtRubberBand.Create(AWinControl, AParams);
QtRubberBand.AttachEvents;
QtRubberBand.setShape(RubberBandShapeMap[TCustomRubberBand(AWinControl).Shape]);
Result := THandle(QtRubberBand);
end;
class procedure TQtWsCustomRubberBand.SetShape(ARubberBand: TCustomRubberBand;
AShape: TRubberBandShape);
begin
if not WSCheckHandleAllocated(ARubberBand, 'SetShape') then
Exit;
TQtRubberBand(ARubberBand.Handle).setShape(RubberBandShapeMap[AShape]);
end;
initialization
////////////////////////////////////////////////////
// To improve speed, register only classes
// which actually implement something
////////////////////////////////////////////////////
RegisterWSComponent(TCustomRubberBand, TQtWSCustomRubberBand);
////////////////////////////////////////////////////
end.

64
lcl/rubberband.pas Normal file
View File

@ -0,0 +1,64 @@
{
/***************************************************************************
rubberband.pas
----------
Component Library TCustomRubberBand, TRubberBand Controls
Initial Revision : Wed Aug 5 09:27:00 GMT+07 2007
***************************************************************************/
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL, 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. *
* *
*****************************************************************************
}
unit RubberBand;
{$mode objfpc}{$H+}
interface
uses
Classes, Controls;
type
TRubberBandShape =
(
rbsLine,
rbsRectangle
);
{ TCustomRubberBand }
TCustomRubberBand = class(TWinControl)
private
FShape: TRubberBandShape;
function GetShape: TRubberBandShape;
procedure SetShape(const AValue: TRubberBandShape);
public
constructor Create(AOwner: TComponent); override;
property Shape: TRubberBandShape read GetShape write SetShape default rbsLine;
end;
TRubberBand = class(TCustomRubberBand)
end;
implementation
uses
WSDesigner;
{$I rubberband.inc}
end.

71
lcl/widgetset/wsdesigner.pp Normal file
View File

@ -0,0 +1,71 @@
{ $Id: wsdesigner.pp 11897 2007-09-01 02:46:24Z marc $}
{
*****************************************************************************
* WSDesigner.pp *
* ------------ *
* *
* *
*****************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL, 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. *
* *
*****************************************************************************
}
unit WSDesigner;
{$mode objfpc}{$H+}
interface
////////////////////////////////////////////////////
// I M P O R T A N T
////////////////////////////////////////////////////
// 1) Only class methods allowed
// 2) Class methods have to be published and virtual
// 3) To get as little as posible circles, the uses
// clause should contain only those LCL units
// needed for registration. WSxxx units are OK
// 4) To improve speed, register only classes in the
// initialization section which actually
// implement something
// 5) To enable your XXX widgetset units, look at
// the uses clause of the XXXintf.pp
////////////////////////////////////////////////////
uses
Classes, RubberBand,
WsControls;
type
{ TWsCustomRubberBand }
TWsCustomRubberBand = class(TWsWinControl)
class procedure SetShape(ARubberBand: TCustomRubberBand; AShape: TRubberBandShape); virtual;
end;
TWsCustomRubberBandClass = class of TWsCustomRubberBand;
implementation
{ TWsCustomRubberBand }
class procedure TWsCustomRubberBand.SetShape(ARubberBand: TCustomRubberBand;
AShape: TRubberBandShape);
begin
end;
initialization
////////////////////////////////////////////////////
// To improve speed, register only classes
// which actually implement something
////////////////////////////////////////////////////
// RegisterWSComponent(TCustomRubberBand, TWSCustomRubberBand);
////////////////////////////////////////////////////
end.