From 525c51cd9e9fc7ade22dd8e21266966085f4d379 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Wed, 5 Aug 2015 10:29:02 +0000 Subject: [PATCH] fpspreadsheet: HTMLReader detects background color (from "bgcolor" or "style:background-color" tags of "td" node). git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4252 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- components/fpspreadsheet/fpshtml.pas | 59 +++++++++++++++- components/fpspreadsheet/fpshtmlutils.pas | 83 +++++++++++++++++------ components/fpspreadsheet/fpsutils.pas | 4 ++ 3 files changed, 124 insertions(+), 22 deletions(-) diff --git a/components/fpspreadsheet/fpshtml.pas b/components/fpspreadsheet/fpshtml.pas index bed134042..7764ae617 100644 --- a/components/fpspreadsheet/fpshtml.pas +++ b/components/fpspreadsheet/fpshtml.pas @@ -28,12 +28,17 @@ type FInHeader: Boolean; FTableCounter: Integer; FCurrRow, FCurrCol: LongInt; - FCelLText: String; + FCurrCellFormat: TsCellFormat; + FCellFont: TsFont; + FCellText: String; FAttrList: TsHTMLAttrList; FColSpan, FRowSpan: Integer; FHRef: String; + procedure ExtractBackgroundColor; procedure ExtractHRef; procedure ExtractMergedRange; + procedure InitFont(AFont: TsFont); + procedure InitCellFormat; procedure TagFoundHandler(NoCaseTag, ActualTag: string); procedure TextFoundHandler(AText: String); protected @@ -419,10 +424,12 @@ begin ReplaceFormatSettings(FFormatSettings, FWorkbook.FormatSettings); FTableCounter := -1; FAttrList := TsHTMLAttrList.Create; + FCellFont := TsFont.Create; end; destructor TsHTMLReader.Destroy; begin + FreeAndNil(FCellFont); FreeAndNil(FAttrList); FreeAndNil(parser); inherited Destroy; @@ -438,13 +445,24 @@ var decs: Integer; currSym: String; warning: String; + fntIndex: Integer; begin // Empty strings are blank cells -- nothing to do if (AText = '') then exit; + // Create cell cell := FWorksheet.AddCell(ARow, ACol); + // Format + fntIndex := FWorkbook.FindFont(FCellFont.FontName, FCellFont.Size, + FCellFont.Style, FCellFont.Color, FCellFont.Position); + if fntIndex = -1 then + fntIndex := FWorkbook.AddFont(FCellFont.FontName, FCellFont.Size, + FCellFont.Style, FCellFont.Color, FCellFont.Position); + FCurrCellFormat.FontIndex := fntIndex; + cell^.FormatIndex := FWorkbook.AddCellFormat(FCurrCellFormat); + // Merged cells if (FColSpan > 0) or (FRowSpan > 0) then begin FWorksheet.MergeCells(ARow, ACol, ARow + FRowSpan, ACol + FColSpan); @@ -497,6 +515,22 @@ begin FWorksheet.WriteUTF8Text(cell, AText); end; +procedure TsHTMLReader.ExtractBackgroundColor; +var + idx: Integer; +begin + idx := FAttrList.IndexOfName('bgcolor'); // html tag + if idx = -1 then + idx := FAttrList.IndexOfName('background-color'); // value taken from "style" + if idx > -1 then + begin + FCurrCellFormat.Background.BgColor := HTMLColorStrToColor(FAttrList[idx].Value); + FCurrCellFormat.Background.FgColor := FCurrCellFormat.Background.BgColor; + FCurrCellFormat.Background.Style := fsSolidFill; // No other fill styles in html + Include(FCurrCellFormat.UsedFormattingFields, uffBackground); + end; +end; + procedure TsHTMLReader.ExtractHRef; var idx: Integer; @@ -522,6 +556,27 @@ begin // -1 to compensate for correct determination of the range end cell end; +procedure TsHTMLReader.InitFont(AFont: TsFont); +var + fnt: TsFont; +begin + fnt := FWorkbook.GetDefaultFont; + AFont.FontName := fnt.FontName; + AFont.Size := fnt.Size; + AFont.Style := fnt.Style; + AFont.Color := fnt.Color; + AFont.Position := fnt.Position; +end; + +procedure TsHTMLReader.InitCellFormat; +begin + InitFormatRecord(FCurrCellFormat); + InitFont(FCellFont); + + // HTML tables, by default, have word-wrapped cell texts. + Include(FCurrCellFormat.UsedFormattingFields, uffWordwrap); +end; + procedure TsHTMLReader.ReadFromStream(AStream: TStream); var list: TStringList; @@ -581,8 +636,10 @@ begin FInCell := true; inc(FCurrCol); FCellText := ''; + InitCellFormat; FAttrList.Parse(ActualTag); ExtractMergedRange; + ExtractBackgroundColor; end else if ((NoCaseTag = '') or (pos(' -1 then ParseStyle(Items[i].Value); +end; + +{ AStyle is the value part of a 'style="...."' HTML string. Splits the into + individual records at the semicolons (;) and into name-value pairs at the + colon (:). Adds the name-value pairs to the list. } +procedure TsHTMLAttrList.ParseStyle(AStyle: String); +var + i, len: Integer; + value, nam: String; +begin + i := 1; + len := Length(AStyle); + + // skip white space + while (i <= len) and (AStyle[i] = ' ') do inc(i); + + // iterate through string + nam := ''; + while (i <= len) do + begin + case AStyle[i] of + ':': begin // name-value separator + while (i <= len) and (AStyle[i] = ' ') do inc(i); // skip white space + value := ''; + while (i <= len) and (AStyle[i] <> ';') do + value := value + AStyle[i]; + inc(i); // skip final ';' + Add(TsHTMLAttr.Create(lowercase(nam), value)); + nam := ''; + end; + ' ': ; + else nam := nam + AStyle[i]; + end; + inc(i); + end; end; procedure TsHTMLAttrList.SetItem(AIndex: Integer; AValue: TsHTMLAttr); diff --git a/components/fpspreadsheet/fpsutils.pas b/components/fpspreadsheet/fpsutils.pas index 1ecb152d1..096a4b537 100644 --- a/components/fpspreadsheet/fpsutils.pas +++ b/components/fpspreadsheet/fpsutils.pas @@ -1474,6 +1474,10 @@ begin if AValue[1] = '#' then begin AValue[1] := '$'; Result := LongRGBToExcelPhysical(DWord(StrToInt(AValue))); + end else + if AValue[1] in ['0'..'9','A'..'F', 'a'..'f'] then begin + AValue := '$' + AValue; + Result := LongRGBToExcelPhysical(DWord(StrToInt(AValue))); end else begin AValue := lowercase(AValue); if AValue = 'red' then