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

fpspreadsheet: Support individual fill colors of bars, bubbles, symbols. Fix dash line pattern broken after previous commit.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8997 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2023-10-29 15:52:46 +00:00
parent b8bff13140
commit fb8b6eef96
5 changed files with 108 additions and 57 deletions
Download Patch File Download Diff File Expand all files Collapse all files

23
components/fpspreadsheet/examples/other/chart/write_chart_demo.lpr
View File

@ -3,11 +3,15 @@ program write_chart_demo;
{.$DEFINE DARK_MODE}
uses
SysUtils, fpspreadsheet, fpstypes, fpschart, xlsxooxml, fpsopendocument;
SysUtils, fpspreadsheet, fpstypes, fpsUtils, fpschart, xlsxooxml, fpsopendocument;
const
SERIES_CLASS: TsChartSeriesClass = TsBubbleSeries; //TsScatterSeries;
SERIES_CLASS: TsChartSeriesClass = TsAreaSeries;
// SERIES_CLASS: TsChartSeriesClass = TsBarSeries;
// SERIES_CLASS: TsChartSeriesClass = TsBubbleSeries;
// SERIES_CLASS: TsChartSeriesClass = TsLineSeries;
r1 = 1;
r2 = 8;
FILL_COLORS: array[0..r2-r1] of TsColor = (scRed, scGreen, scBlue, scYellow, scMagenta, scSilver, scBlack, scOlive);
var
b: TsWorkbook;
sheet1, sheet2, sheet3: TsWorksheet;
@ -21,13 +25,23 @@ begin
sheet1 := b.AddWorksheet('test1');
sheet1.WriteText(0, 1, '1+sin(x)');
sheet1.WriteText(0, 2, '1+sin(x/2)');
sheet1.WriteText(0, 3, 'Bubble');
sheet1.WriteText(0, 3, 'Bubble Radius');
sheet1.WriteText(0, 4, 'Fill Color');
sheet1.WriteText(0, 5, 'Border Color');
for i := r1 to r2-1 do
begin
// x values or labels
sheet1.WriteNumber(i, 0, i-1);
// 1st series y values
sheet1.WriteNumber(i, 1, 1+sin(i-1));
// 2nd series y values
sheet1.WriteNumber(i, 2, 1+sin((i-1)/2));
sheet1.WriteNumber(i, 3, i*i); // Bubble series radii
// Bubble radii
sheet1.WriteNumber(i, 3, i*i);
// Fill colors
sheet1.WriteNumber(i, 4, FlipColorBytes(FILL_COLORS[i-r1])); // !! ODS need red and blue channels exchanged !!
// Border colors
sheet1.WriteNumber(i, 5, FlipColorBytes(FILL_COLORS[r2-i]));
end;
sheet1.WriteNumber(r2, 0, 9);
sheet1.WriteNumber(r2, 1, 2);
@ -45,6 +59,7 @@ begin
ser.SetYRange(r1, 1, r2, 1);
ser.Line.Color := scBlue;
ser.Fill.FgColor := scBlue;
ser.SetFillColorRange(r1, 4, r2, 4);
if (ser is TsLineSeries) then
begin
TsLineSeries(ser).ShowSymbols := true;

17
components/fpspreadsheet/source/common/fpschart.pas
View File

@ -193,6 +193,7 @@ type
FXRange: TsCellRange; // cell range containing the x data
FYRange: TsCellRange;
FLabelRange: TsCellRange;
FFillColorRange: TsCellRange;
FYAxis: TsChartAxisLink;
FTitleAddr: TsCellCoord;
FLabelFormat: String;
@ -211,12 +212,14 @@ type
procedure SetLabelRange(ARow1, ACol1, ARow2, ACol2: Cardinal);
procedure SetXRange(ARow1, ACol1, ARow2, ACol2: Cardinal);
procedure SetYRange(ARow1, ACol1, ARow2, ACol2: Cardinal);
procedure SetFillColorRange(ARow1, ACol1, ARow2, ACol2: Cardinal);
function LabelsInCol: Boolean;
function XValuesInCol: Boolean;
function YValuesInCol: Boolean;
property ChartType: TsChartType read FChartType;
property Count: Integer read GetCount;
property FillColorRange: TsCellRange read FFillColorRange;
property LabelFormat: String read FLabelFormat write FLabelFormat; // Number format in Excel notation, e.g. '0.00'
property LabelRange: TsCellRange read FLabelRange;
property TitleAddr: TsCellCoord read FTitleAddr write FTitleAddr;
@ -654,6 +657,16 @@ begin
FTitleAddr.Col := ACol;
end;
procedure TsChartSeries.SetFillColorRange(ARow1, ACol1, ARow2, ACol2: Cardinal);
begin
if (ARow1 <> ARow2) and (ACol1 <> ACol2) then
raise Exception.Create('Series fill color values can only be located in a single column or row.');
FFillColorRange.Row1 := ARow1;
FFillColorRange.Col1 := ACol1;
FFillColorRange.Row2 := ARow2;
FFillColorRange.Col2 := ACol2;
end;
procedure TsChartSeries.SetLabelRange(ARow1, ACol1, ARow2, ACol2: Cardinal);
begin
if (ARow1 <> ARow2) and (ACol1 <> ACol2) then
@ -725,6 +738,7 @@ begin
FChartType := ctBar;
end;
{ TsBubbleSeries }
constructor TsBubbleSeries.Create(AChart: TsChart);
@ -736,13 +750,14 @@ end;
procedure TsBubbleSeries.SetBubbleRange(ARow1, ACol1, ARow2, ACol2: Cardinal);
begin
if (ARow1 <> ARow2) and (ACol1 <> ACol2) then
raise Exception.Create('Series bubble values can only be located in a single column or row.');
raise Exception.Create('Bubble series values can only be located in a single column or row.');
FBubbleRange.Row1 := ARow1;
FBubbleRange.Col1 := ACol1;
FBubbleRange.Row2 := ARow2;
FBubbleRange.Col2 := ACol2;
end;
{ TsLineSeries }
constructor TsLineSeries.Create(AChart: TsChart);

