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

lcl: remove TWidgetset.DrawArrow which got a TArrow control and TCanvas as arguments, move some implementations to TWSArrow classes

Browse Source 
git-svn-id: trunk@23626 -
This commit is contained in:
paul 2010-02-04 04:06:00 +00:00
parent 9adc8929ff
commit 88d281329b
19 changed files with 134 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
lcl/arrow.pp
View File

@ -57,7 +57,6 @@ type
class function GetControlClassDefaultSize: TPoint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Loaded; override;
procedure InitializeWnd; override;
published
@ -102,11 +101,6 @@ begin
SetInitialBounds(0,0,GetControlClassDefaultSize.X,GetControlClassDefaultSize.Y);
end;
destructor TArrow.Destroy;
begin
inherited;
end;
procedure TArrow.Loaded;
begin
inherited Loaded;
@ -115,7 +109,7 @@ end;
procedure TArrow.Paint;
begin
WidgetSet.DrawArrow(Self, Canvas);
TWSArrowClass(WidgetSetClass).DrawArrow(Self, Canvas);
inherited Paint;
end;

4
lcl/include/intfbaselcl.inc
View File

@ -126,10 +126,6 @@ begin
end;
procedure TWidgetSet.DrawArrow(Arrow: TComponent; Canvas: TPersistent);
begin
end;
procedure TWidgetSet.DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation);
procedure DefaultDockImage(ARect: TRect);

5
lcl/include/lclintf.inc
View File

@ -123,11 +123,6 @@ begin
WidgetSet.DeallocateHWnd(Wnd);
end;
procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent);
begin
WidgetSet.DrawArrow(Arrow, Canvas);
end;
procedure DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation);
begin
WidgetSet.DrawDefaultDockImage(AOldRect, ANewRect, AOperation);

1
lcl/include/lclintfh.inc
View File

@ -60,7 +60,6 @@ function CreateStandardCursor(ACursor: SmallInt): hCursor; {$IFDEF IF_BASE_MEMBE
function DCClipRegionValid(DC: HDC): boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
procedure DeallocateHWnd(Wnd: HWND); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
procedure DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
procedure DrawGrid(DC: HDC; const R: TRect; DX, DY: Integer); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}

58
lcl/interfaces/carbon/carbonlclintf.inc
View File

@ -57,64 +57,6 @@ begin
{$ENDIF}
end;
{------------------------------------------------------------------------------
Method: DrawArrow
Params: Arrow - LCL arrow
Canvas - LCL canvas
Draws the arrow on the specified canvas
------------------------------------------------------------------------------}
procedure TCarbonWidgetSet.DrawArrow(Arrow: TComponent; Canvas: TPersistent);
var
ArrowCanvas: TCanvas;
P: Array [0..2] of TPoint;
R: TRect;
S: Integer;
begin
{$IFDEF VerboseLCLIntf}
DebugLn('TCarbonWidgetSet.DrawArrow Arrow: ' + DbgS(Arrow));
{$ENDIF}
R := TControl(Arrow).ClientRect;
InflateRect(R, -1, -1);
// arrow bounds are square
S := Min(R.Right - R.Left, R.Bottom - R.Top);
R := Bounds((R.Left + R.Right - S) div 2, (R.Top + R.Bottom - S) div 2, S, S);
ArrowCanvas := TCanvas(Canvas);
ArrowCanvas.Brush.Color := clBlack;
ArrowCanvas.Pen.Color := clBlack;
case Ord(TArrow(Arrow).ArrowType) of
0: // up
begin
P[0] := Classes.Point(R.Left, R.Bottom);
P[1] := Classes.Point((R.Left + R.Right) div 2, R.Top);
P[2] := R.BottomRight;
end;
1: // down
begin
P[0] := R.TopLeft;
P[1] := Classes.Point(R.Right, R.Top);
P[2] := Classes.Point((R.Left + R.Right) div 2, R.Bottom);
end;
2: // left
begin
P[0] := R.BottomRight;
P[1] := Classes.Point(R.Left, (R.Top + R.Bottom) div 2);
P[2] := Classes.Point(R.Right, R.Top);
end;
3: // right
begin
P[0] := R.TopLeft;
P[1] := Classes.Point(R.Right, (R.Top + R.Bottom) div 2);
P[2] := Classes.Point(R.Left, R.Bottom);
end;
end;
ArrowCanvas.Polygon(P);
end;
{------------------------------------------------------------------------------
Method: DrawGrid
Params: DC - Handle to device context

1
lcl/interfaces/carbon/carbonlclintfh.inc
View File

@ -28,7 +28,6 @@
//##apiwiz##sps## // Do not remove
function CreateStandardCursor(ACursor: SmallInt): hCursor; override;
procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); override;
procedure DrawGrid(DC: HDC; const R: TRect; DX, DY: Integer); override;
function ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect;

