{ fpsopendocument.pas Writes an OpenDocument 1.0 Spreadsheet document An OpenDocument document is a compressed ZIP file with the following files inside: content.xml - Actual contents meta.xml - Authoring data settings.xml - User persistent viewing information, such as zoom, cursor position, etc. styles.xml - Styles, which are the only way to do formatting mimetype - application/vnd.oasis.opendocument.spreadsheet META-INF\manifest.xml - Describes the other files in the archive Specifications obtained from: http://docs.oasis-open.org/office/v1.1/OS/OpenDocument-v1.1.pdf AUTHORS: Felipe Monteiro de Carvalho / Jose Luis Jurado Rincon } unit fpsopendocument; {$ifdef fpc} {$mode delphi} {$endif} {.$define FPSPREADDEBUG} //used to be XLSDEBUG interface uses Classes, SysUtils, {$IFDEF FPC_FULLVERSION >= 20701} zipper, {$ELSE} fpszipper, {$ENDIF} fpspreadsheet, xmlread, DOM, AVL_Tree, math, dateutils, fpsutils; type TDateMode=(dm1899 {default for ODF; almost same as Excel 1900}, dm1900 {StarCalc legacy only}, dm1904 {e.g. Quattro Pro,Mac Excel compatibility} ); { TsSpreadOpenDocReader } TsSpreadOpenDocReader = class(TsCustomSpreadReader) private FDateMode: TDateMode; FWorksheet: TsWorksheet; // Gets value for the specified attribute. Returns empty string if attribute // not found. function GetAttrValue(ANode : TDOMNode; AAttrName : string) : string; // Figures out what the base year for times in this file (dates are unambiguous) procedure ReadDateMode(SpreadSheetNode: TDOMNode); protected { Record writing methods } procedure ReadFormula(ARow : Word; ACol : Word; ACellNode: TDOMNode); procedure ReadLabel(ARow : Word; ACol : Word; ACellNode: TDOMNode); procedure ReadNumber(ARow : Word; ACol : Word; ACellNode: TDOMNode); procedure ReadDate(ARow : Word; ACol : Word; ACellNode: TDOMNode); public { General reading methods } procedure ReadFromFile(AFileName: string; AData: TsWorkbook); override; end; { TsSpreadOpenDocWriter } TsSpreadOpenDocWriter = class(TsCustomSpreadWriter) protected FPointSeparatorSettings: TFormatSettings; // Strings with the contents of files FMeta, FSettings, FStyles, FContent, FMimetype: string; FMetaInfManifest: string; // Streams with the contents of files FSMeta, FSSettings, FSStyles, FSContent, FSMimetype: TStringStream; FSMetaInfManifest: TStringStream; // Routines to write those files procedure WriteMimetype; procedure WriteMetaInfManifest; procedure WriteMeta; procedure WriteSettings; procedure WriteStyles; procedure WriteContent; procedure WriteWorksheet(CurSheet: TsWorksheet); // Routines to write parts of those files function WriteStylesXMLAsString: string; { Record writing methods } procedure WriteBlank(AStream: TStream; const ARow, ACol: Cardinal; ACell: PCell); override; procedure WriteFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsFormula; ACell: PCell); override; procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal; const AValue: string; ACell: PCell); override; procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); override; procedure WriteDateTime(AStream: TStream; const ARow, ACol: Cardinal; const AValue: TDateTime; ACell: PCell); override; public constructor Create(AWorkbook: TsWorkbook); override; { General writing methods } procedure WriteStringToFile(AString, AFileName: string); procedure WriteToFile(const AFileName: string; const AOverwriteExisting: Boolean = False); override; procedure WriteToStream(AStream: TStream); override; end; implementation const { OpenDocument general XML constants } XML_HEADER = ''; { OpenDocument Directory structure constants } OPENDOC_PATH_CONTENT = 'content.xml'; OPENDOC_PATH_META = 'meta.xml'; OPENDOC_PATH_SETTINGS = 'settings.xml'; OPENDOC_PATH_STYLES = 'styles.xml'; OPENDOC_PATH_MIMETYPE = 'mimetype'; OPENDOC_PATH_METAINF = 'META-INF' + '/'; OPENDOC_PATH_METAINF_MANIFEST = 'META-INF' + '/' + 'manifest.xml'; { OpenDocument schemas constants } SCHEMAS_XMLNS_OFFICE = 'urn:oasis:names:tc:opendocument:xmlns:office:1.0'; SCHEMAS_XMLNS_DCTERMS = 'http://purl.org/dc/terms/'; SCHEMAS_XMLNS_META = 'urn:oasis:names:tc:opendocument:xmlns:meta:1.0'; SCHEMAS_XMLNS = 'http://schemas.openxmlformats.org/officeDocument/2006/extended-properties'; SCHEMAS_XMLNS_CONFIG = 'urn:oasis:names:tc:opendocument:xmlns:config:1.0'; SCHEMAS_XMLNS_OOO = 'http://openoffice.org/2004/office'; SCHEMAS_XMLNS_MANIFEST = 'urn:oasis:names:tc:opendocument:xmlns:manifest:1.0'; SCHEMAS_XMLNS_FO = 'urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0'; SCHEMAS_XMLNS_STYLE = 'urn:oasis:names:tc:opendocument:xmlns:style:1.0'; SCHEMAS_XMLNS_SVG = 'urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0'; SCHEMAS_XMLNS_TABLE = 'urn:oasis:names:tc:opendocument:xmlns:table:1.0'; SCHEMAS_XMLNS_TEXT = 'urn:oasis:names:tc:opendocument:xmlns:text:1.0'; SCHEMAS_XMLNS_V = 'urn:schemas-microsoft-com:vml'; SCHEMAS_XMLNS_NUMBER = 'urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0'; SCHEMAS_XMLNS_CHART = 'urn:oasis:names:tc:opendocument:xmlns:chart:1.0'; SCHEMAS_XMLNS_DR3D = 'urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0'; SCHEMAS_XMLNS_MATH = 'http://www.w3.org/1998/Math/MathML'; SCHEMAS_XMLNS_FORM = 'urn:oasis:names:tc:opendocument:xmlns:form:1.0'; SCHEMAS_XMLNS_SCRIPT = 'urn:oasis:names:tc:opendocument:xmlns:script:1.0'; SCHEMAS_XMLNS_OOOW = 'http://openoffice.org/2004/writer'; SCHEMAS_XMLNS_OOOC = 'http://openoffice.org/2004/calc'; SCHEMAS_XMLNS_DOM = 'http://www.w3.org/2001/xml-events'; SCHEMAS_XMLNS_XFORMS = 'http://www.w3.org/2002/xforms'; SCHEMAS_XMLNS_XSD = 'http://www.w3.org/2001/XMLSchema'; SCHEMAS_XMLNS_XSI = 'http://www.w3.org/2001/XMLSchema-instance'; { DATEMODE similar to but not the same as XLS format; used in time only values. } DATEMODE_1899_BASE=0; //apparently 1899-12-30 for ODF in FPC DateTime; // due to Excel's leap year bug, the date floats in the spreadsheets are the same starting // 1900-03-01 DATEMODE_1900_BASE=2; //StarCalc compatibility, 1900-01-01 in FPC DateTime DATEMODE_1904_BASE=1462; //1/1/1904 in FPC TDateTime { TsSpreadOpenDocReader } function TsSpreadOpenDocReader.GetAttrValue(ANode : TDOMNode; AAttrName : string) : string; var i : integer; Found : Boolean; begin Found:=false; i:=0; Result:=''; while not Found and (i'') then begin for RowsCount:=0 to StrToInt(ParamRowsRepeated)-1 do begin for ColsCount:=0 to StrToInt(ParamColsRepeated)-1 do begin if ParamValueType='string' then ReadLabel(Row+RowsCount,Col+ColsCount,CellNode) else if ParamFormula<>'' then ReadFormula(Row+RowsCount,Col+ColsCount,CellNode) else if ParamValueType='float' then ReadNumber(Row+RowsCount,Col+ColsCount,CellNode) else if (ParamValueType='date') or (ParamValueType='time') then ReadDate(Row+RowsCount,Col+ColsCount,CellNode); end; //for ColsCount end; //for RowsCount end; Inc(Col,ColsCount+1); CellNode:=CellNode.NextSibling; end; //while Assigned(CellNode) Inc(Row,RowsCount+1); RowNode:=RowNode.NextSibling; end; // while Assigned(RowNode) TableNode:=TableNode.NextSibling; end; //while Assigned(TableNode) finally Doc.Free; end; end; procedure TsSpreadOpenDocReader.ReadFormula(ARow: Word; ACol : Word; ACellNode : TDOMNode); begin // For now just read the number ReadNumber(ARow, ACol, ACellNode); end; procedure TsSpreadOpenDocReader.ReadLabel(ARow: Word; ACol : Word; ACellNode : TDOMNode); begin FWorkSheet.WriteUTF8Text(ARow,ACol,UTF8Encode(ACellNode.TextContent)); end; procedure TsSpreadOpenDocReader.ReadNumber(ARow: Word; ACol : Word; ACellNode : TDOMNode); var FSettings: TFormatSettings; Value, Str: String; lNumber: Double; begin FSettings := DefaultFormatSettings; FSettings.DecimalSeparator:='.'; Value:=GetAttrValue(ACellNode,'office:value'); if UpperCase(Value)='1.#INF' then begin FWorkSheet.WriteNumber(Arow,ACol,1.0/0.0); end else begin // Don't merge, or else we can't debug Str := GetAttrValue(ACellNode,'office:value'); lNumber := StrToFloat(Str,FSettings); FWorkSheet.WriteNumber(ARow,ACol,lNumber); end; end; procedure TsSpreadOpenDocReader.ReadDate(ARow: Word; ACol : Word; ACellNode : TDOMNode); var dt: TDateTime; Value: String; Fmt : TFormatSettings; FoundPos : integer; Hours, Minutes, Seconds: integer; HoursPos, MinutesPos, SecondsPos: integer; begin // Format expects ISO 8601 type date string or // time string fmt := DefaultFormatSettings; fmt.ShortDateFormat:='yyyy-mm-dd'; fmt.DateSeparator:='-'; fmt.LongTimeFormat:='hh:nn:ss'; fmt.TimeSeparator:=':'; Value:=GetAttrValue(ACellNode,'office:date-value'); if Value<>'' then begin {$IFDEF FPSPREADDEBUG} writeln('Row (1based): ',ARow+1,'office:date-value: '+Value); {$ENDIF} // Date or date/time string Value:=StringReplace(Value,'T',' ',[rfIgnoreCase,rfReplaceAll]); // Strip milliseconds? FoundPos:=Pos('.',Value); if (FoundPos>1) then begin Value:=Copy(Value,1,FoundPos-1); end; dt:=StrToDateTime(Value,Fmt); FWorkSheet.WriteDateTime(Arow,ACol,dt); end else begin // Try time only, e.g. PT23H59M59S // 12345678901 Value:=GetAttrValue(ACellNode,'office:time-value'); {$IFDEF FPSPREADDEBUG} writeln('Row (1based): ',ARow+1,'office:time-value: '+Value); {$ENDIF} if (Value<>'') and (Pos('PT',Value)=1) then begin // Get hours HoursPos:=Pos('H',Value); if (HoursPos>0) then Hours:=StrToInt(Copy(Value,3,HoursPos-3)) else Hours:=0; // Get minutes MinutesPos:=Pos('M',Value); if (MinutesPos>0) and (MinutesPos>HoursPos) then Minutes:=StrToInt(Copy(Value,HoursPos+1,MinutesPos-HoursPos-1)) else Minutes:=0; // Get seconds SecondsPos:=Pos('S',Value); if (SecondsPos>0) and (SecondsPos>MinutesPos) then Seconds:=StrToInt(Copy(Value,MinutesPos+1,SecondsPos-MinutesPos-1)) else Seconds:=0; // Times smaller than a day can be taken as is // Times larger than a day depend on the file's date mode. // Convert to date/time via Unix timestamp so avoiding limits for number of // hours etc in EncodeDateTime. Perhaps there's a faster way of doing this? if (Hours>-24) and (Hours<24) then begin dt:=UnixToDateTime( Hours*(MinsPerHour*SecsPerMin)+ Minutes*(SecsPerMin)+ Seconds )-UnixEpoch; end else begin // A day or longer case FDateMode of dm1899: dt:=DATEMODE_1899_BASE+UnixToDateTime( Hours*(MinsPerHour*SecsPerMin)+ Minutes*(SecsPerMin)+ Seconds )-UnixEpoch; dm1900: dt:=DATEMODE_1900_BASE+UnixToDateTime( Hours*(MinsPerHour*SecsPerMin)+ Minutes*(SecsPerMin)+ Seconds )-UnixEpoch; dm1904: dt:=DATEMODE_1904_BASE+UnixToDateTime( Hours*(MinsPerHour*SecsPerMin)+ Minutes*(SecsPerMin)+ Seconds )-UnixEpoch; end; end; FWorkSheet.WriteDateTime(Arow,ACol,dt); end; end; end; { TsSpreadOpenDocWriter } procedure TsSpreadOpenDocWriter.WriteMimetype; begin FMimetype := 'application/vnd.oasis.opendocument.spreadsheet'; end; procedure TsSpreadOpenDocWriter.WriteMetaInfManifest; begin FMetaInfManifest := XML_HEADER + LineEnding + '' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ''; end; procedure TsSpreadOpenDocWriter.WriteMeta; begin FMeta := XML_HEADER + LineEnding + '' + LineEnding + ' ' + LineEnding + ' FPSpreadsheet Library' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ''; end; procedure TsSpreadOpenDocWriter.WriteSettings; begin FSettings := XML_HEADER + LineEnding + '' + LineEnding + '' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' Tabelle1' + LineEnding + ' 100' + LineEnding + ' 100' + LineEnding + ' false' + LineEnding + ' true' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' 3' + LineEnding + ' 2' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ''; end; procedure TsSpreadOpenDocWriter.WriteStyles; begin FStyles := XML_HEADER + LineEnding + '' + LineEnding + '' + LineEnding + ' ' + LineEnding + '' + LineEnding + '' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + '' + LineEnding + '' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + '' + LineEnding + '' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + '' + LineEnding + ''; end; procedure TsSpreadOpenDocWriter.WriteContent; var i: Integer; lStylesCode: string; begin ListAllFormattingStyles; lStylesCode := WriteStylesXMLAsString; FContent := XML_HEADER + LineEnding + '' + LineEnding + ' ' + LineEnding + // Fonts ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + // Automatic styles ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + ' ' + LineEnding + // Automatically Generated Styles lStylesCode + ' ' + LineEnding + // Body ' ' + LineEnding + ' ' + LineEnding; // Write all worksheets for i := 0 to Workbook.GetWorksheetCount - 1 do WriteWorksheet(Workbook.GetWorksheetByIndex(i)); FContent := FContent + ' ' + LineEnding + ' ' + LineEnding + ''; end; procedure TsSpreadOpenDocWriter.WriteWorksheet(CurSheet: TsWorksheet); var j, k: Integer; CurCell: PCell; CurRow: array of PCell; LastColNum: Cardinal; LCell: TCell; AVLNode: TAVLTreeNode; begin LastColNum := CurSheet.GetLastColNumber; // Header FContent := FContent + ' ' + LineEnding + ' ' + LineEnding; // The cells need to be written in order, row by row, cell by cell for j := 0 to CurSheet.GetLastRowNumber do begin FContent := FContent + ' ' + LineEnding; // Write cells from this row. for k := 0 to LastColNum do begin LCell.Row := j; LCell.Col := k; AVLNode := CurSheet.Cells.Find(@LCell); if Assigned(AVLNode) then WriteCellCallback(PCell(AVLNode.Data), nil) else FContent := FContent + '' + LineEnding; end; FContent := FContent + ' ' + LineEnding; end; // Footer FContent := FContent + ' ' + LineEnding; end; function TsSpreadOpenDocWriter.WriteStylesXMLAsString: string; var i: Integer; begin Result := ''; for i := 0 to Length(FFormattingStyles) - 1 do begin // Start and Name Result := Result + ' ' + LineEnding; // Fields // style:text-properties if uffBold in FFormattingStyles[i].UsedFormattingFields then Result := Result + ' ' + LineEnding; // style:table-cell-properties if (uffBorder in FFormattingStyles[i].UsedFormattingFields) or (uffBackgroundColor in FFormattingStyles[i].UsedFormattingFields) or (uffWordWrap in FFormattingStyles[i].UsedFormattingFields) then begin Result := Result + ' ' + LineEnding; end; // End Result := Result + ' ' + LineEnding; end; end; constructor TsSpreadOpenDocWriter.Create(AWorkbook: TsWorkbook); begin inherited Create(AWorkbook); FPointSeparatorSettings := SysUtils.DefaultFormatSettings; FPointSeparatorSettings.DecimalSeparator:='.'; end; { Writes a string to a file. Helper convenience method. } procedure TsSpreadOpenDocWriter.WriteStringToFile(AString, AFileName: string); var TheStream : TFileStream; S : String; begin TheStream := TFileStream.Create(AFileName, fmCreate); S:=AString; TheStream.WriteBuffer(Pointer(S)^,Length(S)); TheStream.Free; end; { Writes an OOXML document to the disc. } procedure TsSpreadOpenDocWriter.WriteToFile(const AFileName: string; const AOverwriteExisting: Boolean); var FZip: TZipper; begin { Fill the strings with the contents of the files } WriteMimetype(); WriteMetaInfManifest(); WriteMeta(); WriteSettings(); WriteStyles(); WriteContent; { Write the data to streams } FSMeta := TStringStream.Create(FMeta); FSSettings := TStringStream.Create(FSettings); FSStyles := TStringStream.Create(FStyles); FSContent := TStringStream.Create(FContent); FSMimetype := TStringStream.Create(FMimetype); FSMetaInfManifest := TStringStream.Create(FMetaInfManifest); { Now compress the files } FZip := TZipper.Create; try FZip.FileName := AFileName; FZip.Entries.AddFileEntry(FSMeta, OPENDOC_PATH_META); FZip.Entries.AddFileEntry(FSSettings, OPENDOC_PATH_SETTINGS); FZip.Entries.AddFileEntry(FSStyles, OPENDOC_PATH_STYLES); FZip.Entries.AddFileEntry(FSContent, OPENDOC_PATH_CONTENT); FZip.Entries.AddFileEntry(FSMimetype, OPENDOC_PATH_MIMETYPE); FZip.Entries.AddFileEntry(FSMetaInfManifest, OPENDOC_PATH_METAINF_MANIFEST); FZip.ZipAllFiles; finally FZip.Free; FSMeta.Free; FSSettings.Free; FSStyles.Free; FSContent.Free; FSMimetype.Free; FSMetaInfManifest.Free; end; end; procedure TsSpreadOpenDocWriter.WriteToStream(AStream: TStream); begin // Not supported at the moment raise Exception.Create('TsSpreadOpenDocWriter.WriteToStream not supported'); end; procedure TsSpreadOpenDocWriter.WriteFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsFormula; ACell: PCell); begin { // The row should already be the correct one FContent := FContent + ' ' + LineEnding + ' ' + AFormula.DoubleValue + '' + LineEnding + ' ' + LineEnding; 1833 } end; { Writes an empty cell Not clear whether this is needed for ods, but the inherited procedure is abstract. } procedure TsSpreadOpenDocWriter.WriteBlank(AStream: TStream; const ARow, ACol: Cardinal; ACell: PCell); begin // no action at the moment... end; { Writes a cell with text content The UTF8 Text needs to be converted, because some chars are invalid in XML See bug with patch 19422 } procedure TsSpreadOpenDocWriter.WriteLabel(AStream: TStream; const ARow, ACol: Cardinal; const AValue: string; ACell: PCell); var lStyle: string = ''; lIndex: Integer; begin if ACell^.UsedFormattingFields <> [] then begin lIndex := FindFormattingInList(ACell); lStyle := ' table:style-name="ce' + IntToStr(lIndex) + '" '; end; // The row should already be the correct one FContent := FContent + ' ' + LineEnding + ' ' + UTF8TextToXMLText(AValue) + '' + LineEnding + ' ' + LineEnding; end; procedure TsSpreadOpenDocWriter.WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); var StrValue: string; DisplayStr: string; lStyle: string = ''; lIndex: Integer; begin if ACell^.UsedFormattingFields <> [] then begin lIndex := FindFormattingInList(ACell); lStyle := ' table:style-name="ce' + IntToStr(lIndex) + '" '; end; // The row should already be the correct one if IsInfinite(AValue) then begin StrValue:='1.#INF'; DisplayStr:='1.#INF'; end else begin StrValue:=FloatToStr(AValue,FPointSeparatorSettings); //Uses '.' as decimal separator DisplayStr:=FloatToStr(AValue); // Uses locale decimal separator end; FContent := FContent + ' ' + LineEnding + ' ' + DisplayStr + '' + LineEnding + ' ' + LineEnding; end; {******************************************************************* * TsSpreadOpenDocWriter.WriteDateTime () * * DESCRIPTION: Writes a date/time value * * *******************************************************************} procedure TsSpreadOpenDocWriter.WriteDateTime(AStream: TStream; const ARow, ACol: Cardinal; const AValue: TDateTime; ACell: PCell); var lStyle: string = ''; lIndex: Integer; begin if ACell^.UsedFormattingFields <> [] then begin lIndex := FindFormattingInList(ACell); lStyle := ' table:style-name="ce' + IntToStr(lIndex) + '" '; end; // The row should already be the correct one FContent := FContent + ' ' + LineEnding + ' ' + LineEnding; end; { Registers this reader / writer on fpSpreadsheet } initialization RegisterSpreadFormat(TsSpreadOpenDocReader, TsSpreadOpenDocWriter, sfOpenDocument); end.