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

fpspreadsheet: Initial support for embedded images. Writer for xlsx. Avoid writing relationship for non-existing files to xlsx. Add "numFmtId=0" to xlsx styles (seems to be mandatory for import to Access).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4528 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-03-03 19:12:58 +00:00
parent f0bcbf2316
commit 58547464d3
10 changed files with 1199 additions and 208 deletions
Download Patch File Download Diff File Expand all files Collapse all files

86
components/fpspreadsheet/fpsclasses.pas
View File

@@ -201,8 +201,18 @@ type
function Pop: Integer;
end;
function FindFontInList(AFontList: TFPList; AFontName: String; ASize: Single;
AStyle: TsFontStyles; AColor: TsColor; APos: TsFontPosition): Integer;
{ TsEmbeddedStream }
TsEmbeddedStream = class(TMemoryStream)
private
FName: String;
public
constructor Create(AName: String);
property Name: String read FName;
end;
function FindFontInList(AFontList: TFPList; AFontName: String; ASize: Single;
AStyle: TsFontStyles; AColor: TsColor; APos: TsFontPosition): Integer;
implementation
@@ -221,10 +231,11 @@ begin
end;
{******************************************************************************}
{ TsRowColEnumerator: A specialized enumerator for TsRowColAVLTree using the }
{ pointers to the data records. }
{******************************************************************************}
{==============================================================================}
{ TsRowColEnumerator }
{ A specialized enumerator for TsRowColAVLTree using the pointers to the data }
{ records. }
{==============================================================================}
constructor TsRowColEnumerator.Create(ATree: TsRowColAVLTree;
AStartRow, AStartCol, AEndRow, AEndCol: LongInt; AReverse: Boolean);
@@ -373,10 +384,10 @@ begin
end;
{******************************************************************************}
{==============================================================================}
{ TsRowColAVLTree: A specialized AVLTree working with records containing }
{ row and column indexes. }
{******************************************************************************}
{==============================================================================}
{@@ ----------------------------------------------------------------------------
Constructor of the AVLTree. Installs a compare procedure for row and column
@@ -621,9 +632,9 @@ begin
end;
{******************************************************************************}
{==============================================================================}
{ TsCellEnumerator: enumerator for the TsCells AVLTree }
{******************************************************************************}
{==============================================================================}
function TsCellEnumerator.GetEnumerator: TsCellEnumerator;
begin
@@ -636,9 +647,9 @@ begin
end;
{******************************************************************************}
{==============================================================================}
{ TsCells: an AVLTree to store spreadsheet cells }
{******************************************************************************}
{==============================================================================}
constructor TsCells.Create(AWorksheet: Pointer; AOwnsData: Boolean = true);
begin
@@ -792,9 +803,9 @@ begin
end;
{******************************************************************************}
{==============================================================================}
{ TsCommentEnumerator: enumerator for the TsComments AVLTree }
{******************************************************************************}
{==============================================================================}
function TsCommentEnumerator.GetEnumerator: TsCommentEnumerator;
begin
@@ -807,9 +818,9 @@ begin
end;
{******************************************************************************}
{==============================================================================}
{ TsComments: an AVLTree to store comment records for cells }
{******************************************************************************}
{==============================================================================}
{@@ ----------------------------------------------------------------------------
Adds a node with a new comment record to the tree. If a node already
@@ -872,9 +883,9 @@ begin
end;
{******************************************************************************}
{==============================================================================}
{ TsHyperlinkEnumerator: enumerator for the TsHyperlinks AVLTree }
{******************************************************************************}
{==============================================================================}
function TsHyperlinkEnumerator.GetEnumerator: TsHyperlinkEnumerator;
begin
@@ -887,9 +898,9 @@ begin
end;
{******************************************************************************}
{==============================================================================}
{ TsHyperlinks: an AVLTree to store hyperlink records for cells }
{******************************************************************************}
{==============================================================================}
{@@ ----------------------------------------------------------------------------
Adds a node with a new hyperlink record to the tree. If a node already
@@ -953,9 +964,9 @@ begin
end;
{******************************************************************************}
{==============================================================================}
{ TsCellRangeEnumerator: enumerator for the cell range records }
{******************************************************************************}
{==============================================================================}
function TsCellRangeEnumerator.GetEnumerator: TsCellRangeEnumerator;
begin
@@ -968,9 +979,9 @@ begin
end;
{******************************************************************************}
{==============================================================================}
{ TsMergedCells: a AVLTree to store merged cell range records for cells }
{******************************************************************************}
{==============================================================================}
{@@ ----------------------------------------------------------------------------
Adds a node with a new merge cell range record to the tree. If a node already
@@ -1136,9 +1147,9 @@ begin
end;
{******************************************************************************}
{==============================================================================}
{ TsCellFormatList }
{******************************************************************************}
{==============================================================================}
constructor TsCellFormatList.Create(AAllowDuplicates: Boolean);
begin
@@ -1310,9 +1321,10 @@ begin
inherited Items[AIndex] := AValue;
end;
{******************************************************************************}
{==============================================================================}
{ TsIntegerStack }
{******************************************************************************}
{==============================================================================}
procedure TsIntegerStack.Push(AValue: Integer);
begin
@@ -1331,9 +1343,22 @@ begin
end;
end;
{******************************************************************************}
{==============================================================================}
{ TsEmbeddedStream }
{==============================================================================}
constructor TsEmbeddedStream.Create(AName: String);
begin
inherited Create;
FName := AName;
end;
{==============================================================================}
{ Utilities }
{******************************************************************************}
{==============================================================================}
function FindFontInList(AFontList: TFPList; AFontName: String; ASize: Single;
AStyle: TsFontStyles; AColor: TsColor; APos: TsFontPosition): Integer;
begin
@@ -1347,5 +1372,6 @@ begin
Result := -1;
end;
end.

407
components/fpspreadsheet/fpsimages.pas Normal file
View File

@@ -0,0 +1,407 @@
unit fpsImages;
{$mode objfpc}{$H+}
interface
uses
Classes;
function GetImageSize(AStream: TStream; AFileType: String;
out AWidthInches, AHeightInches: double): Boolean; overload;
function GetImageSize(AStream: TStream; AFileType: String;
out AWidth, AHeight: DWord; out dpiX, dpiY: double): Boolean; overload;
implementation
uses
// laz2_xmlread, laz2_DOM,
Strings, math;
type
TByteOrder = (boLE, boBE); // little edian, or big endian
{ Makes sure that the byte order of w the same as specified by the parameter }
function FixByteOrder(w: Word; AByteOrder: TByteOrder): Word; overload;
begin
Result := IfThen(AByteOrder = boLE, LEToN(w), BEToN(w));
end;
{ Makes sure that the byte order of dw the same as specified by the parameter }
function FixByteOrder(dw: DWord; AByteOrder: TByteOrder): DWord; overload;
begin
Result := IfThen(AByteOrder = boLE, LEToN(dw), BEToN(dw));
end;
function GetTIFSize(AStream: TStream; out AWidth, AHeight: DWord;
out dpiX, dpiY: Double): Boolean; forward;
{ BMP files }
function GetBMPSize(AStream: TStream; out AWidth, AHeight: DWord;
out dpiX, dpiY: Double): Boolean;
// stackoverflow.com/questions/15209076/how-to-get-dimensions-of-image-file-in-delphi
type
TBitMapFileHeader = packed record
bfType: word;
bfSize: longint;
bfReserved: longint;
bfOffset: longint;
end;
TBitMapInfoHeader = packed record
Size: longint;
Width: longint;
Height: longint;
Planes: word;
BitCount: word;
Compression: longint;
SizeImage: longint;
XPelsPerMeter: Longint;
YPelsPerMeter: Longint;
ClrUsed: longint;
ClrImportant: longint;
end;
const
BMP_MAGIC_WORD = ord('M') shl 8 or ord('B');
var
header: TBitmapFileHeader;
info: TBitmapInfoHeader;
begin
result := False;
if AStream.Read(header{%H-}, SizeOf(header)) <> SizeOf(header) then Exit;
if LEToN(header.bfType) <> BMP_MAGIC_WORD then Exit;
if AStream.Read(info{%H-}, SizeOf(info)) <> SizeOf(info) then Exit;
AWidth := LEToN(info.Width);
AHeight := abs(LEToN(info.Height));
dpiX := LEToN(info.XPelsPerMeter) * 0.0254;
dpiY := LEToN(info.YPelsPerMeter) * 0.0254;
Result := true;
end;
{ GIF files }
function GetGIFSize(AStream: TStream; out AWidth, AHeight: DWord;
out dpiX, dpiY: Double): Boolean;
type
TGifHeader = packed record
Sig: array[0..5] of char;
ScreenWidth, ScreenHeight: word;
Flags, Background, Aspect: byte;
end;
TGifImageBlock = packed record
Left, Top, Width, Height: word;
Flags: byte;
end;
var
header: TGifHeader;
imageBlock: TGifImageBlock;
nResult: integer;
x: integer;
c: char;
begin
Result := false;
// Read header and ensure valid file
nResult := AStream.Read(header{%H-}, SizeOf(TGifHeader));
if (nResult <> SizeOf(TGifHeader)) then exit; // invalid file
if (strlicomp(PChar(header.Sig), 'GIF87a', 6) <> 0) and
(strlicomp(PChar(header.Sig), 'GIF89a', 6) <> 0) then exit;
// Skip color map, if there is one
if (header.Flags and $80) > 0 then
begin
x := 3 * (1 SHL ((header.Flags and 7) + 1));
AStream.Position := x;
if AStream.Position > AStream.Size then exit; // Color map thrashed
end;
// Step through blocks
while (AStream.Position < AStream.Size) do
begin
c := char(AStream.ReadByte);
if c = ',' then
begin
// Image found
nResult := AStream.Read(imageBlock{%H-}, SizeOf(TGIFImageBlock));
if nResult <> SizeOf(TGIFImageBlock) then exit; // Invalid image block encountered
AWidth := LEToN(imageBlock.Width);
AHeight := LEToN(imageBlock.Height);
break;
end;
end;
dpiX := 96; // not stored in file, use default screen dpi
dpiY := 96;
Result := true;
end;
{ JPG files }
function GetJPGSize(AStream: TStream; out AWidth, AHeight: DWord;
out dpiX, dpiY: Double): boolean;
type
TJPGHeader = array[0..1] of Byte; //FFD8 = StartOfImage (SOI)
TJPGRecord = packed record
Marker: Byte;
RecType: Byte;
RecSize: Word;
end;
TAPP0Record = packed record
JFIF: Array[0..4] of AnsiChar; // zero-terminated "JFIF" string
Version: Word; // JFIF format revision
Units: Byte; // Units used for resolution: 1->inch, 2->cm, 0-> aspect ratio (1, 1)
XDensity: Word; // Horizontal resolution
YDensity: Word; // Vertical resolution
// thumbnail follows
end;
var
n: integer;
hdr: TJPGHeader;
rec: TJPGRecord = (Marker: $FF; RecType: 0; RecSize: 0);
app0: TAPP0Record;
u: Integer;
p: Int64;
exifSig: Array[0..5] of AnsiChar;
imgW, imgH: DWord;
begin
Result := false;
AWidth := 0;
AHeight := 0;
dpiX := -1;
dpiY := -1;
u := -1; // units of pixel density
// Check for SOI (start of image) record
n := AStream.Read(hdr{%H-}, SizeOf(hdr));
if (n < SizeOf(hdr)) or (hdr[0] <> $FF) or (hdr[1] <> $D8) then
exit;
while (AStream.Position < AStream.Size) and (rec.Marker = $FF) do begin
if AStream.Read(rec, SizeOf(rec)) < SizeOf(rec) then exit;
rec.RecSize := BEToN(rec.RecSize);
p := AStream.Position - 2;
case rec.RecType of
$E0: // APP0 record
if (rec.RecSize >= SizeOf(TAPP0Record)) then
begin
AStream.Read(app0{%H-}, SizeOf(app0));
if stricomp(pchar(app0.JFIF), 'JFIF') <> 0 then break;
dpiX := BEToN(app0.XDensity);
dpiY := BEToN(app0.YDensity);
u := app0.Units;
end else
exit;
$E1: // APP1 record (EXIF)
begin
AStream.Read(exifSig{%H-}, Sizeof(exifSig));
if not GetTIFSize(AStream, imgW, imgH, dpiX, dpiY) then exit;
end;
$C0..$C3:
if (rec.RecSize >= 4) then // Start of frame markers
begin
AStream.Seek(1, soFromCurrent); // Skip "bits per sample"
AHeight := BEToN(AStream.ReadWord);
AWidth := BEToN(AStream.ReadWord);
end else
exit;
$D9: // end of image;
break;
end;
AStream.Position := p + rec.RecSize;
end;
if dpiX = -1 then dpiX := 96;
if dpiY = -1 then dpiY := 96;
if u = 2 then begin
dpiX := dpiX * 2.54;
dpiY := dpiY * 2.54;
end;
Result := true;
end;
{ PNG files }
function GetPNGSize(AStream: TStream; out AWidth, AHeight: DWord;
out dpiX, dpiY: Double): Boolean;
// https://www.w3.org/TR/PNG/
type
TPngSig = array[0..7] of byte;
TPngChunk = packed record
chLength: LongInt;
chType: array[0..3] of AnsiChar;
end;
const
ValidSig: TPNGSig = (137, 80, 78, 71, 13, 10, 26, 10);
var
Sig: TPNGSig;
x: integer;
chunk: TPngChunk;
xdpm: LongInt;
ydpm: LongInt;
units: Byte;
p: Int64;
begin
Result := false;
dpiX := 96;
dpiY := 96;
FillChar(Sig{%H-}, SizeOf(Sig), #0);
AStream.Read(Sig[0], SizeOf(Sig));
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then
exit;
AStream.Seek(18, 0);
AWidth := BEToN(AStream.ReadWord);
AStream.Seek(22, 0);
AHeight := BEToN(AStream.ReadWord);
AStream.Position := SizeOf(TPngSig);
while AStream.Position < AStream.Size do
begin
AStream.Read(chunk{%H-}, SizeOf(TPngChunk));
chunk.chLength := BEToN(chunk.chLength);
p := AStream.Position;
if strlcomp(PChar(chunk.chType), 'pHYs', 4) = 0 then
begin
xdpm := BEToN(AStream.ReadDWord); // pixels per meter
ydpm := BEToN(AStream.ReadDWord);
units := AStream.ReadByte;
if units = 1 then
begin
dpiX := xdpm * 0.0254;
dpiY := ydpm * 0.0254;
end;
break;
end;
AStream.Position := p + chunk.chLength + 4;
end;
Result := true;
end;
{ TIF files }
function GetTIFSize(AStream: TStream; out AWidth, AHeight: DWord;
out dpiX, dpiY: Double): Boolean;
type
TTifHeader = packed record
BOM: word; // 'II' for little endian, 'MM' for big endian
Sig: word; // Signature (42)
IFD: DWORD; // Offset where image data begin
end;
TIFD_Field = packed record
Tag: word;
FieldType: word;
ValCount: DWord;
ValOffset: DWord;
end;
var
header: TTifHeader = (BOM:0; Sig:0; IFD:0);
dirEntries: Word;
field: TIFD_Field = (Tag:0; FieldType:0; ValCount:0; ValOffset:0);
i: Integer;
bo: TByteOrder;
num, denom: LongInt;
units: Word;
p, pStart: Int64;
begin
Result := false;
AWidth := 0;
AHeight := 0;
dpiX := 0;
dpiY := 0;
units := 0;
// Remember current stream position because procedure is called also from
// jpeg Exif block.
pStart := AStream.Position;
if AStream.Read(header, SizeOf(TTifHeader)) < SizeOf(TTifHeader) then exit;
if not ((header.BOM = $4949) or (header.BOM = $4D4D)) then exit;
if header.BOM = $4949 then bo := boLE else bo := boBE; // 'II' --> little endian, 'MM' --> big endian
if FixByteOrder(header.Sig, bo) <> 42 then exit;
AStream.Position := pStart + FixByteOrder(header.IFD, bo);
dirEntries := FixByteOrder(AStream.ReadWord, bo);
for i := 1 to dirEntries do
begin
AStream.Read(field, SizeOf(field));
field.Tag := FixByteOrder(field.Tag, bo);
field.ValOffset := FixByteOrder(field.ValOffset, bo);
field.FieldType := FixByteOrder(field.FieldType, bo);
p := AStream.Position;
case field.Tag OF
$0100 : AWidth := field.ValOffset;
$0101 : AHeight := field.ValOffset;
$011A : begin // XResolution as RATIONAL value
AStream.Position := pStart + field.ValOffset;
num := FixByteOrder(AStream.ReadDWord, bo);
denom := FixByteOrder(AStream.ReadDWord, bo);
dpiX := num/denom;
end;
$011B : begin // YResolution as RATIONAL value
AStream.Position := pStart + field.ValOffset;
num := FixByteOrder(AStream.ReadDWord, bo);
denom := FixByteOrder(AStream.ReadDWord, bo);
dpiY := num/denom;
end;
$0128 : begin
units := field.ValOffset; // 1: non-square 2: inches, 3: cm
end;
end;
if (AWidth > 0) and (AHeight > 0) and (dpiX > 0) and (dpiY > 0) and (units > 0)
then
break;
AStream.Position := p;
end;
case units of
1: begin dpiX := 96; dpiY := 96; end;
2: ; // is already inches, nothing to do
3: begin dpiX := dpiX*25.4; dpiY := dpiY * 25.4; end;
end;
Result := true;
end;
{==============================================================================}
{ Public functions }
{==============================================================================}
function GetImageSize(AStream: TStream; AFileType: String;
out AWidth, AHeight: DWord; out dpiX, dpiY: Double): Boolean;
begin
AFileType := Lowercase(AFileType);
if AFileType[1] = '.' then Delete(AFileType, 1, 1);
AStream.Position := 0;
case AFileType of
'bmp' : Result := GetBMPSize(AStream, AWidth, AHeight, dpiX, dpiY);
'gif' : Result := GetGIFSize(AStream, AWidth, AHeight, dpiX, dpiY);
'jpg', 'jpeg' : Result := GetJPGSize(AStream, AWidth, AHeight, dpiX, dpiY);
'png' : Result := GetPNGSize(AStream, AWidth, AHeight, dpiX, dpiY);
'tif', 'tiff' : Result := GetTIFSize(AStream, AWidth, AHeight, dpiX, dpiY);
else Result := false;
end;
end;
function GetImageSize(AStream: TStream; AFileType: String;
out AWidthInches, AHeightInches: double): Boolean;
var
w, h: DWord;
xdpi, ydpi: Double;
begin
Result := GetImageSize(AStream, AFileType, w, h, xdpi, ydpi);
if Result then
begin
AWidthInches := w / xdpi;
AHeightInches := h / ydpi;
end;
end;
end.

2
components/fpspreadsheet/fpsopendocument.pas
View File

@@ -1000,7 +1000,7 @@ var
col: PCol;
i: Integer;
begin
factor := FWorkbook.GetFont(0).Size/2;
factor := FWorkbook.GetDefaultFont.Size/2;
for i:=0 to FColumnList.Count-1 do
begin
colIndex := TColumnData(FColumnList[i]).Col;

349
components/fpspreadsheet/fpspreadsheet.pas
View File

@@ -112,6 +112,7 @@ type
FComments: TsComments;
FMergedCells: TsMergedCells;
FHyperlinks: TsHyperlinks;
FImages: TFPList;
FRows, FCols: TIndexedAVLTree; // This lists contain only rows or cols with styles different from default
FActiveCellRow: Cardinal;
FActiveCellCol: Cardinal;
@@ -491,7 +492,20 @@ type
procedure UnmergeCells(ARow, ACol: Cardinal); overload;
procedure UnmergeCells(ARange: String); overload;
// Print ranges
{ Embedded images }
function CalcImageExtent(AIndex: Integer;
out ARow1, ACol1, ARow2, ACol2: Cardinal;
out ARowOffs1, AColOffs1, ARowOffs2, AColOffs2: Double;
out x, y, AWidth, AHeight: Double): Boolean;
function GetImage(AIndex: Integer): TsImage;
function GetImageCount: Integer;
procedure RemoveAllImages;
procedure RemoveImage(AIndex: Integer);
function WriteImage(ARow, ACol: Cardinal; AFileName: String;
AOffsetX: Integer = 0; AOffsetY: Integer = 0;
AScaleX: Double = 1.0; AScaleY: Double = 1.0): Integer;
{ Print ranges }
function AddPrintRange(ARow1, ACol1, ARow2, ACol2: Cardinal): Integer; overload;
function AddPrintRange(const ARange: TsCellRange): Integer; overload;
function GetPrintRange(AIndex: Integer): TsCellRange;
@@ -621,7 +635,6 @@ type
FWorksheets: TFPList;
FFormatID: TsSpreadFormatID;
FBuiltinFontCount: Integer;
//FPalette: array of TsColorValue;
FVirtualColCount: Cardinal;
FVirtualRowCount: Cardinal;
FReadWriteFlag: TsReadWriteFlag;
@@ -637,7 +650,6 @@ type
FOnRemoveWorksheet: TsRemoveWorksheetEvent;
FOnRemovingWorksheet: TsWorksheetEvent;
FOnSelectWorksheet: TsWorksheetEvent;
// FOnChangePalette: TNotifyEvent;
FFileName: String;
FLockCount: Integer;
FLog: TStringList;
@@ -655,6 +667,7 @@ type
FFontList: TFPList;
FNumFormatList: TFPList;
FCellFormatList: TsCellFormatList;
FEmbeddedStreamList: TFPList;
{ Internal methods }
class function GetFormatFromFileHeader(const AFileName: TFileName;
@@ -764,6 +777,13 @@ type
AOperation: TsCopyOperation; AParams: TsStreamParams = [];
ATransposed: Boolean = false);
{ Embedded images }
function AddEmbeddedStream(const AName: String): Integer;
function FindEmbeddedStream(const AName: String): Integer;
function GetEmbeddedStream(AIndex: Integer): TsEmbeddedStream;
function GetEmbeddedStreamCount: Integer;
procedure RemoveAllEmbeddedStreams;
{ Utilities }
procedure DisableNotifications;
procedure EnableNotifications;
@@ -821,7 +841,7 @@ uses
Math, StrUtils, DateUtils, TypInfo, lazutf8, lazFileUtils, URIParser,
fpsStrings, uvirtuallayer_ole,
fpsUtils, fpsHTMLUtils, fpsRegFileFormats, fpsReaderWriter,
fpsCurrency, fpsExprParser, fpsNumFormatParser;
fpsCurrency, fpsExprParser, fpsNumFormatParser, fpsImages;
(*
const
@@ -1006,6 +1026,7 @@ begin
FComments := TsComments.Create;
FMergedCells := TsMergedCells.Create;
FHyperlinks := TsHyperlinks.Create;
FImages := TFPList.Create;
InitPageLayout(PageLayout);
@@ -1031,6 +1052,7 @@ end;
-------------------------------------------------------------------------------}
destructor TsWorksheet.Destroy;
begin
RemoveAllImages;
RemoveAllRows;
RemoveAllCols;
@@ -1040,6 +1062,7 @@ begin
FComments.Free;
FMergedCells.Free;
FHyperlinks.Free;
FImages.Free;
inherited Destroy;
end;
@@ -3293,6 +3316,172 @@ begin
Result := (ACell <> nil) and (cfMerged in ACell^.Flags);
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;
{@@ ----------------------------------------------------------------------------
Calculates image extent
@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, in mm
@param AColOffs1 Distance between the left edge of image and column 1, in mm
@param ARowOffs2 Distance between the bottom edge of image and top of row 2, in mm
@param AColOffs2 Distance between the right edge of image and left of col 2, in mm
@param x Absolute coordinate of left edge of image, in mm
@param y Absolute coordinate of top edge of image, in mm
@param AWidth Width of the image, in mm
@param AHeight Height of the image, in mm
@return FALSE if the image stream cannot be read or the format is unsupported.
-------------------------------------------------------------------------------}
function TsWorksheet.CalcImageExtent(AIndex: Integer;
out ARow1, ACol1, ARow2, ACol2: Cardinal;
out ARowOffs1, AColOffs1, ARowOffs2, AColOffs2: Double;
out x,y, AWidth, AHeight: Double): Boolean; // mm
var
img: TsImage;
stream: TsEmbeddedStream;
colW, rowH: Double;
totH, totW: Double;
r, c: Integer;
factor: Double;
begin
img := GetImage(AIndex);
ARow1 := img.Row;
ACol1 := img.Col;
ARowOffs1 := img.OffsetX; // millimeters
AColOffs1 := img.OffsetY;
stream := FWorkbook.GetEmbeddedStream(img.Index);
Result := GetImageSize(stream, ExtractFileExt(stream.Name), AWidth, AHeight); // in inches!
AWidth := inToMM(AWidth); // in millimeters now
AHeight := inToMM(AHeight);
// Find x coordinate of left image edge, in inches.
factor := FWorkbook.GetDefaultFont.Size/2; // Width of "0" character in pts
x := AColOffs1;
for c := 0 to ACol1-1 do
begin
colW := ptsToMM(GetColWidth(c) * factor); // in mm
x := x + colW;
end;
// Find cell with right image edge. Find horizontal within-cell-offsets
totW := -AColOffs1;
ACol2 := ACol1;
while (totW < AWidth) do
begin
colW := ptsToMM(GetColWidth(ACol2) * factor);
totW := totW + colW;
if totW >= AWidth then
begin
AColOffs2 := colW - (totW - AWidth);
break;
end;
inc(ACol2);
end;
// Find y coordinate of top image edge, in inches.
factor := FWorkbook.GetDefaultFont.Size; // Height of line in pts
y := ARowOffs1;
for r := 0 to ARow1 - 1 do
begin
rowH := ptsToMM(CalcAutoRowHeight(r) * factor); // row height in mm
y := y + rowH;
end;
// Find cell with bottom image edge. Find vertical within-cell-offsets
totH := -ARowOffs1;
ARow2 := ARow1;
while (totH < AHeight) do
begin
rowH := ptsToMM(CalcAutoRowHeight(ARow2) * factor);
totH := totH + rowH;
if totH >= AHeight then
begin
ARowOffs2 := rowH - (totH - AHeight);
break;
end;
inc(ARow2);
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 by this pixel count from
the left edge of the anchor cell. May reach into another
cell.
@param AOffsetY The image is offset vertically by this pixel count from the
top edge of the anchor cell. May reach into another cell.
@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: Integer = 0; AOffsetY: Integer = 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 := Workbook.FindEmbeddedStream(AFileName);
if img^.Index = -1 then begin
img^.Index := Workbook.AddEmbeddedStream(AFileName);
Workbook.GetEmbeddedStream(img^.Index).LoadFromFile(AFileName);
end;
FImages.Add(img);
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]);
Dispose(img);
FImages.Delete(AIndex);
end;
procedure TsWorksheet.RemoveAllImages;
var
i: Integer;
begin
for i := FImages.Count-1 downto 0 do
RemoveImage(i);
end;
{@@ ----------------------------------------------------------------------------
Adds a print range defined by the row/column indexes of its corner cells.
-------------------------------------------------------------------------------}
@@ -5928,7 +6117,7 @@ end;
Calculates the optimum height of a given row. Depends on the font size
of the individual cells in the row.
@param ARow Index of the row to be considered
@param ARow Index of the row to be considered
@return Row height in line count of the default font.
-------------------------------------------------------------------------------}
function TsWorksheet.CalcAutoRowHeight(ARow: Cardinal): Single;
@@ -5940,15 +6129,16 @@ begin
h0 := Workbook.GetDefaultFontSize;
for cell in Cells.GetRowEnumerator(ARow) do
Result := Max(Result, ReadCellFont(cell).Size / h0);
if Result = 0 then
Result := DefaultRowHeight;
end;
{@@ ----------------------------------------------------------------------------
Checks if a row record exists for the given row index and returns a pointer
to the row record, or nil if not found
@param ARow Index of the row looked for
@return Pointer to the row record with this row index, or nil if not
found
@param ARow Index of the row looked for
@return Pointer to the row record with this row index, or nil if not found
-------------------------------------------------------------------------------}
function TsWorksheet.FindRow(ARow: Cardinal): PRow;
var
@@ -6696,6 +6886,7 @@ begin
FNumFormatList := TsNumFormatList.Create(FormatSettings, true);
FCellFormatList := TsCellFormatList.Create(false);
FEmbeddedStreamList := TFPList.Create;
// Add default cell format
InitFormatRecord(fmt);
@@ -6708,13 +6899,17 @@ end;
destructor TsWorkbook.Destroy;
begin
RemoveAllWorksheets;
RemoveAllFonts;
FWorksheets.Free;
FCellFormatList.Free;
FNumFormatList.Free;
RemoveAllFonts;
FFontList.Free;
RemoveAllEmbeddedStreams;
FEmbeddedStreamList.Free;
FLog.Free;
FreeAndNil(FSearchEngine);
@@ -8204,89 +8399,64 @@ begin
end;
end;
(*
{@@ ----------------------------------------------------------------------------
Adds a color to the palette and returns its palette index, but only if the
color does not already exist - in this case, it returns the index of the
existing color entry.
The color must in little-endian notation (like TColor of the graphics units)
@param AColorValue Number containing the rgb code of the color to be added
@return Index of the new (or already existing) color item
Creates a new stream with the specified name, adds it to the internal list
and returns its index.
Embedded streams are used to store embedded images. AName is normally the
filename of the image. The image will be loaded to the stream later.
-------------------------------------------------------------------------------}
function TsWorkbook.AddColorToPalette(AColorValue: TsColorValue): TsColor;
var
n: Integer;
function TsWorkbook.AddEmbeddedStream(const AName: String): Integer;
begin
n := Length(FPalette);
// Look look for the color. Is it already in the existing palette?
if n > 0 then
for Result := 0 to n-1 do
if FPalette[Result] = AColorValue then
exit;
// No --> Add it to the palette.
// Do not overwrite Excel's built-in system colors
case n of
DEF_FOREGROUND_COLOR:
begin
SetLength(FPalette, n+3);
FPalette[n] := DEF_FOREGROUND_COLORVALUE;
FPalette[n+1] := DEF_BACKGROUND_COLORVALUE;
FPalette[n+2] := AColorValue;
end;
DEF_BACKGROUND_COLOR:
begin
SetLength(FPalette, n+2);
FPalette[n] := DEF_BACKGROUND_COLORVALUE;
FPalette[n+1] := AColorValue;
end;
DEF_CHART_FOREGROUND_COLOR:
begin
SetLength(FPalette, n+4);
FPalette[n] := DEF_CHART_FOREGROUND_COLORVALUE;
FPalette[n+1] := DEF_CHART_BACKGROUND_COLORVALUE;
FPalette[n+2] := DEF_CHART_NEUTRAL_COLORVALUE;
FPalette[n+3] := AColorValue;
end;
DEF_CHART_BACKGROUND_COLOR:
begin
SetLength(FPalette, n+3);
FPalette[n] := DEF_CHART_BACKGROUND_COLORVALUE;
FPalette[n+1] := DEF_CHART_NEUTRAL_COLORVALUE;
FPalette[n+2] := AColorValue;
end;
DEF_CHART_NEUTRAL_COLOR:
begin
SetLength(FPalette, n+2);
FPalette[n] := DEF_CHART_NEUTRAL_COLORVALUE;
FPalette[n+1] := AColorValue;
end;
DEF_TOOLTIP_TEXT_COLOR:
begin
SetLength(FPalette, n+2);
FPalette[n] := DEF_TOOLTIP_TEXT_COLORVALUE;
FPalette[n+1] := AColorValue;
end;
DEF_FONT_AUTOMATIC_COLOR:
begin
SetLength(FPalette, n+2);
FPalette[n] := DEF_FONT_AUTOMATIC_COLORVALUE;
FPalette[n+1] := AColorValue;
end;
else
begin
SetLength(FPalette, n+1);
FPalette[n] := AColorValue;
end;
end;
Result := Length(FPalette) - 1;
if Assigned(FOnChangePalette) then FOnChangePalette(self);
Result := FEmbeddedStreamList.Add(TsEmbeddedStream.Create(AName));
end;
*)
{@@ ----------------------------------------------------------------------------
Checks whether an embedded stream with the specified name already exists.
If yes, returns its index in the stream list, or -1 if no.
-------------------------------------------------------------------------------}
function TsWorkbook.FindEmbeddedStream(const AName: String): Integer;
var
stream: TsEmbeddedStream;
begin
for Result:=0 to FEmbeddedStreamList.Count-1 do
begin
stream := TsEmbeddedStream(FEmbeddedStreamList[Result]);
if stream.Name = AName then
exit;
end;
Result := -1;
end;
{@@ ----------------------------------------------------------------------------
Returns the embedded stream stored in the embedded stream list at the
specified index.
-------------------------------------------------------------------------------}
function TsWorkbook.GetEmbeddedStream(AIndex: Integer): TsEmbeddedStream;
begin
Result := TsEmbeddedStream(FEmbeddedStreamList[AIndex]);
end;
{@@ ----------------------------------------------------------------------------
Returns the count of embedded streams
-------------------------------------------------------------------------------}
function TsWorkbook.GetEmbeddedStreamCount: Integer;
begin
Result := FEmbeddedStreamList.Count;
end;
{@@ ----------------------------------------------------------------------------
Removes all embedded streams
-------------------------------------------------------------------------------}
procedure TsWorkbook.RemoveAllEmbeddedStreams;
var
i: Integer;
begin
for i:= 0 to FEmbeddedStreamList.Count-1 do
TsEmbeddedStream(FEmbeddedStreamList[i]).Free;
FEmbeddedStreamList.Clear;
end;
{@@ ----------------------------------------------------------------------------
Adds a (simple) error message to an internal list
@@ -8516,3 +8686,4 @@ end;
*)
end. {** End Unit: fpspreadsheet }

10
components/fpspreadsheet/fpsstreams.pas
View File

@@ -46,6 +46,7 @@ type
procedure ResetStream(var AStream: TStream);
implementation
uses
@@ -58,7 +59,12 @@ begin
AStream.Position := 0;
end;
{@@
{==============================================================================}
{ TBufStream }
{==============================================================================}
{@@ ----------------------------------------------------------------------------
Constructor of the TBufStream. Creates a memory stream and prepares everything
to create also a file stream if the stream size exceeds ABufSize bytes.
@@ -70,7 +76,7 @@ end;
is destroyed.
@param ABufSize Maximum size of the memory stream before swapping to file
starts. Value is given in bytes.
}
-------------------------------------------------------------------------------}
constructor TBufStream.Create(ATempFile: String; AKeepFile: Boolean = false;
ABufSize: Cardinal = Cardinal(-1));
begin

9
components/fpspreadsheet/fpstypes.pas
View File

@@ -774,6 +774,15 @@ type
TsStreamParam = (spClipboard, spWindowsClipboardHTML);
TsStreamParams = set of TsStreamParam;
{@@ Embedded image }
TsImage = record
Row, Col: Cardinal;
Index: Integer;
OffsetX, OffsetY: Double; // mm
ScaleX, ScaleY: Double;
end;
PsImage = ^TsImage;
implementation

77
components/fpspreadsheet/fpsutils.pas
View File

@@ -119,18 +119,22 @@ function TryStrToFloatAuto(AText: String; out ANumber: Double;
function TryFractionStrToFloat(AText: String; out ANumber: Double;
out AIsMixed: Boolean; out AMaxDigits: Integer): Boolean;
function TwipsToPts(AValue: Integer): Single; inline;
function PtsToTwips(AValue: Single): Integer; inline;
function cmToPts(AValue: Double): Double; inline;
function PtsToCm(AValue: Double): Double; inline;
function EMUToIn(AValue: Int64): Double; inline;
function EMUToMM(AValue: Int64): Double; inline;
function InToEMU(AValue: Double): Int64; inline;
function InToMM(AValue: Double): Double; inline;
function InToPts(AValue: Double): Double; inline;
function PtsToIn(AValue: Double): Double; inline;
function mmToEMU(AValue: Double): Int64; inline;
function mmToPts(AValue: Double): Double; inline;
function mmToIn(AValue: Double): Double; inline;
function PtsToCm(AValue: Double): Double; inline;
function PtsToIn(AValue: Double): Double; inline;
function PtsToTwips(AValue: Single): Integer; inline;
function PtsToMM(AValue: Double): Double; inline;
function pxToPts(AValue, AScreenPixelsPerInch: Integer): Double; inline;
function PtsToPx(AValue: Double; AScreenPixelsPerInch: Integer): Integer; inline;
function pxToPts(AValue, AScreenPixelsPerInch: Integer): Double; inline;
function TwipsToPts(AValue: Integer): Single; inline;
function HTMLLengthStrToPts(AValue: String; DefaultUnits: String = 'pt'): Double;
function ColorToHTMLColorStr(AValue: TsColor; AExcelDialect: Boolean = false): String;
@@ -157,6 +161,8 @@ procedure FixHyperlinkPathDelims(var ATarget: String);
procedure InitCell(out ACell: TCell); overload;
procedure InitCell(ARow, ACol: Cardinal; out ACell: TCell); overload;
procedure InitFormatRecord(out AValue: TsCellFormat);
procedure InitImageRecord(out AValue: TsImage; ARow, ACol: Cardinal;
AOffsetX, AOffsetY, AScaleX, AScaleY: Double);
procedure InitPageLayout(out APageLayout: TsPageLayout);
procedure CopyCellValue(AFromCell, AToCell: PCell);
@@ -1555,6 +1561,29 @@ begin
Result := AValue / 72 * 2.54;
end;
{@@ ----------------------------------------------------------------------------
Converts inches to EMU (English metric units)
@param AValue Length value in inches
@return Value converted to EMU
-------------------------------------------------------------------------------}
function InToEMU(AValue: Double): Int64;
begin
Result := Round(AValue * 914400);
end;
{@@ ----------------------------------------------------------------------------
Converts EMU (English metric units) to inches
@param AValue Length value in EMU
@return Value converted to inches
-------------------------------------------------------------------------------}
function EMUToIn(AValue: Int64): Double;
begin
Result := Round(AValue / 914400);
end;
{@@ ----------------------------------------------------------------------------
Converts inches to millimeters
@@ -1599,6 +1628,28 @@ begin
Result := AValue / 72;
end;
{@@ ----------------------------------------------------------------------------
Converts EMU to millimeters
@param AValue Length value in EMU (1 cm = 360000 EMU)
@return Value converted to millimeters
-------------------------------------------------------------------------------}
function EMUToMM(AValue: Int64): Double;
begin
Result := AValue / 36000;
end;
{@@ ----------------------------------------------------------------------------
Converts millimeters to EMU (english metric units, 1 cm = 360000 EMU)
@param AValue Length value in millimeters
@return Value converted to EMU
-------------------------------------------------------------------------------}
function mmToEMU(AValue: Double): Int64; inline;
begin
Result := round(AValue * 36000);
end;
{@@ ----------------------------------------------------------------------------
Converts millimeters to points (72 pts = 1 inch)
@@ -2024,6 +2075,21 @@ begin
AValue.NumberFormatIndex := -1; // GENERAL format not contained in NumFormatList
end;
{@@ ----------------------------------------------------------------------------
Initializes the fields of a TsImage record
-------------------------------------------------------------------------------}
procedure InitImageRecord(out AValue: TsImage; ARow, ACol: Cardinal;
AOffsetX, AOffsetY, AScaleX, AScaleY: Double);
begin
AValue.Row := ARow;
AValue.Col := ACol;
AValue.OffsetX := AOffsetX;
AValue.OffsetY := AOffsetY;
AValue.ScaleX := AScaleX;
AValue.ScaleY := AScaleY;
AValue.Index := -1;
end;
{@@ ----------------------------------------------------------------------------
Initializes the fields of a TsPageLayout record
-------------------------------------------------------------------------------}
@@ -2457,7 +2523,6 @@ begin
{$ENDIF}
end;
{$PUSH}{$HINTS OFF}
{@@ Silence warnings due to an unused parameter }
procedure Unused(const A1);

6
components/fpspreadsheet/laz_fpspreadsheet.lpk
View File

@@ -30,7 +30,7 @@
This package is all you need if you don't want graphical components (like grids and charts)."/>
<License Value="LGPL with static linking exception. This is the same license as is used in the LCL (Lazarus Component Library)."/>
<Version Major="1" Minor="7"/>
<Files Count="44">
<Files Count="45">
<Item1>
<Filename Value="fpolestorage.pas"/>
<UnitName Value="fpolestorage"/>
@@ -207,6 +207,10 @@ This package is all you need if you don't want graphical components (like grids
<Filename Value="fpsregfileformats.pas"/>
<UnitName Value="fpsRegFileFormats"/>
</Item44>
<Item45>
<Filename Value="fpsimages.pas"/>
<UnitName Value="fpsImages"/>
</Item45>
</Files>
<RequiredPkgs Count="2">
<Item1>

2
components/fpspreadsheet/laz_fpspreadsheet.pas
View File

@@ -15,7 +15,7 @@ uses
fpscsv, fpsCsvDocument, fpspatches, fpsTypes, xlsEscher, fpsReaderWriter,
fpsNumFormat, fpsclasses, fpsHeaderFooterParser, fpsPalette, fpsHTML,
fpsHTMLUtils, fpsCell, fpsSearch, xlsxml, xlsconst, fpsCurrency,
fpsRegFileFormats;
fpsRegFileFormats, fpsImages;
implementation

459
components/fpspreadsheet/xlsxooxml.pas
View File

@@ -131,6 +131,9 @@ type
procedure WriteComments(AWorksheet: TsWorksheet);
procedure WriteDefinedNames(AStream: TStream);
procedure WriteDimension(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteDrawings(AWorksheet: TsWorksheet);
procedure WriteDrawingsRels(AWorksheet: TsWorksheet);
procedure WriteDrawingsOfSheet(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteFillList(AStream: TStream);
procedure WriteFont(AStream: TStream; AFont: TsFont; UseInStyleNode: Boolean);
procedure WriteFontList(AStream: TStream);
@@ -147,6 +150,8 @@ type
procedure WriteSheetViews(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteStyleList(AStream: TStream; ANodeName: String);
procedure WriteVmlDrawings(AWorksheet: TsWorksheet);
procedure WriteWorkbook(AStream: TStream);
procedure WriteWorkbookRels(AStream: TStream);
procedure WriteWorksheet(AWorksheet: TsWorksheet);
procedure WriteWorksheetRels(AWorksheet: TsWorksheet);
protected
@@ -158,9 +163,12 @@ type
FSStyles: TStream;
FSSharedStrings: TStream;
FSSharedStrings_complete: TStream;
FSMedia: array of TStream;
FSSheets: array of TStream;
FSSheetRels: array of TStream;
FSComments: array of TStream;
FSDrawings: array of TStream;
FSDrawingsRels: array of TStream;
FSVmlDrawings: array of TStream;
FCurSheetNum: Integer;
protected
@@ -168,6 +176,7 @@ type
procedure WriteContent;
procedure WriteContentTypes;
procedure WriteGlobalFiles;
procedure WriteMedia(AZip: TZipper);
protected
{ Record writing methods }
//todo: add WriteDate
@@ -234,7 +243,9 @@ const
OOXML_PATH_XL_WORKSHEETS = 'xl/worksheets/';
OOXML_PATH_XL_WORKSHEETS_RELS = 'xl/worksheets/_rels/';
OOXML_PATH_XL_DRAWINGS = 'xl/drawings/';
OOXML_PATH_XL_DRAWINGS_RELS = 'xl/drawings/_rels/';
OOXML_PATH_XL_THEME = 'xl/theme/theme1.xml';
OOXML_PATH_XL_MEDIA = 'xl/media/';
{ OOXML schemas constants }
SCHEMAS_TYPES = 'http://schemas.openxmlformats.org/package/2006/content-types';
@@ -260,6 +271,7 @@ const
MIME_STYLES = MIME_SPREADML + '.styles+xml';
MIME_STRINGS = MIME_SPREADML + '.sharedStrings+xml';
MIME_COMMENTS = MIME_SPREADML + '.comments+xml';
MIME_DRAWING = MIME_OFFICEDOCUMENT + '.drawing+xml'; // 'application/vnd.openxmlformats-officedocument.drawing+xml
MIME_VMLDRAWING = MIME_OFFICEDOCUMENT + '.vmlDrawing';
LAST_PALETTE_INDEX = 63;
@@ -3128,7 +3140,8 @@ begin
end else
idx := 0; // "General" format is at index 0
s := s + Format('numFmtId="%d" applyNumberFormat="1" ', [idx]);
end;
end else
s := s + 'numFmtId="0" ';
{ Font }
fontId := 0;
@@ -3204,6 +3217,168 @@ begin
'</%s>', [ANodeName]));
end;
procedure TsSpreadOOXMLWriter.WriteDrawings(AWorksheet: TsWorksheet);
var
i: Integer;
img: TsImage;
r1, c1, r2, c2: Cardinal;
roffs1, coffs1, roffs2, coffs2: Double;
x, y, w, h: Double;
begin
if AWorksheet.GetImageCount= 0 then
exit;
SetLength(FSDrawings, FCurSheetNum + 1);
if boFileStream in FWorkbook.Options then
FSDrawings[FCurSheetNum] := TFileStream.Create(GetTempFileName('', Format('fpsD%d', [FCurSheetNum])), fmCreate)
else
if boBufStream in FWorkbook.Options then
FSDrawings[FCurSheetNum] := TBufStream.Create(GetTempFileName('', Format('fpsD%d', [FCurSheetNum])))
else
FSDrawings[FCurSheetNum] := TMemoryStream.Create;
// Header
AppendToStream(FSDrawings[FCurSheetNum],
XML_HEADER,
'<xdr:wsDr xmlns:xdr="http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing" '+
'xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main">');
// Repeat for each image
for i:=0 to AWorksheet.GetImageCount - 1 do
begin
img := AWorksheet.GetImage(i);
if not AWorksheet.CalcImageExtent(i,
r1, c1, r2, c2,
roffs1, coffs1, roffs2, coffs2, // mm
x, y, w, h) // mm
then begin
FWorkbook.AddErrorMsg('Failure reading image "%s"', [FWorkbook.GetEmbeddedStream(img.Index).Name]);
continue;
end;
AppendToStream(FSDrawings[FCurSheetNum],
'<xdr:twoCellAnchor editAs="oneCell">');
AppendToStream(FSDrawings[FCurSheetNum], Format(
'<xdr:from>'+
'<xdr:col>%d</xdr:col>' +
'<xdr:colOff>%d</xdr:colOff>'+
'<xdr:row>%d</xdr:row>'+
'<xdr:rowOff>%d</xdr:rowOff>'+
'</xdr:from>', [
c1, mmToEMU(coffs1),
r1, mmToEMU(roffs1)
]));
AppendToStream(FSDrawings[FCurSheetNum], Format(
'<xdr:to>'+
'<xdr:col>%d</xdr:col>'+
'<xdr:colOff>%d</xdr:colOff>'+
'<xdr:row>%d</xdr:row>'+
'<xdr:rowOff>%d</xdr:rowOff>'+
'</xdr:to>', [
c2, mmToEMU(coffs2),
r2, mmToEMU(roffs2)
]));
AppendToStream(FSDrawings[FCurSheetNum], Format(
'<xdr:pic>'+
'<xdr:nvPicPr>'+
'<xdr:cNvPr id="%d" name="Grafik %d" descr="%s"/>'+ // 1, 2, orig file name
'<xdr:cNvPicPr>'+
'<a:picLocks noChangeAspect="1"/>'+
'</xdr:cNvPicPr>'+
'</xdr:nvPicPr>'+
'<xdr:blipFill>'+
'<a:blip xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" r:embed="rId%d" cstate="print"/>'+ // 1
'<a:stretch>'+
'<a:fillRect/>'+
'</a:stretch>'+
'</xdr:blipFill>'+
'<xdr:spPr>' +
'<a:xfrm>'+
'<a:off x="%d" y="%d"/>' +
'<a:ext cx="%d" cy="%d"/>' + // size in EMU
'</a:xfrm>'+
'<a:prstGeom prst="rect">'+
'<a:avLst/>'+
'</a:prstGeom>'+
'</xdr:spPr>'+
'</xdr:pic>' +
'<xdr:clientData/>', [
i+2, i+1, ExtractFilename(Workbook.GetEmbeddedStream(img.Index).Name),
i+1,
mmToEMU(x), mmToEMU(y),
mmToEMU(w), mmToEMU(h)
]));
AppendToStream(FSDrawings[FCurSheetNum],
'</xdr:twoCellAnchor>');
end;
AppendToStream(FSDrawings[FCurSheetNum],
'</xdr:wsDr>');
end;
procedure TsSpreadOOXMLWriter.WriteDrawingsRels(AWorksheet: TsWorksheet);
var
i: Integer;
img: TsImage;
ext: String;
begin
if AWorksheet.GetImageCount= 0 then
exit;
SetLength(FSDrawingsRels, FCurSheetNum + 1);
if boFileStream in FWorkbook.Options then
FSDrawingsRels[FCurSheetNum] := TFileStream.Create(GetTempFileName('', Format('fpsDR%d', [FCurSheetNum])), fmCreate)
else
if boBufStream in FWorkbook.Options then
FSDrawingsRels[FCurSheetNum] := TBufStream.Create(GetTempFileName('', Format('fpsDR%d', [FCurSheetNum])))
else
FSDrawingsRels[FCurSheetNum] := TMemoryStream.Create;
// Header
AppendToStream(FSDrawingsRels[FCurSheetNum],
XML_HEADER,
'<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">');
// Repeat for each image
for i:=0 to AWorksheet.GetImageCount - 1 do
begin
img := AWorksheet.GetImage(i);
ext := ExtractFileExt(FWorkbook.GetEmbeddedStream(i).Name);
AppendToStream(FSDrawingsRels[FCurSheetNum], Format(
'<Relationship Id="rId%d" '+
'Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/image" '+
'Target="../media/image%d%s"/>', [
i+1, i+1, ext
]));
end;
AppendToStream(FSDrawingsRels[FCurSheetNum],
'</Relationships>');
end;
procedure TsSpreadOOXMLWriter.WriteDrawingsOfSheet(AStream: TStream;
AWorksheet: TsWorksheet);
var
i: Integer;
AVLNode: TAVLTreeNode;
hyperlink: PsHyperlink;
target, bookmark: String;
begin
// Keep in sync with WriteWorksheetRels !
FNext_rID := IfThen(AWorksheet.Comments.Count = 0, 1, 3);
AVLNode := AWorksheet.Hyperlinks.FindLowest;
while AVLNode <> nil do begin
inc(FNext_rID);
AVLNode := AWorksheet.Hyperlinks.FindSuccessor(AVLNode);
end;
for i:=0 to AWorksheet.GetImageCount-1 do
begin
AppendToStream(AStream, Format(
'<drawing r:id="rId%d" />', [FNext_rId]));
inc(FNext_rId);
end;
end;
procedure TsSpreadOOXMLWriter.WriteVmlDrawings(AWorksheet: TsWorksheet);
// My xml viewer does not format vml files property --> format in code.
var
@@ -3283,12 +3458,15 @@ var
hyperlink: PsHyperlink;
s: String;
target, bookmark: String;
i: Integer;
begin
// Extend stream array
SetLength(FSSheetRels, FCurSheetNum + 1);
// Anything to write?
if (AWorksheet.Comments.Count = 0) and (AWorksheet.Hyperlinks.Count = 0) then
if (AWorksheet.Comments.Count = 0) and (AWorksheet.Hyperlinks.Count = 0) and
(AWorksheet.GetImageCount = 0)
then
exit;
// Create stream
@@ -3332,7 +3510,6 @@ begin
begin
if (pos('file:', target) = 0) and FileNameIsAbsolute(target) then
FileNameToURI(target);
// target := 'file:///' + target;
s := Format('Id="rId%d" Type="%s" Target="%s" TargetMode="External"',
[FNext_rId, SCHEMAS_HYPERLINKS, target]);
AppendToStream(FSSheetRels[FCurSheetNum],
@@ -3343,6 +3520,18 @@ begin
end;
end;
// Relationships for embedded images
for i:= 0 to AWorksheet.GetImageCount-1 do
begin
AppendToStream(FSSheetrels[FCurSheetNum], Format(
'<Relationship Id="rId%d" '+
'Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/drawing" '+
'Target="../drawings/drawing%d.xml"/>', [
FNext_rID, i+1
]));
inc(FNext_rId);
end;
// Footer
AppendToStream(FSSheetRels[FCurSheetNum],
'</Relationships>');
@@ -3409,75 +3598,49 @@ begin
'</styleSheet>');
end;
{ Write folder "media" with embedded streams }
procedure TsSpreadOOXMLWriter.WriteMedia(AZip: TZipper);
var
i: Integer;
embStream: TsEmbeddedStream;
embName: String;
begin
for i:=0 to FWorkbook.GetEmbeddedStreamCount-1 do
begin
embStream := FWorkbook.GetEmbeddedStream(i);
embStream.Position := 0;
embName := Format('image%d', [i+1]) + ExtractFileExt(embStream.Name);
AZip.Entries.AddFileEntry(embStream, OOXML_PATH_XL_MEDIA + embname);
end;
end;
{
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">
<Relationship Id="rId3" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet"
Target="worksheets/sheet3.xml"/>
<Relationship Id="rId2" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet"
Target="worksheets/sheet2.xml"/>
<Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet"
Target="worksheets/sheet1.xml"/>
<Relationship Id="rId5" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles"
Target="styles.xml"/>
<Relationship Id="rId4" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme"
Target="theme/theme1.xml"/>
</Relationships>
}
procedure TsSpreadOOXMLWriter.WriteContent;
var
i, counter: Integer;
actTab, sheetname: String;
i: Integer;
begin
{ --- WorkbookRels --- }
{ Workbook relations - Mark relation to all sheets }
counter := 0;
AppendToStream(FSWorkbookRels,
XML_HEADER);
AppendToStream(FSWorkbookRels,
'<Relationships xmlns="' + SCHEMAS_RELS + '">');
while counter <= Workbook.GetWorksheetCount do begin
inc(counter);
AppendToStream(FSWorkbookRels, Format(
'<Relationship Type="%s" Target="worksheets/sheet%d.xml" Id="rId%d" />',
[SCHEMAS_WORKSHEET, counter, counter]));
end;
AppendToStream(FSWorkbookRels, Format(
'<Relationship Id="rId%d" Type="%s" Target="styles.xml" />',
[counter+1, SCHEMAS_STYLES]));
AppendToStream(FSWorkbookRels, Format(
'<Relationship Id="rId%d" Type="%s" Target="sharedStrings.xml" />',
[counter+2, SCHEMAS_STRINGS]));
AppendToStream(FSWorkbookRels,
'</Relationships>');
{ --- Workbook --- }
{ Global workbook data - Mark all sheets }
actTab := IfThen(FWorkbook.ActiveWorksheet = nil, '',
'activeTab="' + IntToStr(FWorkbook.GetWorksheetIndex(FWOrkbook.ActiveWorksheet)) + '"');
WriteWorkbook(FSWorkbook);
AppendToStream(FSWorkbook,
XML_HEADER);
AppendToStream(FSWorkbook, Format(
'<workbook xmlns="%s" xmlns:r="%s">', [SCHEMAS_SPREADML, SCHEMAS_DOC_RELS]));
AppendToStream(FSWorkbook,
'<fileVersion appName="fpspreadsheet" />');
AppendToStream(FSWorkbook,
'<workbookPr defaultThemeVersion="124226" />');
AppendToStream(FSWorkbook,
'<bookViews>' +
'<workbookView xWindow="480" yWindow="90" windowWidth="15195" windowHeight="12525" ' + actTab + '/>' +
'</bookViews>');
AppendToStream(FSWorkbook,
'<sheets>');
for counter:=1 to Workbook.GetWorksheetCount do
begin
sheetname := UTF8TextToXMLText(Workbook.GetWorksheetByIndex(counter-1).Name);
AppendToStream(FSWorkbook, Format(
'<sheet name="%s" sheetId="%d" r:id="rId%d" />',
[sheetname, counter, counter]));
end;
AppendToStream(FSWorkbook,
'</sheets>');
WriteDefinedNames(FSWorkbook);
AppendToStream(FSWorkbook,
'<calcPr calcId="114210" />');
AppendToStream(FSWorkbook,
'</workbook>');
// Preparation for shared strings
{ Preparation for shared strings }
FSharedStringsCount := 0;
// Write all worksheets which fills also the shared strings.
// Also: write comments and related files
{ Write all worksheets which fills also the shared strings.
Also: write comments and related files }
FNext_rId := 1;
for i := 0 to Workbook.GetWorksheetCount - 1 do
begin
@@ -3485,23 +3648,35 @@ begin
WriteWorksheet(FWorksheet);
WriteComments(FWorksheet);
WriteVmlDrawings(FWorksheet);
WriteDrawings(FWorksheet);
WriteDrawingsRels(FWorksheet);
WriteWorksheetRels(FWorksheet);
end;
// Finalization of the shared strings document
AppendToStream(FSSharedStrings_complete,
XML_HEADER, Format(
'<sst xmlns="%s" count="%d" uniqueCount="%d">', [SCHEMAS_SPREADML, FSharedStringsCount, FSharedStringsCount]
));
ResetStream(FSSharedStrings);
FSSharedStrings_complete.CopyFrom(FSSharedStrings, FSSharedStrings.Size);
AppendToStream(FSSharedStrings_complete,
'</sst>');
{ Finalization of the shared strings document }
if FSharedStringsCount > 0 then
begin
AppendToStream(FSSharedStrings_complete,
XML_HEADER, Format(
'<sst xmlns="%s" count="%d" uniqueCount="%d">', [
SCHEMAS_SPREADML, FSharedStringsCount, FSharedStringsCount
]));
ResetStream(FSSharedStrings);
FSSharedStrings_complete.CopyFrom(FSSharedStrings, FSSharedStrings.Size);
AppendToStream(FSSharedStrings_complete,
'</sst>');
end;
{ Workbook relations - Mark relation to all sheets }
WriteWorkbookRels(FSWorkbookRels);
end;
procedure TsSpreadOOXMLWriter.WriteContentTypes;
var
i: Integer;
imgext: TStringList;
ext: String;
sheet: TsWorksheet;
begin
AppendToStream(FSContentTypes,
XML_HEADER);
@@ -3515,13 +3690,39 @@ begin
AppendToStream(FSContentTypes, Format(
'<Default Extension="vml" ContentType="%s" />', [MIME_VMLDRAWING]));
if Workbook.GetEmbeddedStreamCount > 0 then
begin
imgExt := TStringList.Create;
try
imgExt.Duplicates := dupIgnore;
for i:=0 to Workbook.GetEmbeddedStreamCount-1 do
begin
ext := ExtractFileExt(Workbook.GetEmbeddedStream(i).Name);
if ext[1] = '.' then Delete(ext, 1, 1);
imgExt.Add(ext);
end;
for i := 0 to imgExt.Count-1 do
AppendToStream(FSContentTypes, Format(
'<Default Extension="%s" ContentType="image/%s" />', [ext, ext]));
finally
imgExt.Free;
end;
end;
AppendToStream(FSContentTypes,
'<Override PartName="/xl/workbook.xml" ContentType="' + MIME_SHEET + '" />');
for i:=1 to Workbook.GetWorksheetCount do
begin
AppendToStream(FSContentTypes, Format(
'<Override PartName="/xl/worksheets/sheet%d.xml" ContentType="%s" />',
[i, MIME_WORKSHEET]));
sheet := Workbook.GetWorksheetByIndex(i-1);
if sheet.GetImageCount > 0 then
AppendToStream(FSContentTypes, Format(
'<Override PartName="/xl/drawings/drawing%d.xml" ContentType="%s"/>',
[i, MIME_DRAWING]));
end;
for i:=1 to Length(FSComments) do
AppendToStream(FSContentTypes, Format(
@@ -3606,6 +3807,80 @@ begin
'<definedNames>' + stotal + '</definedNames>');
end;
procedure TsSpreadOOXMLWriter.WriteWorkbook(AStream: TStream);
var
actTab: String;
sheetName: String;
counter: Integer;
begin
actTab := IfThen(FWorkbook.ActiveWorksheet = nil, '',
'activeTab="' + IntToStr(FWorkbook.GetWorksheetIndex(FWorkbook.ActiveWorksheet)) + '"');
AppendToStream(FSWorkbook,
XML_HEADER);
AppendToStream(FSWorkbook, Format(
'<workbook xmlns="%s" xmlns:r="%s">', [SCHEMAS_SPREADML, SCHEMAS_DOC_RELS]));
AppendToStream(FSWorkbook,
'<fileVersion appName="fpspreadsheet" />');
AppendToStream(FSWorkbook,
'<workbookPr defaultThemeVersion="124226" />');
AppendToStream(FSWorkbook,
'<bookViews>' +
'<workbookView xWindow="480" yWindow="90" windowWidth="15195" windowHeight="12525" ' + actTab + '/>' +
'</bookViews>');
AppendToStream(FSWorkbook,
'<sheets>');
for counter:=1 to Workbook.GetWorksheetCount do
begin
sheetname := UTF8TextToXMLText(Workbook.GetWorksheetByIndex(counter-1).Name);
AppendToStream(FSWorkbook, Format(
'<sheet name="%s" sheetId="%d" r:id="rId%d" />',
[sheetname, counter, counter]));
end;
AppendToStream(FSWorkbook,
'</sheets>');
WriteDefinedNames(FSWorkbook);
AppendToStream(FSWorkbook,
'<calcPr calcId="114210" />');
AppendToStream(FSWorkbook,
'</workbook>');
end;
procedure TsSpreadOOXMLWriter.WriteWorkbookRels(AStream: TStream);
var
counter: Integer;
begin
AppendToStream(FSWorkbookRels,
XML_HEADER,
'<Relationships xmlns="' + SCHEMAS_RELS + '">');
counter := 1;
while counter <= Workbook.GetWorksheetCount do begin
AppendToStream(FSWorkbookRels, Format(
'<Relationship Id="rId%d" Type="%s" Target="worksheets/sheet%d.xml" />',
[counter, SCHEMAS_WORKSHEET, counter]));
inc(counter);
end;
AppendToStream(FSWorkbookRels, Format(
'<Relationship Id="rId%d" Type="%s" Target="styles.xml" />',
[counter, SCHEMAS_STYLES]));
inc(counter);
if FSharedStringsCount > 0 then begin
AppendToStream(FSWorkbookRels, Format(
'<Relationship Id="rId%d" Type="%s" Target="sharedStrings.xml" />',
[counter, SCHEMAS_STRINGS]));
inc(counter);
end;
AppendToStream(FSWorkbookRels,
'</Relationships>');
end;
procedure TsSpreadOOXMLWriter.WriteWorksheet(AWorksheet: TsWorksheet);
begin
FCurSheetNum := Length(FSSheets);
@@ -3613,10 +3888,12 @@ begin
// Create the stream
if boFileStream in FWorkbook.Options then
FSSheets[FCurSheetNum] := TFileStream.Create(GetTempFileName('', Format('fpsSH%d', [FCurSheetNum])), fmCreate)
FSSheets[FCurSheetNum] := TFileStream.Create(GetTempFileName('',
Format('fpsSH%d', [FCurSheetNum])), fmCreate)
else
if (boBufStream in Workbook.Options) then
FSSheets[FCurSheetNum] := TBufStream.Create(GetTempFileName('', Format('fpsSH%d', [FCurSheetNum])))
FSSheets[FCurSheetNum] := TBufStream.Create(GetTempFileName('',
Format('fpsSH%d', [FCurSheetNum])))
else
FSSheets[FCurSheetNum] := TMemoryStream.Create;
@@ -3637,11 +3914,13 @@ begin
WritePageMargins(FSSheets[FCurSheetNum], AWorksheet);
WritePageSetup(FSSheets[FCurSheetNum], AWorksheet);
WriteHeaderFooter(FSSheets[FCurSheetNum], AWorksheet);
WriteDrawingsOfSheet(FSSheets[FCurSheetNum], AWorksheet);
// Footer
if AWorksheet.Comments.Count > 0 then
AppendToStream(FSSheets[FCurSheetNum],
'<legacyDrawing r:id="rId1" />');
// Footer
AppendToStream(FSSheets[FCurSheetNum],
'</worksheet>');
end;
@@ -3728,6 +4007,10 @@ begin
SetLength(FSSheetRels, 0);
for stream in FSVmlDrawings do DestroyStream(stream);
SetLength(FSVmlDrawings, 0);
for stream in FSDrawings do DestroyStream(stream);
SetLength(FSDrawings, 0);
for stream in FSDrawingsRels do DestroyStream(stream);
Setlength(FSDrawings, 0);
end;
{@@ ----------------------------------------------------------------------------
@@ -3758,6 +4041,8 @@ begin
for i:=0 to High(FSSheetRels) do ResetStream(FSSheetRels[i]);
for i:=0 to High(FSComments) do ResetStream(FSComments[i]);
for i:=0 to High(FSVmlDrawings) do ResetStream(FSVmlDrawings[i]);
for i:=0 to High(FSDrawings) do ResetStream(FSDrawings[i]);
for i:=0 to High(FSDrawingsRels) do ResetStream(FSDrawingsRels[i]);
end;
{@@ ----------------------------------------------------------------------------
@@ -3813,30 +4098,48 @@ begin
FZip.Entries.AddFileEntry(FSWorkbookRels, OOXML_PATH_XL_RELS_RELS);
FZip.Entries.AddFileEntry(FSWorkbook, OOXML_PATH_XL_WORKBOOK);
FZip.Entries.AddFileEntry(FSStyles, OOXML_PATH_XL_STYLES);
FZip.Entries.AddFileEntry(FSSharedStrings_complete, OOXML_PATH_XL_STRINGS);
if FSSharedStrings_complete.Size > 0 then
FZip.Entries.AddFileEntry(FSSharedStrings_complete, OOXML_PATH_XL_STRINGS);
// Write embedded images
WriteMedia(FZip);
// Write worksheets
for i:=0 to High(FSSheets) do begin
FSSheets[i].Position:= 0;
FZip.Entries.AddFileEntry(FSSheets[i], OOXML_PATH_XL_WORKSHEETS + Format('sheet%d.xml', [i+1]));
end;
// Write comments
for i:=0 to High(FSComments) do begin
if (FSComments[i] = nil) or (FSComments[i].Size = 0) then continue;
FSComments[i].Position := 0;
FZip.Entries.AddFileEntry(FSComments[i], OOXML_PATH_XL + Format('comments%d.xml', [i+1]));
end;
// Write worksheet relationships
for i:=0 to High(FSSheetRels) do begin
if (FSSheetRels[i] = nil) or (FSSheetRels[i].Size = 0) then continue;
FSSheetRels[i].Position := 0;
FZip.Entries.AddFileEntry(FSSheetRels[i], OOXML_PATH_XL_WORKSHEETS_RELS + Format('sheet%d.xml.rels', [i+1]));
end;
// Write drawings
for i:=0 to High(FSDrawings) do begin
if (FSDrawings[i] = nil) or (FSDrawings[i].Size = 0) then continue;
FSDrawings[i].Position := 0;
FZip.Entries.AddFileEntry(FSDrawings[i], OOXML_PATH_XL_DRAWINGS + Format('drawing%d.xml', [i+1]));
end;
for i:=0 to High(FSVmlDrawings) do begin
if (FSVmlDrawings[i] = nil) or (FSVmlDrawings[i].Size = 0) then continue;
FSVmlDrawings[i].Position := 0;
FZip.Entries.AddFileEntry(FSVmlDrawings[i], OOXML_PATH_XL_DRAWINGS + Format('vmlDrawing%d.vml', [i+1]));
end;
for i:=0 to High(FSDrawingsRels) do begin
if (FSDrawingsRels[i] = nil) or (FSDrawingsRels[i].Size = 0) then continue;
FSDrawingsRels[i].Position := 0;
FZip.Entries.AddFileEntry(FSDrawingsRels[i], OOXML_PATH_XL_DRAWINGS_RELS + Format('drawing%d.xml.rels', [i+1]));
end;
FZip.SaveToStream(AStream);