From 816063805185fedebd77379bf4716f3b5296f738 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Thu, 25 Jun 2020 17:18:32 +0000 Subject: [PATCH] fpspreadsheet: Initial commit for conditional formatting. Based on ideas of forum user "abcthing" (https://forum.lazarus.freepascal.org/index.php/topic,50149.0.html). git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7492 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../fpspreadsheet/laz_fpspreadsheet.lpk | 10 +- .../source/common/fpsconditionalformat.pas | 299 ++++++++++ .../source/common/fpspreadsheet.pas | 43 +- .../source/common/fpspreadsheet_cf.inc | 53 ++ .../fpspreadsheet/source/common/fpstypes.pas | 44 ++ .../fpspreadsheet/source/common/fpsutils.pas | 6 +- .../fpspreadsheet/source/common/xlsxooxml.pas | 547 ++++++++++++++---- 7 files changed, 869 insertions(+), 133 deletions(-) create mode 100644 components/fpspreadsheet/source/common/fpsconditionalformat.pas create mode 100644 components/fpspreadsheet/source/common/fpspreadsheet_cf.inc diff --git a/components/fpspreadsheet/laz_fpspreadsheet.lpk b/components/fpspreadsheet/laz_fpspreadsheet.lpk index 3e5192abb..92ca967ba 100644 --- a/components/fpspreadsheet/laz_fpspreadsheet.lpk +++ b/components/fpspreadsheet/laz_fpspreadsheet.lpk @@ -34,7 +34,7 @@ This package is all you need if you don't want graphical components (like grids and charts)."/> - + @@ -258,6 +258,14 @@ This package is all you need if you don't want graphical components (like g + + + + + + + + diff --git a/components/fpspreadsheet/source/common/fpsconditionalformat.pas b/components/fpspreadsheet/source/common/fpsconditionalformat.pas new file mode 100644 index 000000000..050aa2aca --- /dev/null +++ b/components/fpspreadsheet/source/common/fpsconditionalformat.pas @@ -0,0 +1,299 @@ +unit fpsConditionalFormat; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, Contnrs, SysUtils, Variants, fpsTypes; + +type + TsCFRule = class + public + procedure Assign(ASource: TsCFRule); virtual; abstract; + end; + + { Cell is... } + TsCFCondition = ( + cfcEqual, cfcNotEqual, + cfcGreaterThan, cfcLessThan, cfcGreaterEqual, cfcLessEqual, + cfcBetween, cfcNotBetween, + cfcAboveAverage, cfcBelowAverage, + cfcBeginsWidth, cfcEndsWith, + cfcDuplicate, cfcUnique, + cfcContainsText, cfcNotContaisText, + cfcContainsErrors, cfcNotContainsErrors + ); + + {cellIs + expression + colorScale, dataBar, iconSet + containsText, notContainsText, beginsWith, endsWith, containsBlanks, notContainsBlanks, containsErrors, notContainsErrors + } + + TsCFCellRule = class(TsCFRule) + public + Condition: TsCFCondition; + Operand1: Variant; + Operand2: Variant; + FormatIndex: Integer; + procedure Assign(ASource: TsCFRule); override; + end; + + { Color range } + TsCFColorRangeValue = (crvMin, crvMax, crvPercentile); + + TsCFColorRangeRule = class(TsCFRule) + StartValue: TsCFColorRangeValue; + CenterValue: TsCFColorRangeValue; + EndValue: TsCFColorRangeValue; + StartValueParam: Double; + CenterValueParam: Double; + EndValueParam: Double; + StartColor: TsColor; + CenterColor: TsColor; + EndColor: TsColor; + procedure Assign(ASource: TsCFRule); override; + end; + + { DataBars } + TsCFDatabarRule = class(TsCFRule) + procedure Assign(ASource: TsCFRule); override; + end; + + { Rules } + TsCFRules = class(TFPObjectList) + private + function GetItem(AIndex: Integer): TsCFRule; + function GetPriority(AIndex: Integer): Integer; + procedure SetItem(AIndex: Integer; const AValue: TsCFRule); + public + property Items[AIndex: Integer]: TsCFRule read GetItem write SetItem; default; + property Priority[AIndex: Integer]: Integer read GetPriority; + end; + + { Conditional format item } + TsConditionalFormat = class + private + FCellRange: TsCellRange; + FRules: TsCFRules; + function GetRules(AIndex: Integer): TsCFRule; + function GetRulesCount: Integer; + public + constructor Create(ACellRange: TsCellRange); + destructor Destroy; override; + + property CellRange: TsCellRange read FCellRange; + property Rules[AIndex: Integer]: TsCFRule read GetRules; + property RulesCount: Integer read GetRulesCount; + end; + + TsConditionalFormatList = class(TFPObjectList) + protected + function AddRule(ARange: TsCellRange; ARule: TsCFRule): Integer; + public + function AddCellRule(ARange: TsCellRange; ACondition: TsCFCondition; + ACellFormatIndex: Integer): Integer; overload; + function AddCellRule(ARange: TsCellRange; ACondition: TsCFCondition; + AParam: Variant; ACellFormatIndex: Integer): Integer; overload; + function AddCellRule(ARange: TsCellRange; ACondition: TsCFCondition; + AParam1, AParam2: Variant; ACellFormatIndex: Integer): Integer; overload; + procedure AddColorRangeRule(ARange: TsCellRange); + procedure AddDataBarRule(ARange: TsCellRange); + function Find(ARange: TsCellRange): Integer; + end; + + +implementation + +procedure TsCFCellRule.Assign(ASource: TsCFRule); +begin + if ASource is TsCFCellRule then + begin + Condition := TsCFCellRule(ASource).Condition; + Operand1 := TsCFCellRule(ASource).Operand1; + Operand2 := TsCFCellRule(ASource).Operand2; + FormatIndex := TsCFCellRule(ASource).FormatIndex; + end else + raise Exception.Create('Source cannot be assigned to TCVCellRule'); +end; + +procedure TsCFDataBarRule.Assign(ASource: TsCFRule); +begin + if ASource is TsCFDataBarRule then + begin + // + end else + raise Exception.Create('Source cannot be assigned to TCVDataBarRule'); +end; + +procedure TsCFColorRangeRule.Assign(ASource: TsCFRule); +begin + if ASource is TsCFColorRangeRule then + begin + StartValue := TsCFColorRangeRule(ASource).StartValue; + CenterValue := TsCFColorRangeRule(ASource).CenterValue; + EndValue := TsCFColorRangeRule(ASource).EndValue; + StartValueParam := TsCFColorRangeRule(ASource).StartValueParam; + CenterValueParam := TsCFColorRangeRule(ASource).CenterValueParam; + EndValueParam := TsCFColorRangeRule(ASource).EndValueParam; + StartColor := TsCFColorRangeRule(ASource).StartColor; + CenterColor := TsCFColorRangeRule(ASource).CenterColor; + EndColor := TsCFColorRangeRule(ASource).EndColor; + end else + raise Exception.Create('Source cannot be assigned to TCVDataBarRule'); +end; + + +{ TCFRule } + +function TsCFRules.GetItem(AIndex: Integer): TsCFRule; +begin + Result := TsCFRule(inherited Items[AIndex]); +end; + +function TsCFRules.GetPriority(AIndex: Integer): Integer; +begin + Result := Count - AIndex; +end; + +procedure TsCFRules.SetItem(AIndex: Integer; const AValue: TsCFRule); +var + item: TsCFRule; +begin + item := GetItem(AIndex); + item.Assign(AValue); + inherited Items[AIndex] := item; +end; + + +{ TsConditonalFormat } + +constructor TsConditionalFormat.Create(ACellRange: TsCellRange); +begin + inherited Create; + FCellRange := ACellRange; + FRules := TsCFRules.Create; +end; + +destructor TsConditionalFormat.Destroy; +begin + FRules.Free; + inherited; +end; + +function TsConditionalFormat.GetRules(AIndex: Integer): TsCFRule; +begin + Result := FRules[AIndex]; +end; + +function TsConditionalFormat.GetRulesCount: Integer; +begin + Result := FRules.Count; +end; + + +{ TsConditionalFormatList } + +{@@ ---------------------------------------------------------------------------- + Adds a new conditional format to the list. + The format is specified by the cell range to which it is applied and by + the rule describing the format. + The rules are grouped for the same cell ranges. +-------------------------------------------------------------------------------} +function TsConditionalFormatList.AddRule(ARange: TsCellRange; + ARule: TsCFRule): Integer; +var + CF: TsConditionalFormat; + idx: Integer; +begin + idx := Find(ARange); + if idx = -1 then begin + CF := TsConditionalFormat.Create(ARange); + idx := Add(CF); + end else + CF := TsConditionalFormat(Items[idx]); + CF.FRules.Add(ARule); + Result := idx; +end; + +// TODO: Add pre-checks for compatibility of condition and operands + +function TsConditionalFormatList.AddCellRule(ARange: TsCellRange; + ACondition: TsCFCondition; ACellFormatIndex: Integer): Integer; +var + rule: TsCFCellRule; +begin + rule := TsCFCellRule.Create; + rule.Condition := ACondition; + rule.Operand1 := varNull; + rule.Operand2 := varNull; + rule.FormatIndex := ACellFormatIndex; + Result := AddRule(ARange, rule); +end; + +function TsConditionalFormatList.AddCellRule(ARange: TsCellRange; + ACondition: TsCFCondition; AParam: Variant; ACellFormatIndex: Integer): Integer; +var + rule: TsCFCellRule; +begin + rule := TsCFCellRule.Create; + rule.Condition := ACondition; + rule.Operand1 := AParam; + rule.Operand2 := varNull; + rule.FormatIndex := ACellFormatIndex; + Result := AddRule(ARange, rule); +end; + +function TsConditionalFormatList.AddCellRule(ARange: TsCellRange; + ACondition: TsCFCondition; AParam1, AParam2: Variant; + ACellFormatIndex: Integer): Integer; +var + rule: TsCFCellRule; +begin + rule := TsCFCellRule.Create; + rule.Condition := ACondition; + rule.Operand1 := AParam1; + rule.Operand2 := AParam2; + rule.FormatIndex := ACellFormatIndex; + Result := AddRule(ARange, rule); +end; + +procedure TsConditionalFormatList.AddColorRangeRule(ARange: TsCellRange); +begin + raise EXception.Create('ColorRange not yet implemented.'); +end; + +procedure TsConditionalFormatlist.AddDataBarRule(ARange: TsCellRange); +begin + raise Exception.Create('DataBars not yet implemented.'); +end; + + +{@@ ---------------------------------------------------------------------------- + The conditional format list must be unique regarding cell ranges. + This function searches all format item whether a given cell ranges is + already listed. +-------------------------------------------------------------------------------} +function TsConditionalFormatList.Find(ARange: TsCellRange): Integer; +var + i: Integer; + CF: TsConditionalFormat; + CFRange: TsCellRange; +begin + for i := 0 to Count-1 do + begin + CF := TsConditionalFormat(Items[i]); + CFRange := CF.CellRange; + if (CFRange.Row1 = ARange.Row1) and (CFRange.Row2 = ARange.Row2) and + (CFRange.Col1 = ARange.Col1) and (CFRange.Col2 = ARange.Col2) then + begin + Result := i; + exit; + end; + end; + Result := -1; +end; + +end. + diff --git a/components/fpspreadsheet/source/common/fpspreadsheet.pas b/components/fpspreadsheet/source/common/fpspreadsheet.pas index 41e565453..19ada966e 100644 --- a/components/fpspreadsheet/source/common/fpspreadsheet.pas +++ b/components/fpspreadsheet/source/common/fpspreadsheet.pas @@ -24,7 +24,7 @@ uses {$endif}{$endif}{$endif} Classes, SysUtils, fpimage, avglvltree, lconvencoding, fpsTypes, fpsExprParser, fpsClasses, fpsNumFormat, fpsPageLayout, - fpsImages; + fpsImages, fpsConditionalFormat; type { Forward declarations } @@ -75,6 +75,7 @@ type FHyperlinks: TsHyperlinks; FFormulas: TsFormulas; FImages: TFPList; + FConditionalFormats: TsConditionalFormatList; FRows, FCols: TIndexedAVLTree; // This lists contain only rows or cols with styles different from default FActiveCellRow: Cardinal; FActiveCellCol: Cardinal; @@ -108,6 +109,7 @@ type FOnWriteCellData: TsWorksheetWriteCellDataEvent; { Setter/Getter } + function GetConditionalFormatCount: Integer; function GetDefaultColWidth: Single; function GetDefaultRowHeight: Single; function GetFormatSettings: TFormatSettings; @@ -383,6 +385,15 @@ type procedure WriteCellProtection(ACell: PCell; AValue: TsCellProtections); overload; + { Conditional formatting } + function ReadConditionalFormat(AIndex: Integer): TsConditionalFormat; + function WriteConditionalCellFormat(ARange: TsCellRange; ACondition: TsCFCondition; + ACellFormatIndex: Integer): Integer; overload; + function WriteConditionalCellFormat(ARange: TsCellRange; ACondition: TsCFCondition; + AParam: Variant; ACellFormatIndex: Integer): Integer; overload; + function WriteConditionalCellFormat(ARange: TsCellRange; ACondition: TsCFCondition; + AParam1, AParam2: Variant; ACellFormatIndex: Integer): Integer; overload; + { Formulas } function BuildRPNFormula(ACell: PCell; ADestCell: PCell = nil): TsRPNFormula; procedure CalcFormula(AFormula: PsFormula); @@ -599,6 +610,8 @@ type property Cells: TsCells read FCells; {@@ List of all column records of the worksheet having a non-standard column width } property Cols: TIndexedAVLTree read FCols; + {@@ Count of conditional format entries } + property ConditionalFormatCount: Integer read GetConditionalFormatCount; {@@ Information how the worksheet is encrypted } property CryptoInfo: TsCryptoInfo read FCryptoInfo write FCryptoInfo; {@@ List of all comment records } @@ -816,7 +829,8 @@ type function AddFont(const AFontName: String; ASize: Single; AStyle: TsFontStyles; AColor: TsColor; APosition: TsFontPosition = fpNormal): Integer; overload; function AddFont(const AFont: TsFont): Integer; overload; - procedure DeleteFont(AFontIndex: Integer); + function CloneFont(const AFontIndex: Integer): TsFont; + procedure DeleteFont(const AFontIndex: Integer); function FindFont(const AFontName: String; ASize: Single; AStyle: TsFontStyles; AColor: TsColor; APosition: TsFontPosition = fpNormal): Integer; function GetBuiltinFontCount: Integer; @@ -1171,6 +1185,7 @@ begin FHyperlinks := TsHyperlinks.Create; FFormulas := TsFormulas.Create; FImages := TFPList.Create; + FConditionalFormats := TsConditionalFormatList.Create; FPageLayout := TsPageLayout.Create(self); @@ -1214,6 +1229,7 @@ begin FHyperlinks.Free; FFormulas.Free; FImages.Free; + FConditionalFormats.Free; inherited Destroy; end; @@ -8501,6 +8517,8 @@ begin end; end; +{$include fpspreadsheet_CF.inc} // conditional formatting + {==============================================================================} { TsWorkbook } @@ -9880,13 +9898,32 @@ begin result := FFontList.Add(AFont); end; +{@@ ---------------------------------------------------------------------------- + Creates a new font as a copy of the font at the specified index. + The new font is NOT YET added to the font list. + If the user does not add the font to the font list he is responsibile for + destroying it. +-------------------------------------------------------------------------------} +function TsWorkbook.CloneFont(const AFontIndex: Integer): TsFont; +var + fnt: TsFont; +begin + Result := TsFont.Create; + fnt := GetFont(AFontIndex); + Result.FontName := fnt.FontName; + Result.Size := fnt.Size; + Result.Style := fnt.Style; + Result.Color := fnt.Color; + Result.Position := fnt.Position; +end; + {@@ ---------------------------------------------------------------------------- Deletes a font. Use with caution because this will screw up the font assignment to cells. The only legal reason to call this method is from a reader of a file format in which the missing font #4 of BIFF does exist. -------------------------------------------------------------------------------} -procedure TsWorkbook.DeleteFont(AFontIndex: Integer); +procedure TsWorkbook.DeleteFont(const AFontIndex: Integer); var fnt: TsFont; begin diff --git a/components/fpspreadsheet/source/common/fpspreadsheet_cf.inc b/components/fpspreadsheet/source/common/fpspreadsheet_cf.inc new file mode 100644 index 000000000..0e94f9bfe --- /dev/null +++ b/components/fpspreadsheet/source/common/fpspreadsheet_cf.inc @@ -0,0 +1,53 @@ +{ Included by fpspreadsheet.pas } + +{ Returns the count of conditional format items } +function TsWorksheet.GetConditionalFormatCount: Integer; +begin + Result := FConditionalFormats.Count; +end; + +{@@ ---------------------------------------------------------------------------- + Returns the conditional format item stored in the CF list at the specified + index. +-------------------------------------------------------------------------------} +function TsWorksheet.ReadConditionalFormat(AIndex: Integer): TsConditionalFormat; +begin + Result := TsConditionalFormat(FConditionalFormats[AIndex]); +end; + +{@@ ---------------------------------------------------------------------------- + Creates a conditional format item for the cells given by ARange. + The condition specified must not require parameters, e.g. cfcEmpty +-------------------------------------------------------------------------------} +function TsWorksheet.WriteConditionalCellFormat(ARange: TsCellRange; + ACondition: TsCFCondition; ACellFormatIndex: Integer): Integer; +begin + Result := FConditionalFormats.AddCellRule(ARange, ACondition, + ACellFormatIndex); +end; + +{@@ ---------------------------------------------------------------------------- + Creates a conditional format item for the cells given by ARange. + The condition specified must require one parameter, e.g. cfcEqual, + and the parameter must be specified as AParam. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteConditionalCellFormat(ARange: TsCellRange; + ACondition: TsCFCondition; AParam: Variant; ACellFormatIndex: Integer): Integer; +begin + Result := FConditionalFormats.AddCellRule(ARange, ACondition, + AParam, ACellFormatIndex); +end; + +{@@ ---------------------------------------------------------------------------- + Creates a conditional format item for the cells given by ARange. + The condition specified must requored two parameters, e.g. cfcBetween, + and the parameters must be specified as AParam1 and AParam2. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteConditionalCellFormat(ARange: TsCellRange; + ACondition: TsCFCondition; AParam1, AParam2: Variant; + ACellFormatIndex: Integer): Integer; +begin + Result := FConditionalFormats.AddCellRule(ARange, ACondition, + AParam1, AParam2, ACellFormatIndex); +end; + diff --git a/components/fpspreadsheet/source/common/fpstypes.pas b/components/fpspreadsheet/source/common/fpstypes.pas index ccd7493fc..c7fefa84c 100644 --- a/components/fpspreadsheet/source/common/fpstypes.pas +++ b/components/fpspreadsheet/source/common/fpstypes.pas @@ -10,6 +10,8 @@ unit fpsTypes; {$mode objfpc}{$H+} +{$modeswitch advancedrecords} + {$include fps.inc} interface @@ -719,6 +721,10 @@ type // next two are deprecated... NumberFormat: TsNumberFormat; NumberFormatStr: String; + procedure SetBackgroundColor(AColor: TsColor); + procedure SetBorders(ABorders: TsCellBorders; + AColor: TsColor = scBlack; ALineStyle: TsLineStyle = lsThin); + procedure SetFont(AFontIndex: Integer); end; {@@ Pointer to a format record } @@ -1059,6 +1065,44 @@ begin end; end; +{ TsCellFormat } + +procedure TsCellFormat.SetBackgroundColor(AColor: TsColor); +begin + UsedFormattingFields := UsedFormattingFields + [uffBackground]; + Background.FgColor := AColor; + Background.BgColor := AColor; + Background.Style := fsSolidFill; +end; + +procedure TsCellFormat.SetBorders(ABorders: TsCellBorders; + AColor: TsColor = scBlack; ALineStyle: TsLineStyle = lsThin); +var + cb: TsCellBorder; +begin + for cb in ABorders do + begin + if (AColor = scNone) or (AColor = scTransparent) then + Exclude(Border, cb) + else + begin + Include(Border, cb); + BorderStyles[cb].LineStyle := ALineStyle; + BorderStyles[cb].Color := AColor; + end; + end; + if Border = [] then + UsedFormattingFields := UsedFormattingfields - [uffBorder] + else + UsedFormattingFields := UsedFormattingfields + [uffBorder]; +end; + +procedure TsCellFormat.SetFont(AFontIndex: Integer); +begin + FontIndex := AFontIndex; + UsedFormattingFields := UsedFormattingFields + [uffFont]; +end; + { TsFont } diff --git a/components/fpspreadsheet/source/common/fpsutils.pas b/components/fpspreadsheet/source/common/fpsutils.pas index 61f9dec40..39269d8fd 100644 --- a/components/fpspreadsheet/source/common/fpsutils.pas +++ b/components/fpspreadsheet/source/common/fpsutils.pas @@ -1129,9 +1129,9 @@ const function GetCellString(ARow, ACol: Cardinal; AFlags: TsRelFlags = [rfRelRow, rfRelCol]): String; begin - Result := Format('%s%s%s%d', [ + Result := Format('%s%s%s%s', [ RELCHAR[rfRelCol in AFlags], GetColString(ACol), - RELCHAR[rfRelRow in AFlags], ARow+1 + RELCHAR[rfRelRow in AFlags], GetRowString(ARow) ]); end; @@ -2188,7 +2188,7 @@ end; @param AValue RGB color value (compatible with the TColor data type of the graphics unit) - @param AExcelDialect If TRUE, returned string is in Excels format for xlsx, + @param AExcelDialect If TRUE, returned string is in Excel's format for xlsx, i.e. in AARRGGBB notation, like '00FF0000' for "red" @return HTML-compatible string, like '#FF0000' (AExcelDialect = false) -------------------------------------------------------------------------------} diff --git a/components/fpspreadsheet/source/common/xlsxooxml.pas b/components/fpspreadsheet/source/common/xlsxooxml.pas index 023285614..e4476ff0c 100644 --- a/components/fpspreadsheet/source/common/xlsxooxml.pas +++ b/components/fpspreadsheet/source/common/xlsxooxml.pas @@ -42,6 +42,7 @@ uses fpszipper, {$ENDIF} fpsTypes, fpsUtils, fpsReaderWriter, fpsNumFormat, fpsPalette, + fpsConditionalFormat, fpsxmlcommon, xlsCommon; type @@ -123,6 +124,7 @@ type FSharedStringsCount: Integer; FFillList: array of PsCellFormat; FBorderList: array of PsCellFormat; + FDifferentialFormatIndexList: array of Integer; function GetActiveTab: String; procedure Get_rId(AWorksheet: TsBasicWorksheet; out AComment_rId, AFirstHyperlink_rId, ADrawing_rId, ADrawingHF_rId: Integer); @@ -134,6 +136,7 @@ type function FindFillInList(AFormat: PsCellFormat): Integer; function GetStyleIndex(ACell: PCell): Cardinal; procedure ListAllBorders; + procedure ListAllDifferentialFormats; procedure ListAllFills; function PrepareFormula(const AFormula: String): String; procedure ResetStreams; @@ -141,7 +144,13 @@ type procedure WriteColBreaks(AStream: TStream; AWorksheet: TsBasicWorksheet); procedure WriteCols(AStream: TStream; AWorksheet: TsBasicWorksheet); procedure WriteComments(AWorksheet: TsBasicWorksheet); + procedure WriteConditionalFormat(AStream: TStream; AFormat: TsConditionalFormat; var APriority: Integer); + procedure WriteConditionalFormatCellRule(AStream: TStream; ARule: TsCFCellRule; APriority: Integer); + procedure WriteConditionalFormatRule(AStream: TStream; ARule: TsCFRule; var APriority: Integer); + procedure WriteConditionalFormats(AStream: TStream; AWorksheet: TsBasicWorksheet); procedure WriteDefinedNames(AStream: TStream); + procedure WriteDifferentialFormat(AStream: TStream; AFormat: PsCellFormat); + procedure WriteDifferentialFormats(AStream: TStream); procedure WriteDimension(AStream: TStream; AWorksheet: TsBasicWorksheet); procedure WriteDrawings(AWorksheet: TsBasicWorksheet); procedure WriteDrawingRels(AWorksheet: TsBasicWorksheet); @@ -164,6 +173,7 @@ type procedure WriteSheetProtection(AStream: TStream; AWorksheet: TsBasicWorksheet); procedure WriteSheets(AStream: TStream); procedure WriteSheetViews(AStream: TStream; AWorksheet: TsBasicWorksheet); + procedure WriteStyle(AStream: TStream; ANodeName: String; AFormat: PsCellFormat); procedure WriteStyleList(AStream: TStream; ANodeName: String); procedure WriteVmlDrawings(AWorksheet: TsBasicWorksheet); procedure WriteVMLDrawings_Comments(AWorksheet: TsBasicWorksheet); @@ -313,6 +323,9 @@ type BorderStyles: TsCellBorderStyles; end; + TDifferentialFormatData = class + end; + THyperlinkListData = class ID: String; CellRef: String; @@ -359,6 +372,21 @@ const 'lightGrid' // fsHatchThinHor ); + LINESTYLE_TYPES: array[TsLineStyle] of String = ( + 'thin', // lsThin + 'medium', // lsMedium + 'dashed', // lsDashed + 'dotted', // lsDotted + 'thick', // lsThick + 'double', // lsDouble + 'hair', // lsHair + 'mediumDashed', // lsMediumDash + 'dashDot', // lsDashDot + 'mediumDashDot', // lsMediumDashDot + 'dashDotDot', // lsDashDotDot + 'mediumDashDotDot', // lsMediumDashDotDot + 'slantDashDot' // lsSlantDashDot + ); procedure InitOOXMLLimitations(out ALimitations: TsSpreadsheetFormatLimitations); begin @@ -3035,6 +3063,49 @@ begin end; end; +{ FDifferentialFormatIndexList stores the indexes of the cells formats used + in conditional formatting. } +procedure TsSpreadOOXMLWriter.ListAllDifferentialFormats; +var + book: TsWorkbook; + sheet: TsWorksheet; + n: Integer; + idx: Integer; + i, j, k, r, d: Integer; + CF: TsConditionalFormat; + rule: TsCFCellRule; +begin + n := 0; + SetLength(FDifferentialFormatIndexList, n); + + book := TsWorkbook(FWorkbook); + for i:=0 to book.GetWorksheetCount-1 do begin + sheet := book.GetWorksheetByIndex(i); + for j := 0 to sheet.ConditionalFormatCount-1 do + begin + CF := sheet.ReadConditionalFormat(j); + for k := 0 to CF.RulesCount-1 do + if CF.Rules[k] is TsCFCellRule then + begin + rule := TsCFCellRule(CF.Rules[k]); + idx := -1; + for d := 0 to High(FDifferentialFormatIndexList) do + if FDifferentialFormatIndexList[d] = rule.FormatIndex then + begin + idx := d; + break; + end; + if idx = -1 then + begin + SetLength(FDifferentialFormatIndexList, n+1); + FDifferentialFormatIndexList[n] := rule.FormatIndex; + inc(n); + end; + end; + end; + end; +end; + { Creates a list of all fill styles found in the workbook. The list contains indexes into the array FFormattingStyles for each unique combination of fill attributes. @@ -3067,13 +3138,6 @@ begin end; procedure TsSpreadOOXMLWriter.WriteBorderList(AStream: TStream); -const - // lsThin, lsMedium, lsDashed, lsDotted, lsThick, lsDouble, lsHair, - // lsMediumDash, lsDashDot, lsMediumDashDot, lsDashDotDot, lsMediumDashDotDot, - // lsSlantDashDot - LINESTYLE_NAME: Array[TsLineStyle] of String = ( - 'thin', 'medium', 'dashed', 'dotted', 'thick', 'double', 'hair', - 'mediumDashed', 'dashDot', 'mediumDashDot', 'dashDotDot', 'mediumDashDotDot', 'slantDashDot'); procedure WriteBorderStyle(AStream: TStream; AFormatRecord: PsCellFormat; ABorder: TsCellBorder; ABorderName: String); @@ -3087,7 +3151,7 @@ const begin if (ABorder in AFormatRecord^.Border) then begin // Line style - styleName := LINESTYLE_NAME[AFormatRecord^.BorderStyles[ABorder].LineStyle]; + styleName := LINESTYLE_TYPES[AFormatRecord^.BorderStyles[ABorder].LineStyle]; // Border color rgb := AFormatRecord^.BorderStyles[ABorder].Color; @@ -3254,6 +3318,89 @@ begin ''); end; +procedure TsSpreadOOXMLWriter.WriteConditionalFormat(AStream: TStream; + AFormat: TsConditionalFormat; var APriority: Integer); +var + rangeStr: String; + i: Integer; + rule: TsCFRule; +begin + with AFormat.CellRange do + rangeStr := GetCellRangeString(Row1, Col1, Row2, Col2,rfAllRel, true); + AppendToStream(AStream, Format( + '', [rangeStr])); + for i := 0 to AFormat.RulesCount-1 do + begin + rule := AFormat.Rules[i]; + WriteConditionalFormatRule(AStream, rule, APriority); + end; + AppendToStream(AStream, + ''); +end; + +procedure TsSpreadOOXMLWriter.WriteConditionalFormatCellRule(AStream: TStream; + ARule: TsCFCellRule; APriority: Integer); +const + OPERATOR_NAMES_1: array[cfcEqual..cfcLessEqual] of String = + ('equal', 'notEqual', 'greaterThan', 'lessThan', 'greaterThanOrEqual', 'lessThanOrEqual'); + OPERATOR_NAMES_2: array[cfcBetween..cfcNotBetween] of String = + ('between', 'notBetween'); +begin + case ARule.Condition of + cfcEqual..cfcLessEqual: + AppendToStream(AStream, Format( + '' + + '%s'+ + '', [ + APriority, OPERATOR_NAMES_1[ARule.Condition], ARule.Operand1 + ])); + + cfcBetween, cfcNotBetween: + AppendToStream(AStream, Format( + '' + + '%s'+ + '%s'+ + '', [ + APriority, OPERATOR_NAMES_1[ARule.Condition], ARule.Operand1, ARule.Operand2 + ])); + + else + FWorkbook.AddErrorMsg('ConditionalFormat operator not supported.'); + end; +end; + +procedure TsSpreadOOXMLWriter.WriteConditionalFormatRule(AStream: TStream; + ARule: TsCFRule; var APriority: Integer); +begin + if ARule is TsCFCellRule then begin + WriteConditionalFormatCellRule(AStream, TsCFCellRule(ARule), APriority); + dec(APriority); + end; +end; + +procedure TsSpreadOOXMLWriter.WriteConditionalFormats(AStream: TStream; + AWorksheet: TsBasicWorksheet); +var + worksheet: TsWorksheet absolute AWorksheet; + i: Integer; + CF: TsConditionalFormat; + priority: Integer = 0; +begin + if worksheet.ConditionalFormatCount = 0 then + exit; + + for i := 0 to worksheet.ConditionalFormatCount-1 do + begin + CF := worksheet.ReadConditionalFormat(i); + inc(priority, CF.RulesCount); + end; + + for i := 0 to worksheet.ConditionalFormatCount-1 do begin + CF := worksheet.ReadConditionalFormat(i); + WriteConditionalFormat(AStream, CF, priority); + end; +end; + procedure TsSpreadOOXMLWriter.WriteDimension(AStream: TStream; AWorksheet: TsBasicWorksheet); var @@ -4035,16 +4182,137 @@ begin end; end; +procedure TsSpreadOOXMLWriter.WriteStyle(AStream: TStream; ANodeName: String; + AFormat: PsCellFormat); +var + s: String; + sAlign: String; + sProtected: String; + book: TsWorkbook; + numFmtParams: TsNumFormatParams; + numFmtStr: String; + fontID: Integer; + fillID: Integer; + borderID: Integer; + idx: Integer; +begin + book := TsWorkbook(FWorkbook); + + s := ''; + sAlign := ''; + sProtected := ''; + + { Number format } + if (uffNumberFormat in AFormat^.UsedFormattingFields) then + begin + numFmtParams := book.GetNumberFormat(AFormat^.NumberFormatIndex); + if numFmtParams <> nil then + begin + numFmtStr := numFmtParams.NumFormatStr; + idx := NumFormatList.IndexOf(numFmtStr); + end else + idx := 0; // "General" format is at index 0 + s := s + Format('numFmtId="%d" applyNumberFormat="1" ', [idx]); + end else + s := s + 'numFmtId="0" '; + + { Font } + fontId := 0; + if (uffFont in AFormat^.UsedFormattingFields) then + fontID := AFormat^.FontIndex; + s := s + Format('fontId="%d" ', [fontId]); + if fontID > 0 then s := s + 'applyFont="1" '; + + if ANodeName = 'xf' then s := s + 'xfId="0" '; +// if ANodeName = 'cellXfs' then s := s + 'xfId="0" '; + + { Text rotation } + if (uffTextRotation in AFormat^.UsedFormattingFields) then + case AFormat^.TextRotation of + trHorizontal: + ; + rt90DegreeClockwiseRotation: + sAlign := sAlign + Format('textRotation="%d" ', [180]); + rt90DegreeCounterClockwiseRotation: + sAlign := sAlign + Format('textRotation="%d" ', [90]); + rtStacked: + sAlign := sAlign + Format('textRotation="%d" ', [255]); + end; + + { Text alignment } + if (uffHorAlign in AFormat^.UsedFormattingFields) and (AFormat^.HorAlignment <> haDefault) + then + case AFormat^.HorAlignment of + haLeft : sAlign := sAlign + 'horizontal="left" '; + haCenter: sAlign := sAlign + 'horizontal="center" '; + haRight : sAlign := sAlign + 'horizontal="right" '; + end; + + if (uffVertAlign in AFormat^.UsedFormattingFields) and (AFormat^.VertAlignment <> vaDefault) + then + case AFormat^.VertAlignment of + vaTop : sAlign := sAlign + 'vertical="top" '; + vaCenter: sAlign := sAlign + 'vertical="center" '; + vaBottom: sAlign := sAlign + 'vertical="bottom" '; + end; + + { Word wrap } + if (uffWordWrap in AFormat^.UsedFormattingFields) then + sAlign := sAlign + 'wrapText="1" '; + + { BiDi mode } + if (uffBiDi in Aformat^.UsedFormattingFields) and (AFormat^.BiDiMode <> bdDefault) then + sAlign := sAlign + Format('readingOrder="%d" ', [Ord(AFormat^.BiDiMode)]); + + if sAlign <> '' then + begin + s := s + 'applyAlignment="1" '; + sAlign := ''; + end; + + { Fill } + if (uffBackground in AFormat^.UsedFormattingFields) then + begin + fillID := FindFillInList(AFormat); + if fillID = -1 then fillID := 0; + s := s + Format('fillId="%d" applyFill="1" ', [fillID]); + end; + + { Border } + if (uffBorder in AFormat^.UsedFormattingFields) then + begin + borderID := FindBorderInList(AFormat); + if borderID = -1 then borderID := 0; + s := s + Format('borderId="%d" applyBorder="1" ', [borderID]); + end; + + { Protection } + if not (cpLockCell in AFormat^.Protection) then + sProtected := 'locked="0" '; + + if (cpHideFormulas in AFormat^.Protection) then + sProtected := sProtected + 'hidden="1" '; + + if sProtected <> '' then + begin + s := s + 'applyProtection="1" '; + sProtected := ''; + end; + + { Write everything to stream } + if (sAlign = '') and (sProtected = '') then + AppendToStream(AStream, + Format('<%s %s />', [ANodeName, s])) + else + AppendToStream(AStream, + Format('<%s %s>', [ANodeName, s]), + sAlign + sProtected, + Format('', [ANodeName])); +end; + { Writes the style list which the workbook has collected in its FormatList } procedure TsSpreadOOXMLWriter.WriteStyleList(AStream: TStream; ANodeName: String); var - s, sAlign, sProtected: String; - fontID: Integer; - numFmtParams: TsNumFormatParams; - numFmtStr: String; - fillId: Integer; - borderId: Integer; - idx: Integer; fmt: PsCellFormat; i: Integer; book: TsWorkbook; @@ -4057,115 +4325,7 @@ begin for i:=0 to book.GetNumCellFormats-1 do begin fmt := book.GetPointerToCellFormat(i); - s := ''; - sAlign := ''; - sProtected := ''; - - { Number format } - if (uffNumberFormat in fmt^.UsedFormattingFields) then - begin - numFmtParams := book.GetNumberFormat(fmt^.NumberFormatIndex); - if numFmtParams <> nil then - begin - numFmtStr := numFmtParams.NumFormatStr; - idx := NumFormatList.IndexOf(numFmtStr); - end else - idx := 0; // "General" format is at index 0 - s := s + Format('numFmtId="%d" applyNumberFormat="1" ', [idx]); - end else - s := s + 'numFmtId="0" '; - - { Font } - fontId := 0; - if (uffFont in fmt^.UsedFormattingFields) then - fontID := fmt^.FontIndex; - s := s + Format('fontId="%d" ', [fontId]); - if fontID > 0 then s := s + 'applyFont="1" '; - - if ANodeName = 'cellXfs' then s := s + 'xfId="0" '; - - { Text rotation } - if (uffTextRotation in fmt^.UsedFormattingFields) then - case fmt^.TextRotation of - trHorizontal: - ; - rt90DegreeClockwiseRotation: - sAlign := sAlign + Format('textRotation="%d" ', [180]); - rt90DegreeCounterClockwiseRotation: - sAlign := sAlign + Format('textRotation="%d" ', [90]); - rtStacked: - sAlign := sAlign + Format('textRotation="%d" ', [255]); - end; - - { Text alignment } - if (uffHorAlign in fmt^.UsedFormattingFields) and (fmt^.HorAlignment <> haDefault) - then - case fmt^.HorAlignment of - haLeft : sAlign := sAlign + 'horizontal="left" '; - haCenter: sAlign := sAlign + 'horizontal="center" '; - haRight : sAlign := sAlign + 'horizontal="right" '; - end; - - if (uffVertAlign in fmt^.UsedFormattingFields) and (fmt^.VertAlignment <> vaDefault) - then - case fmt^.VertAlignment of - vaTop : sAlign := sAlign + 'vertical="top" '; - vaCenter: sAlign := sAlign + 'vertical="center" '; - vaBottom: sAlign := sAlign + 'vertical="bottom" '; - end; - - { Word wrap } - if (uffWordWrap in fmt^.UsedFormattingFields) then - sAlign := sAlign + 'wrapText="1" '; - - { BiDi mode } - if (uffBiDi in fmt^.UsedFormattingFields) and (fmt^.BiDiMode <> bdDefault) then - sAlign := sAlign + Format('readingOrder="%d" ', [Ord(fmt^.BiDiMode)]); - - if sAlign <> '' then - begin - s := s + 'applyAlignment="1" '; - sAlign := ''; - end; - - { Fill } - if (uffBackground in fmt^.UsedFormattingFields) then - begin - fillID := FindFillInList(fmt); - if fillID = -1 then fillID := 0; - s := s + Format('fillId="%d" applyFill="1" ', [fillID]); - end; - - { Border } - if (uffBorder in fmt^.UsedFormattingFields) then - begin - borderID := FindBorderInList(fmt); - if borderID = -1 then borderID := 0; - s := s + Format('borderId="%d" applyBorder="1" ', [borderID]); - end; - - { Protection } - if not (cpLockCell in fmt^.Protection) then - sProtected := 'locked="0" '; - - if (cpHideFormulas in fmt^.Protection) then - sProtected := sProtected + 'hidden="1" '; - - if sProtected <> '' then - begin - s := s + 'applyProtection="1" '; - sProtected := ''; - end; - - { Write everything to stream } - if (sAlign = '') and (sProtected = '') then - AppendToStream(AStream, - '') - else - AppendToStream(AStream, - '', - sAlign + sProtected, - ''); + WriteStyle(AStream, 'xf', fmt); end; AppendToStream(FSStyles, Format( @@ -4850,9 +5010,10 @@ begin '' + ''); + // Conditional format styles + WriteDifferentialFormats(FSStyles); + // Misc - AppendToStream(FSStyles, - ''); AppendToStream(FSStyles, ''); @@ -5081,6 +5242,138 @@ begin '' + stotal + ''); end; +procedure TsSpreadOOXMLWriter.WriteDifferentialFormat(AStream: TStream; + AFormat: PsCellFormat); + + procedure WriteBorderStyle(AStream: TStream; AFormatRecord: PsCellFormat; + ABorder: TsCellBorder; ABorderName: String); + { border names found in xlsx files for Excel selections: + "thin", "hair", "dotted", "dashed", "dashDotDot", "dashDot", "mediumDashDotDot", + "slantDashDot", "mediumDashDot", "mediumDashed", "medium", "thick", "double" } + var + styleName: String; + colorStr: String; + rgb: TsColor; + begin + if (ABorder in AFormatRecord^.Border) then begin + // Line style + styleName := LINESTYLE_TYPES[AFormatRecord^.BorderStyles[ABorder].LineStyle]; + + // Border color + rgb := AFormatRecord^.BorderStyles[ABorder].Color; + colorStr := ColorToHTMLColorStr(rgb, true); + AppendToStream(AStream, Format( + '<%s style="%s">', + [ABorderName, styleName, colorStr, ABorderName] + )); + end else + AppendToStream(AStream, Format( + '<%s />', [ABorderName])); + end; + +var + pt, bc, fc, diag: string; + font: TsFont; +begin + AppendToStream(AStream, + ''); + + { background fill } + if (uffBackground in AFormat^.UsedFormattingFields) then + begin + pt := PATTERN_TYPES[AFormat^.Background.Style]; + if AFormat^.Background.FgColor <> scTransparent then + fc := Format('rgb="%s"', [Copy(ColorToHTMLColorStr(AFormat^.Background.FgColor), 2, MaxInt)]); + if AFormat^.Background.BgColor = scTransparent then + bc := 'auto="1"' + else + bc := Format('rgb="%s"', [Copy(ColorToHTMLColorStr(AFormat^.Background.BgColor), 2, MaxInt)]); + AppendToStream(AStream, + '' + Format( + '', [pt]) + Format( + '', [fc]) + Format( + '', [bc]) + + '' + + ''); + end; + + { cell borders } + if (uffBorder in AFormat^.UsedFormattingFields) then + begin + diag := ''; + if (cbDiagUp in AFormat^.Border) then + diag := diag + ' diagonalUp="1"'; + if (cbDiagDown in AFormat^.Border) then + diag := diag + ' diagonalDown="1"'; + AppendToStream(AStream, + ''); + WriteBorderStyle(AStream, AFormat, cbWest, 'left'); + WriteBorderStyle(AStream, AFormat, cbEast, 'right'); + WriteBorderStyle(AStream, AFormat, cbNorth, 'top'); + WriteBorderStyle(AStream, AFormat, cbSouth, 'bottom'); + // OOXML uses the same border style for both diagonals. In agreement with + // the biff implementation we select the style from the diagonal-up line. + WriteBorderStyle(AStream, AFormat, cbDiagUp, 'diagonal'); + AppendToStream(AStream, + ''); + + // TODO: Fix font handling: although correct in syntax something seems to be missing... + { font } + { + font := TsWorkbook(FWorkbook).GetFont(AFormat^.FontIndex); + if font <> nil then + begin + fc := ColorToHTMLColorStr(font.Color, true); + AppendToStream(AStream, ''); + AppendToStream(AStream, Format('', [fc] )); + if fssBold in font.Style then + AppendToStream(AStream, ''); + if fssItalic in font.Style then + AppendToStream(AStream, ''); + if fssStrikeout in font.Style then + AppendToStream(AStream, ''); + // Font name, font size, and style underline not supported + AppendToStream(AStream, ''); + end; + } + end; + + AppendToStream(AStream, + ''); +end; + +procedure TsSpreadOOXMLWriter.WriteDifferentialFormats(AStream: TStream); +var + book: TsWorkbook; + i: Integer; + fmtIndex: Integer; + fmt: PsCellFormat; +begin + if Length(FDifferentialFormatIndexList) = 0 then + begin + AppendToStream(AStream, ''); + exit; + end; + + AppendToStream(AStream, Format( + '', [Length(FDifferentialFormatIndexList)])); + + book := TsWorkbook(FWorkbook); + for i := 0 to High(FDifferentialFormatIndexList) do + begin + fmtIndex := FDifferentialFormatIndexList[i]; + fmt := book.GetPointerToCellFormat(fmtIndex); + WriteDifferentialFormat(AStream, fmt); + end; + + AppendToStream(AStream, + ''); + { + AppendToStream(AStream, + ''); + } +end; + procedure TsSpreadOOXMLWriter.WriteWorkbook(AStream: TStream); begin AppendToStream(AStream, @@ -5226,6 +5519,7 @@ begin WriteSheetProtection(FSSheets[FCurSheetNum], AWorksheet); WriteMergedCells(FSSheets[FCurSheetNum], AWorksheet); WriteHyperlinks(FSSheets[FCurSheetNum], AWorksheet, rId_FirstHyperlink); + WriteConditionalFormats(FSSheets[FCurSheetNum], AWorksheet); WritePrintOptions(FSSheets[FCurSheetNum], AWorksheet); WritePageMargins(FSSheets[FCurSheetNum], AWorksheet); @@ -5417,6 +5711,7 @@ begin ListAllNumFormats; ListAllFills; ListAllBorders; + ListAllDifferentialFormats; { Create the streams that will hold the file contents } CreateStreams;