From 6aa28600207677adbfa75882e2f02788c3c8bafb Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Thu, 16 Jul 2020 23:40:11 +0000 Subject: [PATCH] fpspreadsheet: Split more code off of fpspreadsheet.pas to separate include files. git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7548 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../fpspreadsheet/laz_fpspreadsheet.lpk | 24 + .../source/common/fpspreadsheet.pas | 2291 +---------------- .../source/common/fpspreadsheet_cf.inc | 31 + .../source/common/fpspreadsheet_clipbrd.inc | 218 ++ .../source/common/fpspreadsheet_comments.inc | 120 + .../source/common/fpspreadsheet_embobj.inc | 456 ++++ .../source/common/fpspreadsheet_fmt.inc | 643 +++-- .../source/common/fpspreadsheet_fonts.inc | 566 ++++ .../common/fpspreadsheet_hyperlinks.inc | 228 ++ .../source/common/fpspreadsheet_numfmt.inc | 490 ++++ 10 files changed, 2531 insertions(+), 2536 deletions(-) create mode 100644 components/fpspreadsheet/source/common/fpspreadsheet_clipbrd.inc create mode 100644 components/fpspreadsheet/source/common/fpspreadsheet_comments.inc create mode 100644 components/fpspreadsheet/source/common/fpspreadsheet_embobj.inc create mode 100644 components/fpspreadsheet/source/common/fpspreadsheet_fonts.inc create mode 100644 components/fpspreadsheet/source/common/fpspreadsheet_hyperlinks.inc create mode 100644 components/fpspreadsheet/source/common/fpspreadsheet_numfmt.inc diff --git a/components/fpspreadsheet/laz_fpspreadsheet.lpk b/components/fpspreadsheet/laz_fpspreadsheet.lpk index fd90c6773..80c6841a3 100644 --- a/components/fpspreadsheet/laz_fpspreadsheet.lpk +++ b/components/fpspreadsheet/laz_fpspreadsheet.lpk @@ -270,6 +270,30 @@ This package is all you need if you don't want graphical components (like g + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/fpspreadsheet/source/common/fpspreadsheet.pas b/components/fpspreadsheet/source/common/fpspreadsheet.pas index 267d61a1a..83670f018 100644 --- a/components/fpspreadsheet/source/common/fpspreadsheet.pas +++ b/components/fpspreadsheet/source/common/fpspreadsheet.pas @@ -1494,311 +1494,6 @@ begin Result := false; end; -{@@ ---------------------------------------------------------------------------- - Checks whether a cell contains a comment and returns a pointer to the - comment data. - - @param ACell Pointer to the cell - @return Pointer to the TsComment record (nil, if the cell does not have a - comment) --------------------------------------------------------------------------------} -function TsWorksheet.FindComment(ACell: PCell): PsComment; -begin - if HasComment(ACell) then - Result := PsComment(FComments.FindByRowCol(ACell^.Row, ACell^.Col)) - else - Result := nil; -end; - -{@@ ---------------------------------------------------------------------------- - Checks whether a specific cell contains a comment --------------------------------------------------------------------------------} -function TsWorksheet.HasComment(ACell: PCell): Boolean; -begin - Result := (ACell <> nil) and (cfHasComment in ACell^.Flags); -end; - -{@@ ---------------------------------------------------------------------------- - Returns the comment text attached to a specific cell - - @param ARow (0-based) index to the row - @param ACol (0-based) index to the column - @return Text assigned to the cell as a comment --------------------------------------------------------------------------------} -function TsWorksheet.ReadComment(ARow, ACol: Cardinal): String; -var - comment: PsComment; -begin - Result := ''; - comment := PsComment(FComments.FindByRowCol(ARow, ACol)); - if comment <> nil then - Result := comment^.Text; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the comment text attached to a specific cell - - @param ACell Pointer to the cell - @return Text assigned to the cell as a comment --------------------------------------------------------------------------------} -function TsWorksheet.ReadComment(ACell: PCell): String; -var - comment: PsComment; -begin - Result := ''; - comment := FindComment(ACell); - if comment <> nil then - Result := comment^.Text; -end; - -{@@ ---------------------------------------------------------------------------- - Adds a comment to a specific cell - - @param ARow (0-based) row index of the cell - @param ACol (0-based) column index of the cell - @param AText Comment text - @return Pointer to the cell containing the comment --------------------------------------------------------------------------------} -function TsWorksheet.WriteComment(ARow, ACol: Cardinal; AText: String): PCell; -begin - Result := GetCell(ARow, ACol); - WriteComment(Result, AText); -end; - -{@@ ---------------------------------------------------------------------------- - Adds a comment to a specific cell - - @param ACell Pointer to the cell - @param AText Comment text --------------------------------------------------------------------------------} -procedure TsWorksheet.WriteComment(ACell: PCell; AText: String); -begin - if ACell = nil then - exit; - - // Remove the comment if an empty string is passed - if AText = '' then - begin - RemoveComment(ACell); - exit; - end; - - // Add new comment record - FComments.AddComment(ACell^.Row, ACell^.Col, AText); - Include(ACell^.Flags, cfHasComment); - - ChangedCell(ACell^.Row, ACell^.Col); - -end; - - -{ Hyperlinks } - -{@@ ---------------------------------------------------------------------------- - Checks whether the specified cell contains a hyperlink and returns a pointer - to the hyperlink data. - - @param ACell Pointer to the cell - @return Pointer to the TsHyperlink record, or NIL if the cell does not contain - a hyperlink. --------------------------------------------------------------------------------} -function TsWorksheet.FindHyperlink(ACell: PCell): PsHyperlink; -begin - if HasHyperlink(ACell) then - Result := PsHyperlink(FHyperlinks.FindByRowCol(ACell^.Row, ACell^.Col)) - else - Result := nil; -end; - -{@@ ---------------------------------------------------------------------------- - Reads the hyperlink information of a specified cell. - - @param ACell Pointer to the cell considered - @returns Record with the hyperlink data assigned to the cell. - If the cell is not a hyperlink the result field Kind is hkNone. --------------------------------------------------------------------------------} -function TsWorksheet.ReadHyperlink(ACell: PCell): TsHyperlink; -var - hyperlink: PsHyperlink; -begin - hyperlink := FindHyperlink(ACell); - if hyperlink <> nil then - Result := hyperlink^ - else - begin - Result.Row := ACell^.Row; - Result.Col := ACell^.Col; - Result.Target := ''; - Result.Tooltip := ''; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Removes a hyperlink from the specified cell. Releaes memory occupied by - the associated TsHyperlink record. Cell content type is converted to - cctUTF8String. --------------------------------------------------------------------------------} -procedure TsWorksheet.RemoveHyperlink(ACell: PCell); -begin - if HasHyperlink(ACell) then - begin - FHyperlinks.DeleteHyperlink(ACell^.Row, ACell^.Col); - Exclude(ACell^.Flags, cfHyperlink); - end; -end; - -{@@ ---------------------------------------------------------------------------- - Checks whether the passed string represents a valid hyperlink target - - @param AValue String to be checked. Must be either a fully qualified URI, - a local relative (!) file name, or a # followed by a cell - address in the current workbook - @param AErrMsg Error message in case that the string is not correct. - @returns TRUE if the string is correct, FALSE otherwise --------------------------------------------------------------------------------} -function TsWorksheet.ValidHyperlink(AValue: String; out AErrMsg: String): Boolean; -var - u: TUri; - sheet: TsWorksheet; - r, c: Cardinal; -begin - Result := false; - AErrMsg := ''; - if AValue = '' then - begin - AErrMsg := rsEmptyHyperlink; - exit; - end else - if (AValue[1] = '#') then - begin - Delete(AValue, 1, 1); - if not FWorkbook.TryStrToCell(AValue, sheet, r, c) then - begin - AErrMsg := Format(rsNoValidHyperlinkInternal, ['#'+AValue]); - exit; - end; - end else - begin - u := ParseURI(AValue); - if SameText(u.Protocol, 'mailto') then - begin - Result := true; // To do: Check email address here... - exit; - end else - if SameText(u.Protocol, 'file') then - begin - if FilenameIsAbsolute(u.Path + u.Document) then - begin - Result := true; - exit; - end else - begin - AErrMsg := Format(rsLocalfileHyperlinkAbs, [AValue]); - exit; - end; - end else - begin - Result := true; - exit; - end; - end; -end; - - -{@@ ---------------------------------------------------------------------------- - Assigns a hyperlink to the cell at the specified row and column - Cell content is not affected by the presence of a hyperlink. - - @param ARow Row index of the cell considered - @param ACol Column index of the cell considered - @param ATarget Hyperlink address given as a fully qualitifed URI for - external links, or as a # followed by a cell address - for internal links. - @param ATooltip Text for popup tooltip hint used by Excel - @returns Pointer to the cell with the hyperlink --------------------------------------------------------------------------------} -function TsWorksheet.WriteHyperlink(ARow, ACol: Cardinal; ATarget: String; - ATooltip: String = ''): PCell; -begin - Result := GetCell(ARow, ACol); - WriteHyperlink(Result, ATarget, ATooltip); -end; - -{@@ ---------------------------------------------------------------------------- - Assigns a hyperlink to the specified cell. - - @param ACell Pointer to the cell considered - @param ATarget Hyperlink address given as a fully qualitifed URI for - external links, or as a # followed by a cell address - for internal links. Local files can be specified also - by their name relative to the workbook. - An existing hyperlink is removed if ATarget is empty. - @param ATooltip Text for popup tooltip hint used by Excel --------------------------------------------------------------------------------} -procedure TsWorksheet.WriteHyperlink(ACell: PCell; ATarget: String; - ATooltip: String = ''); - - function GetDisplayText(ATarget: String): String; - var - target, bm: String; - begin - SplitHyperlink(ATarget, target, bm); - if pos('file:', lowercase(ATarget))=1 then - begin - URIToFilename(target, Result); - ForcePathDelims(Result); - if bm <> '' then Result := Result + '#' + bm; - end else - if target = '' then - Result := bm - else - Result := ATarget; - end; - -var - fmt: TsCellFormat; - noCellText: Boolean = false; -begin - if ACell = nil then - exit; - - fmt := ReadCellFormat(ACell); - - // Empty target string removes the hyperlink. Resets the font from hyperlink - // to default font. - if ATarget = '' then begin - RemoveHyperlink(ACell); - if fmt.FontIndex = HYPERLINK_FONTINDEX then - WriteFont(ACell, DEFAULT_FONTINDEX); - exit; - end; - - // Detect whether the cell already has a hyperlink, but has no other content. - if HasHyperlink(ACell) then - noCellText := (ACell^.ContentType = cctUTF8String) and - (GetDisplayText(ReadHyperlink(ACell).Target) = ReadAsText(ACell)); - - // Attach the hyperlink to the cell - FHyperlinks.AddHyperlink(ACell^.Row, ACell^.Col, ATarget, ATooltip); - Include(ACell^.Flags, cfHyperlink); - - // If there is no other cell content use the target as cell label string. - if (ACell^.ContentType = cctEmpty) or noCellText then - begin - ACell^.ContentType := cctUTF8String; - ACell^.UTF8StringValue := GetDisplayText(ATarget); - end; - - // Select the hyperlink font. - if fmt.FontIndex = DEFAULT_FONTINDEX then - begin - fmt.FontIndex := HYPERLINK_FONTINDEX; - Include(fmt.UsedFormattingFields, uffFont); - ACell^.FormatIndex := FWorkbook.AddCellFormat(fmt); - end; - - ChangedCell(ACell^.Row, ACell^.Col); -end; {@@ ---------------------------------------------------------------------------- Is called whenever a cell value or formatting has changed. Fires an event @@ -2523,57 +2218,6 @@ begin end; end; -{@@ ---------------------------------------------------------------------------- - Determines some number format attributes (decimal places, currency symbol) of - a cell - - @param ACell Pointer to the cell under investigation - @param ADecimals Number of decimal places that can be extracted from - the formatting string, e.g. in case of '0.000' this - would be 3. - @param ACurrencySymbol String representing the currency symbol extracted from - the formatting string. - - @return true if the the format string could be analyzed successfully, false if not --------------------------------------------------------------------------------} -function TsWorksheet.GetNumberFormatAttributes(ACell: PCell; out ADecimals: byte; - out ACurrencySymbol: String): Boolean; -var - parser: TsNumFormatParser; - nf: TsNumberFormat; - nfs: String; -begin - Result := false; - if ACell <> nil then - begin - ReadNumFormat(ACell, nf, nfs); - parser := TsNumFormatParser.Create(nfs, FWorkbook.FormatSettings); - try - if parser.Status = psOK then - begin - nf := parser.NumFormat; - if (nf = nfGeneral) and (ACell^.ContentType = cctNumber) then - begin - ADecimals := GetDisplayedDecimals(ACell); - ACurrencySymbol := ''; - end else - if IsDateTimeFormat(nf) then - begin - ADecimals := 2; - ACurrencySymbol := '?'; - end - else - begin - ADecimals := parser.Decimals; - ACurrencySymbol := parser.CurrencySymbol; - end; - Result := true; - end; - finally - parser.Free; - end; - end; -end; {@@ ---------------------------------------------------------------------------- Returns the 0-based index of the first column with a cell with contents. @@ -3183,174 +2827,6 @@ begin Result := FWorkbook.GetPointerToCellFormat(fmtIndex); end; *) -{@@ ---------------------------------------------------------------------------- - Reads the set of used formatting fields of a cell. - - Each cell contains a set of "used formatting fields". Formatting is applied - only if the corresponding element is contained in the set. - - @param ACell Pointer to the cell - @return Set of elements used in formatting the cell --------------------------------------------------------------------------------} -function TsWorksheet.ReadUsedFormatting(ACell: PCell): TsUsedFormattingFields; -var - fmt: PsCellFormat; -begin - if ACell = nil then - begin - Result := []; - Exit; - end; - fmt := FWorkbook.GetPointerToCellFormat(ACell^.FormatIndex); - Result := fmt^.UsedFormattingFields; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the background fill pattern and colors of a cell. - - @param ACell Pointer to the cell - @return TsFillPattern record (or EMPTY_FILL, if the cell does not have a - filled background --------------------------------------------------------------------------------} -function TsWorksheet.ReadBackground(ACell: PCell): TsFillPattern; -var - fmt : PsCellFormat; -begin - Result := EMPTY_FILL; - if ACell <> nil then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - if (uffBackground in fmt^.UsedFormattingFields) then - Result := fmt^.Background; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the background color of a cell as rbg value - - @param ACell Pointer to the cell - @return Value containing the rgb bytes in little-endian order --------------------------------------------------------------------------------} -function TsWorksheet.ReadBackgroundColor(ACell: PCell): TsColor; -begin - Result := scTransparent; - if ACell <> nil then - Result := ReadBackgroundColor(ACell^.FormatIndex); -end; - -{@@ ---------------------------------------------------------------------------- - Returns the background color stored at the specified index in the format - list of the workkbok. - - @param AFormatIndex Index of the format record - @return Value containing the rgb bytes in little-endian order --------------------------------------------------------------------------------} -function TsWorksheet.ReadBackgroundColor(AFormatIndex: Integer): TsColor; -var - fmt: PsCellFormat; -begin - Result := scTransparent; - if AFormatIndex > -1 then begin - fmt := Workbook.GetPointerToCellFormat(AFormatIndex); - if (uffBackground in fmt^.UsedFormattingFields) then - begin - if fmt^.Background.Style = fsSolidFill then - Result := fmt^.Background.FgColor - else - Result := fmt^.Background.BgColor; - end; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Determines which borders are drawn around a specific cell --------------------------------------------------------------------------------} -function TsWorksheet.ReadCellBorders(ACell: PCell): TsCellBorders; -var - fmt: PsCellFormat; -begin - Result := []; - if ACell <> nil then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - if (uffBorder in fmt^.UsedFormattingFields) then - Result := fmt^.Border; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Determines which the style of a particular cell border --------------------------------------------------------------------------------} -function TsWorksheet.ReadCellBorderStyle(ACell: PCell; - ABorder: TsCelLBorder): TsCellBorderStyle; -var - fmt: PsCellFormat; -begin - Result := DEFAULT_BORDERSTYLES[ABorder]; - if ACell <> nil then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - Result := fmt^.BorderStyles[ABorder]; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Determines which all border styles of a given cell --------------------------------------------------------------------------------} -function TsWorksheet.ReadCellBorderStyles(ACell: PCell): TsCellBorderStyles; -var - fmt: PsCellFormat; -begin - Result := DEFAULT_BORDERSTYLES; - if ACell <> nil then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - Result := Fmt^.BorderStyles; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Determines the font used by a specified cell. Returns the workbook's default - font if the cell does not exist. --------------------------------------------------------------------------------} -function TsWorksheet.ReadCellFont(ACell: PCell): TsFont; -var - fmt: PsCellFormat; -begin - Result := nil; - if ACell <> nil then begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - Result := Workbook.GetFont(fmt^.FontIndex); - end; - if Result = nil then - Result := Workbook.GetDefaultFont; -end; - -{@@ ---------------------------------------------------------------------------- - Determines the index of the font used by a specified cell, referring to the - workbooks font list. Returns 0 (the default font index) if the cell does not - exist. --------------------------------------------------------------------------------} -function TsWorksheet.ReadCellFontIndex(ACell: PCell): Integer; -var - fmt: PsCellFormat; -begin - Result := DEFAULT_FONTINDEX; - if ACell <> nil then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - Result := fmt^.FontIndex; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the format record that is assigned to a specified cell --------------------------------------------------------------------------------} -function TsWorksheet.ReadCellFormat(ACell: PCell): TsCellFormat; -begin - Result := Workbook.GetCellFormat(ACell^.FormatIndex); -end; - {@@ ---------------------------------------------------------------------------- Determines the font used in a specified column record. Returns the workbook's default font if the column record does not exist. @@ -3386,133 +2862,6 @@ begin Result := Workbook.GetDefaultFont; end; -{@@ ---------------------------------------------------------------------------- - Returns the horizontal alignment of a specific cell --------------------------------------------------------------------------------} -function TsWorksheet.ReadHorAlignment(ACell: PCell): TsHorAlignment; -var - fmt: PsCellFormat; -begin - Result := haDefault; - if (ACell <> nil) then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - if (uffHorAlign in fmt^.UsedFormattingFields) then - Result := fmt^.HorAlignment; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the number format type and format string used in a specific cell --------------------------------------------------------------------------------} -procedure TsWorksheet.ReadNumFormat(ACell: PCell; out ANumFormat: TsNumberFormat; - out ANumFormatStr: String); -var - fmt: PsCellFormat; - numFmt: TsNumFormatParams; -begin - ANumFormat := nfGeneral; - ANumFormatStr := ''; - if ACell <> nil then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - if (uffNumberFormat in fmt^.UsedFormattingFields) then - begin - numFmt := Workbook.GetNumberFormat(fmt^.NumberFormatIndex); - if numFmt <> nil then - begin - ANumFormat := numFmt.NumFormat; - ANumFormatStr := numFmt.NumFormatStr; - end else - begin - ANumFormat := nfGeneral; - ANumFormatStr := ''; - end; - end; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the text orientation of a specific cell --------------------------------------------------------------------------------} -function TsWorksheet.ReadTextRotation(ACell: PCell): TsTextRotation; -var - fmt: PsCellFormat; -begin - Result := trHorizontal; - if ACell <> nil then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - if (uffTextRotation in fmt^.UsedFormattingFields) then - Result := fmt^.TextRotation; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the vertical alignment of a specific cell --------------------------------------------------------------------------------} -function TsWorksheet.ReadVertAlignment(ACell: PCell): TsVertAlignment; -var - fmt: PsCellFormat; -begin - Result := vaDefault; - if (ACell <> nil) then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - if (uffVertAlign in fmt^.UsedFormattingFields) then - Result := fmt^.VertAlignment; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Returns whether a specific cell support word-wrapping. --------------------------------------------------------------------------------} -function TsWorksheet.ReadWordwrap(ACell: PCell): boolean; -var - fmt: PsCellFormat; -begin - Result := false; - if (ACell <> nil) then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - Result := uffWordwrap in fmt^.UsedFormattingFields; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the BiDi mode of the cell (right-to-left or left-to-right) --------------------------------------------------------------------------------} -function TsWorksheet.ReadBiDiMode(ACell: PCell): TsBiDiMode; -var - fmt: PsCellFormat; -begin - Result := bdDefault; - if (ACell <> nil) then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - if (uffBiDi in fmt^.UsedFormattingFields) then - Result := fmt^.BiDiMode; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the protection flags of the cell. - - NOTE: These flags are active only if sheet protection is active, i.e. - soProtected in Worksheet.Options. --------------------------------------------------------------------------------} -function TsWorksheet.ReadCellProtection(ACell: PCell): TsCellProtections; -var - fmt: PsCellFormat; -begin - Result := DEFAULT_CELL_PROTECTION; - if (ACell <> nil) then - begin - fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); - if fmt <> nil then - Result := fmt^.Protection; - end; -end; {@@ ---------------------------------------------------------------------------- Returns true if the worksheet does not contain any cell, column or row records @@ -3795,282 +3144,6 @@ begin DeleteFormula(ACell); end; -{@@ ---------------------------------------------------------------------------- - Returns the parameters of the image stored in the internal image list at - the specified index. - - @param AIndex Index of the image to be retrieved - @return TsImage record with all image parameters. --------------------------------------------------------------------------------} -function TsWorksheet.GetImage(AIndex: Integer): TsImage; -var - img: PsImage; -begin - img := PsImage(FImages[AIndex]); - Result := img^; -end; - -function TsWorksheet.GetPointerToImage(AIndex: Integer): PsImage; -begin - Result := PsImage(FImages[AIndex]); -end; - -{@@ ---------------------------------------------------------------------------- - Returns the count of images that are embedded into this sheet. --------------------------------------------------------------------------------} -function TsWorksheet.GetImageCount: Integer; -begin - Result := FImages.Count; -end; - -{@@ ---------------------------------------------------------------------------- - Calculates the position of the image with given index relative to the cell - containing the top/left corner of the image. - - @@param x worksheet-relative coordinate of the left image edge, in workbook units - @@param y worksheet-relative coordinate of the top image edge, in workbook units - @@param ARow Index of the row containing the top/left corner of the image - @@param ACol Index of the column containing the top/left corner of the image - @@param ARowOffset Distance, in workbook units, between top cell and image borders - @@param AColOffset Distance, in workbook units, between left cell and image borders - @@param AScaleX Scaling factor for the image width - @@param AScaleY Scaling factor for the image height --------------------------------------------------------------------------------} -procedure TsWorksheet.CalcImageCell(AIndex: Integer; x, y, AWidth, AHeight: Double; - out ARow, ACol: Cardinal; out ARowOffs, AColOffs, AScaleX, AScaleY: Double); -// All lengths are in workbook units! -var - colW, rowH, sum: Double; - embobj: TsEmbeddedObj; -begin - ACol := 0; - sum := 0; - colW := GetColWidth(0, FWorkbook.Units); - while (sum + colW < x) do begin - sum := sum + colW; - inc(ACol); - colW := GetColWidth(ACol, FWorkbook.Units); - end; - AColOffs := x - sum; - - ARow := 0; - sum := 0; - rowH := CalcRowHeight(0); - while (sum + rowH < y) do begin - sum := sum + rowH; - inc(ARow); - rowH := CalcRowHeight(ARow); - end; - ARowOffs := y - sum; - - embObj := FWorkbook.GetEmbeddedObj(AIndex); - AScaleX := AWidth / embObj.ImageWidth; - AScaleY := AHeight / embObj.ImageHeight; -end; - -{@@ ---------------------------------------------------------------------------- - Calculates image extent - - @param AIndex Index of the image into the worksheet's image list - @param UsePixels if TRUE then pixels are used for calculation - this improves - the display of the images in Excel - @param ARow1 Index of the row containing the top edge of the image - @param ACol1 Index of the column containing the left edege of the image - @param ARow2 Index of the row containing the right edge of the image - @param ACol2 Index of the column containing the bottom edge of the image - @param ARowOffs1 Distance between the top edge of image and row 1 - @param AColOffs1 Distance between the left edge of image and column 1 - @param ARowOffs2 Distance between the bottom edge of image and top of row 2 - @param AColOffs2 Distance between the right edge of image and left of col 2 - @param x Absolute coordinate of left edge of image - @param y Absolute coordinate of top edge of image - @param AWidth Width of the image - @param AHeight Height of the image - - All dimensions are in workbook units --------------------------------------------------------------------------------} -procedure TsWorksheet.CalcImageExtent(AIndex: Integer; UsePixels: Boolean; - out ARow1, ACol1, ARow2, ACol2: Cardinal; - out ARowOffs1, AColOffs1, ARowOffs2, AColOffs2: Double; - out x,y, AWidth, AHeight: Double); -var - img: TsImage; - obj: TsEmbeddedObj; - colW, rowH: Double; - totH: Double; - r, c: Integer; - w_px, h_px: Integer; - totH_px, rowH_px: Integer; - totW_px, colW_px: Integer; - ppi: Integer; - u: TsSizeUnits; -begin - // Abbreviations - ppi := ScreenPixelsPerInch; - u := FWorkbook.Units; - - img := GetImage(AIndex); - ARow1 := img.Row; - ACol1 := img.Col; - ARowOffs1 := img.OffsetX; // in workbook units - AColOffs1 := img.OffsetY; // in workbook units - - obj := FWorkbook.GetEmbeddedObj(img.Index); - AWidth := obj.ImageWidth * img.ScaleX; // in workbook units - AHeight := obj.ImageHeight * img.ScaleY; // in workbook units - - // Find x coordinate of left image edge, in workbook units - x := AColOffs1; - for c := 0 to ACol1-1 do - begin - colW := GetColWidth(c, u); - x := x + colW; - end; - // Find y coordinate of top image edge, in workbook units. - y := ARowOffs1; - for r := 0 to ARow1 - 1 do - begin - rowH := CalcRowHeight(r); - y := y + rowH; - end; - - if UsePixels then - // Use pixels for calculation. Better for Excel, maybe due to rounding error? - begin - // If we don't know the ppi of the screen the calculation is not exact! - w_px := ptsToPx(FWorkbook.ConvertUnits(AWidth, u, suPoints), ppi); - h_px := ptsToPx(FWorkbook.ConvertUnits(AHeight, u, suPoints), ppi); - // Find cell with right image edge. Find horizontal within-cell-offsets - totW_px := -ptsToPx(FWorkbook.ConvertUnits(AColOffs1, u, suPoints), ppi); - ACol2 := ACol1; - while (totW_px < w_px) do - begin - colW := GetColWidth(ACol2, u); - colW_px := ptsToPx(FWorkbook.ConvertUnits(colW, u, suPoints), ppi); - totW_px := totW_px + colW_px; - if totW_px > w_px then - begin - AColOffs2 := FWorkbook.ConvertUnits(pxToPts(colW_px - (totW_px - w_px), ppi), suPoints, u); - break; - end; - inc(ACol2); - end; - // Find cell with bottom image edge. Find vertical within-cell-offset. - totH_px := -ptsToPx(FWorkbook.ConvertUnits(ARowOffs1, u, suPoints), ppi); - ARow2 := ARow1; - while (totH_px < h_px) do - begin - rowH := CalcRowHeight(ARow2); - rowH_px := ptsToPx(FWorkbook.ConvertUnits(rowH, u, suPoints), ppi); - totH_px := totH_px + rowH_px; - if totH_px > h_px then - begin - ARowOffs2 := FWorkbook.ConvertUnits(pxToPts(rowH_px - (totH_px - h_px), ppi), suPoints, u); - break; - end; - inc(ARow2); - end; - end - else // Use workbook units for calculation - begin - // Find cell with right image edge. Find horizontal within-cell-offsets - totH := -ARowOffs1; - ARow2 := ARow1; - while (totH < AHeight) do - begin - rowH := CalcRowHeight(ARow2); - totH := totH + rowH; - if totH >= AHeight then - begin - ARowOffs2 := rowH - (totH - AHeight); - break; - end; - inc(ARow2); - end; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Adds an embedded image to the worksheet - - @param ARow Index of the row at which the image begins (top edge) - @param ACol Index of the column at which the image begins (left edge) - @param AFileName Name of the image file - @param AOffsetX The image is offset horizontally from the left edge of - the anchor cell. May reach into another cell. - Value is in workbook units. - @param AOffsetY The image is offset vertically from the top edge of the - anchor cell. May reach into another cell. - Value is in workbook units. - @param AScaleX Horizontal scaling factor of the image - @param AScaleY Vertical scaling factor of the image - @return Index into the internal image list. --------------------------------------------------------------------------------} -function TsWorksheet.WriteImage(ARow, ACol: Cardinal; AFileName: String; - AOffsetX: Double = 0.0; AOffsetY: Double = 0.0; - AScaleX: Double = 1.0; AScaleY: Double = 1.0): Integer; -var - idx: Integer; -begin - // Does the image already exist? - idx := Workbook.FindEmbeddedObj(AFileName); - // No? Open and store in embedded object list. - if idx = -1 then - idx := Workbook.AddEmbeddedObj(AFileName); - // An error has occured? Error is already logged. Just exit. - if idx = -1 then - exit; - - // Everything ok here... - Result := WriteImage(ARow, ACol, idx, AOffsetX, AOffsetY, AScaleX, AScaleY); -end; - -{@@ ---------------------------------------------------------------------------- - Adds an embedded image to the worksheet. The image passed in a stream. - - @param ARow Index of the row at which the image begins (top edge) - @param ACol Index of the column at which the image begins (left edge) - @param AStream Stream which contains the image data - @param AOffsetX The image is offset horizontally from the left edge of - the anchor cell. May reach into another cell. - Value is in workbook units. - @param AOffsetY The image is offset vertically from the top edge of the - anchor cell. May reach into another cell. - Value is in workbook units. - @param AScaleX Horizontal scaling factor of the image - @param AScaleY Vertical scaling factor of the image - @param ASize Number ob bytes to be read from the input stream. - @return Index into the internal image list. --------------------------------------------------------------------------------} -function TsWorksheet.WriteImage(ARow, ACol: Cardinal; AStream: TStream; - AOffsetX: Double = 0.0; AOffsetY: Double = 0.0; - AScaleX: Double = 1.0; AScaleY: Double = 1.0; - ASize: Int64 = -1): Integer; -var - idx: Integer; -begin - // Copy the stream to a new item in embedded object list. - idx := Workbook.AddEmbeddedObj(AStream, '', ASize); - - // An error has occured? Error is already logged. Just exit. - if idx = -1 then - exit; - - // Everything ok here... - Result := WriteImage(ARow, ACol, idx, AOffsetX, AOffsetY, AScaleX, AScaleY); -end; - -function TsWorksheet.WriteImage(ARow, ACol: Cardinal; AImageIndex: Integer; - AOffsetX: Double = 0.0; AOffsetY: Double = 0.0; - AScaleX: Double = 1.0; AScaleY: Double = 1.0): Integer; -var - img: PsImage; -begin - New(img); - InitImageRecord(img^, ARow, ACol, AOffsetX, AOffsetY, AScaleX, AScaleY); - img^.Index := AImageIndex; - Result := FImages.Add(img); -end; {@@ Assigns a hyperlink to an image. The image is specified by its index in the internal image list} @@ -4086,49 +3159,6 @@ begin end; end; -{@@ ---------------------------------------------------------------------------- - Removes an image from the internal image list. - The image is identified by its index. - The image stream (stored by the workbook) is retained. --------------------------------------------------------------------------------} -procedure TsWorksheet.RemoveImage(AIndex: Integer); -var - img: PsImage; -begin - img := PsImage(FImages[AIndex]); - if (img <> nil) then begin - if (img^.Picture <> nil) then img^.Picture.Free; - img^.HyperlinkTarget := ''; - img^.HyperlinkToolTip := ''; - end; - Dispose(img); - FImages.Delete(AIndex); -end; - -{@@ ---------------------------------------------------------------------------- - Removes all image from the internal image list. - The image streams (stored by the workbook), however, are retained because - images may also be used as header/footer images. --------------------------------------------------------------------------------} -procedure TsWorksheet.RemoveAllImages; -var - i: Integer; -begin - for i := FImages.Count-1 downto 0 do - RemoveImage(i); -end; - -{@@ ---------------------------------------------------------------------------- - Removes the comment from a cell and releases the memory occupied by the node. --------------------------------------------------------------------------------} -procedure TsWorksheet.RemoveComment(ACell: PCell); -begin - if HasComment(ACell) then - begin - FComments.DeleteComment(ACell^.Row, ACell^.Col); - Exclude(ACell^.Flags, cfHasComment); - end; -end; {@@ ---------------------------------------------------------------------------- Removes a cell from its tree container. DOES NOT RELEASE ITS MEMORY! @@ -5669,138 +4699,6 @@ begin WriteDateTime(ACell, AValue, nfCustom, ANumFormatStr); end; -{@@ ---------------------------------------------------------------------------- - Adds a date/time format to the formatting of a cell - - @param ARow The row of the cell - @param ACol The column of the cell - @param ANumFormat Identifier of the format to be applied (nfXXXX constant) - @param ANumFormatString Optional string of formatting codes. Is only considered - if ANumberFormat is nfCustom. - @return Pointer to the cell - - @see TsNumberFormat --------------------------------------------------------------------------------} -function TsWorksheet.WriteDateTimeFormat(ARow, ACol: Cardinal; - ANumFormat: TsNumberFormat; const ANumFormatString: String = ''): PCell; -begin - Result := GetCell(ARow, ACol); - WriteDateTimeFormat(Result, ANumFormat, ANumFormatString); -end; - -{@@ ---------------------------------------------------------------------------- - Adds a date/time format to the formatting of a cell - - @param ACell Pointer to the cell considered - @param ANumFormat Identifier of the format to be applied (nxXXXX constant) - @param ANumFormatString optional string of formatting codes. Is only considered - if ANumberFormat is nfCustom. - - @see TsNumberFormat --------------------------------------------------------------------------------} -procedure TsWorksheet.WriteDateTimeFormat(ACell: PCell; - ANumFormat: TsNumberFormat; const ANumFormatString: String = ''); -var - fmt: TsCellFormat; - nfs: String; - nfp: TsNumFormatParams; - isTextFmt, wasTextFmt: Boolean; - oldVal: String; -begin - if ACell = nil then - exit; - - if not ((ANumFormat in [nfGeneral, nfCustom]) or IsDateTimeFormat(ANumFormat)) then - raise EFPSpreadsheet.Create('WriteDateTimeFormat can only be called with date/time formats.'); - - isTextFmt := false; - wasTextFmt := false; - - fmt := FWorkbook.GetCellFormat(ACell^.FormatIndex); - fmt.NumberFormat := ANumFormat; - if (ANumFormat <> nfGeneral) then - begin - nfp := Workbook.GetNumberFormat(fmt.NumberFormatIndex); - wasTextFmt := IsTextFormat(nfp); - oldval := ReadAsText(ACell); - Include(fmt.UsedFormattingFields, uffNumberFormat); - if (ANumFormatString = '') then - nfs := BuildDateTimeFormatString(ANumFormat, Workbook.FormatSettings) - else - nfs := ANumFormatString; - isTextFmt := (nfs = '@'); - end else - begin - Exclude(fmt.UsedFormattingFields, uffNumberFormat); - fmt.NumberFormatStr := ''; - end; - fmt.NumberFormat := ANumFormat; - fmt.NumberFormatStr := nfs; - fmt.NumberFormatIndex := Workbook.AddNumberFormat(nfs); - ACell^.FormatIndex := FWorkbook.AddCellFormat(fmt); - - if isTextFmt then - WriteText(ACell, oldval) - else - if wasTextFmt then - WriteCellValueAsString(ACell, ACell^.UTF8StringValue); - - ChangedCell(ACell^.Row, ACell^.Col); -end; - -{@@ ---------------------------------------------------------------------------- - Formats the number in a cell to show a given count of decimal places. - Is ignored for non-decimal formats (such as most date/time formats). - - @param ARow Row indows of the cell considered - @param ACol Column indows of the cell considered - @param ADecimals Number of decimal places to be displayed - @return Pointer to the cell - @see TsNumberFormat --------------------------------------------------------------------------------} -function TsWorksheet.WriteDecimals(ARow, ACol: Cardinal; ADecimals: Byte): PCell; -begin - Result := FindCell(ARow, ACol); - WriteDecimals(Result, ADecimals); -end; - -{@@ ---------------------------------------------------------------------------- - Formats the number in a cell to show a given count of decimal places. - Is ignored for non-decimal formats (such as most date/time formats). - - @param ACell Pointer to the cell considered - @param ADecimals Number of decimal places to be displayed - @see TsNumberFormat --------------------------------------------------------------------------------} -procedure TsWorksheet.WriteDecimals(ACell: PCell; ADecimals: Byte); -var - parser: TsNumFormatParser; - fmt: TsCellFormat; - numFmt: TsNumFormatParams; - numFmtStr: String; -begin - if (ACell = nil) or (ACell^.ContentType <> cctNumber) then - exit; - - fmt := FWorkbook.GetCellFormat(ACell^.FormatIndex); - numFmt := FWorkbook.GetNumberFormat(fmt.NumberFormatIndex); - if numFmt <> nil then - numFmtStr := numFmt.NumFormatStr - else - numFmtStr := '0.00'; - parser := TsNumFormatParser.Create(numFmtStr, Workbook.FormatSettings); - try - parser.Decimals := ADecimals; - numFmtStr := parser.FormatString; - fmt.NumberFormatIndex := Workbook.AddNumberFormat(numFmtStr); - Include(fmt.UsedFormattingFields, uffNumberFormat); - ACell^.FormatIndex := Workbook.AddCellFormat(fmt); - ChangedCell(ACell^.Row, ACell^.Col); - finally - parser.Free; - end; -end; - {@@ ---------------------------------------------------------------------------- Writes an error value to a cell. @@ -5937,203 +4835,6 @@ begin ChangedCell(ACell^.Row, ACell^.Col); end; -{@@ ---------------------------------------------------------------------------- - Adds a number format to the formatting of a cell - - @param ARow The row of the cell - @param ACol The column of the cell - @param ANumFormat Identifier of the format to be applied - @param ADecimals Number of decimal places - @param ACurrencySymbol optional currency symbol in case of nfCurrency - @param APosCurrFormat optional identifier for positive currencies - @param ANegCurrFormat optional identifier for negative currencies - @return Pointer to the cell - - @see TsNumberFormat --------------------------------------------------------------------------------} -function TsWorksheet.WriteNumberFormat(ARow, ACol: Cardinal; - ANumFormat: TsNumberFormat; ADecimals: Integer; ACurrencySymbol: String = ''; - APosCurrFormat: Integer = -1; ANegCurrFormat: Integer = -1): PCell; -begin - Result := GetCell(ARow, ACol); - WriteNumberFormat(Result, ANumFormat, ADecimals, ACurrencySymbol, - APosCurrFormat, ANegCurrFormat); -end; - -{@@ ---------------------------------------------------------------------------- - Adds a number format to the formatting of a cell - - @param ARow The row of the cell - @param ACol The column of the cell - @param ANumFormat Identifier of the format to be applied - @param ADecimals Number of decimal places - @param ACurrencySymbol optional currency symbol in case of nfCurrency - @param APosCurrFormat optional identifier for positive currencies - @param ANegCurrFormat optional identifier for negative currencies - - @see TsNumberFormat --------------------------------------------------------------------------------} -procedure TsWorksheet.WriteNumberFormat(ACell: PCell; - ANumFormat: TsNumberFormat; ADecimals: Integer; ACurrencySymbol: String = ''; - APosCurrFormat: Integer = -1; ANegCurrFormat: Integer = -1); -var - fmt: TsCellFormat; - fmtStr: String; - nfp: TsNumFormatParams; - wasTextFmt: Boolean; -begin - if ACell = nil then - exit; - - wasTextFmt := false; - - fmt := Workbook.GetCellFormat(ACell^.FormatIndex); - fmt.NumberFormat := ANumFormat; - if ANumFormat <> nfGeneral then begin - nfp := Workbook.GetNumberFormat(fmt.NumberFormatIndex); - wasTextFmt := IsTextFormat(nfp); - Include(fmt.UsedFormattingFields, uffNumberFormat); - if IsCurrencyFormat(ANumFormat) then - begin - RegisterCurrency(ACurrencySymbol); - fmtStr := BuildCurrencyFormatString(ANumFormat, Workbook.FormatSettings, - ADecimals, APosCurrFormat, ANegCurrFormat, ACurrencySymbol); - end else - fmtStr := BuildNumberFormatString(ANumFormat, - Workbook.FormatSettings, ADecimals); - fmt.NumberFormatIndex := Workbook.AddNumberFormat(fmtStr); - end else begin - Exclude(fmt.UsedFormattingFields, uffNumberFormat); - fmt.NumberFormatIndex := -1; - end; - ACell^.FormatIndex := Workbook.AddCellFormat(fmt); - - if wasTextFmt then - WriteCellValueAsString(ACell, ACell^.UTF8StringValue); - - ChangedCell(ACell^.Row, ACell^.Col); -end; - -{@@ ---------------------------------------------------------------------------- - Formats a number as a fraction - - @param ARow Row index of the cell - @param ACol Column index of the cell - @param ANumFormat Identifier of the format to be applied. Must be - either nfFraction or nfMixedFraction - @param ANumeratorDigts Count of numerator digits - @param ADenominatorDigits Count of denominator digits - @return Pointer to the cell - - @see TsNumberFormat --------------------------------------------------------------------------------} -function TsWorksheet.WriteFractionFormat(ARow, ACol: Cardinal; - AMixedFraction: Boolean; ANumeratorDigits, ADenominatorDigits: Integer): PCell; -begin - Result := GetCell(ARow, ACol); - WriteFractionFormat(Result, AMixedFraction, ANumeratorDigits, ADenominatorDigits); -end; - -{@@ ---------------------------------------------------------------------------- - Formats a number as a fraction - - @param ACell Pointer to the cell to be formatted - @param ANumFormat Identifier of the format to be applied. Must be - either nfFraction or nfMixedFraction - @param ANumeratorDigts Count of numerator digits - @param ADenominatorDigits Count of denominator digits - - @see TsNumberFormat --------------------------------------------------------------------------------} -procedure TsWorksheet.WriteFractionFormat(ACell: PCell; - AMixedFraction: Boolean; ANumeratorDigits, ADenominatorDigits: Integer); -var - fmt: TsCellFormat; - nfs: String; -begin - if ACell = nil then - exit; - - fmt := Workbook.GetCellFormat(ACell^.FormatIndex); - nfs := BuildFractionFormatString(AMixedFraction, ANumeratorDigits, ADenominatorDigits); - fmt.NumberFormatIndex := Workbook.AddNumberFormat(nfs); - Include(fmt.UsedFormattingFields, uffNumberFormat); - ACell^.FormatIndex := Workbook.AddCellFormat(fmt); - - ChangedCell(ACell^.Row, ACell^.Col); -end; - -{@@ ---------------------------------------------------------------------------- - Adds a number format to the formatting of a cell - - @param ARow The row of the cell - @param ACol The column of the cell - @param ANumFormat Identifier of the format to be applied - @param ANumFormatString Optional string of formatting codes. Is only considered - if ANumberFormat is nfCustom. - @return Pointer to the cell - - @see TsNumberFormat --------------------------------------------------------------------------------} -function TsWorksheet.WriteNumberFormat(ARow, ACol: Cardinal; - ANumFormat: TsNumberFormat; const ANumFormatString: String = ''): PCell; -begin - Result := GetCell(ARow, ACol); - WriteNumberFormat(Result, ANumFormat, ANumFormatString); -end; - -{@@ ---------------------------------------------------------------------------- - Adds a number format to the formatting of a cell - - @param ACell Pointer to the cell considered - @param ANumFormat Identifier of the format to be applied - @param ANumFormatString Optional string of formatting codes. Is only considered - if ANumberFormat is nfCustom. - - @see TsNumberFormat --------------------------------------------------------------------------------} -procedure TsWorksheet.WriteNumberFormat(ACell: PCell; - ANumFormat: TsNumberFormat; const ANumFormatString: String = ''); -var - fmt: TsCellFormat; - fmtStr: String; - nfp: TsNumFormatParams; - oldval: String; - isTextFmt, wasTextFmt: Boolean; -begin - if ACell = nil then - exit; - - isTextFmt := false; - wasTextFmt := false; - - fmt := Workbook.GetCellFormat(ACell^.FormatIndex); - - if ANumFormat <> nfGeneral then begin - nfp := Workbook.GetNumberFormat(fmt.NumberFormatIndex); - wasTextFmt := IsTextFormat(nfp); - oldval := ReadAsText(ACell); - Include(fmt.UsedFormattingFields, uffNumberFormat); - if (ANumFormatString = '') then - fmtStr := BuildNumberFormatString(ANumFormat, Workbook.FormatSettings) - else - fmtStr := ANumFormatString; - isTextFmt := (fmtstr = '@'); - fmt.NumberFormatIndex := Workbook.AddNumberFormat(fmtStr); - end else begin - Exclude(fmt.UsedFormattingFields, uffNumberFormat); - fmt.NumberFormatIndex := -1; - end; - ACell^.FormatIndex := Workbook.AddCellFormat(fmt); - - if isTextFmt then - WriteText(ACell, oldval) - else - if wasTextFmt then - WriteCellValueAsString(ACell, ACell^.UTF8StringValue); - - ChangedCell(ACell^.Row, ACell^.Col); -end; {@@ ---------------------------------------------------------------------------- Writes an RPN formula to a cell. An RPN formula is an array of tokens @@ -7417,9 +6118,6 @@ begin end; end; -{$include fpspreadsheet_fmt.inc} // cell formatting -{$include fpspreadsheet_cf.inc} // conditional formatting - {==============================================================================} { TsWorkbook } @@ -8671,451 +7369,6 @@ begin end; -{ Format handling } - -{@@ ---------------------------------------------------------------------------- - Adds the specified format record to the internal list and returns the index - in the list. If the record had already been added before the function only - returns the index. --------------------------------------------------------------------------------} -function TsWorkbook.AddCellFormat(const AValue: TsCellFormat): Integer; -begin - Result := FCellFormatList.Add(AValue); -end; - -{@@ ---------------------------------------------------------------------------- - Returns the contents of the format record with the specified index. --------------------------------------------------------------------------------} -function TsWorkbook.GetCellFormat(AIndex: Integer): TsCellFormat; -begin - Result := FCellFormatList.Items[AIndex]^; -end; - -{@@ ---------------------------------------------------------------------------- - Returns a string describing the cell format with the specified index. --------------------------------------------------------------------------------} -function TsWorkbook.GetCellFormatAsString(AIndex: Integer): String; -var - fmt: PsCellFormat; - cb: TsCellBorder; - s: String; - numFmt: TsNumFormatParams; -begin - Result := ''; - fmt := GetPointerToCellFormat(AIndex); - if fmt = nil then - exit; - - if (uffFont in fmt^.UsedFormattingFields) then - Result := Format('%s; Font%d', [Result, fmt^.FontIndex]); - if (uffBackground in fmt^.UsedFormattingFields) then begin - Result := Format('%s; Bg %s', [Result, GetColorName(fmt^.Background.BgColor)]); - Result := Format('%s; Fg %s', [Result, GetColorName(fmt^.Background.FgColor)]); - Result := Format('%s; Pattern %s', [Result, GetEnumName(TypeInfo(TsFillStyle), ord(fmt^.Background.Style))]); - end; - if (uffHorAlign in fmt^.UsedFormattingfields) then - Result := Format('%s; %s', [Result, GetEnumName(TypeInfo(TsHorAlignment), ord(fmt^.HorAlignment))]); - if (uffVertAlign in fmt^.UsedFormattingFields) then - Result := Format('%s; %s', [Result, GetEnumName(TypeInfo(TsVertAlignment), ord(fmt^.VertAlignment))]); - if (uffWordwrap in fmt^.UsedFormattingFields) then - Result := Format('%s; Word-wrap', [Result]); - if (uffNumberFormat in fmt^.UsedFormattingFields) then - begin - numFmt := GetNumberFormat(fmt^.NumberFormatIndex); - if numFmt <> nil then - Result := Format('%s; %s (%s)', [Result, - GetEnumName(TypeInfo(TsNumberFormat), ord(numFmt.NumFormat)), - numFmt.NumFormatStr - ]) - else - Result := Format('%s; %s', [Result, 'nfGeneral']); - end else - Result := Format('%s; %s', [Result, 'nfGeneral']); - if (uffBorder in fmt^.UsedFormattingFields) then - begin - s := ''; - for cb in fmt^.Border do - if s = '' then s := GetEnumName(TypeInfo(TsCellBorder), ord(cb)) - else s := s + '+' + GetEnumName(TypeInfo(TsCellBorder), ord(cb)); - Result := Format('%s; %s', [Result, s]); - end; - if (uffBiDi in fmt^.UsedFormattingFields) then - Result := Format('%s; %s', [Result, GetEnumName(TypeInfo(TsBiDiMode), ord(fmt^.BiDiMode))]); - if Result <> '' then Delete(Result, 1, 2); -end; - -{@@ ---------------------------------------------------------------------------- - Returns the count of format records used all over the workbook --------------------------------------------------------------------------------} -function TsWorkbook.GetNumCellFormats: Integer; -begin - Result := FCellFormatList.Count; -end; - -{@@ ---------------------------------------------------------------------------- - Returns a pointer to the format record with the specified index --------------------------------------------------------------------------------} -function TsWorkbook.GetPointerToCellFormat(AIndex: Integer): PsCellFormat; -begin - if FCellFormatList.Count = 0 then - raise Exception.Create('[TsWorkbook.GetPointerToCellFormat]: No format items.'); - - if (AIndex < 0) or (AIndex >= FCellFormatList.Count) then - AIndex := 0; // 0 is default format - Result := FCellFormatList.Items[AIndex]; -end; - -{@@ ---------------------------------------------------------------------------- - Removes all cell formats from the workbook. - - If AKeepDefaultFormat is true then index 0 containing the default cell format - is retained. - - Use carefully! --------------------------------------------------------------------------------} -procedure TsWorkbook.RemoveAllCellFormats(AKeepDefaultFormat: Boolean); -var - i: Integer; -begin - if AKeepDefaultFormat then - for i := FCellFormatList.Count-1 downto 1 do - FCellFormatList.Delete(i) - else - FCellFormatList.Clear; -end; - - -{ Conditional formats } - -function TsWorkbook.GetConditionalFormat(AIndex: Integer): TsConditionalFormat; -begin - Result := FConditionalFormatList[AIndex] as TsConditionalFormat; -end; - -function TsWorkbook.GetNumConditionalFormats: Integer; -begin - Result := FConditionalFormatList.Count; -end; - - -{ Font handling } - -{@@ ---------------------------------------------------------------------------- - Adds a font to the font list. Returns the index in the font list. - - @param AFontName Name of the font (like 'Arial') - @param ASize Size of the font in points - @param AStyle Style of the font, a combination of TsFontStyle elements - @param AColor RGB valoe of the font color - @param APosition Specifies subscript or superscript text. - @return Index of the font in the workbook's font list --------------------------------------------------------------------------------} -function TsWorkbook.AddFont(const AFontName: String; ASize: Single; - AStyle: TsFontStyles; AColor: TsColor; - APosition: TsFontPosition = fpNormal): Integer; -var - fnt: TsFont; -begin - fnt := TsFont.Create; - fnt.FontName := AFontName; - fnt.Size := ASize; - fnt.Style := AStyle; - fnt.Color := AColor; - fnt.Position := APosition; - Result := AddFont(fnt); -end; - -{@@ ---------------------------------------------------------------------------- - Adds a font to the font list. Returns the index in the font list. - - @param AFont TsFont record containing all font parameters - @return Index of the font in the workbook's font list --------------------------------------------------------------------------------} -function TsWorkbook.AddFont(const AFont: TsFont): Integer; -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(const AFontIndex: Integer); -var - fnt: TsFont; -begin - if AFontIndex < FFontList.Count then - begin - fnt := TsFont(FFontList.Items[AFontIndex]); - if fnt <> nil then fnt.Free; - FFontList.Delete(AFontIndex); - end; -end; - -{@@ ---------------------------------------------------------------------------- - Checks whether the font with the given specification is already contained in - the font list. Returns the index, or -1 if not found. - - @param AFontName Name of the font (like 'Arial') - @param ASize Size of the font in points - @param AStyle Style of the font, a combination of TsFontStyle elements - @param AColor RGB value of the font color - @param APosition Specified subscript or superscript text. - @return Index of the font in the font list, or -1 if not found. --------------------------------------------------------------------------------} -function TsWorkbook.FindFont(const AFontName: String; ASize: Single; - AStyle: TsFontStyles; AColor: TsColor; APosition: TsFontPosition = fpNormal): Integer; -begin - Result := FindFontInList(FFontList, AFontName, ASize, AStyle, AColor, APosition); -end; -{ -const - EPS = 1e-3; -var - fnt: TsFont; -begin - for Result := 0 to FFontList.Count-1 do - begin - fnt := TsFont(FFontList.Items[Result]); - if (fnt <> nil) and - SameText(AFontName, fnt.FontName) and - SameValue(ASize, fnt.Size, EPS) and // careful when comparing floating point numbers - (AStyle = fnt.Style) and - (AColor = fnt.Color) and - (APosition = fnt.Position) - then - exit; - end; - Result := -1; -end; - } - -{@@ ---------------------------------------------------------------------------- - Initializes the font list by adding 5 fonts: - - 0: default font - 1: like default font, but blue and underlined (for hyperlinks) - 2: like default font, but bold - 3: like default font, but italic --------------------------------------------------------------------------------} -procedure TsWorkbook.InitFonts; -var - fntName: String; - fntSize: Single; -begin - // Memorize old default font - with TsFont(FFontList.Items[0]) do - begin - fntName := FontName; - fntSize := Size; - end; - - // Remove current font list - RemoveAllFonts; - - // Build new font list - SetDefaultFont(fntName, fntSize); // FONT0: Default font - AddFont(fntName, fntSize, [fssUnderline], scBlue); // FONT1: Hyperlink font = blue & underlined - AddFont(fntName, fntSize, [fssBold], scBlack); // FONT2: Bold font - AddFont(fntName, fntSize, [fssItalic], scBlack); // FONT3: Italic font (not used directly) - - FBuiltinFontCount := FFontList.Count; -end; - -{@@ ---------------------------------------------------------------------------- - Clears the list of fonts and releases their memory. --------------------------------------------------------------------------------} -procedure TsWorkbook.RemoveAllFonts; -var - i: Integer; - fnt: TsFont; -begin - for i := FFontList.Count-1 downto 0 do - begin - fnt := TsFont(FFontList.Items[i]); - fnt.Free; - FFontList.Delete(i); - end; - FBuiltinFontCount := 0; -end; - -{@@ ---------------------------------------------------------------------------- - Replaces the built-in font at a specific index with different font parameters --------------------------------------------------------------------------------} -procedure TsWorkbook.ReplaceFont(AFontIndex: Integer; AFontName: String; - ASize: Single; AStyle: TsFontStyles; AColor: TsColor; - APosition: TsFontPosition = fpNormal); -var - fnt: TsFont; -begin - if (AFontIndex < FBuiltinFontCount) then //and (AFontIndex <> 4) then - begin - fnt := TsFont(FFontList[AFontIndex]); - fnt.FontName := AFontName; - fnt.Size := ASize; - fnt.Style := AStyle; - fnt.Color := AColor; - fnt.Position := APosition; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Defines the default font. This is the font with index 0 in the FontList. - The next built-in fonts will have the same font name and size --------------------------------------------------------------------------------} -procedure TsWorkbook.SetDefaultFont(const AFontName: String; ASize: Single); -var - i: Integer; -begin - if FFontList.Count = 0 then - AddFont(AFontName, ASize, [], scBlack) - else - for i:=0 to FBuiltinFontCount-1 do - if (i <> 4) and (i < FFontList.Count) then // wp: why if font #4 relevant here ???? - with TsFont(FFontList[i]) do - begin - FontName := AFontName; - Size := ASize; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the count of built-in fonts (default font, hyperlink font, bold font - by default). --------------------------------------------------------------------------------} -function TsWorkbook.GetBuiltinFontCount: Integer; -begin - Result := FBuiltinFontCount; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the default font. This is the first font (index 0) in the font list --------------------------------------------------------------------------------} -function TsWorkbook.GetDefaultFont: TsFont; -begin - Result := GetFont(0); -end; - -{@@ ---------------------------------------------------------------------------- - Returns the point size of the default font --------------------------------------------------------------------------------} -function TsWorkbook.GetDefaultFontSize: Single; -begin - Result := GetFont(0).Size; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the font with the given index. - - @param AIndex Index of the font to be considered - @return Record containing all parameters of the font (or nil if not found). --------------------------------------------------------------------------------} -function TsWorkbook.GetFont(AIndex: Integer): TsFont; -begin - if (AIndex >= 0) and (AIndex < FFontList.Count) then - Result := FFontList.Items[AIndex] - else - Result := nil; -end; - -{@@ ---------------------------------------------------------------------------- - Returns a string which identifies the font with a given index. - - @param AIndex Index of the font - @return String with font name, font size etc. --------------------------------------------------------------------------------} -function TsWorkbook.GetFontAsString(AIndex: Integer): String; -begin - Result := fpsUtils.GetFontAsString(GetFont(AIndex)); -end; - -{@@ ---------------------------------------------------------------------------- - Returns the count of registered fonts --------------------------------------------------------------------------------} -function TsWorkbook.GetFontCount: Integer; -begin - Result := FFontList.Count; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the hypertext font. This is font with index 6 in the font list --------------------------------------------------------------------------------} -function TsWorkbook.GetHyperlinkFont: TsFont; -begin - Result := GetFont(HYPERLINK_FONTINDEX); -end; - - -{@@ ---------------------------------------------------------------------------- - Adds a number format to the internal list. Returns the list index if already - present, or creates a new format item and returns its index. --------------------------------------------------------------------------------} -function TsWorkbook.AddNumberFormat(AFormatStr: String): Integer; -begin - if AFormatStr = '' then - Result := -1 // General number format is not stored - else - Result := TsNumFormatList(FNumFormatList).AddFormat(AFormatStr); -end; - -{@@ ---------------------------------------------------------------------------- - Returns the parameters of the number format stored in the NumFormatList at the - specified index. - "General" number format is returned as nil. --------------------------------------------------------------------------------} -function TsWorkbook.GetNumberFormat(AIndex: Integer): TsNumFormatParams; -begin - if (AIndex >= 0) and (AIndex < FNumFormatList.Count) then - Result := TsNumFormatParams(FNumFormatList.Items[AIndex]) - else - Result := nil; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the count of number format records stored in the NumFormatList --------------------------------------------------------------------------------} -function TsWorkbook.GetNumberFormatCount: Integer; -begin - Result := FNumFormatList.Count; -end; - -{@@ ---------------------------------------------------------------------------- - Removes all numberformats - Use carefully! --------------------------------------------------------------------------------} -procedure TsWorkbook.RemoveAllNumberFormats; -var - i: Integer; - nfp: TsNumFormatParams; -begin - for i:= FEmbeddedObjList.Count-1 downto 0 do begin - nfp := TsNumFormatParams(FNumFormatList[i]); - FNumFormatList.Delete(i); - nfp.Free; - end; -end; - {@@ ---------------------------------------------------------------------------- Calculates all formulas of the workbook. @@ -9308,544 +7561,16 @@ begin FOnChangeWorksheet(Self, GetWorksheetByIndex(AToIndex)); end; -{@@ ---------------------------------------------------------------------------- - Writes the selected cells to a stream for usage in the clipboard. - Transfer to the clipboard has do be done by the calling routine since - fpspreadsheet does not "know" the system's clipboard. --------------------------------------------------------------------------------} -procedure TsWorkbook.CopyToClipboardStream(AStream: TStream; - AFormat: TsSpreadsheetFormat; AParams: TsStreamParams = []); -var - clipbook: TsWorkbook; - clipsheet: TsWorksheet; - sel: TsCellRange; - range: TsCellRangeArray; - r, c: Cardinal; - srccell, destcell: PCell; -begin - if AStream = nil then - exit; - if ActiveWorksheet = nil then - exit; +{$include fpspreadsheet_fmt.inc} // cell formatting +{$include fpspreadsheet_fonts.inc} // fonts +{$include fpspreadsheet_numfmt.inc} // number formats +{$include fpspreadsheet_cf.inc} // conditional formatting +{$include fpspreadsheet_comments.inc} // comments +{$include fpspreadsheet_hyperlinks.inc} // hyperlinks +{$include fpspreadsheet_embobj.inc} // embedded objects +{$include fpspreadsheet_clipbrd.inc} // clipboard access - // Create workbook which will be written to clipboard stream - // Contains only the selected worksheet and the selected cells. - clipbook := TsWorkbook.Create; - try - clipsheet := clipbook.AddWorksheet(ActiveWorksheet.Name); - for sel in ActiveWorksheet.GetSelection do - begin - for r := sel.Row1 to sel.Row2 do - for c := sel.Col1 to sel.Col2 do - begin - srccell := ActiveWorksheet.FindCell(r, c); - if ActiveWorksheet.IsMerged(srccell) then - srccell := ActiveWorksheet.FindMergeBase(srccell); - if srccell <> nil then begin - destcell := clipsheet.GetCell(r, c); // wp: why was there AddCell? - clipsheet.CopyCell(srccell, destcell); - end; - end; - end; - // Select the same cells as in the source workbook. - range := ActiveWorksheet.GetSelection; - clipsheet.SetSelection(range); - clipsheet.SelectCell(range[0].Row1, range[0].Col1); - - // Write this workbook to a stream. Set the parameter spClipboard to - // indicate that this should be the special clipboard version of the stream. - clipbook.WriteToStream(AStream, AFormat, AParams + [spClipboard]); - - if AFormat = sfCSV then - AStream.WriteByte(0); - - // The calling routine which copies the stream to the clipboard requires - // the stream to be at its beginning. - AStream.Position := 0; - finally - clipbook.Free; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Copies the cells stored in the specified stream to the active worksheet. - The provided stream contains data from the system's clipboard. - Note that transfer from the clipboard to the stream has to be done by the - calling routine since fpspreadsheet does not "know" the system's clipboard. --------------------------------------------------------------------------------} -procedure TsWorkbook.PasteFromClipboardStream(AStream: TStream; - AFormat: TsSpreadsheetFormat; AOperation: TsCopyOperation; - AParams: TsStreamParams = []; ATransposed: Boolean = false); -var - clipbook: TsWorkbook; - clipsheet: TsWorksheet; - sel: TsCellRange; - selArray: TsCellRangeArray; - r, c: LongInt; - dr, dc: LongInt; - srcCell, destCell: PCell; - i: Integer; // counter - ncs, nrs: Integer; // Num cols source, num rows source, ... - //ncd, nrd: Integer; - rdest, cdest: Integer; // row and column index at destination - nselS, nselD: Integer; // count of selected blocks -begin - Unused(ATransposed); - - if AStream = nil then - exit; - - if ActiveWorksheet = nil then - exit; - - if AOperation = coNone then - exit; - - // Create workbook into which the clipboard stream will write - clipbook := TsWorkbook.Create; - try - clipbook.Options := clipbook.Options + [boReadFormulas]; - // Read stream into this temporary workbook - // Set last parameter (ClipboardMode) to TRUE to activate special format - // treatment for clipboard, if needed. - clipbook.ReadFromStream(AStream, AFormat, AParams + [spClipboard]); - clipsheet := clipbook.GetWorksheetByIndex(0); - - // count of blocks in source (clipboard sheet) - nselS := clipsheet.GetSelectionCount; - // count of selected blocks at destination - nselD := ActiveWorksheet.GetSelectionCount; - - // ------------------------------------------------------------------------- - // Case (1): Destination is a single cell, source can be any shape - // --> Source shape is duplicated starting at destination - // ------------------------------------------------------------------------- - if (nselD = 1) - and (ActiveWorksheet.GetSelection[0].Col1 = ActiveWorksheet.GetSelection[0].Col2) - and (ActiveWorksheet.GetSelection[0].Row1 = ActiveWorksheet.GetSelection[0].Row2) - then begin - // Find offset of active cell to left/top cell in clipboard sheet - dr := LongInt(ActiveWorksheet.ActiveCellRow) - clipsheet.ActiveCellRow; - dc := LongInt(ActiveWorksheet.ActiveCellCol) - clipsheet.ActiveCellCol; - // Copy cells from clipboard sheet to active worksheet - // Shift them such that top/left of clipboard sheet is at active cell - for srcCell in clipsheet.Cells do - begin - r := LongInt(srcCell^.Row) + dr; - c := LongInt(srcCell^.Col) + dc; - destcell := ActiveWorksheet.GetCell(r, c); - case AOperation of - coCopyCell : ActiveWorksheet.CopyCell(srcCell, destCell); - coCopyValue : ActiveWorksheet.CopyValue(srcCell, destCell); - coCopyFormat : ActiveWorksheet.CopyFormat(srcCell, destCell); - coCopyFormula : ActiveWorksheet.CopyFormula(srcCell, destCell); - end; - end; - // Select all copied cells - sel := Range(Cardinal(-1), Cardinal(-1), Cardinal(-1), Cardinal(-1)); - SetLength(selArray, nselS); - for i := 0 to nselS-1 do - begin - sel := clipsheet.GetSelection[i]; - selArray[i].Row1 := LongInt(sel.Row1) + dr; - selArray[i].Col1 := LongInt(sel.Col1) + dc; - selArray[i].Row2 := LongInt(sel.Row2) + dr; - selArray[i].Col2 := LongInt(sel.Col2) + dc; - end; - ActiveWorksheet.SetSelection(selArray); - // Select active cell. If not found in the file, let's use the last cell of the selections - if (clipsheet.ActiveCellRow <> 0) and (clipsheet.ActiveCellCol <> 0) then - begin - r := clipsheet.ActiveCellRow; - c := clipsheet.ActiveCellCol; - end else - begin - r := LongInt(sel.Row2); - c := LongInt(sel.Col2); - end; - if (r <> -1) and (c <> -1) then - ActiveWorksheet.SelectCell(r + dr, c + dc); - end - else - // ------------------------------------------------------------------------- - // Case (2): Source is a single block (not necessarily a cell), Dest can be - // any shape --> source is tiled into destination - // ------------------------------------------------------------------------- -// if nselS = 1 then - begin - // size of source block - with clipsheet do - begin - ncs := LongInt(GetLastColIndex(true)) - LongInt(GetFirstColIndex(true)) + 1; - nrs := LongInt(GetLastRowIndex(true)) - LongInt(GetFirstRowIndex(true)) + 1; - end; - // Iterate over all destination blocks - for i := 0 to nselD-1 do - begin - (* - // size of currently selected block at destination - with ActiveWorksheet.GetSelection[i] do - begin - ncd := Integer(Col2) - Integer(Col1) + 1; - nrd := Integer(Row2) - Integer(Row1) + 1; - end; - *) - r := ActiveWorksheet.GetSelection[i].Row1; - while r <= longint(ActiveWorksheet.GetSelection[i].Row2) do begin - c := ActiveWorksheet.GetSelection[i].Col1; - while c <= longint(ActiveWorksheet.GetSelection[i].Col2) do begin - dr := r - clipsheet.GetFirstRowIndex; - dc := c - clipsheet.GetFirstColIndex; - for srccell in clipsheet.Cells do - begin - rdest := longint(srccell^.Row) + dr; - if rdest > integer(ActiveWorksheet.GetSelection[i].Row2) then - Continue; - cdest := longint(srcCell^.Col) + dc; - if cdest > integer(ActiveWorksheet.GetSelection[i].Col2) then - Continue; - destcell := ActiveWorksheet.GetCell( - LongInt(srcCell^.Row) + dr, - LongInt(srcCell^.Col) + dc - ); - case AOperation of - coCopyCell : ActiveWorksheet.CopyCell(srcCell, destCell); - coCopyValue : ActiveWorksheet.CopyValue(srcCell, destCell); - coCopyFormat : ActiveWorksheet.CopyFormat(srcCell, destCell); - coCopyFormula : ActiveWorksheet.CopyFormula(srcCell, destCell); - end; - end; // for srcCell - inc(c, ncs); - end; // while c... - inc(r, nrs); - end; // while r... - end; // for i - // No need to select copied cells - they already are. - end ; - { - else - // ------------------------------------------------------------------------- - // Other arrangements of source and destination are not supported - // ------------------------------------------------------------------------- - raise Exception.Create('This arrangement of source and destination '+ - 'cells in not supported for copy & paste'); - } - finally - clipbook.Free; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Creates a new "embedded" stream and loads the specified file. - Returns the index of the embedded file item. - Image dimensions are converted to workbook units. --------------------------------------------------------------------------------} -function TsWorkbook.AddEmbeddedObj(const AFileName: String): Integer; -var - obj: TsEmbeddedObj = nil; -begin - if not FileExists(AFileName) then - begin - AddErrorMsg(rsFileNotFound, [AFileName]); - Result := -1; - exit; - end; - - obj := TsEmbeddedObj.Create; - if obj.LoadFromFile(AFileName) then - begin - obj.ImageWidth := ConvertUnits(obj.ImageWidth, suInches, FUnits); - obj.ImageHeight := ConvertUnits(obj.ImageHeight, suInches, FUnits); - Result := FEmbeddedObjList.Add(obj) - end else - begin - AddErrorMsg(rsFileFormatNotSupported, [AFileName]); - obj.Free; - Result := -1; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Creates a new "embedded" stream and copies the specified stream to it. - Returns the index of the embedded object. --------------------------------------------------------------------------------} -function TsWorkbook.AddEmbeddedObj(AStream: TStream; - const AName: String = ''; ASize: Int64 = -1): Integer; -var - obj: TsEmbeddedObj = nil; -begin - obj := TsEmbeddedObj.Create; - if obj.LoadFromStream(AStream, AName, ASize) then - begin - obj.ImageWidth := ConvertUnits(obj.ImageWidth, suInches, FUnits); - obj.ImageHeight := ConvertUnits(obj.ImageHeight, suInches, FUnits); - Result := FEmbeddedObjList.Add(obj) - end else - begin - AddErrorMsg(rsImageFormatNotSupported); - obj.Free; - Result := -1; - end; -end; - -{@@ ---------------------------------------------------------------------------- - Checks whether an embedded object with the specified file name already exists. - If yes, returns its index in the object list, or -1 if no. --------------------------------------------------------------------------------} -function TsWorkbook.FindEmbeddedObj(const AFileName: String): Integer; -var - obj: TsEmbeddedObj; -begin - for Result:=0 to FEmbeddedObjList.Count-1 do - begin - obj := TsEmbeddedObj(FEmbeddedObjList[Result]); - if obj.FileName = AFileName then - exit; - end; - Result := -1; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the embedded object stored in the embedded object list at the - specified index. --------------------------------------------------------------------------------} -function TsWorkbook.GetEmbeddedObj(AIndex: Integer): TsEmbeddedObj; -begin - Result := TsEmbeddedObj(FEmbeddedObjList[AIndex]); -end; - - -{@@ ---------------------------------------------------------------------------- - Returns the count of embedded objects --------------------------------------------------------------------------------} -function TsWorkbook.GetEmbeddedObjCount: Integer; -begin - Result := FEmbeddedObjList.Count; -end; - -{@@ ---------------------------------------------------------------------------- - Returns true if there is at least one worksheet with an embedded images. --------------------------------------------------------------------------------} -function TsWorkbook.HasEmbeddedSheetImages: Boolean; -var - i: Integer; - sheet: TsWorksheet; -begin - Result := true; - for i:=0 to FWorksheets.Count-1 do - begin - sheet := TsWorksheet(FWorksheets.Items[i]); - if sheet.GetImageCount > 0 then - exit; - end; - Result := false; -end; - -{@@ ---------------------------------------------------------------------------- - Removes all embedded objects --------------------------------------------------------------------------------} -procedure TsWorkbook.RemoveAllEmbeddedObj; -var - i: Integer; -begin - for i:= 0 to FEmbeddedObjList.Count-1 do - TsEmbeddedObj(FEmbeddedObjList[i]).Free; - FEmbeddedObjList.Clear; -end; - - - (* -{@@ ---------------------------------------------------------------------------- - Converts a fpspreadsheet color into into a string RRGGBB. - Note that colors are written to xls files as ABGR (where A is 0). - if the color is scRGBColor the color value is taken from the argument - ARGBColor, otherwise from the palette entry for the color index. --------------------------------------------------------------------------------} -function TsWorkbook.FPSColorToHexString(AColor: TsColor; - ARGBColor: TFPColor): string; -type - TRgba = packed record Red, Green, Blue, A: Byte end; -var - colorvalue: TsColorValue; - r,g,b: Byte; -begin - if AColor = scRGBColor then - begin - r := ARGBColor.Red div $100; - g := ARGBColor.Green div $100; - b := ARGBColor.Blue div $100; - end else - begin - colorvalue := GetPaletteColor(AColor); - r := TRgba(colorvalue).Red; - g := TRgba(colorvalue).Green; - b := TRgba(colorvalue).Blue; - end; - Result := Format('%.2x%.2x%.2x', [r, g, b]); -end; - -{@@ ---------------------------------------------------------------------------- - Returns the name of the color pointed to by the given color index. - If the name is not known the hex string is returned as RRGGBB. - - @param AColorIndex Palette index of the color considered - @return String identifying the color (a color name or, if unknown, a - string showing the rgb components --------------------------------------------------------------------------------} -function TsWorkbook.GetColorName(AColorIndex: TsColor): string; -begin - case AColorIndex of - scTransparent: - Result := 'transparent'; - scNotDefined: - Result := 'not defined'; - else - GetColorName(GetPaletteColor(AColorIndex), Result); - end; -end; - -{@@ ---------------------------------------------------------------------------- - Returns the name of an rgb color value. - If the name is not known the hex string is returned as RRGGBB. - - @param AColorValue rgb value of the color considered - @param AName String identifying the color (a color name or, if - unknown, a string showing the rgb components --------------------------------------------------------------------------------} -procedure TsWorkbook.GetColorName(AColorValue: TsColorValue; out AName: String); -type - TRgba = packed record R,G,B,A: Byte; end; -var - i: Integer; -begin - // Find color value in default palette - for i:=0 to High(DEFAULT_PALETTE) do - // if found: get the color name from the default color names array - if DEFAULT_PALETTE[i] = AColorValue then - begin - AName := DEFAULT_COLORNAMES[i]; - exit; - end; - - // if not found: construct a string from rgb byte values. - with TRgba(AColorValue) do - AName := Format('%.2x%.2x%.2x', [R, G, B]); -end; - -{@@ ---------------------------------------------------------------------------- - Converts the palette color of the given index to a string that can be used - in HTML code. For ODS. - - @param AColorIndex Index of the color considered - @return A HTML-compatible string identifying the color. - "Red", for example, is returned as '#FF0000'; --------------------------------------------------------------------------------} -function TsWorkbook.GetPaletteColorAsHTMLStr(AColorIndex: TsColor): String; -begin - Result := ColorToHTMLColorStr(GetPaletteColor(AColorIndex)); -end; - -{@@ ---------------------------------------------------------------------------- - Instructs the workbook to take colors from the default palette. Is called - from ODS reader because ODS does not have a palette. Without a palette the - color constants (scRed etc.) would not be correct any more. --------------------------------------------------------------------------------} -procedure TsWorkbook.UseDefaultPalette; -begin - UsePalette(@DEFAULT_PALETTE, Length(DEFAULT_PALETTE), false); -end; - -{@@ ---------------------------------------------------------------------------- - Instructs the Workbook to take colors from the palette pointed to by the - parameter APalette - This palette is only used for writing. When reading the palette found in the - file is used. - - @param APalette Pointer to the array of TsColorValue numbers which will - become the new palette - @param APaletteCount Count of numbers in the source palette - @param ABigEnding If true, indicates that the source palette is in - big-endian notation. The methods inverts the rgb - components to little-endian which is used by - fpspreadsheet internally. --------------------------------------------------------------------------------} -procedure TsWorkbook.UsePalette(APalette: PsPalette; APaletteCount: Word; - ABigEndian: Boolean); -var - i: Integer; -begin - if APaletteCount > 64 then - raise EFPSpreadsheet.Create('Due to Excel-compatibility, palettes cannot have more then 64 colors.'); - - {$IFOPT R+} - {$DEFINE RNGCHECK} - {$ENDIF} - SetLength(FPalette, APaletteCount); - if ABigEndian then - for i:=0 to APaletteCount-1 do - {$IFDEF RNGCHECK} - {$R-} - {$ENDIF} - FPalette[i] := LongRGBToExcelPhysical(APalette^[i]) - {$IFDEF RNGCHECK} - {$R+} - {$ENDIF} - else - for i:=0 to APaletteCount-1 do - {$IFDEF RNGCHECK} - {$R-} - {$ENDIF} - FPalette[i] := APalette^[i]; - {$IFDEF RNGCHECK} - {$R+} - {$ENDIF} - - if Assigned(FOnChangePalette) then FOnChangePalette(self); -end; - -{@@ ---------------------------------------------------------------------------- - Checks whether a given color is used somewhere within the entire workbook - - @param AColorIndex Palette index of the color - @result True if the color is used by at least one cell, false if not. --------------------------------------------------------------------------------} -function TsWorkbook.UsesColor(AColorIndex: TsColor): Boolean; -var - sheet: TsWorksheet; - cell: PCell; - i: Integer; - fnt: TsFont; - b: TsCellBorder; - fmt: PsCellFormat; -begin - Result := true; - for i:=0 to GetWorksheetCount-1 do - begin - sheet := GetWorksheetByIndex(i); - for cell in sheet.Cells do - begin - fmt := GetPointerToCellFormat(cell^.FormatIndex); - if (uffBackground in fmt^.UsedFormattingFields) then - begin - if fmt^.Background.BgColor = AColorIndex then exit; - if fmt^.Background.FgColor = AColorIndex then exit; - end; - if (uffBorder in fmt^.UsedFormattingFields) then - for b in TsCellBorders do - if fmt^.BorderStyles[b].Color = AColorIndex then - exit; - if (uffFont in fmt^.UsedFormattingFields) then - begin - fnt := GetFont(fmt^.FontIndex); - if fnt.Color = AColorIndex then - exit; - end; - end; - end; - Result := false; -end; - *) end. {** End Unit: fpspreadsheet } diff --git a/components/fpspreadsheet/source/common/fpspreadsheet_cf.inc b/components/fpspreadsheet/source/common/fpspreadsheet_cf.inc index 5169de677..cc644ff7d 100644 --- a/components/fpspreadsheet/source/common/fpspreadsheet_cf.inc +++ b/components/fpspreadsheet/source/common/fpspreadsheet_cf.inc @@ -1,5 +1,11 @@ { Included by fpspreadsheet.pas } +{ Code for conditional formatting } + +{==============================================================================} +{ TsWorksheet code for conditional formats } +{==============================================================================} + procedure StoreCFIndexInCells(AWorksheet: TsWorksheet; AIndex: Integer; ARange: TsCellRange); var @@ -17,6 +23,7 @@ begin end; end; + {@@ ---------------------------------------------------------------------------- Creates a conditional format item for the cells given by ARange. The condition specified here must not require parameters, e.g. cfcEmpty @@ -32,6 +39,7 @@ begin StoreCFIndexInCells(self, Result, ARange); end; + {@@ ---------------------------------------------------------------------------- Creates a conditional format item for the cells given by ARange. The condition specified must require one parameter, e.g. cfcEqual, @@ -48,6 +56,7 @@ begin StoreCFIndexInCells(self, Result, ARange); end; + {@@ ---------------------------------------------------------------------------- Creates a conditional format item for the cells given by ARange. The condition specified must requored two parameters, e.g. cfcBetween, @@ -65,6 +74,7 @@ begin StoreCFIndexInCells(self, Result, ARange); end; + {@@ ---------------------------------------------------------------------------- Writes the conditional format "color range" -------------------------------------------------------------------------------} @@ -76,6 +86,7 @@ begin StoreCFIndexInCells(Self, Result, ARange); end; + function TsWorksheet.WriteColorRange(ARange: TsCellRange; AStartColor, ACenterColor, AEndColor: TsColor): Integer; begin @@ -84,6 +95,7 @@ begin StoreCFIndexInCells(Self, Result, ARange); end; + function TsWorksheet.WriteColorRange(ARange: TsCellRange; AStartColor: TsColor; AStartKind: TsCFValueKind; AStartValue: Double; AEndColor: TsColor; AEndKind: TsCFValueKind; AEndValue: Double): Integer; @@ -94,6 +106,7 @@ begin StoreCFIndexInCells(Self, Result, ARange); end; + function TsWorksheet.WriteColorRange(ARange: TsCellRange; AStartColor: TsColor; AStartKind: TsCFValueKind; AStartValue: Double; ACenterColor: TsColor; ACenterKind: TsCFValueKind; ACenterValue: Double; @@ -106,6 +119,7 @@ begin StoreCFIndexInCells(Self, Result, ARange); end; + {@@ ---------------------------------------------------------------------------- Writes the conditional format "data bars" -------------------------------------------------------------------------------} @@ -115,6 +129,7 @@ begin StoreCFIndexInCells(self, Result, ARange); end; + function TsWorksheet.WriteDataBars(ARange: TscellRange; ABarColor: TsColor; AStartKind: TsCFValueKind; AStartValue: Double; AEndKind: TsCFValueKind; AEndValue: Double): Integer; @@ -127,3 +142,19 @@ begin StoreCFIndexInCells(self, Result, ARange); end; + +{==============================================================================} +{ TsWorkbook code for conditional formats } +{==============================================================================} + +function TsWorkbook.GetConditionalFormat(AIndex: Integer): TsConditionalFormat; +begin + Result := FConditionalFormatList[AIndex] as TsConditionalFormat; +end; + + +function TsWorkbook.GetNumConditionalFormats: Integer; +begin + Result := FConditionalFormatList.Count; +end; + diff --git a/components/fpspreadsheet/source/common/fpspreadsheet_clipbrd.inc b/components/fpspreadsheet/source/common/fpspreadsheet_clipbrd.inc new file mode 100644 index 000000000..e83a5eec7 --- /dev/null +++ b/components/fpspreadsheet/source/common/fpspreadsheet_clipbrd.inc @@ -0,0 +1,218 @@ +{ Included by fpspreadsheet.pas } + +{ Clipboard access } + +{@@ ---------------------------------------------------------------------------- + Writes the selected cells to a stream for usage in the clipboard. + Transfer to the clipboard has do be done by the calling routine since + fpspreadsheet does not "know" the system's clipboard. +-------------------------------------------------------------------------------} +procedure TsWorkbook.CopyToClipboardStream(AStream: TStream; + AFormat: TsSpreadsheetFormat; AParams: TsStreamParams = []); +var + clipbook: TsWorkbook; + clipsheet: TsWorksheet; + sel: TsCellRange; + range: TsCellRangeArray; + r, c: Cardinal; + srccell, destcell: PCell; +begin + if AStream = nil then + exit; + + if ActiveWorksheet = nil then + exit; + + // Create workbook which will be written to clipboard stream + // Contains only the selected worksheet and the selected cells. + clipbook := TsWorkbook.Create; + try + clipsheet := clipbook.AddWorksheet(ActiveWorksheet.Name); + for sel in ActiveWorksheet.GetSelection do + begin + for r := sel.Row1 to sel.Row2 do + for c := sel.Col1 to sel.Col2 do + begin + srccell := ActiveWorksheet.FindCell(r, c); + if ActiveWorksheet.IsMerged(srccell) then + srccell := ActiveWorksheet.FindMergeBase(srccell); + if srccell <> nil then begin + destcell := clipsheet.GetCell(r, c); // wp: why was there AddCell? + clipsheet.CopyCell(srccell, destcell); + end; + end; + end; + // Select the same cells as in the source workbook. + range := ActiveWorksheet.GetSelection; + clipsheet.SetSelection(range); + clipsheet.SelectCell(range[0].Row1, range[0].Col1); + + // Write this workbook to a stream. Set the parameter spClipboard to + // indicate that this should be the special clipboard version of the stream. + clipbook.WriteToStream(AStream, AFormat, AParams + [spClipboard]); + + if AFormat = sfCSV then + AStream.WriteByte(0); + + // The calling routine which copies the stream to the clipboard requires + // the stream to be at its beginning. + AStream.Position := 0; + finally + clipbook.Free; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Copies the cells stored in the specified stream to the active worksheet. + The provided stream contains data from the system's clipboard. + Note that transfer from the clipboard to the stream has to be done by the + calling routine since fpspreadsheet does not "know" the system's clipboard. +-------------------------------------------------------------------------------} +procedure TsWorkbook.PasteFromClipboardStream(AStream: TStream; + AFormat: TsSpreadsheetFormat; AOperation: TsCopyOperation; + AParams: TsStreamParams = []; ATransposed: Boolean = false); +var + clipbook: TsWorkbook; + clipsheet: TsWorksheet; + sel: TsCellRange; + selArray: TsCellRangeArray; + r, c: LongInt; + dr, dc: LongInt; + srcCell, destCell: PCell; + i: Integer; // counter + ncs, nrs: Integer; // Num cols source, num rows source, ... + //ncd, nrd: Integer; + rdest, cdest: Integer; // row and column index at destination + nselS, nselD: Integer; // count of selected blocks +begin + Unused(ATransposed); + + if AStream = nil then + exit; + + if ActiveWorksheet = nil then + exit; + + if AOperation = coNone then + exit; + + // Create workbook into which the clipboard stream will write + clipbook := TsWorkbook.Create; + try + clipbook.Options := clipbook.Options + [boReadFormulas]; + // Read stream into this temporary workbook + // Set last parameter (ClipboardMode) to TRUE to activate special format + // treatment for clipboard, if needed. + clipbook.ReadFromStream(AStream, AFormat, AParams + [spClipboard]); + clipsheet := clipbook.GetWorksheetByIndex(0); + + // count of blocks in source (clipboard sheet) + nselS := clipsheet.GetSelectionCount; + // count of selected blocks at destination + nselD := ActiveWorksheet.GetSelectionCount; + + // ------------------------------------------------------------------------- + // Case (1): Destination is a single cell, source can be any shape + // --> Source shape is duplicated starting at destination + // ------------------------------------------------------------------------- + if (nselD = 1) + and (ActiveWorksheet.GetSelection[0].Col1 = ActiveWorksheet.GetSelection[0].Col2) + and (ActiveWorksheet.GetSelection[0].Row1 = ActiveWorksheet.GetSelection[0].Row2) + then begin + // Find offset of active cell to left/top cell in clipboard sheet + dr := LongInt(ActiveWorksheet.ActiveCellRow) - clipsheet.ActiveCellRow; + dc := LongInt(ActiveWorksheet.ActiveCellCol) - clipsheet.ActiveCellCol; + // Copy cells from clipboard sheet to active worksheet + // Shift them such that top/left of clipboard sheet is at active cell + for srcCell in clipsheet.Cells do + begin + r := LongInt(srcCell^.Row) + dr; + c := LongInt(srcCell^.Col) + dc; + destcell := ActiveWorksheet.GetCell(r, c); + case AOperation of + coCopyCell : ActiveWorksheet.CopyCell(srcCell, destCell); + coCopyValue : ActiveWorksheet.CopyValue(srcCell, destCell); + coCopyFormat : ActiveWorksheet.CopyFormat(srcCell, destCell); + coCopyFormula : ActiveWorksheet.CopyFormula(srcCell, destCell); + end; + end; + // Select all copied cells + sel := Range(Cardinal(-1), Cardinal(-1), Cardinal(-1), Cardinal(-1)); + SetLength(selArray, nselS); + for i := 0 to nselS-1 do + begin + sel := clipsheet.GetSelection[i]; + selArray[i].Row1 := LongInt(sel.Row1) + dr; + selArray[i].Col1 := LongInt(sel.Col1) + dc; + selArray[i].Row2 := LongInt(sel.Row2) + dr; + selArray[i].Col2 := LongInt(sel.Col2) + dc; + end; + ActiveWorksheet.SetSelection(selArray); + // Select active cell. If not found in the file, let's use the last cell of the selections + if (clipsheet.ActiveCellRow <> 0) and (clipsheet.ActiveCellCol <> 0) then + begin + r := clipsheet.ActiveCellRow; + c := clipsheet.ActiveCellCol; + end else + begin + r := LongInt(sel.Row2); + c := LongInt(sel.Col2); + end; + if (r <> -1) and (c <> -1) then + ActiveWorksheet.SelectCell(r + dr, c + dc); + end + else + // ------------------------------------------------------------------------- + // Case (2): Source is a single block (not necessarily a cell), Dest can be + // any shape --> source is tiled into destination + // ------------------------------------------------------------------------- +// if nselS = 1 then + begin + // size of source block + with clipsheet do + begin + ncs := LongInt(GetLastColIndex(true)) - LongInt(GetFirstColIndex(true)) + 1; + nrs := LongInt(GetLastRowIndex(true)) - LongInt(GetFirstRowIndex(true)) + 1; + end; + // Iterate over all destination blocks + for i := 0 to nselD-1 do + begin + r := ActiveWorksheet.GetSelection[i].Row1; + while r <= longint(ActiveWorksheet.GetSelection[i].Row2) do begin + c := ActiveWorksheet.GetSelection[i].Col1; + while c <= longint(ActiveWorksheet.GetSelection[i].Col2) do begin + dr := r - clipsheet.GetFirstRowIndex; + dc := c - clipsheet.GetFirstColIndex; + for srccell in clipsheet.Cells do + begin + rdest := longint(srccell^.Row) + dr; + if rdest > integer(ActiveWorksheet.GetSelection[i].Row2) then + Continue; + cdest := longint(srcCell^.Col) + dc; + if cdest > integer(ActiveWorksheet.GetSelection[i].Col2) then + Continue; + destcell := ActiveWorksheet.GetCell( + LongInt(srcCell^.Row) + dr, + LongInt(srcCell^.Col) + dc + ); + case AOperation of + coCopyCell : ActiveWorksheet.CopyCell(srcCell, destCell); + coCopyValue : ActiveWorksheet.CopyValue(srcCell, destCell); + coCopyFormat : ActiveWorksheet.CopyFormat(srcCell, destCell); + coCopyFormula : ActiveWorksheet.CopyFormula(srcCell, destCell); + end; + end; // for srcCell + inc(c, ncs); + end; // while c... + inc(r, nrs); + end; // while r... + end; // for i + // No need to select copied cells - they already are. + end ; + finally + clipbook.Free; + end; +end; + + diff --git a/components/fpspreadsheet/source/common/fpspreadsheet_comments.inc b/components/fpspreadsheet/source/common/fpspreadsheet_comments.inc new file mode 100644 index 000000000..62068dccf --- /dev/null +++ b/components/fpspreadsheet/source/common/fpspreadsheet_comments.inc @@ -0,0 +1,120 @@ +{ Included by fpspreadsheet.pas } + +{ Contains code for comments } + + +{@@ ---------------------------------------------------------------------------- + Checks whether a cell contains a comment and returns a pointer to the + comment data. + + @param ACell Pointer to the cell + @return Pointer to the TsComment record (nil, if the cell does not have a + comment) +-------------------------------------------------------------------------------} +function TsWorksheet.FindComment(ACell: PCell): PsComment; +begin + if HasComment(ACell) then + Result := PsComment(FComments.FindByRowCol(ACell^.Row, ACell^.Col)) + else + Result := nil; +end; + + +{@@ ---------------------------------------------------------------------------- + Checks whether a specific cell contains a comment +-------------------------------------------------------------------------------} +function TsWorksheet.HasComment(ACell: PCell): Boolean; +begin + Result := (ACell <> nil) and (cfHasComment in ACell^.Flags); +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the comment text attached to a specific cell + + @param ARow (0-based) index to the row + @param ACol (0-based) index to the column + @return Text assigned to the cell as a comment +-------------------------------------------------------------------------------} +function TsWorksheet.ReadComment(ARow, ACol: Cardinal): String; +var + comment: PsComment; +begin + Result := ''; + comment := PsComment(FComments.FindByRowCol(ARow, ACol)); + if comment <> nil then + Result := comment^.Text; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the comment text attached to a specific cell + + @param ACell Pointer to the cell + @return Text assigned to the cell as a comment +-------------------------------------------------------------------------------} +function TsWorksheet.ReadComment(ACell: PCell): String; +var + comment: PsComment; +begin + Result := ''; + comment := FindComment(ACell); + if comment <> nil then + Result := comment^.Text; +end; + + +{@@ ---------------------------------------------------------------------------- + Removes the comment from a cell and releases the memory occupied by the node. +-------------------------------------------------------------------------------} +procedure TsWorksheet.RemoveComment(ACell: PCell); +begin + if HasComment(ACell) then + begin + FComments.DeleteComment(ACell^.Row, ACell^.Col); + Exclude(ACell^.Flags, cfHasComment); + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Adds a comment to a specific cell + + @param ARow (0-based) row index of the cell + @param ACol (0-based) column index of the cell + @param AText Comment text + @return Pointer to the cell containing the comment +-------------------------------------------------------------------------------} +function TsWorksheet.WriteComment(ARow, ACol: Cardinal; AText: String): PCell; +begin + Result := GetCell(ARow, ACol); + WriteComment(Result, AText); +end; + + +{@@ ---------------------------------------------------------------------------- + Adds a comment to a specific cell + + @param ACell Pointer to the cell + @param AText Comment text +-------------------------------------------------------------------------------} +procedure TsWorksheet.WriteComment(ACell: PCell; AText: String); +begin + if ACell = nil then + exit; + + // Remove the comment if an empty string is passed + if AText = '' then + begin + RemoveComment(ACell); + exit; + end; + + // Add new comment record + FComments.AddComment(ACell^.Row, ACell^.Col, AText); + Include(ACell^.Flags, cfHasComment); + + ChangedCell(ACell^.Row, ACell^.Col); + +end; + diff --git a/components/fpspreadsheet/source/common/fpspreadsheet_embobj.inc b/components/fpspreadsheet/source/common/fpspreadsheet_embobj.inc new file mode 100644 index 000000000..4b553f6e0 --- /dev/null +++ b/components/fpspreadsheet/source/common/fpspreadsheet_embobj.inc @@ -0,0 +1,456 @@ +{ Included by fpspreadsheet.pas } + +{ Code for embedded objects (images) } + +{==============================================================================} +{ TsWorksheet code for embedded objects } +{==============================================================================} + +{@@ ---------------------------------------------------------------------------- + Calculates the position of the image with given index relative to the cell + containing the top/left corner of the image. + + @@param x worksheet-relative coordinate of the left image edge, in workbook units + @@param y worksheet-relative coordinate of the top image edge, in workbook units + @@param ARow Index of the row containing the top/left corner of the image + @@param ACol Index of the column containing the top/left corner of the image + @@param ARowOffset Distance, in workbook units, between top cell and image borders + @@param AColOffset Distance, in workbook units, between left cell and image borders + @@param AScaleX Scaling factor for the image width + @@param AScaleY Scaling factor for the image height +-------------------------------------------------------------------------------} +procedure TsWorksheet.CalcImageCell(AIndex: Integer; x, y, AWidth, AHeight: Double; + out ARow, ACol: Cardinal; out ARowOffs, AColOffs, AScaleX, AScaleY: Double); +// All lengths are in workbook units! +var + colW, rowH, sum: Double; + embobj: TsEmbeddedObj; +begin + ACol := 0; + sum := 0; + colW := GetColWidth(0, FWorkbook.Units); + while (sum + colW < x) do begin + sum := sum + colW; + inc(ACol); + colW := GetColWidth(ACol, FWorkbook.Units); + end; + AColOffs := x - sum; + + ARow := 0; + sum := 0; + rowH := CalcRowHeight(0); + while (sum + rowH < y) do begin + sum := sum + rowH; + inc(ARow); + rowH := CalcRowHeight(ARow); + end; + ARowOffs := y - sum; + + embObj := FWorkbook.GetEmbeddedObj(AIndex); + AScaleX := AWidth / embObj.ImageWidth; + AScaleY := AHeight / embObj.ImageHeight; +end; + + +{@@ ---------------------------------------------------------------------------- + Calculates image extent + + @param AIndex Index of the image into the worksheet's image list + @param UsePixels if TRUE then pixels are used for calculation - this improves + the display of the images in Excel + @param ARow1 Index of the row containing the top edge of the image + @param ACol1 Index of the column containing the left edege of the image + @param ARow2 Index of the row containing the right edge of the image + @param ACol2 Index of the column containing the bottom edge of the image + @param ARowOffs1 Distance between the top edge of image and row 1 + @param AColOffs1 Distance between the left edge of image and column 1 + @param ARowOffs2 Distance between the bottom edge of image and top of row 2 + @param AColOffs2 Distance between the right edge of image and left of col 2 + @param x Absolute coordinate of left edge of image + @param y Absolute coordinate of top edge of image + @param AWidth Width of the image + @param AHeight Height of the image + + All dimensions are in workbook units +-------------------------------------------------------------------------------} +procedure TsWorksheet.CalcImageExtent(AIndex: Integer; UsePixels: Boolean; + out ARow1, ACol1, ARow2, ACol2: Cardinal; + out ARowOffs1, AColOffs1, ARowOffs2, AColOffs2: Double; + out x,y, AWidth, AHeight: Double); +var + img: TsImage; + obj: TsEmbeddedObj; + colW, rowH: Double; + totH: Double; + r, c: Integer; + w_px, h_px: Integer; + totH_px, rowH_px: Integer; + totW_px, colW_px: Integer; + ppi: Integer; + u: TsSizeUnits; +begin + // Abbreviations + ppi := ScreenPixelsPerInch; + u := FWorkbook.Units; + + img := GetImage(AIndex); + ARow1 := img.Row; + ACol1 := img.Col; + ARowOffs1 := img.OffsetX; // in workbook units + AColOffs1 := img.OffsetY; // in workbook units + + obj := FWorkbook.GetEmbeddedObj(img.Index); + AWidth := obj.ImageWidth * img.ScaleX; // in workbook units + AHeight := obj.ImageHeight * img.ScaleY; // in workbook units + + // Find x coordinate of left image edge, in workbook units + x := AColOffs1; + for c := 0 to ACol1-1 do + begin + colW := GetColWidth(c, u); + x := x + colW; + end; + // Find y coordinate of top image edge, in workbook units. + y := ARowOffs1; + for r := 0 to ARow1 - 1 do + begin + rowH := CalcRowHeight(r); + y := y + rowH; + end; + + if UsePixels then + // Use pixels for calculation. Better for Excel, maybe due to rounding error? + begin + // If we don't know the ppi of the screen the calculation is not exact! + w_px := ptsToPx(FWorkbook.ConvertUnits(AWidth, u, suPoints), ppi); + h_px := ptsToPx(FWorkbook.ConvertUnits(AHeight, u, suPoints), ppi); + // Find cell with right image edge. Find horizontal within-cell-offsets + totW_px := -ptsToPx(FWorkbook.ConvertUnits(AColOffs1, u, suPoints), ppi); + ACol2 := ACol1; + while (totW_px < w_px) do + begin + colW := GetColWidth(ACol2, u); + colW_px := ptsToPx(FWorkbook.ConvertUnits(colW, u, suPoints), ppi); + totW_px := totW_px + colW_px; + if totW_px > w_px then + begin + AColOffs2 := FWorkbook.ConvertUnits(pxToPts(colW_px - (totW_px - w_px), ppi), suPoints, u); + break; + end; + inc(ACol2); + end; + // Find cell with bottom image edge. Find vertical within-cell-offset. + totH_px := -ptsToPx(FWorkbook.ConvertUnits(ARowOffs1, u, suPoints), ppi); + ARow2 := ARow1; + while (totH_px < h_px) do + begin + rowH := CalcRowHeight(ARow2); + rowH_px := ptsToPx(FWorkbook.ConvertUnits(rowH, u, suPoints), ppi); + totH_px := totH_px + rowH_px; + if totH_px > h_px then + begin + ARowOffs2 := FWorkbook.ConvertUnits(pxToPts(rowH_px - (totH_px - h_px), ppi), suPoints, u); + break; + end; + inc(ARow2); + end; + end + else // Use workbook units for calculation + begin + // Find cell with right image edge. Find horizontal within-cell-offsets + totH := -ARowOffs1; + ARow2 := ARow1; + while (totH < AHeight) do + begin + rowH := CalcRowHeight(ARow2); + totH := totH + rowH; + if totH >= AHeight then + begin + ARowOffs2 := rowH - (totH - AHeight); + break; + end; + inc(ARow2); + end; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the parameters of the image stored in the internal image list at + the specified index. + + @param AIndex Index of the image to be retrieved + @return TsImage record with all image parameters. +-------------------------------------------------------------------------------} +function TsWorksheet.GetImage(AIndex: Integer): TsImage; +var + img: PsImage; +begin + img := PsImage(FImages[AIndex]); + Result := img^; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the count of images that are embedded into this sheet. +-------------------------------------------------------------------------------} +function TsWorksheet.GetImageCount: Integer; +begin + Result := FImages.Count; +end; + + +function TsWorksheet.GetPointerToImage(AIndex: Integer): PsImage; +begin + Result := PsImage(FImages[AIndex]); +end; + + +{@@ ---------------------------------------------------------------------------- + Removes all image from the internal image list. + The image streams (stored by the workbook), however, are retained because + images may also be used as header/footer images. +-------------------------------------------------------------------------------} +procedure TsWorksheet.RemoveAllImages; +var + i: Integer; +begin + for i := FImages.Count-1 downto 0 do + RemoveImage(i); +end; + + +{@@ ---------------------------------------------------------------------------- + Removes an image from the internal image list. + The image is identified by its index. + The image stream (stored by the workbook) is retained. +-------------------------------------------------------------------------------} +procedure TsWorksheet.RemoveImage(AIndex: Integer); +var + img: PsImage; +begin + img := PsImage(FImages[AIndex]); + if (img <> nil) then begin + if (img^.Picture <> nil) then img^.Picture.Free; + img^.HyperlinkTarget := ''; + img^.HyperlinkToolTip := ''; + end; + Dispose(img); + FImages.Delete(AIndex); +end; + + +{@@ ---------------------------------------------------------------------------- + Adds an embedded image to the worksheet + + @param ARow Index of the row at which the image begins (top edge) + @param ACol Index of the column at which the image begins (left edge) + @param AFileName Name of the image file + @param AOffsetX The image is offset horizontally from the left edge of + the anchor cell. May reach into another cell. + Value is in workbook units. + @param AOffsetY The image is offset vertically from the top edge of the + anchor cell. May reach into another cell. + Value is in workbook units. + @param AScaleX Horizontal scaling factor of the image + @param AScaleY Vertical scaling factor of the image + @return Index into the internal image list. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteImage(ARow, ACol: Cardinal; AFileName: String; + AOffsetX: Double = 0.0; AOffsetY: Double = 0.0; + AScaleX: Double = 1.0; AScaleY: Double = 1.0): Integer; +var + idx: Integer; +begin + // Does the image already exist? + idx := Workbook.FindEmbeddedObj(AFileName); + // No? Open and store in embedded object list. + if idx = -1 then + idx := Workbook.AddEmbeddedObj(AFileName); + // An error has occured? Error is already logged. Just exit. + if idx = -1 then + exit; + + // Everything ok here... + Result := WriteImage(ARow, ACol, idx, AOffsetX, AOffsetY, AScaleX, AScaleY); +end; + + +{@@ ---------------------------------------------------------------------------- + Adds an embedded image to the worksheet. The image passed in a stream. + + @param ARow Index of the row at which the image begins (top edge) + @param ACol Index of the column at which the image begins (left edge) + @param AStream Stream which contains the image data + @param AOffsetX The image is offset horizontally from the left edge of + the anchor cell. May reach into another cell. + Value is in workbook units. + @param AOffsetY The image is offset vertically from the top edge of the + anchor cell. May reach into another cell. + Value is in workbook units. + @param AScaleX Horizontal scaling factor of the image + @param AScaleY Vertical scaling factor of the image + @param ASize Number ob bytes to be read from the input stream. + @return Index into the internal image list. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteImage(ARow, ACol: Cardinal; AStream: TStream; + AOffsetX: Double = 0.0; AOffsetY: Double = 0.0; + AScaleX: Double = 1.0; AScaleY: Double = 1.0; + ASize: Int64 = -1): Integer; +var + idx: Integer; +begin + // Copy the stream to a new item in embedded object list. + idx := Workbook.AddEmbeddedObj(AStream, '', ASize); + + // An error has occured? Error is already logged. Just exit. + if idx = -1 then + exit; + + // Everything ok here... + Result := WriteImage(ARow, ACol, idx, AOffsetX, AOffsetY, AScaleX, AScaleY); +end; + + +function TsWorksheet.WriteImage(ARow, ACol: Cardinal; AImageIndex: Integer; + AOffsetX: Double = 0.0; AOffsetY: Double = 0.0; + AScaleX: Double = 1.0; AScaleY: Double = 1.0): Integer; +var + img: PsImage; +begin + New(img); + InitImageRecord(img^, ARow, ACol, AOffsetX, AOffsetY, AScaleX, AScaleY); + img^.Index := AImageIndex; + Result := FImages.Add(img); +end; + + + +{==============================================================================} +{ TsWorkbook code for embedded objects } +{==============================================================================} + +{@@ ---------------------------------------------------------------------------- + Creates a new "embedded" stream and loads the specified file. + Returns the index of the embedded file item. + Image dimensions are converted to workbook units. +-------------------------------------------------------------------------------} +function TsWorkbook.AddEmbeddedObj(const AFileName: String): Integer; +var + obj: TsEmbeddedObj = nil; +begin + if not FileExists(AFileName) then + begin + AddErrorMsg(rsFileNotFound, [AFileName]); + Result := -1; + exit; + end; + + obj := TsEmbeddedObj.Create; + if obj.LoadFromFile(AFileName) then + begin + obj.ImageWidth := ConvertUnits(obj.ImageWidth, suInches, FUnits); + obj.ImageHeight := ConvertUnits(obj.ImageHeight, suInches, FUnits); + Result := FEmbeddedObjList.Add(obj) + end else + begin + AddErrorMsg(rsFileFormatNotSupported, [AFileName]); + obj.Free; + Result := -1; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Creates a new "embedded" stream and copies the specified stream to it. + Returns the index of the embedded object. +-------------------------------------------------------------------------------} +function TsWorkbook.AddEmbeddedObj(AStream: TStream; + const AName: String = ''; ASize: Int64 = -1): Integer; +var + obj: TsEmbeddedObj = nil; +begin + obj := TsEmbeddedObj.Create; + if obj.LoadFromStream(AStream, AName, ASize) then + begin + obj.ImageWidth := ConvertUnits(obj.ImageWidth, suInches, FUnits); + obj.ImageHeight := ConvertUnits(obj.ImageHeight, suInches, FUnits); + Result := FEmbeddedObjList.Add(obj) + end else + begin + AddErrorMsg(rsImageFormatNotSupported); + obj.Free; + Result := -1; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Checks whether an embedded object with the specified file name already exists. + If yes, returns its index in the object list, or -1 if no. +-------------------------------------------------------------------------------} +function TsWorkbook.FindEmbeddedObj(const AFileName: String): Integer; +var + obj: TsEmbeddedObj; +begin + for Result:=0 to FEmbeddedObjList.Count-1 do + begin + obj := TsEmbeddedObj(FEmbeddedObjList[Result]); + if obj.FileName = AFileName then + exit; + end; + Result := -1; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the embedded object stored in the embedded object list at the + specified index. +-------------------------------------------------------------------------------} +function TsWorkbook.GetEmbeddedObj(AIndex: Integer): TsEmbeddedObj; +begin + Result := TsEmbeddedObj(FEmbeddedObjList[AIndex]); +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the count of embedded objects +-------------------------------------------------------------------------------} +function TsWorkbook.GetEmbeddedObjCount: Integer; +begin + Result := FEmbeddedObjList.Count; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns true if there is at least one worksheet with an embedded images. +-------------------------------------------------------------------------------} +function TsWorkbook.HasEmbeddedSheetImages: Boolean; +var + i: Integer; + sheet: TsWorksheet; +begin + Result := true; + for i:=0 to FWorksheets.Count-1 do + begin + sheet := TsWorksheet(FWorksheets.Items[i]); + if sheet.GetImageCount > 0 then + exit; + end; + Result := false; +end; + + +{@@ ---------------------------------------------------------------------------- + Removes all embedded objects +-------------------------------------------------------------------------------} +procedure TsWorkbook.RemoveAllEmbeddedObj; +var + i: Integer; +begin + for i:= 0 to FEmbeddedObjList.Count-1 do + TsEmbeddedObj(FEmbeddedObjList[i]).Free; + FEmbeddedObjList.Clear; +end; + + diff --git a/components/fpspreadsheet/source/common/fpspreadsheet_fmt.inc b/components/fpspreadsheet/source/common/fpspreadsheet_fmt.inc index 5ca909df8..781dedc6b 100644 --- a/components/fpspreadsheet/source/common/fpspreadsheet_fmt.inc +++ b/components/fpspreadsheet/source/common/fpspreadsheet_fmt.inc @@ -1,6 +1,10 @@ { Included by fpspreadsheet.pas } { Contains code for cell formatting } +{==============================================================================} +{ TsWorksheet code for format handling } +{==============================================================================} + {@@ ---------------------------------------------------------------------------- Modifies the background parameters of the format record stored at the specified index. @@ -40,6 +44,251 @@ begin Result := Workbook.AddCellFormat(fmt); end; + +{@@ ---------------------------------------------------------------------------- + Returns the background fill pattern and colors of a cell. + + @param ACell Pointer to the cell + @return TsFillPattern record (or EMPTY_FILL, if the cell does not have a + filled background +-------------------------------------------------------------------------------} +function TsWorksheet.ReadBackground(ACell: PCell): TsFillPattern; +var + fmt : PsCellFormat; +begin + Result := EMPTY_FILL; + if ACell <> nil then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + if (uffBackground in fmt^.UsedFormattingFields) then + Result := fmt^.Background; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the background color of a cell as rbg value + + @param ACell Pointer to the cell + @return Value containing the rgb bytes in little-endian order +-------------------------------------------------------------------------------} +function TsWorksheet.ReadBackgroundColor(ACell: PCell): TsColor; +begin + Result := scTransparent; + if ACell <> nil then + Result := ReadBackgroundColor(ACell^.FormatIndex); +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the background color stored at the specified index in the format + list of the workkbok. + + @param AFormatIndex Index of the format record + @return Value containing the rgb bytes in little-endian order +-------------------------------------------------------------------------------} +function TsWorksheet.ReadBackgroundColor(AFormatIndex: Integer): TsColor; +var + fmt: PsCellFormat; +begin + Result := scTransparent; + if AFormatIndex > -1 then begin + fmt := Workbook.GetPointerToCellFormat(AFormatIndex); + if (uffBackground in fmt^.UsedFormattingFields) then + begin + if fmt^.Background.Style = fsSolidFill then + Result := fmt^.Background.FgColor + else + Result := fmt^.Background.BgColor; + end; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the BiDi mode of the cell (right-to-left or left-to-right) +-------------------------------------------------------------------------------} +function TsWorksheet.ReadBiDiMode(ACell: PCell): TsBiDiMode; +var + fmt: PsCellFormat; +begin + Result := bdDefault; + if (ACell <> nil) then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + if (uffBiDi in fmt^.UsedFormattingFields) then + Result := fmt^.BiDiMode; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Determines which borders are drawn around a specific cell +-------------------------------------------------------------------------------} +function TsWorksheet.ReadCellBorders(ACell: PCell): TsCellBorders; +var + fmt: PsCellFormat; +begin + Result := []; + if ACell <> nil then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + if (uffBorder in fmt^.UsedFormattingFields) then + Result := fmt^.Border; + end; +end; + +{@@ ---------------------------------------------------------------------------- + Determines which the style of a particular cell border +-------------------------------------------------------------------------------} +function TsWorksheet.ReadCellBorderStyle(ACell: PCell; + ABorder: TsCelLBorder): TsCellBorderStyle; +var + fmt: PsCellFormat; +begin + Result := DEFAULT_BORDERSTYLES[ABorder]; + if ACell <> nil then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + Result := fmt^.BorderStyles[ABorder]; + end; +end; + +{@@ ---------------------------------------------------------------------------- + Determines which all border styles of a given cell +-------------------------------------------------------------------------------} +function TsWorksheet.ReadCellBorderStyles(ACell: PCell): TsCellBorderStyles; +var + fmt: PsCellFormat; +begin + Result := DEFAULT_BORDERSTYLES; + if ACell <> nil then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + Result := Fmt^.BorderStyles; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the format record that is assigned to a specified cell +-------------------------------------------------------------------------------} +function TsWorksheet.ReadCellFormat(ACell: PCell): TsCellFormat; +begin + Result := Workbook.GetCellFormat(ACell^.FormatIndex); +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the protection flags of the cell. + + NOTE: These flags are active only if sheet protection is active, i.e. + soProtected in Worksheet.Options. +-------------------------------------------------------------------------------} +function TsWorksheet.ReadCellProtection(ACell: PCell): TsCellProtections; +var + fmt: PsCellFormat; +begin + Result := DEFAULT_CELL_PROTECTION; + if (ACell <> nil) then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + if fmt <> nil then + Result := fmt^.Protection; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the horizontal alignment of a specific cell +-------------------------------------------------------------------------------} +function TsWorksheet.ReadHorAlignment(ACell: PCell): TsHorAlignment; +var + fmt: PsCellFormat; +begin + Result := haDefault; + if (ACell <> nil) then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + if (uffHorAlign in fmt^.UsedFormattingFields) then + Result := fmt^.HorAlignment; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the text orientation of a specific cell +-------------------------------------------------------------------------------} +function TsWorksheet.ReadTextRotation(ACell: PCell): TsTextRotation; +var + fmt: PsCellFormat; +begin + Result := trHorizontal; + if ACell <> nil then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + if (uffTextRotation in fmt^.UsedFormattingFields) then + Result := fmt^.TextRotation; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Reads the set of used formatting fields of a cell. + + Each cell contains a set of "used formatting fields". Formatting is applied + only if the corresponding element is contained in the set. + + @param ACell Pointer to the cell + @return Set of elements used in formatting the cell +-------------------------------------------------------------------------------} +function TsWorksheet.ReadUsedFormatting(ACell: PCell): TsUsedFormattingFields; +var + fmt: PsCellFormat; +begin + if ACell = nil then + begin + Result := []; + Exit; + end; + fmt := FWorkbook.GetPointerToCellFormat(ACell^.FormatIndex); + Result := fmt^.UsedFormattingFields; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the vertical alignment of a specific cell +-------------------------------------------------------------------------------} +function TsWorksheet.ReadVertAlignment(ACell: PCell): TsVertAlignment; +var + fmt: PsCellFormat; +begin + Result := vaDefault; + if (ACell <> nil) then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + if (uffVertAlign in fmt^.UsedFormattingFields) then + Result := fmt^.VertAlignment; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns whether a specific cell support word-wrapping. +-------------------------------------------------------------------------------} +function TsWorksheet.ReadWordwrap(ACell: PCell): boolean; +var + fmt: PsCellFormat; +begin + Result := false; + if (ACell <> nil) then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + Result := uffWordwrap in fmt^.UsedFormattingFields; + end; +end; + + {@@ ---------------------------------------------------------------------------- Defines a background pattern for a cell @@ -63,6 +312,7 @@ begin WriteBackground(Result, AStyle, APatternColor, ABackgroundColor); end; + {@@ ---------------------------------------------------------------------------- Defines a background pattern for a cell @@ -89,6 +339,7 @@ begin end; end; + {@@ ---------------------------------------------------------------------------- Sets a uniform background color of a cell. @@ -106,6 +357,7 @@ begin WriteBackgroundColor(Result, AColor); end; + {@@ ---------------------------------------------------------------------------- Sets a uniform background color of a cell. @@ -124,12 +376,14 @@ begin end; end; + function TsWorksheet.WriteBiDiMode(ARow, ACol: Cardinal; AValue: TsBiDiMode): PCell; begin Result := GetCell(ARow, ACol); WriteBiDiMode(Result, AValue); end; + procedure TsWorksheet.WriteBiDiMode(ACell: PCell; AValue: TsBiDiMode); var fmt: TsCellFormat; @@ -146,6 +400,7 @@ begin ChangedCell(ACell^.Row, ACell^.Col); end; + {@@ ---------------------------------------------------------------------------- Sets the color of a cell border line. Note: the border must be included in Borders set in order to be shown! @@ -164,6 +419,7 @@ begin WriteBorderColor(Result, ABorder, AColor); end; + {@@ ---------------------------------------------------------------------------- Sets the color of a cell border line. Note: the border must be included in Borders set in order to be shown! @@ -186,6 +442,7 @@ begin end; end; + {@@ ---------------------------------------------------------------------------- Sets the linestyle of a cell border. Note: the border must be included in the "Borders" set in order to be shown! @@ -206,6 +463,7 @@ begin WriteBorderLineStyle(Result, ABorder, ALineStyle); end; + {@@ ---------------------------------------------------------------------------- Sets the linestyle of a cell border. Note: the border must be included in the "Borders" set in order to be shown! @@ -230,6 +488,7 @@ begin end; end; + {@@ ---------------------------------------------------------------------------- Shows the cell borders included in the set ABorders. No border lines are drawn for those not included. @@ -248,6 +507,7 @@ begin WriteBorders(Result, ABorders); end; + {@@ ---------------------------------------------------------------------------- Shows the cell borders included in the set ABorders. No border lines are drawn for those not included. @@ -292,6 +552,7 @@ begin WriteBorderStyle(Result, ABorder, AStyle); end; + {@@ ---------------------------------------------------------------------------- Sets the style of a cell border, i.e. line style and line color. Note: the border must be included in the "Borders" set in order to be shown! @@ -314,6 +575,7 @@ begin end; end; + {@@ ---------------------------------------------------------------------------- Sets line style and line color of a cell border. Note: the border must be included in the "Borders" set in order to be shown! @@ -334,6 +596,7 @@ begin WriteBorderStyle(Result, ABorder, ALineStyle, AColor); end; + {@@ ---------------------------------------------------------------------------- Sets line style and line color of a cell border. Note: the border must be included in the "Borders" set in order to be shown! @@ -359,6 +622,7 @@ begin end; end; + {@@ ---------------------------------------------------------------------------- Sets the style of all cell border of a cell, i.e. line style and line color. Note: Only those borders included in the "Borders" set are shown! @@ -377,6 +641,7 @@ begin WriteBorderStyles(Result, AStyles); end; + {@@ ---------------------------------------------------------------------------- Sets the style of all cell border of a cell, i.e. line style and line color. Note: Only those borders included in the "Borders" set are shown! @@ -401,6 +666,7 @@ begin end; end; + {@@ ---------------------------------------------------------------------------- Assigns a complete cell format record to a cell @@ -418,6 +684,7 @@ begin WriteCellFormatIndex(ACell, idx); end; + {@@ ---------------------------------------------------------------------------- Formats a cell to the cell format stored at the specified index in the workbook's cell format list. @@ -440,6 +707,7 @@ begin end; end; + {@@ ---------------------------------------------------------------------------- Defines how the cell at the specified row and column is protected: lock cell modification and/or hide formulas. Note that this is activated only after @@ -456,6 +724,7 @@ begin WriteCellProtection(Result, AValue); end; + procedure TsWorksheet.WriteCellProtection(ACell: PCell; AValue: TsCellProtections); var @@ -473,259 +742,6 @@ begin ChangedCell(ACell^.Row, ACell^.Col); end; -{@@ ---------------------------------------------------------------------------- - Adds font specification to the formatting of a cell. Looks in the workbook's - FontList and creates an new entry if the font is not used so far. Returns the - index of the font in the font list. - - @param ARow The row of the cell - @param ACol The column of the cell - @param AFontName Name of the font - @param AFontSize Size of the font, in points - @param AFontStyle Set with font style attributes - (don't use those of unit "graphics" !) - @param AFontColor RGB value of the font's color - @param APosition Specifies sub- or superscript text - @return Index of the font in the workbook's font list. --------------------------------------------------------------------------------} -function TsWorksheet.WriteFont(ARow, ACol: Cardinal; const AFontName: String; - AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor; - APosition: TsFontPosition = fpNormal): Integer; -begin - Result := WriteFont(GetCell(ARow, ACol), AFontName, AFontSize, AFontStyle, - AFontColor, APosition); -end; - -{@@ ---------------------------------------------------------------------------- - Adds font specification to the formatting of a cell. Looks in the workbook's - FontList and creates an new entry if the font is not used so far. Returns the - index of the font in the font list. - - @param ACell Pointer to the cell considered - @param AFontName Name of the font - @param AFontSize Size of the font, in points - @param AFontStyle Set with font style attributes - (don't use those of unit "graphics" !) - @param AFontColor RGB value of the font's color - @param APosition Specified subscript or superscript text. - @return Index of the font in the workbook's font list. --------------------------------------------------------------------------------} -function TsWorksheet.WriteFont(ACell: PCell; const AFontName: String; - AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor; - APosition: TsFontPosition = fpNormal): Integer; -var - fmt: TsCellFormat; -begin - if ACell = nil then - begin - Result := -1; - Exit; - end; - - Result := FWorkbook.FindFont(AFontName, AFontSize, AFontStyle, AFontColor, APosition); - if Result = -1 then - result := FWorkbook.AddFont(AFontName, AFontSize, AFontStyle, AFontColor, APosition); - - fmt := Workbook.GetCellFormat(ACell^.FormatIndex); - Include(fmt.UsedFormattingFields, uffFont); - fmt.FontIndex := Result; - ACell^.FormatIndex := Workbook.AddCellFormat(fmt); - - ChangedFont(ACell^.Row, ACell^.Col); -end; - -{@@ ---------------------------------------------------------------------------- - Applies a font to the formatting of a cell. The font is determined by its - index in the workbook's font list: - - @param ARow The row of the cell - @param ACol The column of the cell - @param AFontIndex Index of the font in the workbook's font list - @return Pointer to the cell --------------------------------------------------------------------------------} -function TsWorksheet.WriteFont(ARow, ACol: Cardinal; AFontIndex: Integer): PCell; -begin - Result := GetCell(ARow, ACol); - WriteFont(Result, AFontIndex); -end; - -{@@ ---------------------------------------------------------------------------- - Applies a font to the formatting of a cell. The font is determined by its - index in the workbook's font list: - - @param ACell Pointer to the cell considered - @param AFontIndex Index of the font in the workbook's font list --------------------------------------------------------------------------------} -procedure TsWorksheet.WriteFont(ACell: PCell; AFontIndex: Integer); -var - fmt: TsCellFormat; -begin - if ACell = nil then - exit; - - if (AFontIndex < 0) or (AFontIndex >= Workbook.GetFontCount) then - raise EFPSpreadsheet.Create(rsInvalidFontIndex); - - fmt := Workbook.GetCellFormat(ACell^.FormatIndex); - Include(fmt.UsedFormattingFields, uffFont); - fmt.FontIndex := AFontIndex; - ACell^.FormatIndex := Workbook.AddCellFormat(fmt); - - ChangedFont(ACell^.Row, ACell^.Col); -end; - -{@@ ---------------------------------------------------------------------------- - Replaces the text color used in formatting of a cell. Looks in the workbook's - font list if this modified font has already been used. If not a new font entry - is created. Returns the index of this font in the font list. - - @param ARow The row of the cell - @param ACol The column of the cell - @param AFontColor RGB value of the new text color - @return Index of the font in the workbook's font list. --------------------------------------------------------------------------------} -function TsWorksheet.WriteFontColor(ARow, ACol: Cardinal; AFontColor: TsColor): Integer; -begin - Result := WriteFontColor(GetCell(ARow, ACol), AFontColor); -end; - -{@@ ---------------------------------------------------------------------------- - Replaces the text color used in formatting of a cell. Looks in the workbook's - font list if this modified font has already been used. If not a new font entry - is created. Returns the index of this font in the font list. - - @param ACell Pointer to the cell - @param AFontColor RGB value of the new text color - @return Index of the font in the workbook's font list. --------------------------------------------------------------------------------} -function TsWorksheet.WriteFontColor(ACell: PCell; AFontColor: TsColor): Integer; -var - fnt: TsFont; -begin - if ACell = nil then begin - Result := 0; - exit; - end; - fnt := ReadCellFont(ACell); - Result := WriteFont(ACell, fnt.FontName, fnt.Size, fnt.Style, AFontColor); -end; - -{@@ ---------------------------------------------------------------------------- - Replaces the font used in formatting of a cell considering only the font face - and leaving font size, style and color unchanged. Looks in the workbook's - font list if this modified font has already been used. If not a new font entry - is created. Returns the index of this font in the font list. - - @param ARow The row of the cell - @param ACol The column of the cell - @param AFontName Name of the new font to be used - @return Index of the font in the workbook's font list. --------------------------------------------------------------------------------} -function TsWorksheet.WriteFontName(ARow, ACol: Cardinal; AFontName: String): Integer; -begin - result := WriteFontName(GetCell(ARow, ACol), AFontName); -end; - -{@@ ---------------------------------------------------------------------------- - Replaces the font used in formatting of a cell considering only the font face - and leaving font size, style and color unchanged. Looks in the workbook's - font list if this modified font has already been used. If not a new font entry - is created. Returns the index of this font in the font list. - - @param ACell Pointer to the cell - @param AFontName Name of the new font to be used - @return Index of the font in the workbook's font list. --------------------------------------------------------------------------------} -function TsWorksheet.WriteFontName(ACell: PCell; AFontName: String): Integer; -var - fnt: TsFont; -begin - if ACell = nil then begin - Result := 0; - exit; - end; - fnt := ReadCellFont(ACell); - result := WriteFont(ACell, AFontName, fnt.Size, fnt.Style, fnt.Color); -end; - -{@@ ---------------------------------------------------------------------------- - Replaces the font size in formatting of a cell. Looks in the workbook's - font list if this modified font has already been used. If not a new font entry - is created. Returns the index of this font in the font list. - - @param ARow The row of the cell - @param ACol The column of the cell - @param ASize Size of the font to be used (in points). - @return Index of the font in the workbook's font list. --------------------------------------------------------------------------------} -function TsWorksheet.WriteFontSize(ARow, ACol: Cardinal; ASize: Single): Integer; -begin - Result := WriteFontSize(GetCell(ARow, ACol), ASize); -end; - -{@@ ---------------------------------------------------------------------------- - Replaces the font size in formatting of a cell. Looks in the workbook's - font list if this modified font has already been used. If not a new font entry - is created. Returns the index of this font in the font list. - - @param ACell Pointer to the cell - @param ASize Size of the font to be used (in points). - @return Index of the font in the workbook's font list. --------------------------------------------------------------------------------} -function TsWorksheet.WriteFontSize(ACell: PCell; ASize: Single): Integer; -var - fnt: TsFont; -begin - if ACell = nil then begin - Result := 0; - exit; - end; - fnt := ReadCellFont(ACell); - Result := WriteFont(ACell, fnt.FontName, ASize, fnt.Style, fnt.Color); -end; - -{@@ ---------------------------------------------------------------------------- - Replaces the font style (bold, italic, etc) in formatting of a cell. - Looks in the workbook's font list if this modified font has already been used. - If not a new font entry is created. - Returns the index of this font in the font list. - - @param ARow The row of the cell - @param ACol The column of the cell - @param AStyle New font style to be used - @return Index of the font in the workbook's font list. - - @see TsFontStyle --------------------------------------------------------------------------------} -function TsWorksheet.WriteFontStyle(ARow, ACol: Cardinal; - AStyle: TsFontStyles): Integer; -begin - Result := WriteFontStyle(GetCell(ARow, ACol), AStyle); -end; - -{@@ ---------------------------------------------------------------------------- - Replaces the font style (bold, italic, etc) in formatting of a cell. - Looks in the workbook's font list if this modified font has already been used. - If not a new font entry is created. - Returns the index of this font in the font list. - - @param ACell Pointer to the cell considered - @param AStyle New font style to be used - @return Index of the font in the workbook's font list. - - @see TsFontStyle --------------------------------------------------------------------------------} -function TsWorksheet.WriteFontStyle(ACell: PCell; AStyle: TsFontStyles): Integer; -var - fnt: TsFont; -begin - if ACell = nil then begin - Result := -1; - exit; - end; - fnt := ReadCellFont(ACell); - Result := WriteFont(ACell, fnt.FontName, fnt.Size, AStyle, fnt.Color); -end; {@@ ---------------------------------------------------------------------------- Defines the horizontal alignment of text in a cell. @@ -927,3 +943,124 @@ begin ChangedCell(ACell^.Row, ACell^.Col); end; + +{==============================================================================} +{ TsWorkbook code for format handling } +{==============================================================================} + +{@@ ---------------------------------------------------------------------------- + Adds the specified format record to the internal list and returns the index + in the list. If the record had already been added before the function only + returns the index. +-------------------------------------------------------------------------------} +function TsWorkbook.AddCellFormat(const AValue: TsCellFormat): Integer; +begin + Result := FCellFormatList.Add(AValue); +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the contents of the format record with the specified index. +-------------------------------------------------------------------------------} +function TsWorkbook.GetCellFormat(AIndex: Integer): TsCellFormat; +begin + Result := FCellFormatList.Items[AIndex]^; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns a string describing the cell format with the specified index. +-------------------------------------------------------------------------------} +function TsWorkbook.GetCellFormatAsString(AIndex: Integer): String; +var + fmt: PsCellFormat; + cb: TsCellBorder; + s: String; + numFmt: TsNumFormatParams; +begin + Result := ''; + fmt := GetPointerToCellFormat(AIndex); + if fmt = nil then + exit; + + if (uffFont in fmt^.UsedFormattingFields) then + Result := Format('%s; Font%d', [Result, fmt^.FontIndex]); + if (uffBackground in fmt^.UsedFormattingFields) then begin + Result := Format('%s; Bg %s', [Result, GetColorName(fmt^.Background.BgColor)]); + Result := Format('%s; Fg %s', [Result, GetColorName(fmt^.Background.FgColor)]); + Result := Format('%s; Pattern %s', [Result, GetEnumName(TypeInfo(TsFillStyle), ord(fmt^.Background.Style))]); + end; + if (uffHorAlign in fmt^.UsedFormattingfields) then + Result := Format('%s; %s', [Result, GetEnumName(TypeInfo(TsHorAlignment), ord(fmt^.HorAlignment))]); + if (uffVertAlign in fmt^.UsedFormattingFields) then + Result := Format('%s; %s', [Result, GetEnumName(TypeInfo(TsVertAlignment), ord(fmt^.VertAlignment))]); + if (uffWordwrap in fmt^.UsedFormattingFields) then + Result := Format('%s; Word-wrap', [Result]); + if (uffNumberFormat in fmt^.UsedFormattingFields) then + begin + numFmt := GetNumberFormat(fmt^.NumberFormatIndex); + if numFmt <> nil then + Result := Format('%s; %s (%s)', [Result, + GetEnumName(TypeInfo(TsNumberFormat), ord(numFmt.NumFormat)), + numFmt.NumFormatStr + ]) + else + Result := Format('%s; %s', [Result, 'nfGeneral']); + end else + Result := Format('%s; %s', [Result, 'nfGeneral']); + if (uffBorder in fmt^.UsedFormattingFields) then + begin + s := ''; + for cb in fmt^.Border do + if s = '' then s := GetEnumName(TypeInfo(TsCellBorder), ord(cb)) + else s := s + '+' + GetEnumName(TypeInfo(TsCellBorder), ord(cb)); + Result := Format('%s; %s', [Result, s]); + end; + if (uffBiDi in fmt^.UsedFormattingFields) then + Result := Format('%s; %s', [Result, GetEnumName(TypeInfo(TsBiDiMode), ord(fmt^.BiDiMode))]); + if Result <> '' then Delete(Result, 1, 2); +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the count of format records used all over the workbook +-------------------------------------------------------------------------------} +function TsWorkbook.GetNumCellFormats: Integer; +begin + Result := FCellFormatList.Count; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns a pointer to the format record with the specified index +-------------------------------------------------------------------------------} +function TsWorkbook.GetPointerToCellFormat(AIndex: Integer): PsCellFormat; +begin + if FCellFormatList.Count = 0 then + raise Exception.Create('[TsWorkbook.GetPointerToCellFormat]: No format items.'); + + if (AIndex < 0) or (AIndex >= FCellFormatList.Count) then + AIndex := 0; // 0 is default format + Result := FCellFormatList.Items[AIndex]; +end; + + +{@@ ---------------------------------------------------------------------------- + Removes all cell formats from the workbook. + + If AKeepDefaultFormat is true then index 0 containing the default cell format + is retained. + + Use carefully! +-------------------------------------------------------------------------------} +procedure TsWorkbook.RemoveAllCellFormats(AKeepDefaultFormat: Boolean); +var + i: Integer; +begin + if AKeepDefaultFormat then + for i := FCellFormatList.Count-1 downto 1 do + FCellFormatList.Delete(i) + else + FCellFormatList.Clear; +end; + diff --git a/components/fpspreadsheet/source/common/fpspreadsheet_fonts.inc b/components/fpspreadsheet/source/common/fpspreadsheet_fonts.inc new file mode 100644 index 000000000..60b166c81 --- /dev/null +++ b/components/fpspreadsheet/source/common/fpspreadsheet_fonts.inc @@ -0,0 +1,566 @@ +{ Included by fpspreadsheet.pas } + +{ Code for font handling } + +{==============================================================================} +{ TsWorksheet code for fonts } +{==============================================================================} + +{@@ ---------------------------------------------------------------------------- + Determines the font used by a specified cell. Returns the workbook's default + font if the cell does not exist. +-------------------------------------------------------------------------------} +function TsWorksheet.ReadCellFont(ACell: PCell): TsFont; +var + fmt: PsCellFormat; +begin + Result := nil; + if ACell <> nil then begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + Result := Workbook.GetFont(fmt^.FontIndex); + end; + if Result = nil then + Result := Workbook.GetDefaultFont; +end; + +{@@ ---------------------------------------------------------------------------- + Determines the index of the font used by a specified cell, referring to the + workbooks font list. Returns 0 (the default font index) if the cell does not + exist. +-------------------------------------------------------------------------------} +function TsWorksheet.ReadCellFontIndex(ACell: PCell): Integer; +var + fmt: PsCellFormat; +begin + Result := DEFAULT_FONTINDEX; + if ACell <> nil then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + Result := fmt^.FontIndex; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Adds font specification to the formatting of a cell. Looks in the workbook's + FontList and creates an new entry if the font is not used so far. Returns the + index of the font in the font list. + + @param ARow The row of the cell + @param ACol The column of the cell + @param AFontName Name of the font + @param AFontSize Size of the font, in points + @param AFontStyle Set with font style attributes + (don't use those of unit "graphics" !) + @param AFontColor RGB value of the font's color + @param APosition Specifies sub- or superscript text + @return Index of the font in the workbook's font list. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFont(ARow, ACol: Cardinal; const AFontName: String; + AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor; + APosition: TsFontPosition = fpNormal): Integer; +begin + Result := WriteFont(GetCell(ARow, ACol), AFontName, AFontSize, AFontStyle, + AFontColor, APosition); +end; + + +{@@ ---------------------------------------------------------------------------- + Adds font specification to the formatting of a cell. Looks in the workbook's + FontList and creates an new entry if the font is not used so far. Returns the + index of the font in the font list. + + @param ACell Pointer to the cell considered + @param AFontName Name of the font + @param AFontSize Size of the font, in points + @param AFontStyle Set with font style attributes + (don't use those of unit "graphics" !) + @param AFontColor RGB value of the font's color + @param APosition Specified subscript or superscript text. + @return Index of the font in the workbook's font list. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFont(ACell: PCell; const AFontName: String; + AFontSize: Single; AFontStyle: TsFontStyles; AFontColor: TsColor; + APosition: TsFontPosition = fpNormal): Integer; +var + fmt: TsCellFormat; +begin + if ACell = nil then + begin + Result := -1; + Exit; + end; + + Result := FWorkbook.FindFont(AFontName, AFontSize, AFontStyle, AFontColor, APosition); + if Result = -1 then + result := FWorkbook.AddFont(AFontName, AFontSize, AFontStyle, AFontColor, APosition); + + fmt := Workbook.GetCellFormat(ACell^.FormatIndex); + Include(fmt.UsedFormattingFields, uffFont); + fmt.FontIndex := Result; + ACell^.FormatIndex := Workbook.AddCellFormat(fmt); + + ChangedFont(ACell^.Row, ACell^.Col); +end; + + +{@@ ---------------------------------------------------------------------------- + Applies a font to the formatting of a cell. The font is determined by its + index in the workbook's font list: + + @param ARow The row of the cell + @param ACol The column of the cell + @param AFontIndex Index of the font in the workbook's font list + @return Pointer to the cell +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFont(ARow, ACol: Cardinal; AFontIndex: Integer): PCell; +begin + Result := GetCell(ARow, ACol); + WriteFont(Result, AFontIndex); +end; + + +{@@ ---------------------------------------------------------------------------- + Applies a font to the formatting of a cell. The font is determined by its + index in the workbook's font list: + + @param ACell Pointer to the cell considered + @param AFontIndex Index of the font in the workbook's font list +-------------------------------------------------------------------------------} +procedure TsWorksheet.WriteFont(ACell: PCell; AFontIndex: Integer); +var + fmt: TsCellFormat; +begin + if ACell = nil then + exit; + + if (AFontIndex < 0) or (AFontIndex >= Workbook.GetFontCount) then + raise EFPSpreadsheet.Create(rsInvalidFontIndex); + + fmt := Workbook.GetCellFormat(ACell^.FormatIndex); + Include(fmt.UsedFormattingFields, uffFont); + fmt.FontIndex := AFontIndex; + ACell^.FormatIndex := Workbook.AddCellFormat(fmt); + + ChangedFont(ACell^.Row, ACell^.Col); +end; + + +{@@ ---------------------------------------------------------------------------- + Replaces the text color used in formatting of a cell. Looks in the workbook's + font list if this modified font has already been used. If not a new font entry + is created. Returns the index of this font in the font list. + + @param ARow The row of the cell + @param ACol The column of the cell + @param AFontColor RGB value of the new text color + @return Index of the font in the workbook's font list. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFontColor(ARow, ACol: Cardinal; AFontColor: TsColor): Integer; +begin + Result := WriteFontColor(GetCell(ARow, ACol), AFontColor); +end; + + +{@@ ---------------------------------------------------------------------------- + Replaces the text color used in formatting of a cell. Looks in the workbook's + font list if this modified font has already been used. If not a new font entry + is created. Returns the index of this font in the font list. + + @param ACell Pointer to the cell + @param AFontColor RGB value of the new text color + @return Index of the font in the workbook's font list. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFontColor(ACell: PCell; AFontColor: TsColor): Integer; +var + fnt: TsFont; +begin + if ACell = nil then begin + Result := 0; + exit; + end; + fnt := ReadCellFont(ACell); + Result := WriteFont(ACell, fnt.FontName, fnt.Size, fnt.Style, AFontColor); +end; + + +{@@ ---------------------------------------------------------------------------- + Replaces the font used in formatting of a cell considering only the font face + and leaving font size, style and color unchanged. Looks in the workbook's + font list if this modified font has already been used. If not a new font entry + is created. Returns the index of this font in the font list. + + @param ARow The row of the cell + @param ACol The column of the cell + @param AFontName Name of the new font to be used + @return Index of the font in the workbook's font list. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFontName(ARow, ACol: Cardinal; AFontName: String): Integer; +begin + result := WriteFontName(GetCell(ARow, ACol), AFontName); +end; + + +{@@ ---------------------------------------------------------------------------- + Replaces the font used in formatting of a cell considering only the font face + and leaving font size, style and color unchanged. Looks in the workbook's + font list if this modified font has already been used. If not a new font entry + is created. Returns the index of this font in the font list. + + @param ACell Pointer to the cell + @param AFontName Name of the new font to be used + @return Index of the font in the workbook's font list. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFontName(ACell: PCell; AFontName: String): Integer; +var + fnt: TsFont; +begin + if ACell = nil then begin + Result := 0; + exit; + end; + fnt := ReadCellFont(ACell); + result := WriteFont(ACell, AFontName, fnt.Size, fnt.Style, fnt.Color); +end; + + +{@@ ---------------------------------------------------------------------------- + Replaces the font size in formatting of a cell. Looks in the workbook's + font list if this modified font has already been used. If not a new font entry + is created. Returns the index of this font in the font list. + + @param ARow The row of the cell + @param ACol The column of the cell + @param ASize Size of the font to be used (in points). + @return Index of the font in the workbook's font list. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFontSize(ARow, ACol: Cardinal; ASize: Single): Integer; +begin + Result := WriteFontSize(GetCell(ARow, ACol), ASize); +end; + + +{@@ ---------------------------------------------------------------------------- + Replaces the font size in formatting of a cell. Looks in the workbook's + font list if this modified font has already been used. If not a new font entry + is created. Returns the index of this font in the font list. + + @param ACell Pointer to the cell + @param ASize Size of the font to be used (in points). + @return Index of the font in the workbook's font list. +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFontSize(ACell: PCell; ASize: Single): Integer; +var + fnt: TsFont; +begin + if ACell = nil then begin + Result := 0; + exit; + end; + fnt := ReadCellFont(ACell); + Result := WriteFont(ACell, fnt.FontName, ASize, fnt.Style, fnt.Color); +end; + + +{@@ ---------------------------------------------------------------------------- + Replaces the font style (bold, italic, etc) in formatting of a cell. + Looks in the workbook's font list if this modified font has already been used. + If not a new font entry is created. + Returns the index of this font in the font list. + + @param ARow The row of the cell + @param ACol The column of the cell + @param AStyle New font style to be used + @return Index of the font in the workbook's font list. + + @see TsFontStyle +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFontStyle(ARow, ACol: Cardinal; + AStyle: TsFontStyles): Integer; +begin + Result := WriteFontStyle(GetCell(ARow, ACol), AStyle); +end; + + +{@@ ---------------------------------------------------------------------------- + Replaces the font style (bold, italic, etc) in formatting of a cell. + Looks in the workbook's font list if this modified font has already been used. + If not a new font entry is created. + Returns the index of this font in the font list. + + @param ACell Pointer to the cell considered + @param AStyle New font style to be used + @return Index of the font in the workbook's font list. + + @see TsFontStyle +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFontStyle(ACell: PCell; AStyle: TsFontStyles): Integer; +var + fnt: TsFont; +begin + if ACell = nil then begin + Result := -1; + exit; + end; + fnt := ReadCellFont(ACell); + Result := WriteFont(ACell, fnt.FontName, fnt.Size, AStyle, fnt.Color); +end; + + + +{==============================================================================} +{ TsWorkbook code for fonts } +{==============================================================================} + +{@@ ---------------------------------------------------------------------------- + Adds a font to the font list. Returns the index in the font list. + + @param AFontName Name of the font (like 'Arial') + @param ASize Size of the font in points + @param AStyle Style of the font, a combination of TsFontStyle elements + @param AColor RGB valoe of the font color + @param APosition Specifies subscript or superscript text. + @return Index of the font in the workbook's font list +-------------------------------------------------------------------------------} +function TsWorkbook.AddFont(const AFontName: String; ASize: Single; + AStyle: TsFontStyles; AColor: TsColor; + APosition: TsFontPosition = fpNormal): Integer; +var + fnt: TsFont; +begin + fnt := TsFont.Create; + fnt.FontName := AFontName; + fnt.Size := ASize; + fnt.Style := AStyle; + fnt.Color := AColor; + fnt.Position := APosition; + Result := AddFont(fnt); +end; + + +{@@ ---------------------------------------------------------------------------- + Adds a font to the font list. Returns the index in the font list. + + @param AFont TsFont record containing all font parameters + @return Index of the font in the workbook's font list +-------------------------------------------------------------------------------} +function TsWorkbook.AddFont(const AFont: TsFont): Integer; +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(const AFontIndex: Integer); +var + fnt: TsFont; +begin + if AFontIndex < FFontList.Count then + begin + fnt := TsFont(FFontList.Items[AFontIndex]); + if fnt <> nil then fnt.Free; + FFontList.Delete(AFontIndex); + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Checks whether the font with the given specification is already contained in + the font list. Returns the index, or -1 if not found. + + @param AFontName Name of the font (like 'Arial') + @param ASize Size of the font in points + @param AStyle Style of the font, a combination of TsFontStyle elements + @param AColor RGB value of the font color + @param APosition Specified subscript or superscript text. + @return Index of the font in the font list, or -1 if not found. +-------------------------------------------------------------------------------} +function TsWorkbook.FindFont(const AFontName: String; ASize: Single; + AStyle: TsFontStyles; AColor: TsColor; APosition: TsFontPosition = fpNormal): Integer; +begin + Result := FindFontInList(FFontList, AFontName, ASize, AStyle, AColor, APosition); +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the count of built-in fonts (default font, hyperlink font, bold font + by default). +-------------------------------------------------------------------------------} +function TsWorkbook.GetBuiltinFontCount: Integer; +begin + Result := FBuiltinFontCount; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the default font. This is the first font (index 0) in the font list +-------------------------------------------------------------------------------} +function TsWorkbook.GetDefaultFont: TsFont; +begin + Result := GetFont(0); +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the point size of the default font +-------------------------------------------------------------------------------} +function TsWorkbook.GetDefaultFontSize: Single; +begin + Result := GetFont(0).Size; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the font with the given index. + + @param AIndex Index of the font to be considered + @return Record containing all parameters of the font (or nil if not found). +-------------------------------------------------------------------------------} +function TsWorkbook.GetFont(AIndex: Integer): TsFont; +begin + if (AIndex >= 0) and (AIndex < FFontList.Count) then + Result := FFontList.Items[AIndex] + else + Result := nil; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns a string which identifies the font with a given index. + + @param AIndex Index of the font + @return String with font name, font size etc. +-------------------------------------------------------------------------------} +function TsWorkbook.GetFontAsString(AIndex: Integer): String; +begin + Result := fpsUtils.GetFontAsString(GetFont(AIndex)); +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the count of registered fonts +-------------------------------------------------------------------------------} +function TsWorkbook.GetFontCount: Integer; +begin + Result := FFontList.Count; +end; + + +{@@ ---------------------------------------------------------------------------- + Initializes the font list by adding 5 fonts: + + 0: default font + 1: like default font, but blue and underlined (for hyperlinks) + 2: like default font, but bold + 3: like default font, but italic +-------------------------------------------------------------------------------} +procedure TsWorkbook.InitFonts; +var + fntName: String; + fntSize: Single; +begin + // Memorize old default font + with TsFont(FFontList.Items[0]) do + begin + fntName := FontName; + fntSize := Size; + end; + + // Remove current font list + RemoveAllFonts; + + // Build new font list + SetDefaultFont(fntName, fntSize); // FONT0: Default font + AddFont(fntName, fntSize, [fssUnderline], scBlue); // FONT1: Hyperlink font = blue & underlined + AddFont(fntName, fntSize, [fssBold], scBlack); // FONT2: Bold font + AddFont(fntName, fntSize, [fssItalic], scBlack); // FONT3: Italic font (not used directly) + + FBuiltinFontCount := FFontList.Count; +end; + + +{@@ ---------------------------------------------------------------------------- + Clears the list of fonts and releases their memory. +-------------------------------------------------------------------------------} +procedure TsWorkbook.RemoveAllFonts; +var + i: Integer; + fnt: TsFont; +begin + for i := FFontList.Count-1 downto 0 do + begin + fnt := TsFont(FFontList.Items[i]); + fnt.Free; + FFontList.Delete(i); + end; + FBuiltinFontCount := 0; +end; + + +{@@ ---------------------------------------------------------------------------- + Replaces the built-in font at a specific index with different font parameters +-------------------------------------------------------------------------------} +procedure TsWorkbook.ReplaceFont(AFontIndex: Integer; AFontName: String; + ASize: Single; AStyle: TsFontStyles; AColor: TsColor; + APosition: TsFontPosition = fpNormal); +var + fnt: TsFont; +begin + if (AFontIndex < FBuiltinFontCount) then //and (AFontIndex <> 4) then + begin + fnt := TsFont(FFontList[AFontIndex]); + fnt.FontName := AFontName; + fnt.Size := ASize; + fnt.Style := AStyle; + fnt.Color := AColor; + fnt.Position := APosition; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Defines the default font. This is the font with index 0 in the FontList. + The next built-in fonts will have the same font name and size +-------------------------------------------------------------------------------} +procedure TsWorkbook.SetDefaultFont(const AFontName: String; ASize: Single); +var + i: Integer; +begin + if FFontList.Count = 0 then + AddFont(AFontName, ASize, [], scBlack) + else + for i:=0 to FBuiltinFontCount-1 do + if (i <> 4) and (i < FFontList.Count) then // wp: why if font #4 relevant here ???? + with TsFont(FFontList[i]) do + begin + FontName := AFontName; + Size := ASize; + end; +end; + + diff --git a/components/fpspreadsheet/source/common/fpspreadsheet_hyperlinks.inc b/components/fpspreadsheet/source/common/fpspreadsheet_hyperlinks.inc new file mode 100644 index 000000000..a2751a67e --- /dev/null +++ b/components/fpspreadsheet/source/common/fpspreadsheet_hyperlinks.inc @@ -0,0 +1,228 @@ +{ Included by fpspreadsheet.pas } + +{ Contains code for hyperlinks } + +{@@ ---------------------------------------------------------------------------- + Checks whether the specified cell contains a hyperlink and returns a pointer + to the hyperlink data. + + @param ACell Pointer to the cell + @return Pointer to the TsHyperlink record, or NIL if the cell does not contain + a hyperlink. +-------------------------------------------------------------------------------} +function TsWorksheet.FindHyperlink(ACell: PCell): PsHyperlink; +begin + if HasHyperlink(ACell) then + Result := PsHyperlink(FHyperlinks.FindByRowCol(ACell^.Row, ACell^.Col)) + else + Result := nil; +end; + + +{@@ ---------------------------------------------------------------------------- + Reads the hyperlink information of a specified cell. + + @param ACell Pointer to the cell considered + @returns Record with the hyperlink data assigned to the cell. + If the cell is not a hyperlink the result field Kind is hkNone. +-------------------------------------------------------------------------------} +function TsWorksheet.ReadHyperlink(ACell: PCell): TsHyperlink; +var + hyperlink: PsHyperlink; +begin + hyperlink := FindHyperlink(ACell); + if hyperlink <> nil then + Result := hyperlink^ + else + begin + Result.Row := ACell^.Row; + Result.Col := ACell^.Col; + Result.Target := ''; + Result.Tooltip := ''; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Removes a hyperlink from the specified cell. Releaes memory occupied by + the associated TsHyperlink record. Cell content type is converted to + cctUTF8String. +-------------------------------------------------------------------------------} +procedure TsWorksheet.RemoveHyperlink(ACell: PCell); +begin + if HasHyperlink(ACell) then + begin + FHyperlinks.DeleteHyperlink(ACell^.Row, ACell^.Col); + Exclude(ACell^.Flags, cfHyperlink); + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Checks whether the passed string represents a valid hyperlink target + + @param AValue String to be checked. Must be either a fully qualified URI, + a local relative (!) file name, or a # followed by a cell + address in the current workbook + @param AErrMsg Error message in case that the string is not correct. + @returns TRUE if the string is correct, FALSE otherwise +-------------------------------------------------------------------------------} +function TsWorksheet.ValidHyperlink(AValue: String; out AErrMsg: String): Boolean; +var + u: TUri; + sheet: TsWorksheet; + r, c: Cardinal; +begin + Result := false; + AErrMsg := ''; + if AValue = '' then + begin + AErrMsg := rsEmptyHyperlink; + exit; + end else + if (AValue[1] = '#') then + begin + Delete(AValue, 1, 1); + if not FWorkbook.TryStrToCell(AValue, sheet, r, c) then + begin + AErrMsg := Format(rsNoValidHyperlinkInternal, ['#'+AValue]); + exit; + end; + end else + begin + u := ParseURI(AValue); + if SameText(u.Protocol, 'mailto') then + begin + Result := true; // To do: Check email address here... + exit; + end else + if SameText(u.Protocol, 'file') then + begin + if FilenameIsAbsolute(u.Path + u.Document) then + begin + Result := true; + exit; + end else + begin + AErrMsg := Format(rsLocalfileHyperlinkAbs, [AValue]); + exit; + end; + end else + begin + Result := true; + exit; + end; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Assigns a hyperlink to the cell at the specified row and column + Cell content is not affected by the presence of a hyperlink. + + @param ARow Row index of the cell considered + @param ACol Column index of the cell considered + @param ATarget Hyperlink address given as a fully qualitifed URI for + external links, or as a # followed by a cell address + for internal links. + @param ATooltip Text for popup tooltip hint used by Excel + @returns Pointer to the cell with the hyperlink +-------------------------------------------------------------------------------} +function TsWorksheet.WriteHyperlink(ARow, ACol: Cardinal; ATarget: String; + ATooltip: String = ''): PCell; +begin + Result := GetCell(ARow, ACol); + WriteHyperlink(Result, ATarget, ATooltip); +end; + + +{@@ ---------------------------------------------------------------------------- + Assigns a hyperlink to the specified cell. + + @param ACell Pointer to the cell considered + @param ATarget Hyperlink address given as a fully qualitifed URI for + external links, or as a # followed by a cell address + for internal links. Local files can be specified also + by their name relative to the workbook. + An existing hyperlink is removed if ATarget is empty. + @param ATooltip Text for popup tooltip hint used by Excel +-------------------------------------------------------------------------------} +procedure TsWorksheet.WriteHyperlink(ACell: PCell; ATarget: String; + ATooltip: String = ''); + + function GetDisplayText(ATarget: String): String; + var + target, bm: String; + begin + SplitHyperlink(ATarget, target, bm); + if pos('file:', lowercase(ATarget))=1 then + begin + URIToFilename(target, Result); + ForcePathDelims(Result); + if bm <> '' then Result := Result + '#' + bm; + end else + if target = '' then + Result := bm + else + Result := ATarget; + end; + +var + fmt: TsCellFormat; + noCellText: Boolean = false; +begin + if ACell = nil then + exit; + + fmt := ReadCellFormat(ACell); + + // Empty target string removes the hyperlink. Resets the font from hyperlink + // to default font. + if ATarget = '' then begin + RemoveHyperlink(ACell); + if fmt.FontIndex = HYPERLINK_FONTINDEX then + WriteFont(ACell, DEFAULT_FONTINDEX); + exit; + end; + + // Detect whether the cell already has a hyperlink, but has no other content. + if HasHyperlink(ACell) then + noCellText := (ACell^.ContentType = cctUTF8String) and + (GetDisplayText(ReadHyperlink(ACell).Target) = ReadAsText(ACell)); + + // Attach the hyperlink to the cell + FHyperlinks.AddHyperlink(ACell^.Row, ACell^.Col, ATarget, ATooltip); + Include(ACell^.Flags, cfHyperlink); + + // If there is no other cell content use the target as cell label string. + if (ACell^.ContentType = cctEmpty) or noCellText then + begin + ACell^.ContentType := cctUTF8String; + ACell^.UTF8StringValue := GetDisplayText(ATarget); + end; + + // Select the hyperlink font. + if fmt.FontIndex = DEFAULT_FONTINDEX then + begin + fmt.FontIndex := HYPERLINK_FONTINDEX; + Include(fmt.UsedFormattingFields, uffFont); + ACell^.FormatIndex := FWorkbook.AddCellFormat(fmt); + end; + + ChangedCell(ACell^.Row, ACell^.Col); +end; + + +{==============================================================================} +{ TsWorkbook code for hyperlinls } +{==============================================================================} + +{@@ ---------------------------------------------------------------------------- + Returns the hypertext font. This is font with index 6 in the font list +-------------------------------------------------------------------------------} +function TsWorkbook.GetHyperlinkFont: TsFont; +begin + Result := GetFont(HYPERLINK_FONTINDEX); +end; + + diff --git a/components/fpspreadsheet/source/common/fpspreadsheet_numfmt.inc b/components/fpspreadsheet/source/common/fpspreadsheet_numfmt.inc new file mode 100644 index 000000000..cc9f8289f --- /dev/null +++ b/components/fpspreadsheet/source/common/fpspreadsheet_numfmt.inc @@ -0,0 +1,490 @@ +{ Included by fpspreadsheet.pas } + +{ Code for number format } + +{==============================================================================} +{ TsWorksheet code for number format } +{==============================================================================} + +{@@ ---------------------------------------------------------------------------- + Determines some number format attributes (decimal places, currency symbol) of + a cell + + @param ACell Pointer to the cell under investigation + @param ADecimals Number of decimal places that can be extracted from + the formatting string, e.g. in case of '0.000' this + would be 3. + @param ACurrencySymbol String representing the currency symbol extracted from + the formatting string. + + @return true if the the format string could be analyzed successfully, false if not +-------------------------------------------------------------------------------} +function TsWorksheet.GetNumberFormatAttributes(ACell: PCell; out ADecimals: byte; + out ACurrencySymbol: String): Boolean; +var + parser: TsNumFormatParser; + nf: TsNumberFormat; + nfs: String; +begin + Result := false; + if ACell <> nil then + begin + ReadNumFormat(ACell, nf, nfs); + parser := TsNumFormatParser.Create(nfs, FWorkbook.FormatSettings); + try + if parser.Status = psOK then + begin + nf := parser.NumFormat; + if (nf = nfGeneral) and (ACell^.ContentType = cctNumber) then + begin + ADecimals := GetDisplayedDecimals(ACell); + ACurrencySymbol := ''; + end else + if IsDateTimeFormat(nf) then + begin + ADecimals := 2; + ACurrencySymbol := '?'; + end + else + begin + ADecimals := parser.Decimals; + ACurrencySymbol := parser.CurrencySymbol; + end; + Result := true; + end; + finally + parser.Free; + end; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the number format type and format string used in a specific cell +-------------------------------------------------------------------------------} +procedure TsWorksheet.ReadNumFormat(ACell: PCell; out ANumFormat: TsNumberFormat; + out ANumFormatStr: String); +var + fmt: PsCellFormat; + numFmt: TsNumFormatParams; +begin + ANumFormat := nfGeneral; + ANumFormatStr := ''; + if ACell <> nil then + begin + fmt := Workbook.GetPointerToCellFormat(ACell^.FormatIndex); + if (uffNumberFormat in fmt^.UsedFormattingFields) then + begin + numFmt := Workbook.GetNumberFormat(fmt^.NumberFormatIndex); + if numFmt <> nil then + begin + ANumFormat := numFmt.NumFormat; + ANumFormatStr := numFmt.NumFormatStr; + end else + begin + ANumFormat := nfGeneral; + ANumFormatStr := ''; + end; + end; + end; +end; + + + {@@ ---------------------------------------------------------------------------- + Adds a date/time format to the formatting of a cell + + @param ARow The row of the cell + @param ACol The column of the cell + @param ANumFormat Identifier of the format to be applied (nfXXXX constant) + @param ANumFormatString Optional string of formatting codes. Is only considered + if ANumberFormat is nfCustom. + @return Pointer to the cell + + @see TsNumberFormat +-------------------------------------------------------------------------------} +function TsWorksheet.WriteDateTimeFormat(ARow, ACol: Cardinal; + ANumFormat: TsNumberFormat; const ANumFormatString: String = ''): PCell; +begin + Result := GetCell(ARow, ACol); + WriteDateTimeFormat(Result, ANumFormat, ANumFormatString); +end; + + +{@@ ---------------------------------------------------------------------------- + Adds a date/time format to the formatting of a cell + + @param ACell Pointer to the cell considered + @param ANumFormat Identifier of the format to be applied (nxXXXX constant) + @param ANumFormatString optional string of formatting codes. Is only considered + if ANumberFormat is nfCustom. + + @see TsNumberFormat +-------------------------------------------------------------------------------} +procedure TsWorksheet.WriteDateTimeFormat(ACell: PCell; + ANumFormat: TsNumberFormat; const ANumFormatString: String = ''); +var + fmt: TsCellFormat; + nfs: String; + nfp: TsNumFormatParams; + isTextFmt, wasTextFmt: Boolean; + oldVal: String; +begin + if ACell = nil then + exit; + + if not ((ANumFormat in [nfGeneral, nfCustom]) or IsDateTimeFormat(ANumFormat)) then + raise EFPSpreadsheet.Create('WriteDateTimeFormat can only be called with date/time formats.'); + + isTextFmt := false; + wasTextFmt := false; + + fmt := FWorkbook.GetCellFormat(ACell^.FormatIndex); + fmt.NumberFormat := ANumFormat; + if (ANumFormat <> nfGeneral) then + begin + nfp := Workbook.GetNumberFormat(fmt.NumberFormatIndex); + wasTextFmt := IsTextFormat(nfp); + oldval := ReadAsText(ACell); + Include(fmt.UsedFormattingFields, uffNumberFormat); + if (ANumFormatString = '') then + nfs := BuildDateTimeFormatString(ANumFormat, Workbook.FormatSettings) + else + nfs := ANumFormatString; + isTextFmt := (nfs = '@'); + end else + begin + Exclude(fmt.UsedFormattingFields, uffNumberFormat); + fmt.NumberFormatStr := ''; + end; + fmt.NumberFormat := ANumFormat; + fmt.NumberFormatStr := nfs; + fmt.NumberFormatIndex := Workbook.AddNumberFormat(nfs); + ACell^.FormatIndex := FWorkbook.AddCellFormat(fmt); + + if isTextFmt then + WriteText(ACell, oldval) + else + if wasTextFmt then + WriteCellValueAsString(ACell, ACell^.UTF8StringValue); + + ChangedCell(ACell^.Row, ACell^.Col); +end; + + +{@@ ---------------------------------------------------------------------------- + Formats the number in a cell to show a given count of decimal places. + Is ignored for non-decimal formats (such as most date/time formats). + + @param ARow Row indows of the cell considered + @param ACol Column indows of the cell considered + @param ADecimals Number of decimal places to be displayed + @return Pointer to the cell + @see TsNumberFormat +-------------------------------------------------------------------------------} +function TsWorksheet.WriteDecimals(ARow, ACol: Cardinal; ADecimals: Byte): PCell; +begin + Result := FindCell(ARow, ACol); + WriteDecimals(Result, ADecimals); +end; + + +{@@ ---------------------------------------------------------------------------- + Formats the number in a cell to show a given count of decimal places. + Is ignored for non-decimal formats (such as most date/time formats). + + @param ACell Pointer to the cell considered + @param ADecimals Number of decimal places to be displayed + @see TsNumberFormat +-------------------------------------------------------------------------------} +procedure TsWorksheet.WriteDecimals(ACell: PCell; ADecimals: Byte); +var + parser: TsNumFormatParser; + fmt: TsCellFormat; + numFmt: TsNumFormatParams; + numFmtStr: String; +begin + if (ACell = nil) or (ACell^.ContentType <> cctNumber) then + exit; + + fmt := FWorkbook.GetCellFormat(ACell^.FormatIndex); + numFmt := FWorkbook.GetNumberFormat(fmt.NumberFormatIndex); + if numFmt <> nil then + numFmtStr := numFmt.NumFormatStr + else + numFmtStr := '0.00'; + parser := TsNumFormatParser.Create(numFmtStr, Workbook.FormatSettings); + try + parser.Decimals := ADecimals; + numFmtStr := parser.FormatString; + fmt.NumberFormatIndex := Workbook.AddNumberFormat(numFmtStr); + Include(fmt.UsedFormattingFields, uffNumberFormat); + ACell^.FormatIndex := Workbook.AddCellFormat(fmt); + ChangedCell(ACell^.Row, ACell^.Col); + finally + parser.Free; + end; +end; + + +{@@ ---------------------------------------------------------------------------- + Formats a number as a fraction + + @param ARow Row index of the cell + @param ACol Column index of the cell + @param ANumFormat Identifier of the format to be applied. Must be + either nfFraction or nfMixedFraction + @param ANumeratorDigts Count of numerator digits + @param ADenominatorDigits Count of denominator digits + @return Pointer to the cell + + @see TsNumberFormat +-------------------------------------------------------------------------------} +function TsWorksheet.WriteFractionFormat(ARow, ACol: Cardinal; + AMixedFraction: Boolean; ANumeratorDigits, ADenominatorDigits: Integer): PCell; +begin + Result := GetCell(ARow, ACol); + WriteFractionFormat(Result, AMixedFraction, ANumeratorDigits, ADenominatorDigits); +end; + +{@@ ---------------------------------------------------------------------------- + Formats a number as a fraction + + @param ACell Pointer to the cell to be formatted + @param ANumFormat Identifier of the format to be applied. Must be + either nfFraction or nfMixedFraction + @param ANumeratorDigts Count of numerator digits + @param ADenominatorDigits Count of denominator digits + + @see TsNumberFormat +-------------------------------------------------------------------------------} +procedure TsWorksheet.WriteFractionFormat(ACell: PCell; + AMixedFraction: Boolean; ANumeratorDigits, ADenominatorDigits: Integer); +var + fmt: TsCellFormat; + nfs: String; +begin + if ACell = nil then + exit; + + fmt := Workbook.GetCellFormat(ACell^.FormatIndex); + nfs := BuildFractionFormatString(AMixedFraction, ANumeratorDigits, ADenominatorDigits); + fmt.NumberFormatIndex := Workbook.AddNumberFormat(nfs); + Include(fmt.UsedFormattingFields, uffNumberFormat); + ACell^.FormatIndex := Workbook.AddCellFormat(fmt); + + ChangedCell(ACell^.Row, ACell^.Col); +end; + + +{@@ ---------------------------------------------------------------------------- + Adds a number format to the formatting of a cell + + @param ARow The row of the cell + @param ACol The column of the cell + @param ANumFormat Identifier of the format to be applied + @param ADecimals Number of decimal places + @param ACurrencySymbol optional currency symbol in case of nfCurrency + @param APosCurrFormat optional identifier for positive currencies + @param ANegCurrFormat optional identifier for negative currencies + @return Pointer to the cell + + @see TsNumberFormat +-------------------------------------------------------------------------------} +function TsWorksheet.WriteNumberFormat(ARow, ACol: Cardinal; + ANumFormat: TsNumberFormat; ADecimals: Integer; ACurrencySymbol: String = ''; + APosCurrFormat: Integer = -1; ANegCurrFormat: Integer = -1): PCell; +begin + Result := GetCell(ARow, ACol); + WriteNumberFormat(Result, ANumFormat, ADecimals, ACurrencySymbol, + APosCurrFormat, ANegCurrFormat); +end; + +{@@ ---------------------------------------------------------------------------- + Adds a number format to the formatting of a cell + + @param ARow The row of the cell + @param ACol The column of the cell + @param ANumFormat Identifier of the format to be applied + @param ADecimals Number of decimal places + @param ACurrencySymbol optional currency symbol in case of nfCurrency + @param APosCurrFormat optional identifier for positive currencies + @param ANegCurrFormat optional identifier for negative currencies + + @see TsNumberFormat +-------------------------------------------------------------------------------} +procedure TsWorksheet.WriteNumberFormat(ACell: PCell; + ANumFormat: TsNumberFormat; ADecimals: Integer; ACurrencySymbol: String = ''; + APosCurrFormat: Integer = -1; ANegCurrFormat: Integer = -1); +var + fmt: TsCellFormat; + fmtStr: String; + nfp: TsNumFormatParams; + wasTextFmt: Boolean; +begin + if ACell = nil then + exit; + + wasTextFmt := false; + + fmt := Workbook.GetCellFormat(ACell^.FormatIndex); + fmt.NumberFormat := ANumFormat; + if ANumFormat <> nfGeneral then + begin + nfp := Workbook.GetNumberFormat(fmt.NumberFormatIndex); + wasTextFmt := IsTextFormat(nfp); + Include(fmt.UsedFormattingFields, uffNumberFormat); + if IsCurrencyFormat(ANumFormat) then + begin + RegisterCurrency(ACurrencySymbol); + fmtStr := BuildCurrencyFormatString(ANumFormat, Workbook.FormatSettings, + ADecimals, APosCurrFormat, ANegCurrFormat, ACurrencySymbol); + end else + fmtStr := BuildNumberFormatString(ANumFormat, + Workbook.FormatSettings, ADecimals); + fmt.NumberFormatIndex := Workbook.AddNumberFormat(fmtStr); + end else + begin + Exclude(fmt.UsedFormattingFields, uffNumberFormat); + fmt.NumberFormatIndex := -1; + end; + ACell^.FormatIndex := Workbook.AddCellFormat(fmt); + + if wasTextFmt then + WriteCellValueAsString(ACell, ACell^.UTF8StringValue); + + ChangedCell(ACell^.Row, ACell^.Col); +end; + + +{@@ ---------------------------------------------------------------------------- + Adds a number format to the formatting of a cell + + @param ARow The row of the cell + @param ACol The column of the cell + @param ANumFormat Identifier of the format to be applied + @param ANumFormatString Optional string of formatting codes. Is only considered + if ANumberFormat is nfCustom. + @return Pointer to the cell + + @see TsNumberFormat +-------------------------------------------------------------------------------} +function TsWorksheet.WriteNumberFormat(ARow, ACol: Cardinal; + ANumFormat: TsNumberFormat; const ANumFormatString: String = ''): PCell; +begin + Result := GetCell(ARow, ACol); + WriteNumberFormat(Result, ANumFormat, ANumFormatString); +end; + + +{@@ ---------------------------------------------------------------------------- + Adds a number format to the formatting of a cell + + @param ACell Pointer to the cell considered + @param ANumFormat Identifier of the format to be applied + @param ANumFormatString Optional string of formatting codes. Is only considered + if ANumberFormat is nfCustom. + + @see TsNumberFormat +-------------------------------------------------------------------------------} +procedure TsWorksheet.WriteNumberFormat(ACell: PCell; + ANumFormat: TsNumberFormat; const ANumFormatString: String = ''); +var + fmt: TsCellFormat; + fmtStr: String; + nfp: TsNumFormatParams; + oldval: String; + isTextFmt, wasTextFmt: Boolean; +begin + if ACell = nil then + exit; + + isTextFmt := false; + wasTextFmt := false; + + fmt := Workbook.GetCellFormat(ACell^.FormatIndex); + + if ANumFormat <> nfGeneral then begin + nfp := Workbook.GetNumberFormat(fmt.NumberFormatIndex); + wasTextFmt := IsTextFormat(nfp); + oldval := ReadAsText(ACell); + Include(fmt.UsedFormattingFields, uffNumberFormat); + if (ANumFormatString = '') then + fmtStr := BuildNumberFormatString(ANumFormat, Workbook.FormatSettings) + else + fmtStr := ANumFormatString; + isTextFmt := (fmtstr = '@'); + fmt.NumberFormatIndex := Workbook.AddNumberFormat(fmtStr); + end else begin + Exclude(fmt.UsedFormattingFields, uffNumberFormat); + fmt.NumberFormatIndex := -1; + end; + ACell^.FormatIndex := Workbook.AddCellFormat(fmt); + + if isTextFmt then + WriteText(ACell, oldval) + else + if wasTextFmt then + WriteCellValueAsString(ACell, ACell^.UTF8StringValue); + + ChangedCell(ACell^.Row, ACell^.Col); +end; + + + +{==============================================================================} +{ TsWorkbook code for number format } +{==============================================================================} + +{@@ ---------------------------------------------------------------------------- + Adds a number format to the internal list. Returns the list index if already + present, or creates a new format item and returns its index. +-------------------------------------------------------------------------------} +function TsWorkbook.AddNumberFormat(AFormatStr: String): Integer; +begin + if AFormatStr = '' then + Result := -1 // General number format is not stored + else + Result := TsNumFormatList(FNumFormatList).AddFormat(AFormatStr); +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the parameters of the number format stored in the NumFormatList at the + specified index. + "General" number format is returned as nil. +-------------------------------------------------------------------------------} +function TsWorkbook.GetNumberFormat(AIndex: Integer): TsNumFormatParams; +begin + if (AIndex >= 0) and (AIndex < FNumFormatList.Count) then + Result := TsNumFormatParams(FNumFormatList.Items[AIndex]) + else + Result := nil; +end; + + +{@@ ---------------------------------------------------------------------------- + Returns the count of number format records stored in the NumFormatList +-------------------------------------------------------------------------------} +function TsWorkbook.GetNumberFormatCount: Integer; +begin + Result := FNumFormatList.Count; +end; + + +{@@ ---------------------------------------------------------------------------- + Removes all numberformats + Use carefully! +-------------------------------------------------------------------------------} +procedure TsWorkbook.RemoveAllNumberFormats; +var + i: Integer; + nfp: TsNumFormatParams; +begin + for i:= FEmbeddedObjList.Count-1 downto 0 do begin + nfp := TsNumFormatParams(FNumFormatList[i]); + FNumFormatList.Delete(i); + nfp.Free; + end; +end; + +