61
components/fpspreadsheet/source/common/fpsopendocument.pas
View File

@ -277,7 +277,6 @@ type
function WriteDefaultGraphicStyleXMLAsString: String; overload;
function WriteDocumentProtectionXMLAsString: String;
function WriteFontStyleXMLAsString(const AFormat: TsCellFormat): String; overload;
// function WriteFontStyleXMLAsString(AFont: TsFont): String; overload;
function WriteHeaderFooterFontXMLAsString(AFont: TsHeaderFooterFont): String;
function WriteHorAlignmentStyleXMLAsString(const AFormat: TsCellFormat): String;
function WriteNumFormatStyleXMLAsString(const AFormat: TsCellFormat): String;
@ -296,8 +295,6 @@ type
// Streams with the contents of files
FSMeta, FSSettings, FSStyles, FSContent: TStream;
FSMimeType, FSMetaInfManifest: TStream;
// FSCharts: array of TStream;
// FSObjectStyles: array of TStream;
{ Helpers }
procedure AddBuiltinNumFormats; override;
@ -6120,32 +6117,18 @@ begin
begin
embObj := TsWorkbook(FWorkbook).GetEmbeddedObj(i);
imgtype := embObj.ImageType;
if imgtype = itUnknown then
continue;
mime := GetImageMimeType(imgtype);
ext := GetImageTypeExt(imgType);
AppendToStream(FSMetaInfManifest, Format(
' <manifest:file-entry manifest:media-type="%s" manifest:full-path="Pictures/%d.%s" />' + LE,
[mime, i+1, ext]
));
if imgtype <> itUnknown then
begin
mime := GetImageMimeType(imgtype);
ext := GetImageTypeExt(imgType);
AppendToStream(FSMetaInfManifest, Format(
' <manifest:file-entry manifest:media-type="%s" manifest:full-path="Pictures/%d.%s" />' + LE,
[mime, i+1, ext]
));
end;
end;
for i:=0 to (FWorkbook as TsWorkbook).GetChartCount-1 do
begin
AppendToStream(FSMetaInfManifest, Format(
' <manifest:file-entry manifest:media-type="application/vnd.oasis.opendocument.chart" manifest:full-path="Object %d/" />' + LE,
[i+1]
));
AppendToStream(FSMetaInfManifest, Format(
' <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="Object %d/content.xml" />' + LE,
[i+1]
));
AppendToStream(FSMetaInfManifest, Format(
' <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="Object %d/styles.xml" />' + LE,
[i+1]
));
// Object X/meta.xml and ObjectReplacement/Object X not needed necessarily
end;
TsSpreadOpenDocChartWriter(FChartWriter).AddToMetaInfManifest(FSMetaInfManifest);
AppendToStream(FSMetaInfManifest,
'</manifest:manifest>');
@ -6461,30 +6444,6 @@ begin
'<office:scripts />'
);
{
'<office:document-content xmlns:office="' + SCHEMAS_XMLNS_OFFICE +
'" xmlns:fo="' + SCHEMAS_XMLNS_FO +
'" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/' +
'" xmlns:style="' + SCHEMAS_XMLNS_STYLE +
'" xmlns:text="' + SCHEMAS_XMLNS_TEXT +
'" xmlns:table="' + SCHEMAS_XMLNS_TABLE +
'" xmlns:svg="' + SCHEMAS_XMLNS_SVG +
'" xmlns:number="' + SCHEMAS_XMLNS_NUMBER +
'" xmlns:meta="' + SCHEMAS_XMLNS_META +
'" xmlns:chart="' + SCHEMAS_XMLNS_CHART +
'" xmlns:dr3d="' + SCHEMAS_XMLNS_DR3D +
'" xmlns:math="' + SCHEMAS_XMLNS_MATH +
'" xmlns:form="' + SCHEMAS_XMLNS_FORM +
'" xmlns:script="' + SCHEMAS_XMLNS_SCRIPT +
'" xmlns:ooo="' + SCHEMAS_XMLNS_OOO +
'" xmlns:ooow="' + SCHEMAS_XMLNS_OOOW +
'" xmlns:oooc="' + SCHEMAS_XMLNS_OOOC +
'" xmlns:dom="' + SCHEMAS_XMLNS_DOM +
'" xmlns:xforms="' + SCHEMAS_XMLNS_XFORMS +
'" xmlns:xsd="' + SCHEMAS_XMLNS_XSD +
'" xmlns:xsi="' + SCHEMAS_XMLNS_XSI + '">' +
'<office:scripts />');
}
// Fonts
AppendToStream(FSContent,
'<office:font-face-decls>');

