{ fpActions } {@@ ---------------------------------------------------------------------------- A collection of standard actions to simplify creation of menu and toolbar for spreadsheet applications. AUTHORS: Werner Pamler LICENSE: See the file COPYING.modifiedLGPL.txt, included in the Lazarus distribution, for details about the license. -------------------------------------------------------------------------------} unit fpsActions; interface uses SysUtils, Classes, Controls, Graphics, ActnList, StdActns, Dialogs, fpstypes, fpspreadsheet, fpspreadsheetctrls; type TsSpreadsheetAction = class(TCustomAction) private FWorkbookSource: TsWorkbookSource; function GetActiveCell: PCell; function GetSelection: TsCellRangeArray; function GetWorkbook: TsWorkbook; function GetWorksheet: TsWorksheet; protected procedure ApplyFormatToCell(ACell: PCell); virtual; procedure ApplyFormatToRange(ARange: TsCellrange); virtual; procedure ApplyFormatToSelection; virtual; procedure ExtractFromCell(ACell: PCell); virtual; procedure Notification(AComponent: TComponent; Operation: TOperation); override; property ActiveCell: PCell read GetActiveCell; property Selection: TsCellRangeArray read GetSelection; property Worksheet: TsWorksheet read GetWorksheet; public function HandlesTarget(Target: TObject): Boolean; override; procedure UpdateTarget(Target: TObject); override; property Workbook: TsWorkbook read GetWorkbook; published property WorkbookSource: TsWorkbookSource read FWorkbookSource write FWorkbookSource; end; { --- Actions related to worksheets --- } TsWorksheetAction = class(TsSpreadsheetAction) private public function HandlesTarget(Target: TObject): Boolean; override; procedure UpdateTarget(Target: TObject); override; property Worksheet; published property Caption; property Enabled; property HelpContext; property HelpKeyword; property HelpType; property Hint; property ImageIndex; property OnExecute; property OnHint; property OnUpdate; property SecondaryShortCuts; property ShortCut; property Visible; end; TsWorksheetNameEvent = procedure (Sender: TObject; AWorksheet: TsWorksheet; var ASheetName: String) of object; { Action for adding a worksheet } TsWorksheetAddAction = class(TsWorksheetAction) private FNameMask: String; FOnGetWorksheetName: TsWorksheetNameEvent; procedure SetNameMask(const AValue: String); protected function GetUniqueSheetName: String; public constructor Create(AOwner: TComponent); override; procedure ExecuteTarget(Target: TObject); override; published property NameMask: String read FNameMask write SetNameMask; property OnGetWorksheetName: TsWorksheetNameEvent read FOnGetWorksheetName write FOnGetWorksheetName; end; { Action for deleting selected worksheet } TsWorksheetDeleteAction = class(TsWorksheetAction) public procedure ExecuteTarget(Target: TObject); override; end; { Action for renaming selected worksheet } TsWorksheetRenameAction = class(TsWorksheetAction) private FOnGetWorksheetName: TsWorksheetNameEvent; public procedure ExecuteTarget(Target: TObject); override; published property OnGetWorksheetName: TsWorksheetNameEvent read FOnGetWorksheetName write FOnGetWorksheetName; end; { --- Actions related to cell and cell selection formatting--- } TsCopyItem = (ciFormat, ciValue, ciFormula, ciAll); TsCopyMode = (cmBrush, cmCopy, cmCut, cmPaste); TsCopyAction = class(TsSpreadsheetAction) private FCopyItem: TsCopyItem; FCopyMode: TsCopyMode; public procedure ExecuteTarget(Target: TObject); override; procedure UpdateTarget(Target: TObject); override; published property Caption; property CopyItem: TsCopyItem read FCopyItem write FCopyItem default ciFormat; property CopyMode: TsCopyMode read FCopyMode write FCopyMode default cmBrush; property Enabled; property HelpContext; property HelpKeyword; property HelpType; property Hint; property ImageIndex; property OnExecute; property OnHint; property OnUpdate; property SecondaryShortCuts; property ShortCut; property Visible; end; TsCellAction = class(TsSpreadsheetAction) public function HandlesTarget(Target: TObject): Boolean; override; property ActiveCell; property Selection; property Worksheet; end; TsAutoFormatAction = class(TsCellAction) public procedure ExecuteTarget(Target: TObject); override; procedure UpdateTarget(Target: TObject); override; published property Caption; property Enabled; property HelpContext; property HelpKeyword; property HelpType; property Hint; property ImageIndex; property OnExecute; property OnHint; property OnUpdate; property SecondaryShortCuts; property ShortCut; property Visible; end; { TsFontStyleAction } TsFontStyleAction = class(TsAutoFormatAction) private FFontStyle: TsFontStyle; protected procedure ApplyFormatToCell(ACell: PCell); override; procedure ExtractFromCell(ACell: PCell); override; public constructor Create(AOwner: TComponent); override; published property FontStyle: TsFontStyle read FFontStyle write FFontStyle; end; { TsHorAlignmentAction } TsHorAlignmentAction = class(TsAutoFormatAction) private FHorAlign: TsHorAlignment; protected procedure ApplyFormatToCell(ACell: PCell); override; procedure ExtractFromCell(ACell: PCell); override; public constructor Create(AOwner: TComponent); override; published property HorAlignment: TsHorAlignment read FHorAlign write FHorAlign default haDefault; end; { TsVertAlignmentAction } TsVertAlignmentAction = class(TsAutoFormatAction) private FVertAlign: TsVertAlignment; protected procedure ApplyFormatToCell(ACell: PCell); override; procedure ExtractFromCell(ACell: PCell); override; public constructor Create(AOwner: TComponent); override; published property VertAlignment: TsVertAlignment read FVertAlign write FVertAlign default vaDefault; end; { TsTextRotationAction } TsTextRotationAction = class(TsAutoFormatAction) private FTextRotation: TsTextRotation; protected procedure ApplyFormatToCell(ACell: PCell); override; procedure ExtractFromCell(ACell: PCell); override; public constructor Create(AOwner: TComponent); override; published property TextRotation: TsTextRotation read FTextRotation write FTextRotation default trHorizontal; end; { TsWordwrapAction } TsWordwrapAction = class(TsAutoFormatAction) private function GetWordwrap: Boolean; procedure SetWordwrap(AValue: Boolean); protected procedure ApplyFormatToCell(ACell: PCell); override; procedure ExtractFromCell(ACell: PCell); override; public constructor Create(AOwner: TComponent); override; published property Wordwrap: boolean read GetWordwrap write SetWordwrap default false; end; { TsNumberFormatAction } TsNumberFormatAction = class(TsAutoFormatAction) private FNumberFormat: TsNumberFormat; FNumberFormatStr: string; protected procedure ApplyFormatToCell(ACell: PCell); override; procedure ExtractFromCell(ACell: PCell); override; public constructor Create(AOwner: TComponent); override; published property NumberFormat: TsNumberFormat read FNumberFormat write FNumberFormat default nfGeneral; property NumberFormatString: string read FNumberFormatStr write FNumberFormatStr; end; { TsDecimalsAction } TsDecimalsAction = class(TsAutoFormatAction) private FDecimals: Integer; FDelta: Integer; protected procedure ApplyFormatToCell(ACell: PCell); override; procedure ExtractFromCell(ACell: PCell); override; public constructor Create(AOwner: TComponent); override; published property Delta: Integer read FDelta write FDelta default +1; property Hint stored false; end; { TsCellBorderAction } TsActionBorder = class(TPersistent) private FLineStyle: TsLineStyle; FColor: TColor; FVisible: Boolean; public procedure ApplyStyle(AWorkbook: TsWorkbook; out ABorderStyle: TsCellBorderStyle); procedure ExtractStyle(AWorkbook: TsWorkbook; ABorderStyle: TsCellBorderStyle); published property LineStyle: TsLineStyle read FLineStyle write FLineStyle; property Color: TColor read FColor write FColor; property Visible: Boolean read FVisible write FVisible; end; TsActionBorders = class(TPersistent) private FBorders: Array[TsCellBorder] of TsActionBorder; function GetBorder(AIndex: TsCellBorder): TsActionBorder; procedure SetBorder(AIndex: TsCellBorder; AValue: TsActionBorder); public constructor Create; destructor Destroy; override; procedure ExtractFromCell(AWorkbook: TsWorkbook; ACell: PCell); published property East: TsActionBorder index cbEast read GetBorder write SetBorder; property North: TsActionBorder index cbNorth read GetBorder write SetBorder; property South: TsActionBorder index cbSouth read GetBorder write SetBorder; property West: TsActionBorder index cbWest read GetBorder write SetBorder; property InnerHor: TsActionBorder index cbDiagUp // NOTE: "abusing" cbDiagUp here! read GetBorder write SetBorder; property InnerVert: TsActionBorder index cbDiagDown // NOTE: "abusing" cbDiagDown here" read GetBorder write SetBorder; end; TsCellBorderAction = class(TsCellAction) private FBorders: TsActionBorders; protected procedure ApplyFormatToRange(ARange: TsCellRange); override; procedure ExtractFromCell(ACell: PCell); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure ExecuteTarget(Target: TObject); override; published property Borders: TsActionBorders read FBorders write FBorders; property Caption; property Enabled; property HelpContext; property HelpKeyword; property HelpType; property Hint; property ImageIndex; property OnExecute; property OnHint; property OnUpdate; property SecondaryShortCuts; property ShortCut; property Visible; end; TsNoCellBordersAction = class(TsCellAction) protected procedure ApplyFormatToCell(ACell: PCell); override; public procedure ExecuteTarget(Target: TObject); override; published property Caption; property Enabled; property HelpContext; property HelpKeyword; property HelpType; property Hint; property ImageIndex; property OnExecute; property OnHint; property OnUpdate; property SecondaryShortCuts; property ShortCut; property Visible; end; TsCellCommentMode = (ccmNew, ccmEdit, ccmDelete); TsCellCommentAction = class(TsCellAction) private FMode: TsCellCommentMode; protected function EditComment(ACaption: String; var AText: String): Boolean; virtual; public procedure ExecuteTarget(Target: TObject); override; procedure UpdateTarget(Target: TObject); override; published property Mode: TsCellCommentMode read FMode write FMode; property Caption; property Enabled; property HelpContext; property HelpKeyword; property HelpType; property Hint; property ImageIndex; property OnExecute; property OnHint; property OnUpdate; property SecondaryShortCuts; property ShortCut; property Visible; end; { TsMergeAction } TsMergeAction = class(TsAutoFormatAction) private function GetMerged: Boolean; procedure SetMerged(AValue: Boolean); protected procedure ApplyFormatToRange(ARange: TsCellRange); override; procedure ExtractFromCell(ACell: PCell); override; public constructor Create(AOwner: TComponent); override; published property Merged: Boolean read GetMerged write SetMerged default false; end; { --- Actions like those derived from TCommonDialogAction --- } TsCommonDialogSpreadsheetAction = class(TsSpreadsheetAction) 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; { TsCommondDialogCellAction } TsCommonDialogCellAction = class(TsCommondialogSpreadsheetAction) protected procedure DoAccept; override; procedure DoBeforeExecute; override; public property ActiveCell; property Selection; property Workbook; property Worksheet; published property Caption; 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; { TsFontDialogAction } TsFontDialogAction = class(TsCommonDialogCellAction) private function GetDialog: TFontDialog; protected procedure ApplyFormatToCell(ACell: PCell); override; procedure ExtractFromCell(ACell: PCell); override; function GetDialogClass: TCommonDialogClass; override; published property Dialog: TFontDialog read GetDialog; end; { TsBackgroundColorDialogAction } TsBackgroundColorDialogAction = class(TsCommonDialogCellAction) 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; published property Dialog: TColorDialog read GetDialog; end; procedure Register; implementation uses StdCtrls, ExtCtrls, Buttons, Forms, fpsUtils, fpsNumFormat, fpsVisualUtils; procedure Register; begin RegisterActions('FPSpreadsheet', [ // Worksheet-releated actions TsWorksheetAddAction, TsWorksheetDeleteAction, TsWorksheetRenameAction, // Cell or cell range formatting actions TsCopyAction, TsFontStyleAction, TsFontDialogAction, TsBackgroundColorDialogAction, TsHorAlignmentAction, TsVertAlignmentAction, TsTextRotationAction, TsWordWrapAction, TsNumberFormatAction, TsDecimalsAction, TsCellBorderAction, TsNoCellBordersAction, TsCellCommentAction, TsMergeAction ], nil); end; { TsSpreadsheetAction } { Copies the format item for which the action is responsible to the specified cell. Must be overridden by descendants. } procedure TsSpreadsheetAction.ApplyFormatToCell(ACell: PCell); begin Unused(ACell); end; procedure TsSpreadsheetAction.ApplyFormatToRange(ARange: TsCellRange); var r, c: Cardinal; cell: PCell; begin 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 TsSpreadsheetAction.ApplyFormatToSelection; var sel: TsCellRangeArray; range: Integer; begin sel := GetSelection; for range := 0 to High(sel) do ApplyFormatToRange(sel[range]); end; { Extracts the format item for which the action is responsible from the specified cell. Must be overridden by descendants. } procedure TsSpreadsheetAction.ExtractFromCell(ACell: PCell); begin Unused(ACell); end; function TsSpreadsheetAction.GetActiveCell: PCell; begin if Worksheet <> nil then Result := Worksheet.FindCell(Worksheet.ActiveCellRow, Worksheet.ActiveCellCol) else Result := nil; end; function TsSpreadsheetAction.GetSelection: TsCellRangeArray; begin Result := Worksheet.GetSelection; end; function TsSpreadsheetAction.GetWorkbook: TsWorkbook; begin if FWorkbookSource <> nil then Result := FWorkbookSource.Workbook else Result := nil; end; function TsSpreadsheetAction.GetWorksheet: TsWorksheet; begin if FWorkbookSource <> nil then Result := FWorkbookSource.Worksheet else Result := nil; end; function TsSpreadsheetAction.HandlesTarget(Target: TObject): Boolean; begin Result := (Target <> nil) and (Target = FWorkbookSource); end; procedure TsSpreadsheetAction.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (Operation = opRemove) and (AComponent = FWorkbookSource) then FWorkbookSource := nil; end; procedure TsSpreadsheetAction.UpdateTarget(Target: TObject); begin Enabled := HandlesTarget(Target); end; { TsWorksheetAction } function TsWorksheetAction.HandlesTarget(Target: TObject): Boolean; begin Result := inherited HandlesTarget(Target) and (Worksheet <> nil); end; procedure TsWorksheetAction.UpdateTarget(Target: TObject); begin Unused(Target); Enabled := inherited Enabled and (Worksheet <> nil); end; { TsWorksheetAddAction } constructor TsWorksheetAddAction.Create(AOwner: TComponent); begin inherited Create(AOwner); FNameMask := 'Sheet%d'; end; { Helper procedure which creates a default worksheetname by counting a number up until - if inserted in the NameMask - it provides a unique worksheet name. } function TsWorksheetAddAction.GetUniqueSheetName: String; var i: Integer; begin Result := ''; if Workbook = nil then exit; i := 0; repeat inc(i); Result := Format(FNameMask, [i]); until Workbook.GetWorksheetByName(Result) = nil end; procedure TsWorksheetAddAction.ExecuteTarget(Target: TObject); var sheetName: String; begin if HandlesTarget(Target) then begin // Get default name of the new worksheet sheetName := GetUniqueSheetName; // If available use own procedure to specify new worksheet name if Assigned(FOnGetWorksheetName) then FOnGetWorksheetName(self, Worksheet, sheetName); // Check validity of worksheet name if not Workbook.ValidWorksheetName(sheetName) then begin MessageDlg(Format('"5s" is not a valid worksheet name.', [sheetName]), mtError, [mbOK], 0); exit; end; // Add new worksheet using the worksheet name. Workbook.AddWorksheet(sheetName); end; end; procedure TsWorksheetAddAction.SetNameMask(const AValue: String); begin if AValue = FNameMask then exit; if pos('%d', AValue) = 0 then raise Exception.Create('Worksheet name mask must contain a %d place-holder.'); FNameMask := AValue; end; { TsWorksheetDeleteAction } procedure TsWorksheetDeleteAction.ExecuteTarget(Target: TObject); begin if HandlesTarget(Target) then begin // Make sure that the last worksheet is not deleted - there must always be // at least 1 worksheet. if Workbook.GetWorksheetCount = 1 then begin MessageDlg('The workbook must contain at least 1 worksheet', mtError, [mbOK], 0); exit; end; // Confirmation dialog if MessageDlg( Format('Do you really want to delete worksheet "%s"?', [Worksheet.Name]), mtConfirmation, [mbYes, mbNo], 0) <> mrYes then exit; // Remove the worksheet; the workbookSource takes care of selecting the // next worksheet after deletion. Workbook.RemoveWorksheet(Worksheet); end; end; { TsWorksheetRenameAction } procedure TsWorksheetRenameAction.ExecuteTarget(Target: TObject); var s: String; begin if HandlesTarget(Target) then begin s := Worksheet.Name; // If requested, override input box by own input if Assigned(FOnGetWorksheetName) then FOnGetWorksheetName(self, Worksheet, s) else s := InputBox('Rename worksheet', 'New worksheet name', s); // No change if s = Worksheet.Name then exit; // Check validity of new worksheet name if Workbook.ValidWorksheetName(s) then Worksheet.Name := s else MessageDlg(Format('"%s" is not a valid worksheet name.', [s]), mtError, [mbOK], 0); end; end; { TsCopyAction } procedure TsCopyAction.ExecuteTarget(Target: TObject); const OPERATIONS: array[TsCopyItem] of TsCopyOperation = ( coCopyFormat, coCopyValue, coCopyFormula, coCopyCell ); begin Unused(Target); case FCopyMode of cmBrush: begin Checked := true; WorkbookSource.SetPendingOperation(OPERATIONS[FCopyItem], Worksheet.GetSelection); end; cmCopy: begin Checked := false; WorkbookSource.CopyCellsToClipboard; end; cmCut: begin Checked := false; WorkbookSource.CutCellsToClipboard; end; cmPaste: begin Checked := false; WorkbookSource.PasteCellsFromClipboard(OPERATIONS[FCopyItem]); end; end; end; procedure TsCopyAction.UpdateTarget(Target: TObject); begin Unused(Target); case FCopyMode of cmBrush: if WorkbookSource.PendingOperation = coNone then Checked := false; cmCopy, cmCut: Enabled := Worksheet.GetSelectionCount > 0; cmPaste: Enabled := not WorkbookSource.CellClipboardEmpty; end; end; { TsCellAction } function TsCellAction.HandlesTarget(Target: TObject): Boolean; begin Result := inherited HandlesTarget(Target) and (Worksheet <> nil) and (Length(GetSelection) > 0); end; { TsAutoFormatAction - action for cell formatting which is automatically updated according to the current selection } procedure TsAutoFormatAction.ExecuteTarget(Target: TObject); begin Unused(Target); ApplyFormatToSelection; end; procedure TsAutoFormatAction.UpdateTarget(Target: TObject); begin Unused(Target); Enabled := inherited Enabled and (Worksheet <> nil) and (Length(GetSelection) > 0); if Enabled then ExtractFromCell(ActiveCell); end; { TsFontStyleAction } constructor TsFontStyleAction.Create(AOwner: TComponent); begin inherited Create(AOwner); AutoCheck := true; end; procedure TsFontStyleAction.ApplyFormatToCell(ACell: PCell); var fnt: TsFont; fs: TsFontStyles; begin fnt := Worksheet.ReadCellFont(ACell); fs := fnt.Style; if Checked then Include(fs, FFontStyle) else Exclude(fs, FFontStyle); Worksheet.WriteFontStyle(ACell, fs); end; procedure TsFontStyleAction.ExtractFromCell(ACell: PCell); var fnt: TsFont; fmt: PsCellFormat; begin if (ACell = nil) then begin Checked := false; exit; end; fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); if (uffBold in fmt^.UsedFormattingFields) then Checked := (FFontStyle = fssBold) else if (uffFont in fmt^.UsedFormattingFields) then begin fnt := Workbook.GetFont(fmt^.FontIndex); Checked := (FFontStyle in fnt.Style); end else Checked := false; end; { TsHorAlignmentAction } constructor TsHorAlignmentAction.Create(AOwner: TComponent); begin inherited Create(AOwner); GroupIndex := 1411122312; // Date/time when this was written AutoCheck := true; end; procedure TsHorAlignmentAction.ApplyFormatToCell(ACell: PCell); begin if Checked then Worksheet.WriteHorAlignment(ACell, FHorAlign) else Worksheet.WriteHorAlignment(ACell, haDefault); end; procedure TsHorAlignmentAction.ExtractFromCell(ACell: PCell); begin Checked := (ACell <> nil) and (Worksheet.ReadHorAlignment(ACell) = FHorAlign); end; { TsVertAlignmentAction } constructor TsVertAlignmentAction.Create(AOwner: TComponent); begin inherited Create(AOwner); GroupIndex := 1411122322; // Date/time when this was written AutoCheck := true; end; procedure TsVertAlignmentAction.ApplyFormatToCell(ACell: PCell); begin if Checked then Worksheet.WriteVertAlignment(ACell, FVertAlign) else Worksheet.WriteVertAlignment(ACell, vaDefault); end; procedure TsVertAlignmentAction.ExtractFromCell(ACell: PCell); begin Checked := (ACell <> nil) and (Worksheet.ReadVertAlignment(ACell) = FVertAlign); end; { TsTextRotationAction } constructor TsTextRotationAction.Create(AOwner: TComponent); begin inherited Create(AOwner); GroupIndex := 1411141108; // Date/time when this was written AutoCheck := true; end; procedure TsTextRotationAction.ApplyFormatToCell(ACell: PCell); begin if Checked then Worksheet.WriteTextRotation(ACell, FTextRotation) else Worksheet.WriteTextRotation(ACell, trHorizontal); end; procedure TsTextRotationAction.ExtractFromCell(ACell: PCell); begin Checked := (ACell <> nil) and (Worksheet.ReadTextRotation(ACell) = FTextRotation); end; { TsWordwrapAction } constructor TsWordwrapAction.Create(AOwner: TComponent); begin inherited Create(AOwner); AutoCheck := true; end; procedure TsWordwrapAction.ApplyFormatToCell(ACell: PCell); begin Worksheet.WriteWordwrap(ACell, Checked); end; procedure TsWordwrapAction.ExtractFromCell(ACell: PCell); begin Checked := (ACell <> nil) and Worksheet.ReadWordwrap(ACell); end; function TsWordwrapAction.GetWordwrap: Boolean; begin Result := Checked; end; procedure TsWordwrapAction.SetWordwrap(AValue: Boolean); begin Checked := AValue; end; { TsNumberFormatAction } constructor TsNumberFormatAction.Create(AOwner: TComponent); begin inherited Create(AOwner); GroupIndex := 1411141258; // Date/time when this was written AutoCheck := true; end; procedure TsNumberFormatAction.ApplyFormatToCell(ACell: PCell); var nf: TsNumberFormat; nfstr: String; begin if Checked then begin nf := FNumberFormat; nfstr := FNumberFormatStr; end else begin nf := nfGeneral; nfstr := ''; end; if IsDateTimeFormat(nf) then Worksheet.WriteDateTimeFormat(ACell, nf, nfstr) else Worksheet.WriteNumberFormat(ACell, nf, nfstr); end; procedure TsNumberFormatAction.ExtractFromCell(ACell: PCell); var nf: TsNumberFormat; nfs: String; begin Worksheet.ReadNumFormat(ACell, nf, nfs); Checked := (ACell <> nil) and (nf = FNumberFormat) and (nfs = FNumberFormatStr); end; { TsDecimalsAction } constructor TsDecimalsAction.Create(AOwner: TComponent); begin inherited Create(AOwner); FDelta := +1; end; procedure TsDecimalsAction.ApplyFormatToCell(ACell: PCell); var decs: Integer; nf: TsNumberFormat; nfs: String; begin Worksheet.ReadNumFormat(ACell, nf, nfs); if IsDateTimeFormat(nf) then exit; if (ACell^.ContentType in [cctEmpty, cctNumber]) and (nf <> nfGeneral) then decs := Worksheet.GetDisplayedDecimals(ACell) else decs := FDecimals; inc(decs, FDelta); if decs < 0 then decs := 0; Worksheet.WriteDecimals(ACell, decs); end; procedure TsDecimalsAction.ExtractFromCell(ACell: PCell); var csym: String; decs: Byte; nf: TsNumberFormat; nfs: String; begin if ACell = nil then begin FDecimals := 2; exit; end; Worksheet.ReadNumFormat(ACell, nf, nfs); if (ACell^.ContentType in [cctEmpty, cctNumber]) and (nf <> nfGeneral) then decs := Worksheet.GetDisplayedDecimals(ACell) else Worksheet.GetNumberFormatAttributes(ACell, decs, csym); FDecimals := decs; end; { TsCellBorderAction } procedure TsActionBorder.ApplyStyle(AWorkbook: TsWorkbook; out ABorderStyle: TsCellBorderStyle); begin ABorderStyle.LineStyle := FLineStyle; ABorderStyle.Color := AWorkbook.GetPaletteColor(ABorderStyle.Color); end; procedure TsActionBorder.ExtractStyle(AWorkbook: TsWorkbook; ABorderStyle: TsCellBorderStyle); begin FLineStyle := ABorderStyle.LineStyle; Color := AWorkbook.AddColorToPalette(ABorderStyle.Color); end; constructor TsActionBorders.Create; var cb: TsCellBorder; begin inherited Create; for cb in TsCellBorder do FBorders[cb] := TsActionBorder.Create; end; destructor TsActionBorders.Destroy; var cb: TsCellBorder; begin for cb in TsCellBorder do FBorders[cb].Free; inherited Destroy; end; procedure TsActionBorders.ExtractFromCell(AWorkbook: TsWorkbook; ACell: PCell); var cb: TsCellBorder; fmt: PsCellFormat; begin if (ACell <> nil) then fmt := AWorkbook.GetPointerToCellFormat(ACell^.FormatIndex); if (ACell = nil) or not (uffBorder in fmt^.UsedFormattingFields) then for cb in TsCellBorder do begin FBorders[cb].ExtractStyle(AWorkbook, DEFAULT_BORDERSTYLES[cb]); FBorders[cb].Visible := false; end else for cb in TsCellBorder do begin FBorders[cb].ExtractStyle(AWorkbook, fmt^.BorderStyles[cb]); FBorders[cb].Visible := cb in fmt^.Border; end; end; function TsActionBorders.GetBorder(AIndex: TsCellBorder): TsActionBorder; begin Result := FBorders[AIndex]; end; procedure TsActionBorders.SetBorder(AIndex: TsCellBorder; AValue: TsActionBorder); begin FBorders[AIndex] := AValue; end; constructor TsCellBorderAction.Create(AOwner: TComponent); begin inherited Create(AOwner); FBorders := TsActionBorders.Create; end; destructor TsCellBorderAction.Destroy; begin FBorders.Free; inherited; end; procedure TsCellBorderAction.ApplyFormatToRange(ARange: TsCellRange); procedure ShowBorder(ABorder: TsCellBorder; ACell: PCell; ABorderStyle: TsCellBorderStyle; AEnable: boolean); var fmt: TsCellFormat; begin fmt := Workbook.GetCellFormat(ACell^.FormatIndex); if AEnable then begin Include(fmt.UsedFormattingFields, uffBorder); Include(fmt.Border, ABorder); fmt.BorderStyles[ABorder] := ABorderStyle; ACell^.FormatIndex := Workbook.AddCellFormat(fmt); end else Exclude(fmt.UsedFormattingFields, uffBorder); Worksheet.ChangedCell(ACell^.Row, ACell^.Col); end; var r, c: LongInt; bs: TsCellBorderStyle; begin // Top edges Borders.North.ApplyStyle(Workbook, bs); for c := ARange.Col1 to ARange.Col2 do ShowBorder(cbNorth, Worksheet.GetCell(ARange.Row1, c), bs, Borders.North.Visible); // Bottom edges Borders.South.ApplyStyle(Workbook, bs); for c := ARange.Col1 to ARange.Col2 do ShowBorder(cbSouth, Worksheet.GetCell(ARange.Row2, c), bs, Borders.South.Visible); // Inner horizontal edges Borders.InnerHor.ApplyStyle(Workbook, bs); for c := ARange.Col1 to ARange.Col2 do begin for r := ARange.Row1 to LongInt(ARange.Row2)-1 do ShowBorder(cbSouth, Worksheet.GetCell(r, c), bs, Borders.InnerHor.Visible); for r := ARange.Row1+1 to ARange.Row2 do ShowBorder(cbNorth, Worksheet.GetCell(r, c), bs, Borders.InnerHor.Visible); end; // Left edges Borders.West.ApplyStyle(Workbook, bs); for r := ARange.Row1 to ARange.Row2 do ShowBorder(cbWest, Worksheet.GetCell(r, ARange.Col1), bs, Borders.West.Visible); // Right edges Borders.East.ApplyStyle(Workbook, bs); for r := ARange.Row1 to ARange.Row2 do ShowBorder(cbEast, Worksheet.GetCell(r, ARange.Col2), bs, Borders.East.Visible); // Inner vertical lines Borders.InnerVert.ApplyStyle(Workbook, bs); for r := ARange.Row1 to ARange.Row2 do begin for c := ARange.Col1 to LongInt(ARange.Col2)-1 do ShowBorder(cbEast, Worksheet.GetCell(r, c), bs, Borders.InnerVert.Visible); for c := ARange.Col1+1 to ARange.Col2 do ShowBorder(cbWest, Worksheet.GetCell(r, c), bs, Borders.InnerVert.Visible); end; end; procedure TsCellBorderAction.ExecuteTarget(Target: TObject); begin Unused(Target); ApplyFormatToSelection; end; procedure TsCellBorderAction.ExtractFromCell(ACell: PCell); var EmptyCell: TCell; begin if (ACell = nil) or not (uffBorder in Worksheet.ReadUsedFormatting(ACell)) then begin EmptyCell.Row := 0; // silence the compiler... InitCell(EmptyCell); FBorders.ExtractFromCell(Workbook, @EmptyCell); end else FBorders.ExtractFromCell(Workbook, ACell); end; { TsNoCellBordersAction } procedure TsNoCellBordersAction.ApplyFormatToCell(ACell: PCell); begin Worksheet.WriteBorders(ACell, []); end; procedure TsNoCellBordersAction.ExecuteTarget(Target: TObject); begin Unused(Target); ApplyFormatToSelection; end; { TsCellCommentAction } function TsCellCommentAction.EditComment(ACaption: String; var AText: String): Boolean; var F: TForm; memo: TMemo; panel: TPanel; btn: TBitBtn; begin F := TForm.Create(nil); try F.Caption := ACaption; F.Width := 400; F.Height := 300; F.Position := poMainFormCenter; memo := TMemo.Create(F); memo.Parent := F; memo.Align := alClient; memo.BorderSpacing.Around := 4; memo.Lines.Text := AText; panel := TPanel.Create(F); panel.Parent := F; panel.Align := alBottom; panel.Height := 44; panel.BevelOuter := bvNone; panel.Caption := ''; btn := TBitBtn.Create(F); btn.Parent := panel; btn.Kind := bkOK; btn.Left := panel.ClientWidth - 2*btn.Width - 2*8; btn.Top := 6; btn.Anchors := [akTop, akRight]; btn := TBitBtn.Create(F); btn.Parent := panel; btn.Kind := bkCancel; btn.Left := panel.ClientWidth - btn.Width - 8; btn.Top := 6; btn.Anchors := [akTop, akRight]; if F.ShowModal = mrOK then begin Result := true; AText := memo.Lines.Text; end else Result := false; finally F.Free; end; end; procedure TsCellCommentAction.ExecuteTarget(Target: TObject); var txt: String; cellStr: String; begin Unused(Target); if Worksheet = nil then exit; cellstr := GetCellString(Worksheet.ActiveCellRow, Worksheet.ActiveCellCol); case FMode of ccmNew: begin txt := ''; if EditComment(Format('New comment for cell %s',[cellStr]), txt) then Worksheet.WriteComment(Worksheet.ActiveCellRow, Worksheet.ActiveCellCol, txt); end; ccmEdit: begin txt := Worksheet.ReadComment(ActiveCell); if EditComment(Format('Edit comment for cell %s', [cellStr]), txt) then Worksheet.WriteComment(Worksheet.ActiveCellRow, Worksheet.ActiveCellCol, txt); end; ccmDelete: Worksheet.WriteComment(ActiveCell, ''); end; end; procedure TsCellCommentAction.UpdateTarget(Target: TObject); begin Unused(Target); case FMode of ccmNew : Enabled := (Worksheet <> nil) and (Length(GetSelection) > 0); ccmEdit, ccmDelete: Enabled := (Worksheet <> nil) and (Worksheet.ReadComment(ActiveCell) <> ''); end; end; { TsMergeAction } constructor TsMergeAction.Create(AOwner: TComponent); begin inherited Create(AOwner); AutoCheck := true; end; procedure TsMergeAction.ApplyFormatToRange(ARange: TsCellRange); begin if Merged then Worksheet.MergeCells(ARange.Row1, ARange.Col1, ARange.Row2, ARange.Col2) else Worksheet.UnmergeCells(ARange.Row1, ARange.Col1); end; procedure TsMergeAction.ExtractFromCell(ACell: PCell); begin Checked := (ACell <> nil) and Worksheet.IsMerged(ACell); end; function TsMergeAction.GetMerged: Boolean; begin Result := Checked; end; procedure TsMergeAction.SetMerged(AValue: Boolean); begin Checked := AValue; 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; var cell: PCell; begin if Assigned(FBeforeExecute) then FBeforeExecute(Self); cell := Worksheet.FindCell(Worksheet.ActiveCellRow, Worksheet.ActiveCellCol); ExtractFromCell(cell); 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 Unused(Target); DoBeforeExecute; FExecuteResult := FDialog.Execute; if FExecuteResult then DoAccept else DoCancel; end; { TsCommonDialogCellAction } procedure TsCommonDialogCellAction.DoAccept; begin ApplyFormatToSelection; inherited; end; procedure TsCommonDialogCellAction.DoBeforeExecute; begin inherited; ExtractFromCell(ActiveCell); end; { TsFontDialogAction } procedure TsFontDialogAction.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 TsFontDialogAction.ExtractFromCell(ACell: PCell); var sfnt: TsFont; fnt: TFont; fmt: PsCellFormat; begin fnt := TFont.Create; try if (ACell = nil) then sfnt := Workbook.GetDefaultFont else begin fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); if (uffBold in fmt^.UsedFormattingFields) then sfnt := Workbook.GetFont(1) else if (uffFont in fmt^.UsedFormattingFields) then sfnt := Workbook.GetFont(fmt^.FontIndex) else sfnt := Workbook.GetDefaultFont; end; Convert_sFont_to_Font(Workbook, sfnt, fnt); GetDialog.Font.Assign(fnt); finally fnt.Free; end; end; function TsFontDialogAction.GetDialog: TFontDialog; begin Result := TFontDialog(FDialog); end; function TsFontDialogAction.GetDialogClass: TCommonDialogClass; begin Result := TFontDialog; end; { TsBackgroundColorDialogAction } procedure TsBackgroundColorDialogAction.ApplyFormatToCell(ACell: PCell); begin Worksheet.WritebackgroundColor(ACell, FBackgroundColor); end; procedure TsBackgroundColorDialogAction.DoAccept; begin FBackgroundColor := Workbook.AddColorToPalette(TsColorValue(Dialog.Color)); inherited; end; procedure TsBackgroundColorDialogAction.DoBeforeExecute; begin inherited; Dialog.Color := Workbook.GetPaletteColor(FBackgroundColor); end; procedure TsBackgroundColorDialogAction.ExtractFromCell(ACell: PCell); var fmt: PsCellFormat; begin FBackgroundColor := scNotDefined; if (ACell <> nil) then begin fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); if (uffBackground in fmt^.UsedFormattingFields) then begin if fmt^.Background.Style = fsSolidFill then FBackgroundColor := fmt^.Background.FgColor else FBackgroundColor := fmt^.Background.BgColor; end; end; end; function TsBackgroundColorDialogAction.GetDialog: TColorDialog; begin Result := TColorDialog(FDialog); end; function TsBackgroundColorDialogAction.GetDialogClass: TCommonDialogClass; begin Result := TColorDialog; end; end.