pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

fpspreadsheet: Add actions for font and background color selection.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3727 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2014-11-14 23:27:49 +00:00
parent 0a34c6314a
commit 8c38687a90
7 changed files with 677 additions and 276 deletions
Download Patch File Download Diff File Expand all files Collapse all files

229
components/fpspreadsheet/examples/fpsctrls/main.lfm
View File

@ -4,7 +4,7 @@ object Form1: TForm1
Top = 243
Width = 925
Caption = 'Form1'
ClientHeight = 575
ClientHeight = 580
ClientWidth = 925
Menu = MainMenu
ShowHint = True
@ -12,7 +12,7 @@ object Form1: TForm1
object Panel1: TPanel
Left = 0
Height = 36
Top = 28
Top = 26
Width = 925
Align = alTop
BevelOuter = bvNone
@ -30,7 +30,7 @@ object Form1: TForm1
end
object CellIndicator: TsCellIndicator
Left = 95
Height = 28
Height = 23
Top = 4
Width = 80
TabOrder = 1
@ -39,7 +39,7 @@ object Form1: TForm1
end
object CellEdit: TsCellEdit
Left = 184
Height = 28
Height = 23
Top = 4
Width = 731
Anchors = [akTop, akLeft, akRight]
@ -50,8 +50,8 @@ object Form1: TForm1
end
object WorkbookTabControl: TsWorkbookTabControl
Left = 0
Height = 511
Top = 64
Height = 518
Top = 62
Width = 672
TabIndex = 0
Tabs.Strings = (
@ -62,8 +62,8 @@ object Form1: TForm1
WorkbookSource = WorkbookSource
object WorksheetGrid: TsWorksheetGrid
Left = 2
Height = 481
Top = 28
Height = 493
Top = 23
Width = 668
FrozenCols = 0
FrozenRows = 0
@ -116,8 +116,8 @@ object Form1: TForm1
end
object InspectorTabControl: TTabControl
Left = 677
Height = 511
Top = 64
Height = 518
Top = 62
Width = 248
OnChange = InspectorTabControlChange
TabIndex = 0
@ -131,8 +131,8 @@ object Form1: TForm1
TabOrder = 2
object Inspector: TsSpreadsheetInspector
Left = 2
Height = 481
Top = 28
Height = 493
Top = 23
Width = 244
Align = alClient
RowCount = 25
@ -144,7 +144,7 @@ object Form1: TForm1
'Options=boAutoCalc, boCalcBeforeSaving, boReadFormulas'
'FormatSettings='
' ThousandSeparator=.'
' DecimalSeparator=,'
' DecimalSeparator=.'
' ListSeparator=;'
' DateSeparator=.'
' TimeSeparator=:'
@ -170,22 +170,22 @@ object Form1: TForm1
WorkbookSource = WorkbookSource
Mode = imWorkbook
ColWidths = (
109
110
111
112
)
end
end
object Splitter1: TSplitter
Left = 672
Height = 511
Top = 64
Height = 518
Top = 62
Width = 5
Align = alRight
ResizeAnchor = akRight
end
object ToolBar1: TToolBar
Left = 0
Height = 28
Height = 26
Top = 0
Width = 925
AutoSize = True
@ -196,181 +196,199 @@ object Form1: TForm1
TabOrder = 4
object ToolButton1: TToolButton
Left = 1
Top = 2
Top = 0
Action = AcAddWorksheet
end
object ToolButton2: TToolButton
Left = 24
Top = 2
Top = 0
Action = AcDeleteWorksheet
end
object ToolButton3: TToolButton
Left = 47
Top = 2
Top = 0
Action = acRenameWorksheet
end
object ToolButton4: TToolButton
Left = 75
Height = 24
Top = 2
Top = 0
Width = 3
Caption = 'ToolButton4'
Style = tbsDivider
end
object ToolButton5: TToolButton
Left = 537
Top = 2
Left = 593
Top = 0
Action = AcFileExit
end
object ToolButton6: TToolButton
Left = 78
Top = 2
Left = 101
Top = 0
Action = AcFontBold
end
object ToolButton7: TToolButton
Left = 101
Top = 2
Left = 124
Top = 0
Action = AcFontItalic
end
object ToolButton8: TToolButton
Left = 124
Top = 2
Left = 147
Top = 0
Action = AcFontUnderline
end
object ToolButton9: TToolButton
Left = 70
Height = 24
Top = 2
Top = 0
Width = 5
Caption = 'ToolButton9'
Style = tbsDivider
end
object ToolButton10: TToolButton
Left = 170
Left = 193
Height = 24
Top = 2
Top = 0
Width = 5
Caption = 'ToolButton10'
Style = tbsDivider
end
object ToolButton11: TToolButton
Left = 147
Top = 2
Left = 170
Top = 0
Action = AcFontStrikeout
end
object ToolButton12: TToolButton
Left = 175
Top = 2
Left = 198
Top = 0
Action = AcHorAlignLeft
end
object ToolButton13: TToolButton
Left = 198
Top = 2
Left = 221
Top = 0
Action = AcHorAlignCenter
end
object ToolButton14: TToolButton
Left = 221
Top = 2
Left = 244
Top = 0
Action = AcHorAlignRight
end
object ToolButton15: TToolButton
Left = 244
Left = 267
Height = 24
Top = 2
Top = 0
Width = 5
Caption = 'ToolButton15'
Style = tbsDivider
end
object ToolButton16: TToolButton
Left = 249
Top = 2
Left = 272
Top = 0
Action = AcVertAlignTop
end
object ToolButton17: TToolButton
Left = 272
Top = 2
Left = 295
Top = 0
Action = AcVertAlignCenter
end
object ToolButton18: TToolButton
Left = 295
Top = 2
Left = 318
Top = 0
Action = AcVertAlignBottom
end
object ToolButton19: TToolButton
Left = 318
Left = 341
Height = 24
Top = 2
Top = 0
Width = 5
Caption = 'ToolButton19'
Style = tbsDivider
end
object ToolButton20: TToolButton
Left = 323
Left = 374
Hint = 'Number format'
Top = 2
Top = 0
Caption = 'ToolButton20'
DropdownMenu = PuNumFormat
ImageIndex = 15
Style = tbsDropDown
end
object ToolButton21: TToolButton
Left = 381
Left = 432
Hint = 'Currency format'
Top = 2
Top = 0
Caption = 'ToolButton21'
DropdownMenu = PuCurrencyFormat
ImageIndex = 17
Style = tbsDropDown
end
object ToolButton22: TToolButton
Left = 358
Top = 2
Left = 409
Top = 0
Action = AcNumFormatPercentage
end
object ToolButton23: TToolButton
Left = 486
Left = 537
Height = 24
Top = 2
Top = 0
Width = 5
Caption = 'ToolButton23'
Style = tbsDivider
end
object ToolButton24: TToolButton
Left = 416
Left = 467
Hint = 'Date format'
Top = 2
Top = 0
Caption = 'ToolButton24'
DropdownMenu = PuDateFormat
ImageIndex = 18
Style = tbsDropDown
end
object ToolButton25: TToolButton
Left = 451
Left = 502
Hint = 'Time format'
Top = 2
Top = 0
Caption = 'ToolButton25'
DropdownMenu = PuTimeFormat
ImageIndex = 19
Style = tbsDropDown
end
object ToolButton26: TToolButton
Left = 491
Top = 2
Left = 542
Top = 0
Action = AcDecDecimals
end
object ToolButton27: TToolButton
Left = 514
Top = 2
Left = 565
Top = 0
Action = AcIncDecimals
end
object ToolButton28: TToolButton
Left = 560
Left = 588
Height = 24
Top = 2
Top = 0
Width = 5
Caption = 'ToolButton28'
Style = tbsDivider
end
object ToolButton29: TToolButton
Left = 78
Top = 0
Action = AcCellFont
end
object ToolButton30: TToolButton
Left = 346
Top = 0
Action = AcBackgroundColor
end
object ToolButton31: TToolButton
Left = 369
Height = 24
Top = 0
Width = 5
Caption = 'ToolButton31'
Style = tbsDivider
end
end
object WorkbookSource: TsWorkbookSource
AutoDetectFormat = False
@ -637,22 +655,57 @@ object Form1: TForm1
object AcIncDecimals: TsDecimalsAction
Category = 'FPSpreadsheet'
WorkbookSource = WorkbookSource
Caption = 'Decimals'
ImageIndex = 21
end
object AcDecDecimals: TsDecimalsAction
Category = 'FPSpreadsheet'
WorkbookSource = WorkbookSource
Caption = 'Decimals'
ImageIndex = 20
Delta = -1
end
object AcCellFont: TsFontAction
Category = 'FPSpreadsheet'
WorkbookSource = WorkbookSource
Caption = 'AcCellFont'
ImageIndex = 14
Dialog.MinFontSize = 0
Dialog.MaxFontSize = 0
end
object AcBackgroundColor: TsBackgroundColorAction
Category = 'FPSpreadsheet'
WorkbookSource = WorkbookSource
Caption = 'AcBackgroundColor'
ImageIndex = 22
Dialog.Color = clBlack
Dialog.CustomColors.Strings = (
'ColorA=000000'
'ColorB=000080'
'ColorC=008000'
'ColorD=008080'
'ColorE=800000'
'ColorF=800080'
'ColorG=808000'
'ColorH=808080'
'ColorI=C0C0C0'
'ColorJ=0000FF'
'ColorK=00FF00'
'ColorL=00FFFF'
'ColorM=FF0000'
'ColorN=FF00FF'
'ColorO=FFFF00'
'ColorP=FFFFFF'
'ColorQ=C0DCC0'
'ColorR=F0CAA6'
'ColorS=F0FBFF'
'ColorT=A4A0A0'
)
end
end
object ImageList: TImageList
left = 432
top = 249
Bitmap = {
4C69340000001000000010000000003F9300003F9300003F9300003F9424003F
4C69350000001000000010000000003F9300003F9300003F9300003F9424003F
948A003E93CC004095CC004095CC004095CC004095CC004095CC004095CC0040
95CC004095CC00409599003F9400003F9300003F9324003F938A0E4B9CD33F76
C0EC5D90D4FF3365A9FFA0A0A0FFA9A9A9FFA9A9A9FFAAAAAAFFACACACFFAEAE
@ -1356,6 +1409,38 @@ object Form1: TForm1
010001010146010101CB010101CC00000048000000000000004E000000E40000
00E900000053FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF006B6FFEFF6B6FFEFF6B6F
FEFFFFFFFF0073AAFFFF73AAFFFF73AAFFFFFFFFFF0067D5F0FF67D5F0FF67D5
F0FFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF006B6FFEFF6B6FFEFF6B6F
FEFFFFFFFF0073AAFFFF73AAFFFF73AAFFFFFFFFFF0067D5F0FF67D5F0FF67D5
F0FFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF006B6FFEFF6B6FFEFF6B6F
FEFFFFFFFF0073AAFFFF73AAFFFF73AAFFFFFFFFFF0067D5F0FF67D5F0FF67D5
F0FFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00B2EBD0FFB2EBD0FFB2EB
D0FFFFFFFF006DCC50FF6DCC50FF6DCC50FFFFFFFF00EBB060FFEBB060FFEBB0
60FFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00B2EBD0FFB2EBD0FFB2EB
D0FFFFFFFF006DCC50FF6DCC50FF6DCC50FFFFFFFF00EBB060FFEBB060FFEBB0
60FFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00B2EBD0FFB2EBD0FFB2EB
D0FFFFFFFF006DCC50FF6DCC50FF6DCC50FFFFFFFF00EBB060FFEBB060FFEBB0
60FFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00B07A58FFB07A58FFB07A
58FFFFFFFF00DD9BD9FFDD9BD9FFDD9BD9FFFFFFFF00B177FFFFB177FFFFB177
FFFFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00B07A58FFB07A58FFB07A
58FFFFFFFF00DD9BD9FFDD9BD9FFDD9BD9FFFFFFFF00B177FFFFB177FFFFB177
FFFFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00B07A58FFB07A58FFB07A
58FFFFFFFF00DD9BD9FFDD9BD9FFDD9BD9FFFFFFFF00B177FFFFB177FFFFB177
FFFFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF007F7F554D7F7F55667F7F55667F7F55667F7F
55667F7F55667F7F55667F7F55667F7F55667F7F55667F7F55667F7F55667F7F
55667F7F55667F7F55667F7F554D7D7D5367FFFFFFFFFFFFFFFFFFFFFFFFFFFF

5
components/fpspreadsheet/examples/fpsctrls/main.pas
View File

@ -92,6 +92,8 @@ type
AcNumFormatTimeInterval: TsNumberFormatAction;
AcIncDecimals: TsDecimalsAction;
AcDecDecimals: TsDecimalsAction;
AcCellFont: TsFontAction;
AcBackgroundColor: TsBackgroundColorAction;
ToolButton11: TToolButton;
ToolButton12: TToolButton;
ToolButton13: TToolButton;
@ -122,7 +124,10 @@ type
ToolButton26: TToolButton;
ToolButton27: TToolButton;
ToolButton28: TToolButton;
ToolButton29: TToolButton;
ToolButton3: TToolButton;
ToolButton30: TToolButton;
ToolButton31: TToolButton;
ToolButton4: TToolButton;
ToolButton5: TToolButton;
ToolButton6: TToolButton;

293
components/fpspreadsheet/fpsactions.pas
View File

@ -3,7 +3,7 @@ unit fpsActions;
interface
uses
SysUtils, Classes, Controls, ActnList,
SysUtils, Classes, Controls, Graphics, ActnList, StdActns, Dialogs,
fpspreadsheet, fpspreadsheetctrls;
type
@ -25,7 +25,6 @@ type
property WorkbookSource: TsWorkbookSource read FWorkbookSource write FWorkbookSource;
end;
{ --- Actions related to worksheets --- }
TsWorksheetAction = class(TsSpreadsheetAction)
@ -97,6 +96,8 @@ type
//
protected
procedure ApplyFormatToCell(ACell: PCell); virtual;
procedure ApplyFormatToRange(ARange: TsCellrange); virtual;
procedure ApplyFormatToSelection; virtual;
procedure ExtractFromCell(ACell: PCell); virtual;
public
procedure ExecuteTarget(Target: TObject); override;
@ -246,14 +247,97 @@ type
end;
{ --- Actions like from TCommonDialogAction --- }
TsCommonDialogSpreadsheetAction = class(TsCellFormatAction)
private
FBeforeExecute: TNotifyEvent;
FExecuteResult: Boolean;
FOnAccept: TNotifyEvent;
FOnCancel: TNotifyEvent;
protected
FDialog: TCommonDialog;
procedure DoAccept; virtual;
procedure DoBeforeExecute; virtual;
procedure DoCancel; virtual;
function GetDialogClass: TCommonDialogClass; virtual;
procedure CreateDialog; virtual;
public
constructor Create(AOwner: TComponent); override;
procedure ExecuteTarget(Target: TObject); override;
property ExecuteResult: Boolean read FExecuteResult;
property BeforeExecute: TNotifyEvent read FBeforeExecute write FBeforeExecute;
property OnAccept: TNotifyEvent read FOnAccept write FOnAccept;
property OnCancel: TNotifyEvent read FOnCancel write FOnCancel;
end;
{ TsFontAction }
TsFontAction = class(TsCommonDialogSpreadsheetAction)
private
function GetDialog: TFontDialog;
protected
procedure ApplyFormatToCell(ACell: PCell); override;
procedure DoAccept; override;
procedure ExtractFromCell(ACell: PCell); override;
function GetDialogClass: TCommonDialogClass; override;
public
constructor Create(AOwner: TComponent); override;
published
property Caption;
property Dialog: TFontDialog read GetDialog;
property Enabled;
property HelpContext;
property HelpKeyword;
property HelpType;
property Hint;
property ImageIndex;
property ShortCut;
property SecondaryShortCuts;
property Visible;
// property BeforeExecute;
// property OnAccept;
// property OnCancel;
property OnHint;
end;
{ TsBackgroundColorAction }
TsBackgroundColorAction = class(TsCommonDialogSpreadsheetAction)
private
FBackgroundColor: TsColor;
function GetDialog: TColorDialog;
protected
procedure ApplyFormatToCell(ACell: PCell); override;
procedure DoAccept; override;
procedure DoBeforeExecute; override;
procedure ExtractFromCell(ACell: PCell); override;
function GetDialogClass: TCommonDialogClass; override;
public
constructor Create(AOwner: TComponent); override;
published
property Caption;
property Dialog: TColorDialog read GetDialog;
property Enabled;
property HelpContext;
property HelpKeyword;
property HelpType;
property Hint;
property ImageIndex;
property ShortCut;
property SecondaryShortCuts;
property Visible;
// property BeforeExecute;
// property OnAccept;
// property OnCancel;
property OnHint;
end;
procedure Register;
implementation
uses
Dialogs,
fpsutils;
fpsutils, fpsVisualUtils;
procedure Register;
begin
@ -261,7 +345,7 @@ begin
// Worksheet-releated actions
TsWorksheetAddAction, TsWorksheetDeleteAction, TsWorksheetRenameAction,
// Cell or cell range formatting actions
TsFontStyleAction,
TsFontAction, TsFontStyleAction, TsBackgroundColorAction,
TsHorAlignmentAction, TsVertAlignmentAction,
TsTextRotationAction, TsWordWrapAction,
TsNumberFormatAction, TsDecimalsAction
@ -463,24 +547,32 @@ begin
Unused(ACell);
end;
procedure TsCellFormatAction.ExecuteTarget(Target: TObject);
procedure TsCellFormatAction.ApplyFormatToRange(ARange: TsCellRange);
var
range: Integer;
r,c: Cardinal;
sel: TsCellRangeArray;
r, c: Cardinal;
cell: PCell;
begin
if not HandlesTarget(Target) then
exit;
for r := ARange.Row1 to ARange.Row2 do
for c := ARange.Col1 to ARange.Col2 do
begin
cell := Worksheet.GetCell(r, c); // Use "GetCell" here to format empty cells as well
ApplyFormatToCell(cell); // no check for nil required because of "GetCell"
end;
end;
procedure TsCellFormatAction.ApplyFormatToSelection;
var
sel: TsCellRangeArray;
range: Integer;
begin
sel := GetSelection;
for range := 0 to High(sel) do
for r := sel[range].Row1 to sel[range].Row2 do
for c := sel[range].Col1 to sel[range].Col2 do
begin
cell := Worksheet.GetCell(r, c); // Use "GetCell", empty cells will be formatted!
if cell <> nil then
ApplyFormatToCell(cell);
end;
ApplyFormatToRange(sel[range]);
end;
procedure TsCellFormatAction.ExecuteTarget(Target: TObject);
begin
ApplyFormatToSelection;
end;
{ Extracts the format item for which the action is responsible from the
@ -850,4 +942,169 @@ begin
Hint := 'Less decimal places';
end;
{ TsCommonDialogSpreadsheetAction }
constructor TsCommonDialogSpreadsheetAction.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
CreateDialog;
DisableIfNoHandler := False;
Enabled := True;
end;
procedure TsCommonDialogSpreadsheetAction.CreateDialog;
var
DlgClass: TCommonDialogClass;
begin
DlgClass := GetDialogClass;
if Assigned(DlgClass) then
begin
FDialog := DlgClass.Create(Self);
FDialog.Name := DlgClass.ClassName;
FDialog.SetSubComponent(True);
end;
end;
procedure TsCommonDialogSpreadsheetAction.DoAccept;
begin
if Assigned(FOnAccept) then
FOnAccept(Self);
end;
procedure TsCommonDialogSpreadsheetAction.DoBeforeExecute;
begin
if Assigned(FBeforeExecute) then
FBeforeExecute(Self);
end;
procedure TsCommonDialogSpreadsheetAction.DoCancel;
begin
if Assigned(FOnCancel) then
FOnCancel(Self);
end;
function TsCommonDialogSpreadsheetAction.GetDialogClass: TCommonDialogClass;
begin
result := nil;
end;
procedure TsCommonDialogSpreadsheetAction.ExecuteTarget(Target: TObject);
begin
DoBeforeExecute;
FExecuteResult := FDialog.Execute;
if FExecuteResult then
DoAccept
else
DoCancel;
end;
{ TsFontAction }
constructor TsFontAction.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Caption := 'Font';
Hint := 'Select cell font';
end;
procedure TsFontAction.ApplyFormatToCell(ACell: PCell);
var
sfnt: TsFont;
begin
sfnt := TsFont.Create;
Convert_Font_to_sFont(Workbook, GetDialog.Font, sfnt);
Worksheet.WriteFont(ACell, Workbook.AddFont(sfnt));
end;
procedure TsFontAction.DoAccept;
begin
ApplyFormatToSelection;
end;
procedure TsFontAction.ExtractFromCell(ACell: PCell);
var
sfnt: TsFont;
fnt: TFont;
begin
fnt := TFont.Create;
try
if (ACell = nil) then
sfnt := Workbook.GetDefaultFont
else
if uffBold in ACell^.UsedFormattingFields then
sfnt := Workbook.GetFont(1)
else
if uffFont in ACell^.UsedFormattingFields then
sfnt := Workbook.GetFont(ACell^.FontIndex)
else
sfnt := Workbook.GetDefaultFont;
Convert_sFont_to_Font(Workbook, sfnt, fnt);
GetDialog.Font.Assign(fnt);
finally
fnt.Free;
end;
end;
function TsFontAction.GetDialog: TFontDialog;
begin
Result := TFontDialog(FDialog);
end;
function TsFontAction.GetDialogClass: TCommonDialogClass;
begin
Result := TFontDialog;
end;
{ TsBackgroundColorAction }
constructor TsBackgroundColorAction.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Caption := 'Backgroundcolor';
Hint := 'Modify background color';
end;
procedure TsBackgroundColorAction.ApplyFormatToCell(ACell: PCell);
begin
Worksheet.WritebackgroundColor(ACell, FBackgroundColor);
end;
procedure TsBackgroundColorAction.DoAccept;
begin
FBackgroundColor := Workbook.AddColorToPalette(TsColorValue(Dialog.Color));
ApplyFormatToSelection;
end;
procedure TsBackgroundColorAction.DoBeforeExecute;
var
cell: PCell;
begin
cell := Worksheet.FindCell(Worksheet.ActiveCellRow, Worksheet.ActiveCellCol);
if (cell = nil) or not (uffBackgroundColor in cell^.UsedFormattingFields) then
FBackgroundColor := scNotDefined
else
FBackgroundColor := cell^.BackgroundColor;
Dialog.Color := Workbook.GetPaletteColor(FBackgroundColor);
end;
procedure TsBackgroundColorAction.ExtractFromCell(ACell: PCell);
begin
//
end;
function TsBackgroundColorAction.GetDialog: TColorDialog;
begin
Result := TColorDialog(FDialog);
end;
function TsBackgroundColorAction.GetDialogClass: TCommonDialogClass;
begin
Result := TColorDialog;
end;
end.

189
components/fpspreadsheet/fpspreadsheetgrid.pas
View File

@ -561,7 +561,8 @@ procedure Register;
implementation
uses
Types, LCLType, LCLIntf, Math, fpCanvas, fpsUtils;
Types, LCLType, LCLIntf, Math,
fpCanvas, fpsUtils, fpsVisualUtils;
const
{@@ Translation of the fpspreadsheet type of horizontal text alignment to that
@ -643,83 +644,6 @@ begin
end;
end;
{@@ ----------------------------------------------------------------------------
Wraps text by inserting line ending characters so that the lines are not
longer than AMaxWidth.
@param ACanvas Canvas on which the text will be drawn
@param AText Text to be drawn
@param AMaxWidth Maximimum line width (in pixels)
@return Text with inserted line endings such that the lines are shorter than
AMaxWidth.
@note Based on ocde posted by user "taazz" in the Lazarus forum
http://forum.lazarus.freepascal.org/index.php/topic,21305.msg124743.html#msg124743
-------------------------------------------------------------------------------}
function WrapText(ACanvas: TCanvas; const AText: string; AMaxWidth: integer): string;
var
DC: HDC;
textExtent: TSize = (cx:0; cy:0);
S, P, E: PChar;
line: string;
isFirstLine: boolean;
begin
Result := '';
DC := ACanvas.Handle;
isFirstLine := True;
P := PChar(AText);
while P^ = ' ' do
Inc(P);
while P^ <> #0 do begin
S := P;
E := nil;
while (P^ <> #0) and (P^ <> #13) and (P^ <> #10) do begin
LCLIntf.GetTextExtentPoint(DC, S, P - S + 1, textExtent);
if (textExtent.CX > AMaxWidth) and (E <> nil) then begin
if (P^ <> ' ') and (P^ <> ^I) then begin
while (E >= S) do
case E^ of
'.', ',', ';', '?', '!', '-', ':',
')', ']', '}', '>', '/', '\', ' ':
break;
else
Dec(E);
end;
if E < S then
E := P - 1;
end;
Break;
end;
E := P;
Inc(P);
end;
if E <> nil then begin
while (E >= S) and (E^ = ' ') do
Dec(E);
end;
if E <> nil then
SetString(Line, S, E - S + 1)
else
SetLength(Line, 0);
if (P^ = #13) or (P^ = #10) then begin
Inc(P);
if (P^ <> (P - 1)^) and ((P^ = #13) or (P^ = #10)) then
Inc(P);
if P^ = #0 then
line := line + LineEnding;
end
else if P^ <> ' ' then
P := E + 1;
while P^ = ' ' do
Inc(P);
if isFirstLine then begin
Result := Line;
isFirstLine := False;
end else
Result := Result + LineEnding + line;
end;
end;
{@@ ----------------------------------------------------------------------------
Calculates a background color for selected cells. The procedures takes the
original background color and dims or brightens it by adding the value ADelta
@ -1075,16 +999,7 @@ end;
-------------------------------------------------------------------------------}
procedure TsCustomWorksheetGrid.Convert_sFont_to_Font(sFont: TsFont; AFont: TFont);
begin
if Assigned(AFont) and Assigned(sFont) then begin
AFont.Name := sFont.FontName;
AFont.Size := round(sFont.Size);
AFont.Style := [];
if fssBold in sFont.Style then AFont.Style := AFont.Style + [fsBold];
if fssItalic in sFont.Style then AFont.Style := AFont.Style + [fsItalic];
if fssUnderline in sFont.Style then AFont.Style := AFont.Style + [fsUnderline];
if fssStrikeout in sFont.Style then AFont.Style := AFont.Style + [fsStrikeout];
AFont.Color := Workbook.GetPaletteColor(sFont.Color);
end;
fpsVisualUtils.Convert_sFont_to_Font(Workbook, sFont, Font);
end;
{@@ ----------------------------------------------------------------------------
@ -1096,16 +1011,7 @@ end;
procedure TsCustomWorksheetGrid.Convert_Font_to_sFont(AFont: TFont;
sFont: TsFont);
begin
if Assigned(AFont) and Assigned(sFont) then begin
sFont.FontName := AFont.Name;
sFont.Size := AFont.Size;
sFont.Style := [];
if fsBold in AFont.Style then Include(sFont.Style, fssBold);
if fsItalic in AFont.Style then Include(sFont.Style, fssItalic);
if fsUnderline in AFont.Style then Include(sFont.Style, fssUnderline);
if fsStrikeout in AFont.Style then Include(sFont.Style, fssStrikeout);
sFont.Color := FindNearestPaletteIndex(AFont.Color);
end;
fpsVisualUtils.Convert_Font_to_sFont(Workbook, AFont, sFont);
end;
{@@ ----------------------------------------------------------------------------
@ -2035,93 +1941,10 @@ end;
@param AColor Color index into the workbook's palette
-------------------------------------------------------------------------------}
function TsCustomWorksheetGrid.FindNearestPaletteIndex(AColor: TColor): TsColor;
procedure ColorToHSL(RGB: TColor; out H, S, L : double);
// Taken from https://code.google.com/p/thtmlviewer/source/browse/trunk/source/HSLUtils.pas?r=277
// The procedure in GraphUtils crashes for some colors in Laz < 1.3
var
R, G, B, D, Cmax, Cmin: double;
begin
R := GetRValue(RGB) / 255;
G := GetGValue(RGB) / 255;
B := GetBValue(RGB) / 255;
Cmax := Max(R, Max(G, B));
Cmin := Min(R, Min(G, B));
// calculate luminosity
L := (Cmax + Cmin) / 2;
if Cmax = Cmin then begin // it's grey
H := 0; // it's actually undefined
S := 0
end else
begin
D := Cmax - Cmin;
// calculate Saturation
if L < 0.5 then
S := D / (Cmax + Cmin)
else
S := D / (2 - Cmax - Cmin);
// calculate Hue
if R = Cmax then
H := (G - B) / D
else
if G = Cmax then
H := 2 + (B - R) /D
else
H := 4 + (R - G) / D;
H := H / 6;
if H < 0 then
H := H + 1
end
end;
function ColorDistance(color1, color2: TColor): Double;
var
H1,S1,L1, H2,S2,L2: Double;
begin
ColorToHSL(color1, H1, S1, L1);
ColorToHSL(color2, H2, S2, L2);
Result := sqr(H1-H2) + sqr(S1-S2) + sqr(L1-L2);
end;
{
// To 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;
begin
Result := 0;
if Workbook <> nil then
begin
mindist := 1E308;
for i:=0 to Workbook.GetPaletteSize-1 do
begin
dist := ColorDistance(AColor, TColor(Workbook.GetPaletteColor(i)));
if dist < mindist then
begin
mindist := dist;
Result := i;
end;
end;
end;
Result := fpsVisualUtils.FindNearestPaletteIndex(Workbook, AColor);
end;
(*
{@@ ----------------------------------------------------------------------------
Notification by the workbook link that a cell has been modified. --> Repaint.

227
components/fpspreadsheet/fpsvisualutils.pas Normal file
View File

@ -0,0 +1,227 @@
unit fpsvisualutils;
interface
uses
Classes, SysUtils, Graphics,
fpspreadsheet;
procedure Convert_sFont_to_Font(AWorkbook: TsWorkbook; sFont: TsFont; AFont: TFont);
procedure Convert_Font_to_sFont(AWorkbook: TsWorkbook; AFont: TFont; sFont: TsFont);
function FindNearestPaletteIndex(AWorkbook: TsWorkbook; AColor: TColor): TsColor;
function WrapText(ACanvas: TCanvas; const AText: string; AMaxWidth: integer): string;
implementation
uses
Types, LCLType, LCLIntf, Math;
{@@ ----------------------------------------------------------------------------
Converts a spreadsheet font to a font used for painting (TCanvas.Font).
@param AWorkbook Workbook in which the font is used
@param sFont Font as used by fpspreadsheet (input)
@param AFont Font as used by TCanvas for painting (output)
-------------------------------------------------------------------------------}
procedure Convert_sFont_to_Font(AWorkbook: TsWorkbook; sFont: TsFont; AFont: TFont);
begin
if Assigned(AFont) and Assigned(sFont) then begin
AFont.Name := sFont.FontName;
AFont.Size := round(sFont.Size);
AFont.Style := [];
if fssBold in sFont.Style then AFont.Style := AFont.Style + [fsBold];
if fssItalic in sFont.Style then AFont.Style := AFont.Style + [fsItalic];
if fssUnderline in sFont.Style then AFont.Style := AFont.Style + [fsUnderline];
if fssStrikeout in sFont.Style then AFont.Style := AFont.Style + [fsStrikeout];
AFont.Color := AWorkbook.GetPaletteColor(sFont.Color);
end;
end;
{@@ ----------------------------------------------------------------------------
Converts a font used for painting (TCanvas.Font) to a spreadsheet font.
@param AFont Font as used by TCanvas for painting (input)
@param sFont Font as used by fpspreadsheet (output)
-------------------------------------------------------------------------------}
procedure Convert_Font_to_sFont(AWorkbook: TsWorkbook; AFont: TFont; sFont: TsFont);
begin
if Assigned(AFont) and Assigned(sFont) then begin
sFont.FontName := AFont.Name;
sFont.Size := AFont.Size;
sFont.Style := [];
if fsBold in AFont.Style then Include(sFont.Style, fssBold);
if fsItalic in AFont.Style then Include(sFont.Style, fssItalic);
if fsUnderline in AFont.Style then Include(sFont.Style, fssUnderline);
if fsStrikeout in AFont.Style then Include(sFont.Style, fssStrikeout);
sFont.Color := FindNearestPaletteIndex(AWorkbook, AFont.Color);
end;
end;
function FindNearestPaletteIndex(AWorkbook: TsWorkbook; AColor: TColor): TsColor;
procedure ColorToHSL(RGB: TColor; out H, S, L : double);
// Taken from https://code.google.com/p/thtmlviewer/source/browse/trunk/source/HSLUtils.pas?r=277
// The procedure in GraphUtils crashes for some colors in Laz < 1.3
var
R, G, B, D, Cmax, Cmin: double;
begin
R := GetRValue(RGB) / 255;
G := GetGValue(RGB) / 255;
B := GetBValue(RGB) / 255;
Cmax := Max(R, Max(G, B));
Cmin := Min(R, Min(G, B));
// calculate luminosity
L := (Cmax + Cmin) / 2;
if Cmax = Cmin then begin // it's grey
H := 0; // it's actually undefined
S := 0
end else
begin
D := Cmax - Cmin;
// calculate Saturation
if L < 0.5 then
S := D / (Cmax + Cmin)
else
S := D / (2 - Cmax - Cmin);
// calculate Hue
if R = Cmax then
H := (G - B) / D
else
if G = Cmax then
H := 2 + (B - R) /D
else
H := 4 + (R - G) / D;
H := H / 6;
if H < 0 then
H := H + 1
end
end;
function ColorDistance(color1, color2: TColor): Double;
var
H1,S1,L1, H2,S2,L2: Double;
begin
ColorToHSL(color1, H1, S1, L1);
ColorToHSL(color2, H2, S2, L2);
Result := sqr(H1-H2) + sqr(S1-S2) + sqr(L1-L2);
end;
{
// To 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;
begin
Result := 0;
if AWorkbook <> nil then
begin
mindist := 1E308;
for i:=0 to AWorkbook.GetPaletteSize-1 do
begin
dist := ColorDistance(AColor, TColor(AWorkbook.GetPaletteColor(i)));
if dist < mindist then
begin
mindist := dist;
Result := i;
end;
end;
end;
end;
{@@ ----------------------------------------------------------------------------
Wraps text by inserting line ending characters so that the lines are not
longer than AMaxWidth.
@param ACanvas Canvas on which the text will be drawn
@param AText Text to be drawn
@param AMaxWidth Maximimum line width (in pixels)
@return Text with inserted line endings such that the lines are shorter than
AMaxWidth.
@note Based on ocde posted by user "taazz" in the Lazarus forum
http://forum.lazarus.freepascal.org/index.php/topic,21305.msg124743.html#msg124743
-------------------------------------------------------------------------------}
function WrapText(ACanvas: TCanvas; const AText: string; AMaxWidth: integer): string;
var
DC: HDC;
textExtent: TSize = (cx:0; cy:0);
S, P, E: PChar;
line: string;
isFirstLine: boolean;
begin
Result := '';
DC := ACanvas.Handle;
isFirstLine := True;
P := PChar(AText);
while P^ = ' ' do
Inc(P);
while P^ <> #0 do begin
S := P;
E := nil;
while (P^ <> #0) and (P^ <> #13) and (P^ <> #10) do begin
LCLIntf.GetTextExtentPoint(DC, S, P - S + 1, textExtent);
if (textExtent.CX > AMaxWidth) and (E <> nil) then begin
if (P^ <> ' ') and (P^ <> ^I) then begin
while (E >= S) do
case E^ of
'.', ',', ';', '?', '!', '-', ':',
')', ']', '}', '>', '/', '\', ' ':
break;
else
Dec(E);
end;
if E < S then
E := P - 1;
end;
Break;
end;
E := P;
Inc(P);
end;
if E <> nil then begin
while (E >= S) and (E^ = ' ') do
Dec(E);
end;
if E <> nil then
SetString(Line, S, E - S + 1)
else
SetLength(Line, 0);
if (P^ = #13) or (P^ = #10) then begin
Inc(P);
if (P^ <> (P - 1)^) and ((P^ = #13) or (P^ = #10)) then
Inc(P);
if P^ = #0 then
line := line + LineEnding;
end
else if P^ <> ' ' then
P := E + 1;
while P^ = ' ' do
Inc(P);
if isFirstLine then begin
Result := Line;
isFirstLine := False;
end else
Result := Result + LineEnding + line;
end;
end;
end.

6
components/fpspreadsheet/laz_fpspreadsheet_visual.lpk
View File

@ -20,7 +20,7 @@
It provides graphical components like a grid and chart."/>
<License Value="LGPL with static linking exception. This is the same license as is used in the LCL (Lazarus Component Library)."/>
<Version Major="1" Minor="2"/>
<Files Count="4">
<Files Count="5">
<Item1>
<Filename Value="fpspreadsheetctrls.pas"/>
<HasRegisterProc Value="True"/>
@ -41,6 +41,10 @@ It provides graphical components like a grid and chart."/>
<HasRegisterProc Value="True"/>
<UnitName Value="fpsActions"/>
</Item4>
<Item5>
<Filename Value="fpsvisualutils.pas"/>
<UnitName Value="fpsvisualutils"/>
</Item5>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="4">

4
components/fpspreadsheet/laz_fpspreadsheet_visual.pas
View File

@ -8,7 +8,7 @@ interface
uses
fpspreadsheetctrls, fpspreadsheetgrid, fpspreadsheetchart, fpsActions,
LazarusPackageIntf;
fpsvisualutils, LazarusPackageIntf;
implementation
@ -17,7 +17,7 @@ begin
RegisterUnit('fpspreadsheetctrls', @fpspreadsheetctrls.Register);
RegisterUnit('fpspreadsheetgrid', @fpspreadsheetgrid.Register);
RegisterUnit('fpspreadsheetchart', @fpspreadsheetchart.Register);
RegisterUnit('fpsactions', @fpsactions.Register);
RegisterUnit('fpsActions', @fpsActions.Register);
end;
initialization