53
components/fpspreadsheet/source/common/fpsopendocumentchart.pas
View File

@ -56,6 +56,7 @@ type
public
constructor Create(AWriter: TsBasicSpreadWriter);
procedure AddChartsToZip(AZip: TZipper);
procedure AddToMetaInfManifest(AStream: TStream);
procedure CreateStreams; override;
procedure DestroyStreams; override;
procedure ResetStreams; override;
@ -119,6 +120,30 @@ begin
end;
end;
{ Writes the chart entries needed in the META-INF/manifest.xml file }
procedure TsSpreadOpenDocChartWriter.AddToMetaInfManifest(AStream: TStream);
var
i: Integer;
begin
for i:=0 to TsWorkbook(Writer.Workbook).GetChartCount-1 do
begin
AppendToStream(AStream, Format(
' <manifest:file-entry manifest:media-type="application/vnd.oasis.opendocument.chart" manifest:full-path="Object %d/" />' + LE,
[i+1]
));
AppendToStream(AStream, Format(
' <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="Object %d/content.xml" />' + LE,
[i+1]
));
AppendToStream(AStream, Format(
' <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="Object %d/styles.xml" />' + LE,
[i+1]
));
// Object X/meta.xml and ObjectReplacement/Object X are not necessarily needed.
end;
end;
procedure TsSpreadOpenDocChartWriter.CreateStreams;
var
i, n: Integer;
@ -1167,6 +1192,8 @@ var
valuesRange: String;
domainRangeX: String = '';
domainRangeY: String = '';
fillColorRange: String = '';
borderColorRange: String = '';
rangeStr: String = '';
titleAddr: String;
count: Integer;
@ -1211,6 +1238,17 @@ begin
rfAllRel, false
);
// Fill colors for bars, line series symbols, bubbles
if (series.FillColorRange.Row1 <> series.FillColorRange.Row2) or
(series.FillColorRange.Col1 <> series.FillColorRange.Col2)
then
fillColorRange := GetSheetCellRangeString_ODS(
sheet.Name, sheet.Name,
series.FillColorRange.Row1, series.FillColorRange.Col1,
series.FillColorRange.Row2, series.FillColorRange.Col2,
rfAllRel, false
);
// And these are the data point labels.
titleAddr := GetSheetCellRangeString_ODS(
sheet.Name, sheet.Name,
@ -1238,6 +1276,19 @@ begin
indent + '<chart:domain table:cell-range-address="%s"/>' + LE,
[ domainRangeX ]
));
if fillColorRange <> '' then
AppendToStream(AChartStream, Format(
indent + '<loext:propertry-mapping loext:property="FillColor" loext:cell-range-address="%s"/>' + LE,
[ fillColorRange ]
));
{ --- not working...
if borderColorRange <> '' then
AppendToStream(AChartStream, Format(
indent + '<loext:propertry-mapping loext:property="BorderColor" loext:cell-range-address="%s"/>' + LE,
[ borderColorRange ]
));
}
AppendToStream(AChartStream, Format(
indent + ' <chart:data-point chart:repeated="%d"/>' + LE,
@ -1265,6 +1316,7 @@ begin
begin
chart := TsWorkbook(Writer.Workbook).GetChartByIndex(i);
WriteChart(FSCharts[i], chart);
WriteObjectStyles(FSObjectStyles[i], chart);
end;
end;
@ -1450,6 +1502,5 @@ begin
inc(AStyleID);
end;
end.

11
components/fpspreadsheet/source/common/fpsutils.pas
View File

@ -189,6 +189,7 @@ function HTMLLengthStrToPts(AValue: String; DefaultUnits: String = 'pt'): Double
function ColorToHTMLColorStr(AValue: TsColor; AExcelDialect: Boolean = false): String;
function HTMLColorStrToColor(AValue: String): TsColor;
function FlipColorBytes(AColor: TsColor): TsColor;
function GetColorName(AColor: TsColor): String;
function HighContrastColor(AColor: TsColor): TsColor;
function IsPaletteIndex(AColor: TsColor): Boolean;
@ -2213,6 +2214,16 @@ begin
raise EFPSpreadsheet.Create('Unknown length units');
end;
function FlipColorBytes(AColor: TsColor): TsColor;
var
r,g,b: Byte;
begin
r := (AColor and $0000FF);
g := (AColor and $00FF00) shr 8;
b := (AColor and $FF0000) shr 16;
Result := b + g shl 8 + r shl 16;
end;
{@@ ----------------------------------------------------------------------------
Determines the name of a color from its rgb value
-------------------------------------------------------------------------------}