From 9d68a4809d706a9186e1a5c1e3229cf786e93f03 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Thu, 8 May 2014 22:44:52 +0000 Subject: [PATCH] fpspreadsheet: Improved painting of range-selected cells in TsWorksheetGrid, not perfect yet. git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3030 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../examples/fpsgrid/fpsgrid.lpi | 204 ++++++------------ .../fpspreadsheet/fpspreadsheetgrid.pas | 48 ++++- 2 files changed, 115 insertions(+), 137 deletions(-) diff --git a/components/fpspreadsheet/examples/fpsgrid/fpsgrid.lpi b/components/fpspreadsheet/examples/fpsgrid/fpsgrid.lpi index a98f36651..c643a1f40 100644 --- a/components/fpspreadsheet/examples/fpsgrid/fpsgrid.lpi +++ b/components/fpspreadsheet/examples/fpsgrid/fpsgrid.lpi @@ -107,7 +107,7 @@ - + @@ -116,7 +116,7 @@ - + @@ -128,9 +128,12 @@ - - - + + + + + + @@ -138,24 +141,21 @@ - + - - - + + + - + - - - - - - + + + @@ -224,22 +224,18 @@ - - - - - + + + - - - + @@ -252,8 +248,8 @@ - - + + @@ -266,11 +262,11 @@ - + - + @@ -291,31 +287,31 @@ - + - + - + - + - + - + @@ -497,128 +493,64 @@ + + + + + + + + - + - - + + - - + + - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + diff --git a/components/fpspreadsheet/fpspreadsheetgrid.pas b/components/fpspreadsheet/fpspreadsheetgrid.pas index 1f32ea198..ab53d5140 100644 --- a/components/fpspreadsheet/fpspreadsheetgrid.pas +++ b/components/fpspreadsheet/fpspreadsheetgrid.pas @@ -5,6 +5,12 @@ Grid component which can load and write data from / to FPSpreadsheet documents AUTHORS: Felipe Monteiro de Carvalho, Werner Pamler } + +{ To do: + - When Lazarus 1.4 comes out remove the workaround for the RGB2HLS bug in + FindNearestPaletteIndex. +} + unit fpspreadsheetgrid; {$mode objfpc}{$H+} @@ -42,6 +48,7 @@ type procedure SetFrozenRows(AValue: Integer); procedure SetShowGridLines(AValue: Boolean); procedure SetShowHeaders(AValue: Boolean); + protected { Protected declarations } procedure DefaultDrawCell(ACol, ARow: Integer; var ARect: TRect; AState: TGridDrawState); override; @@ -64,6 +71,7 @@ type property FrozenRows: Integer read FFrozenRows write SetFrozenRows; property ShowGridLines: Boolean read GetShowGridLines write SetShowGridLines default true; property ShowHeaders: Boolean read GetShowHeaders write SetShowHeaders default true; + public { public methods } constructor Create(AOwner: TComponent); override; @@ -143,6 +151,7 @@ type property PopupMenu; property RowCount; property ScrollBars; + property SelectedColor default $00E8E8E8; property ShowHint; property TabOrder; property TabStop; @@ -290,6 +299,22 @@ begin end; end; +function DimColorByPercent(c: TColor; APercentage: Integer) : TColor; +type + TRGBA = record R,G,B,A: Byte end; +begin + c := ColorToRGB(c); + Result := rgb(Integer(TRGBA(c).R) * (100 - APercentage) div 100, + Integer(TRGBA(c).G) * (100 - APercentage) div 100, + Integer(TRGBA(c).B) * (100 - APercentage) div 100 + ); + { + Result := rgb(Max(0, Min(255, TRGBA(c1).R + TRGBA(c2).R))), + Max(0, Min(255, TRGBA(c1).G + TRGBA(c2).G)), + Max(0, Min(255, TRGBA(c1).B + TRGBA(c2).B))); + } +end; + procedure Register; begin RegisterComponents('Additional',[TsWorksheetGrid]); @@ -302,6 +327,7 @@ constructor TsCustomWorksheetGrid.Create(AOwner: TComponent); begin inherited Create(AOwner); FHeaderCount := 1; + SelectedColor := $00E8E8E8; end; destructor TsCustomWorksheetGrid.Destroy; @@ -447,7 +473,9 @@ var r, c: Integer; fnt: TsFont; style: TFontStyles; + isSelected: Boolean; begin + GetSelectedState(AState, isSelected); Canvas.Font.Assign(Font); Canvas.Brush.Bitmap := nil; ts := Canvas.TextStyle; @@ -503,6 +531,10 @@ begin // Wordwrap, text alignment and text rotation are handled by "DrawTextInCell". end; end; + + if IsSelected then + Canvas.Brush.Color := DimColorByPercent(Canvas.Brush.Color, 15); + Canvas.TextStyle := ts; inherited DoPrepareCanvas(ACol, ARow, AState); @@ -835,7 +867,7 @@ function TsCustomWorksheetGrid.FindNearestPaletteIndex(AColor: TColor): TsColor; procedure ColorToHSL(RGB: TColor; var H, S, L : double); // Taken from https://code.google.com/p/thtmlviewer/source/browse/trunk/source/HSLUtils.pas?r=277 - // The procedure in GraphUtils is crashing for clFuchsia. + // The procedure in GraphUtils is crashing for some colors in Laz < 1.3 var R, G, B, D, Cmax, Cmin: double; begin @@ -886,6 +918,20 @@ function TsCustomWorksheetGrid.FindNearestPaletteIndex(AColor: TColor): TsColor; Result := sqr(H1-H2) + sqr(S1-S2) + sqr(L1-L2); end; + (* + // will be activated when Lazarus 1.4 is available. (RgbToHLS bug in Laz < 1.3) + + function ColorDistance(color1, color2: TColor): Integer; + type + TRGBA = packed record R, G, B, A: Byte end; + var + H1,L1,S1, H2,L2,S2: Byte; + begin + ColorToHLS(color1, H1,L1,S1); + ColorToHLS(color2, H2,L2,S2); + result := sqr(Integer(H1)-H2) + sqr(Integer(L1)-L2) + sqr(Integer(S1)-S2); + end; *) + var i: Integer; dist, mindist: Double;