1
lcl/interfaces/fpgui/fpguilclintfh.inc
View File

@ -38,7 +38,6 @@ function AllocateHWnd(Method: TLCLWndMethod): HWND; override;
function CreateStandardCursor(ACursor: SmallInt): hCursor; override;
procedure DeallocateHWnd(Wnd: HWND); override;
procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); override;
procedure DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation); override;
function ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect;

37
lcl/interfaces/qt/qtlclintf.inc
View File

@ -109,43 +109,6 @@ begin
Result := HCURSOR(TQtCursor.Create(CursorShape));
end;
{------------------------------------------------------------------------------
Function: DrawArrow
Params:
Returns:
------------------------------------------------------------------------------}
procedure TQtWidgetSet.DrawArrow(Arrow: TComponent; Canvas: TPersistent);
const
QtArrowTypeMap: array[TArrowType] of QStylePrimitiveElement =
(
{atUp } QStylePE_IndicatorArrowUp,
{atDown } QStylePE_IndicatorArrowDown,
{atLeft } QStylePE_IndicatorArrowLeft,
{atRight} QStylePE_IndicatorArrowRight
);
var
DC: TQtDeviceContext;
ARect: TRect;
StyleOption: QStyleOptionH;
begin
DC := TQtDeviceContext(TCanvas(Canvas).Handle);
ARect := TControl(Arrow).ClientRect;
StyleOption := QStyleOption_create(1, integer(QStyleOptionSO_Default));
try
// I dont know the reason, but under windows down arrow size is very small
// and is not dependent on passed ARect.
// There is nothing in qt source that can cause such bad painting.
// Other styles draw down arrow very well.
QStyleOption_initFrom(StyleOption, DC.Parent);
QStyleOption_setRect(StyleOption, @ARect);
QStyle_drawPrimitive(QApplication_style, QtArrowTypeMap[TArrow(Arrow).ArrowType],
StyleOption, DC.Widget, DC.Parent);
finally
QStyleOption_destroy(StyleOption);
end;
end;
procedure TQtWidgetSet.DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation);
begin
if FDockImage = nil then

1
lcl/interfaces/qt/qtlclintfh.inc
View File

@ -39,7 +39,6 @@ function AddProcessEventHandler(AHandle: THandle;
function CreateEmptyRegion: hRGN; override;
function CreateStandardCursor(ACursor: SmallInt): HCURSOR; override;
procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); override;
procedure DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation); override;
procedure DrawGrid(DC: HDC; const R: TRect; DX, DY: Integer); override;

38
lcl/interfaces/qt/qtwsarrow.pp
View File

@ -29,9 +29,10 @@ interface
{$I qtdefines.inc}
uses
Types,
// Bindings
qt4,
qtwidgets,
qtwidgets, qtobjects,
// LCL
SysUtils, Controls, LCLType, LCLProc, Graphics, Arrow,
////////////////////////////////////////////////////
@ -47,6 +48,8 @@ type
const AParams: TCreateParams): TLCLIntfHandle; override;
class procedure SetType(const AArrow: TArrow; const AArrowType: TArrowType;
const AShadowType: TShadowType); override;
class procedure DrawArrow(const AArrow: TArrow; const ACanvas: TCanvas);
override;
end;
@ -93,4 +96,37 @@ begin
QtArrow.ArrowType := Ord(AArrowType);
end;
class procedure TQtWSArrow.DrawArrow(const AArrow: TArrow;
const ACanvas: TCanvas);
const
QtArrowTypeMap: array[TArrowType] of QStylePrimitiveElement =
(
{atUp } QStylePE_IndicatorArrowUp,
{atDown } QStylePE_IndicatorArrowDown,
{atLeft } QStylePE_IndicatorArrowLeft,
{atRight} QStylePE_IndicatorArrowRight
);
var
DC: TQtDeviceContext;
ARect: TRect;
StyleOption: QStyleOptionH;
begin
DC := TQtDeviceContext(ACanvas.Handle);
ARect := AArrow.ClientRect;
StyleOption := QStyleOption_create(1, integer(QStyleOptionSO_Default));
try
// I dont know the reason, but under windows down arrow size is very small
// and is not dependent on passed ARect.
// There is nothing in qt source that can cause such bad painting.
// Other styles draw down arrow very well.
QStyleOption_initFrom(StyleOption, DC.Parent);
QStyleOption_setRect(StyleOption, @ARect);
QStyle_drawPrimitive(QApplication_style, QtArrowTypeMap[AArrow.ArrowType],
StyleOption, DC.Widget, DC.Parent);
finally
QStyleOption_destroy(StyleOption);
end;
end;
end.

2
lcl/interfaces/win32/win32int.pp
View File

