From 88d281329bfd7d377f474556a81377bb06e5a57f Mon Sep 17 00:00:00 2001 From: paul Date: Thu, 4 Feb 2010 04:06:00 +0000 Subject: [PATCH] lcl: remove TWidgetset.DrawArrow which got a TArrow control and TCanvas as arguments, move some implementations to TWSArrow classes git-svn-id: trunk@23626 - --- lcl/arrow.pp | 8 +--- lcl/include/intfbaselcl.inc | 4 -- lcl/include/lclintf.inc | 5 -- lcl/include/lclintfh.inc | 1 - lcl/interfaces/carbon/carbonlclintf.inc | 58 ------------------------ lcl/interfaces/carbon/carbonlclintfh.inc | 1 - lcl/interfaces/fpgui/fpguilclintfh.inc | 1 - lcl/interfaces/qt/qtlclintf.inc | 37 --------------- lcl/interfaces/qt/qtlclintfh.inc | 1 - lcl/interfaces/qt/qtwsarrow.pp | 38 +++++++++++++++- lcl/interfaces/win32/win32int.pp | 2 +- lcl/interfaces/win32/win32lclintf.inc | 27 ----------- lcl/interfaces/win32/win32lclintfh.inc | 1 - lcl/interfaces/win32/win32wsarrow.pp | 23 +++++++++- lcl/interfaces/wince/winceint.pp | 2 +- lcl/interfaces/wince/wincelclintf.inc | 22 +-------- lcl/interfaces/wince/wincelclintfh.inc | 4 +- lcl/interfaces/wince/wincewsarrow.pp | 23 +++++++++- lcl/widgetset/wsarrow.pp | 49 +++++++++++++++++++- 19 files changed, 134 insertions(+), 173 deletions(-) diff --git a/lcl/arrow.pp b/lcl/arrow.pp index d94c6bf624..fbfaa2a1ef 100644 --- a/lcl/arrow.pp +++ b/lcl/arrow.pp @@ -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; diff --git a/lcl/include/intfbaselcl.inc b/lcl/include/intfbaselcl.inc index b819a1fe86..204cbd1db2 100644 --- a/lcl/include/intfbaselcl.inc +++ b/lcl/include/intfbaselcl.inc @@ -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); diff --git a/lcl/include/lclintf.inc b/lcl/include/lclintf.inc index 859e5fa923..0c9696f936 100644 --- a/lcl/include/lclintf.inc +++ b/lcl/include/lclintf.inc @@ -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); diff --git a/lcl/include/lclintfh.inc b/lcl/include/lclintfh.inc index b18e4ab58a..150743594d 100644 --- a/lcl/include/lclintfh.inc +++ b/lcl/include/lclintfh.inc @@ -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} diff --git a/lcl/interfaces/carbon/carbonlclintf.inc b/lcl/interfaces/carbon/carbonlclintf.inc index e62d8e335a..ee1e2d0b60 100644 --- a/lcl/interfaces/carbon/carbonlclintf.inc +++ b/lcl/interfaces/carbon/carbonlclintf.inc @@ -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 diff --git a/lcl/interfaces/carbon/carbonlclintfh.inc b/lcl/interfaces/carbon/carbonlclintfh.inc index 4ef4d596f4..de47d758b9 100644 --- a/lcl/interfaces/carbon/carbonlclintfh.inc +++ b/lcl/interfaces/carbon/carbonlclintfh.inc @@ -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; diff --git a/lcl/interfaces/fpgui/fpguilclintfh.inc b/lcl/interfaces/fpgui/fpguilclintfh.inc index a3289c5059..86bf20da84 100644 --- a/lcl/interfaces/fpgui/fpguilclintfh.inc +++ b/lcl/interfaces/fpgui/fpguilclintfh.inc @@ -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; diff --git a/lcl/interfaces/qt/qtlclintf.inc b/lcl/interfaces/qt/qtlclintf.inc index 01220544de..0496840aa1 100644 --- a/lcl/interfaces/qt/qtlclintf.inc +++ b/lcl/interfaces/qt/qtlclintf.inc @@ -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 diff --git a/lcl/interfaces/qt/qtlclintfh.inc b/lcl/interfaces/qt/qtlclintfh.inc index e8ab6328c2..3ddeba8151 100644 --- a/lcl/interfaces/qt/qtlclintfh.inc +++ b/lcl/interfaces/qt/qtlclintfh.inc @@ -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; diff --git a/lcl/interfaces/qt/qtwsarrow.pp b/lcl/interfaces/qt/qtwsarrow.pp index 267b8c6b26..8315eb5b4f 100644 --- a/lcl/interfaces/qt/qtwsarrow.pp +++ b/lcl/interfaces/qt/qtwsarrow.pp @@ -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. diff --git a/lcl/interfaces/win32/win32int.pp b/lcl/interfaces/win32/win32int.pp index 6ed6431ee1..1e73396c0c 100644 --- a/lcl/interfaces/win32/win32int.pp +++ b/lcl/interfaces/win32/win32int.pp @@ -249,7 +249,7 @@ uses Win32WSStdCtrls, Win32Themes, //////////////////////////////////////////////////// - Arrow, Calendar, {CheckLst, }Win32Extra, LclProc, LCLMessageGlue; + Calendar, Win32Extra, LclProc, LCLMessageGlue; type TMouseDownFocusStatus = (mfNone, mfFocusSense, mfFocusChanged); diff --git a/lcl/interfaces/win32/win32lclintf.inc b/lcl/interfaces/win32/win32lclintf.inc index 2cc3176726..fb6668311f 100644 --- a/lcl/interfaces/win32/win32lclintf.inc +++ b/lcl/interfaces/win32/win32lclintf.inc @@ -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; diff --git a/lcl/interfaces/win32/win32lclintfh.inc b/lcl/interfaces/win32/win32lclintfh.inc index 21fe7c24d6..9fd456a743 100644 --- a/lcl/interfaces/win32/win32lclintfh.inc +++ b/lcl/interfaces/win32/win32lclintfh.inc @@ -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; diff --git a/lcl/interfaces/win32/win32wsarrow.pp b/lcl/interfaces/win32/win32wsarrow.pp index 74a71b402c..332f01486d 100644 --- a/lcl/interfaces/win32/win32wsarrow.pp +++ b/lcl/interfaces/win32/win32wsarrow.pp @@ -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. diff --git a/lcl/interfaces/wince/winceint.pp b/lcl/interfaces/wince/winceint.pp index e9a937b680..7ebfdd9ce2 100644 --- a/lcl/interfaces/wince/winceint.pp +++ b/lcl/interfaces/wince/winceint.pp @@ -262,7 +262,7 @@ uses WinCEWSStdCtrls, WinCEWSSpin, //////////////////////////////////////////////////// - Arrow, Spin, CheckLst, LCLProc, LCLMessageGlue; + Spin, CheckLst, LCLProc, LCLMessageGlue; type TMouseDownFocusStatus = (mfNone, mfFocusSense, mfFocusChanged); diff --git a/lcl/interfaces/wince/wincelclintf.inc b/lcl/interfaces/wince/wincelclintf.inc index 09a2f7ee1a..db4f0508ff 100644 --- a/lcl/interfaces/wince/wincelclintf.inc +++ b/lcl/interfaces/wince/wincelclintf.inc @@ -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: diff --git a/lcl/interfaces/wince/wincelclintfh.inc b/lcl/interfaces/wince/wincelclintfh.inc index 9e31f79b43..55d74778f9 100644 --- a/lcl/interfaces/wince/wincelclintfh.inc +++ b/lcl/interfaces/wince/wincelclintfh.inc @@ -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; diff --git a/lcl/interfaces/wince/wincewsarrow.pp b/lcl/interfaces/wince/wincewsarrow.pp index 26ccff5a83..3f8074684a 100644 --- a/lcl/interfaces/wince/wincewsarrow.pp +++ b/lcl/interfaces/wince/wincewsarrow.pp @@ -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. diff --git a/lcl/widgetset/wsarrow.pp b/lcl/widgetset/wsarrow.pp index f76b5e4f93..55c2ef253b 100644 --- a/lcl/widgetset/wsarrow.pp +++ b/lcl/widgetset/wsarrow.pp @@ -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;