diff --git a/components/fpspreadsheet/examples/fpsctrls/main.lfm b/components/fpspreadsheet/examples/fpsctrls/main.lfm index 840b5b623..558178b63 100644 --- a/components/fpspreadsheet/examples/fpsctrls/main.lfm +++ b/components/fpspreadsheet/examples/fpsctrls/main.lfm @@ -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 diff --git a/components/fpspreadsheet/examples/fpsctrls/main.pas b/components/fpspreadsheet/examples/fpsctrls/main.pas index 3675d5ff9..32d60837f 100644 --- a/components/fpspreadsheet/examples/fpsctrls/main.pas +++ b/components/fpspreadsheet/examples/fpsctrls/main.pas @@ -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; diff --git a/components/fpspreadsheet/fpsactions.pas b/components/fpspreadsheet/fpsactions.pas index fddb26616..f7150466a 100644 --- a/components/fpspreadsheet/fpsactions.pas +++ b/components/fpspreadsheet/fpsactions.pas @@ -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. diff --git a/components/fpspreadsheet/fpspreadsheetgrid.pas b/components/fpspreadsheet/fpspreadsheetgrid.pas index 08a497343..1d6be1188 100644 --- a/components/fpspreadsheet/fpspreadsheetgrid.pas +++ b/components/fpspreadsheet/fpspreadsheetgrid.pas @@ -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. diff --git a/components/fpspreadsheet/fpsvisualutils.pas b/components/fpspreadsheet/fpsvisualutils.pas new file mode 100644 index 000000000..311fa5da1 --- /dev/null +++ b/components/fpspreadsheet/fpsvisualutils.pas @@ -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. diff --git a/components/fpspreadsheet/laz_fpspreadsheet_visual.lpk b/components/fpspreadsheet/laz_fpspreadsheet_visual.lpk index 3333f156a..c1e971379 100644 --- a/components/fpspreadsheet/laz_fpspreadsheet_visual.lpk +++ b/components/fpspreadsheet/laz_fpspreadsheet_visual.lpk @@ -20,7 +20,7 @@ It provides graphical components like a grid and chart."/> - + @@ -41,6 +41,10 @@ It provides graphical components like a grid and chart."/> + + + + diff --git a/components/fpspreadsheet/laz_fpspreadsheet_visual.pas b/components/fpspreadsheet/laz_fpspreadsheet_visual.pas index 051539048..91d790a75 100644 --- a/components/fpspreadsheet/laz_fpspreadsheet_visual.pas +++ b/components/fpspreadsheet/laz_fpspreadsheet_visual.pas @@ -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