@ -249,7 +249,7 @@ uses
Win32WSStdCtrls,
Win32Themes,
////////////////////////////////////////////////////
Arrow, Calendar, {CheckLst, }Win32Extra, LclProc, LCLMessageGlue;
Calendar, Win32Extra, LclProc, LCLMessageGlue;
type
TMouseDownFocusStatus = (mfNone, mfFocusSense, mfFocusChanged);

27
lcl/interfaces/win32/win32lclintf.inc
View File

@ -294,33 +294,6 @@ begin
if Assigned(PMethod) then Freemem(PMethod);
end;
{------------------------------------------------------------------------------
Procedure:
Params:
Returns:
------------------------------------------------------------------------------}
procedure TWin32WidgetSet.DrawArrow(Arrow: TComponent; Canvas: TPersistent);
const
{ up, down, left, right }
ArrowTypeToState: array[TArrowType] of dword = (DFCS_SCROLLUP, DFCS_SCROLLDOWN,
DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT);
var
drawRect: Windows.RECT;
canvasHandle: HDC;
begin
drawRect := TControl(Arrow).ClientRect;
canvasHandle := TCanvas(Canvas).Handle;
Windows.FillRect(canvasHandle, drawRect, GetSysColorBrush(COLOR_BTNFACE));
dec(drawRect.Left, 2);
dec(drawRect.Top, 2);
inc(drawRect.Right, 2);
inc(drawRect.Bottom, 2);
Windows.DrawFrameControl(TCanvas(Canvas).Handle, drawRect,
DFC_SCROLL, ArrowTypeToState[TArrow(Arrow).ArrowType]);
end;
procedure TWin32WidgetSet.DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation);
const
LineSize = 4;

1
lcl/interfaces/win32/win32lclintfh.inc
View File

@ -40,7 +40,6 @@ function AllocateHWnd(Method: TLCLWndMethod): HWND; override;
function CreateStandardCursor(ACursor: SmallInt): hCursor; override;
procedure DeallocateHWnd(Wnd: HWND); override;
procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); override;
procedure DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation); override;
procedure DrawGrid(DC: HDC; const R: TRect; DX, DY: Integer); override;

23
lcl/interfaces/win32/win32wsarrow.pp
View File

@ -33,7 +33,7 @@ uses
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
Arrow,
Windows, Arrow, Graphics,
////////////////////////////////////////////////////
WSArrow, WSLCLClasses;
@ -45,6 +45,7 @@ type
published
class procedure SetType(const AArrow: TArrow; const AArrowType: TArrowType;
const AShadowType: TShadowType); override;
class procedure DrawArrow(const AArrow: TArrow; const ACanvas: TCanvas); override;
end;
@ -58,4 +59,24 @@ begin
// TODO: implement me!
end;
class procedure TWin32WSArrow.DrawArrow(const AArrow: TArrow;
const ACanvas: TCanvas);
const
{ up, down, left, right }
ArrowTypeToState: array[TArrowType] of dword = (DFCS_SCROLLUP, DFCS_SCROLLDOWN,
DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT);
var
drawRect: Windows.RECT;
canvasHandle: HDC;
begin
drawRect := AArrow.ClientRect;
canvasHandle := ACanvas.Handle;
Windows.FillRect(canvasHandle, drawRect, GetSysColorBrush(COLOR_BTNFACE));
dec(drawRect.Left, 2);
dec(drawRect.Top, 2);
inc(drawRect.Right, 2);
inc(drawRect.Bottom, 2);
Windows.DrawFrameControl(canvasHandle, drawRect, DFC_SCROLL, ArrowTypeToState[AArrow.ArrowType]);
end;
end.

2
lcl/interfaces/wince/winceint.pp
View File

@ -262,7 +262,7 @@ uses
WinCEWSStdCtrls,
WinCEWSSpin,
////////////////////////////////////////////////////
Arrow, Spin, CheckLst, LCLProc, LCLMessageGlue;
Spin, CheckLst, LCLProc, LCLMessageGlue;
type
TMouseDownFocusStatus = (mfNone, mfFocusSense, mfFocusChanged);

22
lcl/interfaces/wince/wincelclintf.inc
View File

