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

LCL: Allow changing background Color of TArrow. Compile with define NewArrow. Issue #21117, modified from Tomasz Wieckowski's patch

Browse Source 
git-svn-id: trunk@40947 -
This commit is contained in:
juha 2013-04-30 09:17:21 +00:00
parent 73e5bae873
commit aa38f3a4f4
5 changed files with 103 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
lcl/arrow.pp
View File

@ -33,7 +33,7 @@ unit Arrow;
interface
uses
Types, SysUtils, Classes, LCLType, Controls;
Types, SysUtils, Classes, LCLType, Controls, Graphics;
type
@ -98,6 +98,7 @@ begin
fCompStyle := csArrow;
fArrowType := atLeft;
fShadowType := stEtchedIn;
Canvas.Brush.Color := clBtnFace;
with GetControlClassDefaultSize do
SetInitialBounds(0, 0, CX, CY);
end;

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

@ -34,7 +34,7 @@ uses
qt4,
qtwidgets, qtobjects,
// LCL
SysUtils, Controls, LCLType, LCLProc, Graphics, Arrow,
SysUtils, Controls, LCLType, Graphics, Arrow,
////////////////////////////////////////////////////
WSArrow, WSLCLClasses;
@ -48,8 +48,9 @@ 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;
{$IFnDEF NewArrow}
class procedure DrawArrow(const AArrow: TArrow; const ACanvas: TCanvas); override;
{$ENDIF}
end;
@ -96,8 +97,8 @@ begin
QtArrow.ArrowType := Ord(AArrowType);
end;
class procedure TQtWSArrow.DrawArrow(const AArrow: TArrow;
const ACanvas: TCanvas);
{$IFnDEF NewArrow}
class procedure TQtWSArrow.DrawArrow(const AArrow: TArrow; const ACanvas: TCanvas);
const
QtArrowTypeMap: array[TArrowType] of QStylePrimitiveElement =
(
@ -128,5 +129,6 @@ begin
QStyleOption_destroy(StyleOption);
end;
end;
{$ENDIF}
end.

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

@ -45,7 +45,9 @@ type
published
class procedure SetType(const AArrow: TArrow; const AArrowType: TArrowType;
const AShadowType: TShadowType); override;
{$IFnDEF NewArrow}
class procedure DrawArrow(const AArrow: TArrow; const ACanvas: TCanvas); override;
{$ENDIF}
end;
@ -59,12 +61,11 @@ begin
// TODO: implement me!
end;
class procedure TWin32WSArrow.DrawArrow(const AArrow: TArrow;
const ACanvas: TCanvas);
{$IFnDEF NewArrow}
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);
ArrowTypeToState: array[TArrowType] of dword = // up, down, left, right
(DFCS_SCROLLUP, DFCS_SCROLLDOWN, DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT);
var
drawRect: Windows.RECT;
canvasHandle: HDC;
@ -78,5 +79,6 @@ begin
inc(drawRect.Bottom, 2);
Windows.DrawFrameControl(canvasHandle, drawRect, DFC_SCROLL, ArrowTypeToState[AArrow.ArrowType]);
end;
{$ENDIF}
end.

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

@ -41,7 +41,9 @@ type
published
class procedure SetType(const AArrow: TArrow; const AArrowType: TArrowType;
const AShadowType: TShadowType); override;
{$IFnDEF NewArrow}
class procedure DrawArrow(const AArrow: TArrow; const ACanvas: TCanvas); override;
{$ENDIF}
end;
@ -55,12 +57,11 @@ begin
// TODO: implement me!
end;
class procedure TWinCEWSArrow.DrawArrow(const AArrow: TArrow;
const ACanvas: TCanvas);
{$IFnDEF NewArrow}
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);
ArrowTypeToState: array[TArrowType] of dword = // up, down, left, right
(DFCS_SCROLLUP, DFCS_SCROLLDOWN, DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT);
var
drawRect: Windows.RECT;
canvasHandle: HDC;
@ -74,5 +75,6 @@ begin
inc(drawRect.Bottom, 2);
Windows.DrawFrameControl(canvasHandle, @drawRect, DFC_SCROLL, ArrowTypeToState[AArrow.ArrowType]);
end;
{$ENDIF}
end.

