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).

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

View File

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

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.

View File

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

View File

@@ -112,6 +112,7 @@ type
FComments: TsComments; FComments: TsComments;
FMergedCells: TsMergedCells; FMergedCells: TsMergedCells;
FHyperlinks: TsHyperlinks; FHyperlinks: TsHyperlinks;
FImages: TFPList;
FRows, FCols: TIndexedAVLTree; // This lists contain only rows or cols with styles different from default FRows, FCols: TIndexedAVLTree; // This lists contain only rows or cols with styles different from default
FActiveCellRow: Cardinal; FActiveCellRow: Cardinal;
FActiveCellCol: Cardinal; FActiveCellCol: Cardinal;
@@ -491,7 +492,20 @@ type
procedure UnmergeCells(ARow, ACol: Cardinal); overload; procedure UnmergeCells(ARow, ACol: Cardinal); overload;
procedure UnmergeCells(ARange: String); 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(ARow1, ACol1, ARow2, ACol2: Cardinal): Integer; overload;
function AddPrintRange(const ARange: TsCellRange): Integer; overload; function AddPrintRange(const ARange: TsCellRange): Integer; overload;
function GetPrintRange(AIndex: Integer): TsCellRange; function GetPrintRange(AIndex: Integer): TsCellRange;
@@ -621,7 +635,6 @@ type
FWorksheets: TFPList; FWorksheets: TFPList;
FFormatID: TsSpreadFormatID; FFormatID: TsSpreadFormatID;
FBuiltinFontCount: Integer; FBuiltinFontCount: Integer;
//FPalette: array of TsColorValue;
FVirtualColCount: Cardinal; FVirtualColCount: Cardinal;
FVirtualRowCount: Cardinal; FVirtualRowCount: Cardinal;
FReadWriteFlag: TsReadWriteFlag; FReadWriteFlag: TsReadWriteFlag;
@@ -637,7 +650,6 @@ type
FOnRemoveWorksheet: TsRemoveWorksheetEvent; FOnRemoveWorksheet: TsRemoveWorksheetEvent;
FOnRemovingWorksheet: TsWorksheetEvent; FOnRemovingWorksheet: TsWorksheetEvent;
FOnSelectWorksheet: TsWorksheetEvent; FOnSelectWorksheet: TsWorksheetEvent;
// FOnChangePalette: TNotifyEvent;
FFileName: String; FFileName: String;
FLockCount: Integer; FLockCount: Integer;
FLog: TStringList; FLog: TStringList;
@@ -655,6 +667,7 @@ type
FFontList: TFPList; FFontList: TFPList;
FNumFormatList: TFPList; FNumFormatList: TFPList;
FCellFormatList: TsCellFormatList; FCellFormatList: TsCellFormatList;
FEmbeddedStreamList: TFPList;
{ Internal methods } { Internal methods }
class function GetFormatFromFileHeader(const AFileName: TFileName; class function GetFormatFromFileHeader(const AFileName: TFileName;
@@ -764,6 +777,13 @@ type
AOperation: TsCopyOperation; AParams: TsStreamParams = []; AOperation: TsCopyOperation; AParams: TsStreamParams = [];
ATransposed: Boolean = false); 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 } { Utilities }
procedure DisableNotifications; procedure DisableNotifications;
procedure EnableNotifications; procedure EnableNotifications;
@@ -821,7 +841,7 @@ uses
Math, StrUtils, DateUtils, TypInfo, lazutf8, lazFileUtils, URIParser, Math, StrUtils, DateUtils, TypInfo, lazutf8, lazFileUtils, URIParser,
fpsStrings, uvirtuallayer_ole, fpsStrings, uvirtuallayer_ole,
fpsUtils, fpsHTMLUtils, fpsRegFileFormats, fpsReaderWriter, fpsUtils, fpsHTMLUtils, fpsRegFileFormats, fpsReaderWriter,
fpsCurrency, fpsExprParser, fpsNumFormatParser; fpsCurrency, fpsExprParser, fpsNumFormatParser, fpsImages;
(* (*
const const
@@ -1006,6 +1026,7 @@ begin
FComments := TsComments.Create; FComments := TsComments.Create;
FMergedCells := TsMergedCells.Create; FMergedCells := TsMergedCells.Create;
FHyperlinks := TsHyperlinks.Create; FHyperlinks := TsHyperlinks.Create;
FImages := TFPList.Create;
InitPageLayout(PageLayout); InitPageLayout(PageLayout);
@@ -1031,6 +1052,7 @@ end;
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
destructor TsWorksheet.Destroy; destructor TsWorksheet.Destroy;
begin begin
RemoveAllImages;
RemoveAllRows; RemoveAllRows;
RemoveAllCols; RemoveAllCols;
@@ -1040,6 +1062,7 @@ begin
FComments.Free; FComments.Free;
FMergedCells.Free; FMergedCells.Free;
FHyperlinks.Free; FHyperlinks.Free;
FImages.Free;
inherited Destroy; inherited Destroy;
end; end;
@@ -3293,6 +3316,172 @@ begin
Result := (ACell <> nil) and (cfMerged in ACell^.Flags); Result := (ACell <> nil) and (cfMerged in ACell^.Flags);
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;
{@@ ----------------------------------------------------------------------------
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. 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 Calculates the optimum height of a given row. Depends on the font size
of the individual cells in the row. 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. @return Row height in line count of the default font.
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
function TsWorksheet.CalcAutoRowHeight(ARow: Cardinal): Single; function TsWorksheet.CalcAutoRowHeight(ARow: Cardinal): Single;
@@ -5940,15 +6129,16 @@ begin
h0 := Workbook.GetDefaultFontSize; h0 := Workbook.GetDefaultFontSize;
for cell in Cells.GetRowEnumerator(ARow) do for cell in Cells.GetRowEnumerator(ARow) do
Result := Max(Result, ReadCellFont(cell).Size / h0); Result := Max(Result, ReadCellFont(cell).Size / h0);
if Result = 0 then
Result := DefaultRowHeight;
end; end;
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
Checks if a row record exists for the given row index and returns a pointer Checks if a row record exists for the given row index and returns a pointer
to the row record, or nil if not found to the row record, or nil if not found
@param ARow Index of the row looked for @param ARow Index of the row looked for
@return Pointer to the row record with this row index, or nil if not @return Pointer to the row record with this row index, or nil if not found
found
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
function TsWorksheet.FindRow(ARow: Cardinal): PRow; function TsWorksheet.FindRow(ARow: Cardinal): PRow;
var var
@@ -6696,6 +6886,7 @@ begin
FNumFormatList := TsNumFormatList.Create(FormatSettings, true); FNumFormatList := TsNumFormatList.Create(FormatSettings, true);
FCellFormatList := TsCellFormatList.Create(false); FCellFormatList := TsCellFormatList.Create(false);
FEmbeddedStreamList := TFPList.Create;
// Add default cell format // Add default cell format
InitFormatRecord(fmt); InitFormatRecord(fmt);
@@ -6708,13 +6899,17 @@ end;
destructor TsWorkbook.Destroy; destructor TsWorkbook.Destroy;
begin begin
RemoveAllWorksheets; RemoveAllWorksheets;
RemoveAllFonts;
FWorksheets.Free; FWorksheets.Free;
FCellFormatList.Free; FCellFormatList.Free;
FNumFormatList.Free; FNumFormatList.Free;
RemoveAllFonts;
FFontList.Free; FFontList.Free;
RemoveAllEmbeddedStreams;
FEmbeddedStreamList.Free;
FLog.Free; FLog.Free;
FreeAndNil(FSearchEngine); FreeAndNil(FSearchEngine);
@@ -8204,89 +8399,64 @@ begin
end; end;
end; end;
(*
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
Adds a color to the palette and returns its palette index, but only if the Creates a new stream with the specified name, adds it to the internal list
color does not already exist - in this case, it returns the index of the and returns its index.
existing color entry. Embedded streams are used to store embedded images. AName is normally the
The color must in little-endian notation (like TColor of the graphics units) filename of the image. The image will be loaded to the stream later.
@param AColorValue Number containing the rgb code of the color to be added
@return Index of the new (or already existing) color item
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
function TsWorkbook.AddColorToPalette(AColorValue: TsColorValue): TsColor; function TsWorkbook.AddEmbeddedStream(const AName: String): Integer;
var
n: Integer;
begin begin
n := Length(FPalette); Result := FEmbeddedStreamList.Add(TsEmbeddedStream.Create(AName));
// 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);
end; 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 Adds a (simple) error message to an internal list
@@ -8516,3 +8686,4 @@ end;
*) *)
end. {** End Unit: fpspreadsheet } end. {** End Unit: fpspreadsheet }

View File

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

View File

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

View File

@@ -119,18 +119,22 @@ function TryStrToFloatAuto(AText: String; out ANumber: Double;
function TryFractionStrToFloat(AText: String; out ANumber: Double; function TryFractionStrToFloat(AText: String; out ANumber: Double;
out AIsMixed: Boolean; out AMaxDigits: Integer): Boolean; 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 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 InToMM(AValue: Double): Double; inline;
function InToPts(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 mmToPts(AValue: Double): Double; inline;
function mmToIn(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 PtsToMM(AValue: Double): Double; inline;
function pxToPts(AValue, AScreenPixelsPerInch: Integer): Double; inline;
function PtsToPx(AValue: Double; AScreenPixelsPerInch: Integer): Integer; 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 HTMLLengthStrToPts(AValue: String; DefaultUnits: String = 'pt'): Double;
function ColorToHTMLColorStr(AValue: TsColor; AExcelDialect: Boolean = false): String; 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(out ACell: TCell); overload;
procedure InitCell(ARow, ACol: Cardinal; out ACell: TCell); overload; procedure InitCell(ARow, ACol: Cardinal; out ACell: TCell); overload;
procedure InitFormatRecord(out AValue: TsCellFormat); procedure InitFormatRecord(out AValue: TsCellFormat);
procedure InitImageRecord(out AValue: TsImage; ARow, ACol: Cardinal;
AOffsetX, AOffsetY, AScaleX, AScaleY: Double);
procedure InitPageLayout(out APageLayout: TsPageLayout); procedure InitPageLayout(out APageLayout: TsPageLayout);
procedure CopyCellValue(AFromCell, AToCell: PCell); procedure CopyCellValue(AFromCell, AToCell: PCell);
@@ -1555,6 +1561,29 @@ begin
Result := AValue / 72 * 2.54; Result := AValue / 72 * 2.54;
end; 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 Converts inches to millimeters
@@ -1599,6 +1628,28 @@ begin
Result := AValue / 72; Result := AValue / 72;
end; 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) Converts millimeters to points (72 pts = 1 inch)
@@ -2024,6 +2075,21 @@ begin
AValue.NumberFormatIndex := -1; // GENERAL format not contained in NumFormatList AValue.NumberFormatIndex := -1; // GENERAL format not contained in NumFormatList
end; 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 Initializes the fields of a TsPageLayout record
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
@@ -2457,7 +2523,6 @@ begin
{$ENDIF} {$ENDIF}
end; end;
{$PUSH}{$HINTS OFF} {$PUSH}{$HINTS OFF}
{@@ Silence warnings due to an unused parameter } {@@ Silence warnings due to an unused parameter }
procedure Unused(const A1); procedure Unused(const A1);

View File

@@ -30,7 +30,7 @@
This package is all you need if you don't want graphical components (like grids and charts)."/> 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)."/> <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"/> <Version Major="1" Minor="7"/>
<Files Count="44"> <Files Count="45">
<Item1> <Item1>
<Filename Value="fpolestorage.pas"/> <Filename Value="fpolestorage.pas"/>
<UnitName Value="fpolestorage"/> <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"/> <Filename Value="fpsregfileformats.pas"/>
<UnitName Value="fpsRegFileFormats"/> <UnitName Value="fpsRegFileFormats"/>
</Item44> </Item44>
<Item45>
<Filename Value="fpsimages.pas"/>
<UnitName Value="fpsImages"/>
</Item45>
</Files> </Files>
<RequiredPkgs Count="2"> <RequiredPkgs Count="2">
<Item1> <Item1>

View File

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

View File

@@ -131,6 +131,9 @@ type
procedure WriteComments(AWorksheet: TsWorksheet); procedure WriteComments(AWorksheet: TsWorksheet);
procedure WriteDefinedNames(AStream: TStream); procedure WriteDefinedNames(AStream: TStream);
procedure WriteDimension(AStream: TStream; AWorksheet: TsWorksheet); 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 WriteFillList(AStream: TStream);
procedure WriteFont(AStream: TStream; AFont: TsFont; UseInStyleNode: Boolean); procedure WriteFont(AStream: TStream; AFont: TsFont; UseInStyleNode: Boolean);
procedure WriteFontList(AStream: TStream); procedure WriteFontList(AStream: TStream);
@@ -147,6 +150,8 @@ type
procedure WriteSheetViews(AStream: TStream; AWorksheet: TsWorksheet); procedure WriteSheetViews(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteStyleList(AStream: TStream; ANodeName: String); procedure WriteStyleList(AStream: TStream; ANodeName: String);
procedure WriteVmlDrawings(AWorksheet: TsWorksheet); procedure WriteVmlDrawings(AWorksheet: TsWorksheet);
procedure WriteWorkbook(AStream: TStream);
procedure WriteWorkbookRels(AStream: TStream);
procedure WriteWorksheet(AWorksheet: TsWorksheet); procedure WriteWorksheet(AWorksheet: TsWorksheet);
procedure WriteWorksheetRels(AWorksheet: TsWorksheet); procedure WriteWorksheetRels(AWorksheet: TsWorksheet);
protected protected
@@ -158,9 +163,12 @@ type
FSStyles: TStream; FSStyles: TStream;
FSSharedStrings: TStream; FSSharedStrings: TStream;
FSSharedStrings_complete: TStream; FSSharedStrings_complete: TStream;
FSMedia: array of TStream;
FSSheets: array of TStream; FSSheets: array of TStream;
FSSheetRels: array of TStream; FSSheetRels: array of TStream;
FSComments: array of TStream; FSComments: array of TStream;
FSDrawings: array of TStream;
FSDrawingsRels: array of TStream;
FSVmlDrawings: array of TStream; FSVmlDrawings: array of TStream;
FCurSheetNum: Integer; FCurSheetNum: Integer;
protected protected
@@ -168,6 +176,7 @@ type
procedure WriteContent; procedure WriteContent;
procedure WriteContentTypes; procedure WriteContentTypes;
procedure WriteGlobalFiles; procedure WriteGlobalFiles;
procedure WriteMedia(AZip: TZipper);
protected protected
{ Record writing methods } { Record writing methods }
//todo: add WriteDate //todo: add WriteDate
@@ -234,7 +243,9 @@ const
OOXML_PATH_XL_WORKSHEETS = 'xl/worksheets/'; OOXML_PATH_XL_WORKSHEETS = 'xl/worksheets/';
OOXML_PATH_XL_WORKSHEETS_RELS = 'xl/worksheets/_rels/'; OOXML_PATH_XL_WORKSHEETS_RELS = 'xl/worksheets/_rels/';
OOXML_PATH_XL_DRAWINGS = 'xl/drawings/'; 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_THEME = 'xl/theme/theme1.xml';
OOXML_PATH_XL_MEDIA = 'xl/media/';
{ OOXML schemas constants } { OOXML schemas constants }
SCHEMAS_TYPES = 'http://schemas.openxmlformats.org/package/2006/content-types'; SCHEMAS_TYPES = 'http://schemas.openxmlformats.org/package/2006/content-types';
@@ -260,6 +271,7 @@ const
MIME_STYLES = MIME_SPREADML + '.styles+xml'; MIME_STYLES = MIME_SPREADML + '.styles+xml';
MIME_STRINGS = MIME_SPREADML + '.sharedStrings+xml'; MIME_STRINGS = MIME_SPREADML + '.sharedStrings+xml';
MIME_COMMENTS = MIME_SPREADML + '.comments+xml'; MIME_COMMENTS = MIME_SPREADML + '.comments+xml';
MIME_DRAWING = MIME_OFFICEDOCUMENT + '.drawing+xml'; // 'application/vnd.openxmlformats-officedocument.drawing+xml
MIME_VMLDRAWING = MIME_OFFICEDOCUMENT + '.vmlDrawing'; MIME_VMLDRAWING = MIME_OFFICEDOCUMENT + '.vmlDrawing';
LAST_PALETTE_INDEX = 63; LAST_PALETTE_INDEX = 63;
@@ -3128,7 +3140,8 @@ begin
end else end else
idx := 0; // "General" format is at index 0 idx := 0; // "General" format is at index 0
s := s + Format('numFmtId="%d" applyNumberFormat="1" ', [idx]); s := s + Format('numFmtId="%d" applyNumberFormat="1" ', [idx]);
end; end else
s := s + 'numFmtId="0" ';
{ Font } { Font }
fontId := 0; fontId := 0;
@@ -3204,6 +3217,168 @@ begin
'</%s>', [ANodeName])); '</%s>', [ANodeName]));
end; 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); procedure TsSpreadOOXMLWriter.WriteVmlDrawings(AWorksheet: TsWorksheet);
// My xml viewer does not format vml files property --> format in code. // My xml viewer does not format vml files property --> format in code.
var var
@@ -3283,12 +3458,15 @@ var
hyperlink: PsHyperlink; hyperlink: PsHyperlink;
s: String; s: String;
target, bookmark: String; target, bookmark: String;
i: Integer;
begin begin
// Extend stream array // Extend stream array
SetLength(FSSheetRels, FCurSheetNum + 1); SetLength(FSSheetRels, FCurSheetNum + 1);
// Anything to write? // 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; exit;
// Create stream // Create stream
@@ -3332,7 +3510,6 @@ begin
begin begin
if (pos('file:', target) = 0) and FileNameIsAbsolute(target) then if (pos('file:', target) = 0) and FileNameIsAbsolute(target) then
FileNameToURI(target); FileNameToURI(target);
// target := 'file:///' + target;
s := Format('Id="rId%d" Type="%s" Target="%s" TargetMode="External"', s := Format('Id="rId%d" Type="%s" Target="%s" TargetMode="External"',
[FNext_rId, SCHEMAS_HYPERLINKS, target]); [FNext_rId, SCHEMAS_HYPERLINKS, target]);
AppendToStream(FSSheetRels[FCurSheetNum], AppendToStream(FSSheetRels[FCurSheetNum],
@@ -3343,6 +3520,18 @@ begin
end; end;
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 // Footer
AppendToStream(FSSheetRels[FCurSheetNum], AppendToStream(FSSheetRels[FCurSheetNum],
'</Relationships>'); '</Relationships>');
@@ -3409,75 +3598,49 @@ begin
'</styleSheet>'); '</styleSheet>');
end; 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; procedure TsSpreadOOXMLWriter.WriteContent;
var var
i, counter: Integer; i: Integer;
actTab, sheetname: String;
begin 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 } { Global workbook data - Mark all sheets }
actTab := IfThen(FWorkbook.ActiveWorksheet = nil, '', WriteWorkbook(FSWorkbook);
'activeTab="' + IntToStr(FWorkbook.GetWorksheetIndex(FWOrkbook.ActiveWorksheet)) + '"');
AppendToStream(FSWorkbook, { Preparation for shared strings }
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
FSharedStringsCount := 0; FSharedStringsCount := 0;
// Write all worksheets which fills also the shared strings. { Write all worksheets which fills also the shared strings.
// Also: write comments and related files Also: write comments and related files }
FNext_rId := 1; FNext_rId := 1;
for i := 0 to Workbook.GetWorksheetCount - 1 do for i := 0 to Workbook.GetWorksheetCount - 1 do
begin begin
@@ -3485,23 +3648,35 @@ begin
WriteWorksheet(FWorksheet); WriteWorksheet(FWorksheet);
WriteComments(FWorksheet); WriteComments(FWorksheet);
WriteVmlDrawings(FWorksheet); WriteVmlDrawings(FWorksheet);
WriteDrawings(FWorksheet);
WriteDrawingsRels(FWorksheet);
WriteWorksheetRels(FWorksheet); WriteWorksheetRels(FWorksheet);
end; end;
// Finalization of the shared strings document { Finalization of the shared strings document }
AppendToStream(FSSharedStrings_complete, if FSharedStringsCount > 0 then
XML_HEADER, Format( begin
'<sst xmlns="%s" count="%d" uniqueCount="%d">', [SCHEMAS_SPREADML, FSharedStringsCount, FSharedStringsCount] AppendToStream(FSSharedStrings_complete,
)); XML_HEADER, Format(
ResetStream(FSSharedStrings); '<sst xmlns="%s" count="%d" uniqueCount="%d">', [
FSSharedStrings_complete.CopyFrom(FSSharedStrings, FSSharedStrings.Size); SCHEMAS_SPREADML, FSharedStringsCount, FSharedStringsCount
AppendToStream(FSSharedStrings_complete, ]));
'</sst>'); ResetStream(FSSharedStrings);
FSSharedStrings_complete.CopyFrom(FSSharedStrings, FSSharedStrings.Size);
AppendToStream(FSSharedStrings_complete,
'</sst>');
end;
{ Workbook relations - Mark relation to all sheets }
WriteWorkbookRels(FSWorkbookRels);
end; end;
procedure TsSpreadOOXMLWriter.WriteContentTypes; procedure TsSpreadOOXMLWriter.WriteContentTypes;
var var
i: Integer; i: Integer;
imgext: TStringList;
ext: String;
sheet: TsWorksheet;
begin begin
AppendToStream(FSContentTypes, AppendToStream(FSContentTypes,
XML_HEADER); XML_HEADER);
@@ -3515,13 +3690,39 @@ begin
AppendToStream(FSContentTypes, Format( AppendToStream(FSContentTypes, Format(
'<Default Extension="vml" ContentType="%s" />', [MIME_VMLDRAWING])); '<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, AppendToStream(FSContentTypes,
'<Override PartName="/xl/workbook.xml" ContentType="' + MIME_SHEET + '" />'); '<Override PartName="/xl/workbook.xml" ContentType="' + MIME_SHEET + '" />');
for i:=1 to Workbook.GetWorksheetCount do for i:=1 to Workbook.GetWorksheetCount do
begin
AppendToStream(FSContentTypes, Format( AppendToStream(FSContentTypes, Format(
'<Override PartName="/xl/worksheets/sheet%d.xml" ContentType="%s" />', '<Override PartName="/xl/worksheets/sheet%d.xml" ContentType="%s" />',
[i, MIME_WORKSHEET])); [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 for i:=1 to Length(FSComments) do
AppendToStream(FSContentTypes, Format( AppendToStream(FSContentTypes, Format(
@@ -3606,6 +3807,80 @@ begin
'<definedNames>' + stotal + '</definedNames>'); '<definedNames>' + stotal + '</definedNames>');
end; 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); procedure TsSpreadOOXMLWriter.WriteWorksheet(AWorksheet: TsWorksheet);
begin begin
FCurSheetNum := Length(FSSheets); FCurSheetNum := Length(FSSheets);
@@ -3613,10 +3888,12 @@ begin
// Create the stream // Create the stream
if boFileStream in FWorkbook.Options then 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 else
if (boBufStream in Workbook.Options) then 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 else
FSSheets[FCurSheetNum] := TMemoryStream.Create; FSSheets[FCurSheetNum] := TMemoryStream.Create;
@@ -3637,11 +3914,13 @@ begin
WritePageMargins(FSSheets[FCurSheetNum], AWorksheet); WritePageMargins(FSSheets[FCurSheetNum], AWorksheet);
WritePageSetup(FSSheets[FCurSheetNum], AWorksheet); WritePageSetup(FSSheets[FCurSheetNum], AWorksheet);
WriteHeaderFooter(FSSheets[FCurSheetNum], AWorksheet); WriteHeaderFooter(FSSheets[FCurSheetNum], AWorksheet);
WriteDrawingsOfSheet(FSSheets[FCurSheetNum], AWorksheet);
// Footer
if AWorksheet.Comments.Count > 0 then if AWorksheet.Comments.Count > 0 then
AppendToStream(FSSheets[FCurSheetNum], AppendToStream(FSSheets[FCurSheetNum],
'<legacyDrawing r:id="rId1" />'); '<legacyDrawing r:id="rId1" />');
// Footer
AppendToStream(FSSheets[FCurSheetNum], AppendToStream(FSSheets[FCurSheetNum],
'</worksheet>'); '</worksheet>');
end; end;
@@ -3728,6 +4007,10 @@ begin
SetLength(FSSheetRels, 0); SetLength(FSSheetRels, 0);
for stream in FSVmlDrawings do DestroyStream(stream); for stream in FSVmlDrawings do DestroyStream(stream);
SetLength(FSVmlDrawings, 0); SetLength(FSVmlDrawings, 0);
for stream in FSDrawings do DestroyStream(stream);
SetLength(FSDrawings, 0);
for stream in FSDrawingsRels do DestroyStream(stream);
Setlength(FSDrawings, 0);
end; end;
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
@@ -3758,6 +4041,8 @@ begin
for i:=0 to High(FSSheetRels) do ResetStream(FSSheetRels[i]); 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(FSComments) do ResetStream(FSComments[i]);
for i:=0 to High(FSVmlDrawings) do ResetStream(FSVmlDrawings[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; end;
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
@@ -3813,30 +4098,48 @@ begin
FZip.Entries.AddFileEntry(FSWorkbookRels, OOXML_PATH_XL_RELS_RELS); FZip.Entries.AddFileEntry(FSWorkbookRels, OOXML_PATH_XL_RELS_RELS);
FZip.Entries.AddFileEntry(FSWorkbook, OOXML_PATH_XL_WORKBOOK); FZip.Entries.AddFileEntry(FSWorkbook, OOXML_PATH_XL_WORKBOOK);
FZip.Entries.AddFileEntry(FSStyles, OOXML_PATH_XL_STYLES); 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 for i:=0 to High(FSSheets) do begin
FSSheets[i].Position:= 0; FSSheets[i].Position:= 0;
FZip.Entries.AddFileEntry(FSSheets[i], OOXML_PATH_XL_WORKSHEETS + Format('sheet%d.xml', [i+1])); FZip.Entries.AddFileEntry(FSSheets[i], OOXML_PATH_XL_WORKSHEETS + Format('sheet%d.xml', [i+1]));
end; end;
// Write comments
for i:=0 to High(FSComments) do begin for i:=0 to High(FSComments) do begin
if (FSComments[i] = nil) or (FSComments[i].Size = 0) then continue; if (FSComments[i] = nil) or (FSComments[i].Size = 0) then continue;
FSComments[i].Position := 0; FSComments[i].Position := 0;
FZip.Entries.AddFileEntry(FSComments[i], OOXML_PATH_XL + Format('comments%d.xml', [i+1])); FZip.Entries.AddFileEntry(FSComments[i], OOXML_PATH_XL + Format('comments%d.xml', [i+1]));
end; end;
// Write worksheet relationships
for i:=0 to High(FSSheetRels) do begin for i:=0 to High(FSSheetRels) do begin
if (FSSheetRels[i] = nil) or (FSSheetRels[i].Size = 0) then continue; if (FSSheetRels[i] = nil) or (FSSheetRels[i].Size = 0) then continue;
FSSheetRels[i].Position := 0; FSSheetRels[i].Position := 0;
FZip.Entries.AddFileEntry(FSSheetRels[i], OOXML_PATH_XL_WORKSHEETS_RELS + Format('sheet%d.xml.rels', [i+1])); FZip.Entries.AddFileEntry(FSSheetRels[i], OOXML_PATH_XL_WORKSHEETS_RELS + Format('sheet%d.xml.rels', [i+1]));
end; 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 for i:=0 to High(FSVmlDrawings) do begin
if (FSVmlDrawings[i] = nil) or (FSVmlDrawings[i].Size = 0) then continue; if (FSVmlDrawings[i] = nil) or (FSVmlDrawings[i].Size = 0) then continue;
FSVmlDrawings[i].Position := 0; FSVmlDrawings[i].Position := 0;
FZip.Entries.AddFileEntry(FSVmlDrawings[i], OOXML_PATH_XL_DRAWINGS + Format('vmlDrawing%d.vml', [i+1])); FZip.Entries.AddFileEntry(FSVmlDrawings[i], OOXML_PATH_XL_DRAWINGS + Format('vmlDrawing%d.vml', [i+1]));
end; 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); FZip.SaveToStream(AStream);