@ -15,7 +15,7 @@
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
@ -466,26 +466,6 @@ begin
end;
end;
procedure TWinCEWidgetSet.DrawArrow(Arrow: TComponent; Canvas: TPersistent);
const
{ up, down, left, right }
ArrowTypeToState: array[TArrowType] of dword = (DFCS_SCROLLUP, DFCS_SCROLLDOWN,
DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT);
var
drawRect: Windows.RECT;
canvasHandle: HDC;
begin
drawRect := TControl(Arrow).ClientRect;
canvasHandle := TCanvas(Canvas).Handle;
Windows.FillRect(canvasHandle, drawRect, GetSysColorBrush(COLOR_BTNFACE or SYS_COLOR_INDEX_FLAG));
dec(drawRect.Left, 2);
dec(drawRect.Top, 2);
inc(drawRect.Right, 2);
inc(drawRect.Bottom, 2);
Windows.DrawFrameControl(TCanvas(Canvas).Handle, @drawRect,
DFC_SCROLL, ArrowTypeToState[TArrow(Arrow).ArrowType]);
end;
{------------------------------------------------------------------------------
Function: GetAcceleratorString
Params: AVKey:

4
lcl/interfaces/wince/wincelclintfh.inc
View File

@ -16,7 +16,7 @@
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
@ -37,8 +37,6 @@ function AddProcessEventHandler(AHandle: THandle;
function CreateStandardCursor(ACursor: SmallInt): hCursor; override;
procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); override;
function GetAcceleratorString(const AVKey: Byte; const AShiftState: TShiftState): String; override;
function GetControlConstraints(Constraints: TObject): boolean; override;
function GetDeviceSize(DC: HDC; var p: TPoint): boolean; override;

23
lcl/interfaces/wince/wincewsarrow.pp
View File

@ -32,7 +32,7 @@ uses
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
Arrow,
Windows, Arrow, Graphics,
////////////////////////////////////////////////////
WSArrow, WSLCLClasses;
@ -44,6 +44,7 @@ type
published
class procedure SetType(const AArrow: TArrow; const AArrowType: TArrowType;
const AShadowType: TShadowType); override;
class procedure DrawArrow(const AArrow: TArrow; const ACanvas: TCanvas); override;
end;
@ -57,4 +58,24 @@ begin
// TODO: implement me!
end;
class procedure TWinCEWSArrow.DrawArrow(const AArrow: TArrow;
const ACanvas: TCanvas);
const
{ up, down, left, right }
ArrowTypeToState: array[TArrowType] of dword = (DFCS_SCROLLUP, DFCS_SCROLLDOWN,
DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT);
var
drawRect: Windows.RECT;
canvasHandle: HDC;
begin
drawRect := AArrow.ClientRect;
canvasHandle := ACanvas.Handle;
Windows.FillRect(canvasHandle, drawRect, GetSysColorBrush(COLOR_BTNFACE or SYS_COLOR_INDEX_FLAG));
dec(drawRect.Left, 2);
dec(drawRect.Top, 2);
inc(drawRect.Right, 2);
inc(drawRect.Bottom, 2);
Windows.DrawFrameControl(canvasHandle, @drawRect, DFC_SCROLL, ArrowTypeToState[AArrow.ArrowType]);
end;
end.

49
lcl/widgetset/wsarrow.pp
View File

@ -44,7 +44,7 @@ uses
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
Arrow,
Types, Math, Arrow, Graphics,
////////////////////////////////////////////////////
WSLCLClasses, WSControls, WSFactory;
@ -56,6 +56,7 @@ type
published
class procedure SetType(const AArrow: TArrow; const AArrowType: TArrowType;
const AShadowType: TShadowType); virtual;
class procedure DrawArrow(const AArrow: TArrow; const ACanvas: TCanvas); virtual;
end;
{ WidgetSetRegistration }
@ -71,6 +72,52 @@ class procedure TWSArrow.SetType(const AArrow: TArrow; const AArrowType: TArrowT
begin
end;
class procedure TWSArrow.DrawArrow(const AArrow: TArrow;
const ACanvas: TCanvas);
var
P: Array [0..2] of TPoint;
R: TRect;
S: Integer;
begin
R := AArrow.ClientRect;
InflateRect(R, -1, -1);
// arrow bounds are square
S := Min(R.Right - R.Left, R.Bottom - R.Top);
R := Bounds((R.Left + R.Right - S) div 2, (R.Top + R.Bottom - S) div 2, S, S);
ACanvas.Brush.Color := clBlack;
ACanvas.Pen.Color := clBlack;
case Ord(AArrow.ArrowType) of
0: // up
begin
P[0] := Point(R.Left, R.Bottom);
P[1] := Point((R.Left + R.Right) div 2, R.Top);
P[2] := R.BottomRight;
end;
1: // down
begin
P[0] := R.TopLeft;
P[1] := Point(R.Right, R.Top);
P[2] := Point((R.Left + R.Right) div 2, R.Bottom);
end;
2: // left
begin
P[0] := R.BottomRight;
P[1] := Point(R.Left, (R.Top + R.Bottom) div 2);
P[2] := Point(R.Right, R.Top);
end;
3: // right
begin
P[0] := R.TopLeft;
P[1] := Point(R.Right, (R.Top + R.Bottom) div 2);
P[2] := Point(R.Left, R.Bottom);
end;
end;
ACanvas.Polygon(P);
end;
{ WidgetSetRegistration }
procedure RegisterArrow;