84
lcl/widgetset/wsarrow.pp
View File

@ -44,7 +44,7 @@ uses
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
Types, Math, Arrow, Graphics,
LCLProc, LCLIntf, LCLType, Math, Classes, Arrow, Graphics,
////////////////////////////////////////////////////
WSLCLClasses, WSControls, WSFactory;
@ -72,8 +72,84 @@ class procedure TWSArrow.SetType(const AArrow: TArrow; const AArrowType: TArrowT
begin
end;
class procedure TWSArrow.DrawArrow(const AArrow: TArrow;
const ACanvas: TCanvas);
{$IFDEF NewArrow}
class procedure TWSArrow.DrawArrow(const AArrow: TArrow; const ACanvas: TCanvas);
const
SpaceFactor = 5;
var
drawRect: TRect;
RegionHandle: HRGN;
Pt: array[0..2] of TPoint;
w, h, arrowSize1, arrowSize2, cx, cy, Space: integer;
begin
drawRect := AArrow.ClientRect;
w := drawRect.Right - drawRect.Left;
h := drawRect.Bottom - drawRect.Top;
Space := Min(w, h) div SpaceFactor;
Dec(w, Space * 2);
Dec(h, Space * 2);
arrowSize1 := min(w,h) - 2;
if (arrowSize1 mod 2) = 0 then Inc(arrowSize1);
arrowSize2 := (arrowSize1 div 2) + 1;
case AArrow.ArrowType of
atUp:
begin
cx := drawRect.Left + Space + (max((w-arrowSize1) div 2,0)) - 1;
cy := drawRect.Top + Space + (max((h-arrowSize2) div 2,0)) - 1;
Pt[0].x := cx + (arrowSize1 div 2) + 1;
Pt[0].y := cy;
Pt[1].x := cx + arrowSize1 + 1;
Pt[1].y := cy + arrowSize2 + 1;
Pt[2].X := cx;
Pt[2].y := cy + arrowSize2 + 1;
end;
atDown:
begin
cx := drawRect.Left + Space + (max((w-arrowSize1) div 2,0));
cy := drawRect.Top + Space + (max((h-arrowSize2) div 2,0)) + 1;
Pt[0].X := cx;
Pt[0].y := cy;
Pt[1].x := cx + arrowSize1;
Pt[1].y := cy;
Pt[2].x := cx + (arrowSize1 div 2);
Pt[2].y := cy + arrowSize2;
end;
atLeft:
begin
cx := drawRect.Left + Space + (max((w-arrowSize2) div 2,0)) - 1;
cy := drawRect.Top + Space + (max((h-arrowSize1) div 2,0));
Pt[0].X := cx + arrowSize2;
Pt[0].y := cy;
Pt[1].x := cx + arrowSize2;
Pt[1].y := cy + arrowSize1 + 1;
Pt[2].x := cx;
Pt[2].y := cy + (arrowSize1 div 2) + 1;
end;
atRight:
begin
cx := drawRect.Left + Space + (max((w-arrowSize2) div 2,0)) + 1;
cy := drawRect.Top + Space + (max((h-arrowSize1) div 2,0));
Pt[0].X := cx;
Pt[0].y := cy;
Pt[1].x := cx + arrowSize2;
Pt[1].y := cy + (arrowSize1 div 2) + 1;
Pt[2].x := cx;
Pt[2].y := cy + arrowSize1 + 1;
end;
else
exit;
end;
RegionHandle := CreatePolygonRgn(Pt, 3, ALTERNATE);
aCanvas.FillRect(drawRect); // Same as FillRect(aCanvas.Handle, drawRect, aCanvas.Brush.Reference.Handle);
// This FillRgn crashes with QT and does not work with GTK2
FillRgn(aCanvas.Handle, RegionHandle, aCanvas.Pen.Reference.Handle);
DeleteObject(RegionHandle);
end;
{$ELSE}
class procedure TWSArrow.DrawArrow(const AArrow: TArrow; const ACanvas: TCanvas);
var
P: Array [0..2] of TPoint;
R: TRect;
@ -114,9 +190,9 @@ begin
P[2] := Point(R.Left, R.Bottom);
end;
end;
ACanvas.Polygon(P);
end;
{$ENDIF}
{ WidgetSetRegistration }