{ docxvectorialwriter.pas License: The same modified LGPL as the Free Pascal RTL See the file COPYING.modifiedLGPL for more details THIS IS A UNIT CURRENTLY UNDER DEVELOPEMENT Current Functionality - Text support (inc Tabs and CRs) - Paragraph/Character Style Support - Supports Section Breaks (via PageSequences) - Supports Header and Footer - Supports Portrait/Landscape - Support Tables TODO - Add following to both FPVectorial AND DOCXWriter - Add Image Support (From file and from Stream, in Paragraph and in Table) - Add simple Work Fields (NumPage, PageCount, Filename (Full, part), DatePrinted) - Add TOC support - Consider Unicode Support (eek) Writes an OOXML (Office Open XML) document An OOXML document is a compressed ZIP file with the following files inside: [Content_Types].xml - An index of all files, defines their content format _rels\.rels - Relationships between high level documents word\_rels\document.xml.rels - defines relationships to files required by document.xml (ie styles.xml) word\document.xml - this is the main document. Conforms to WordprocessingML word\styles.xml - The Style Library word\header%d.xml - One file per header word\footer%d.xml - One file per footer word\numbering.xml - Header and List numbering details media\*.[png, jpg, etc] - Images Specifications and examples obtained from: http://openxmldeveloper.org/default.aspx http://officeopenxml.com/ http://www.ecma-international.org/publications/standards/Ecma-376.htm - Office Open XML Part 4 - Markup Language Reference.docx (First edition) AUTHORS: Mike Thompson, Felipe Monteiro de Carvalho Change History 0.1 - minimal document.xml produced - experimental support for styles (not working, hidden behind INCLUDE_STYLES define) 0.2 - Refactored for new VectorialElement TvParagraph - Removed INCLUDE_STYLES define - Added support for Styles - resulting .docx contains ONLY styles defined in VectorialDocument Only Paragraph Style supported for now - Added IndentedStringList simply to prettify the resulting XML 0.3 - Added support for Character Styles (named TextSpan Styles within FPVectorial - If Style.Name not defined, then create one based on index - Refactored PrepareTextRunStyle out of Prepare Styles. Resulting XML is perfectly valid inside Document.XML and Style.xml, though FPVectorial currently does not support this - Closed out minor TODO items 0.4 - realised <>'"& would break the resulting XML. Added EscapeHTML when User defined text is outputted into the HTML - Multiple PageSequences are now handled. - Added support for Portrait/Landscape (reverse Width/Height if you want Landscape) - Added generic support for multiple files. Link IDs and Relationships between Files are automatically handled. Currently works for XML files only but should be easily extended for Image Support (code tagged with TODO) - Added support for Header and Footer. Can be defined per PageSequence resulting in multiple headers and footers or just on the first PageSequence (in which case the rest of the document will inherit the same Header / Footer) Couldn't get the inline Header/Footers to work, so implemented as separate files. - Added handling for #11 (tab), #10 (line feed), #13 (CR) and #13#10 in Text Support - Significant refactoring of code, and formatted code with Jedi Code Format. I intend to Jedi Code Format before each Patch from here on - Added support for Alignment to Styles 0.5 - Support TvParagraph margins - Added numbering.xml 0.6 - Changed #11 (vert tab) to #09 (horiz tab, what it always should have been) - Added Table Support - Bug fix - Margin support in Styles fixed... 0.7 - Added experimental LocalAlignment support to TvParagraph } Unit docxvectorialwriter; {$mode objfpc}{$H+} Interface Uses Classes, SysUtils, zipper, {NOTE: might require zipper from FPC 2.6.2+ } fpimage, fpcanvas, fpvectorial, fpvutils, lazutf8, Math; Type TIndentOption = (indInc, indDec, indNone); { TIndentedStringList } // Here to just to ensure the resulting xml files are pretty :-) { TODO : Replace this with a genuine XML handler } TIndentedStringList = Class(TStringList) Private FIndent: String; FIndentSteps: String; Public Constructor Create; Function Add(indBefore: TIndentOption = indNone; S: String = ''; indAfter: TIndentOption = indNone): Integer; Function Add(Const S: String): Integer; Override; Function Add(Const S: String; indAfter: TIndentOption): Integer; Procedure IncIndent; Procedure DecIndent; End; TFileType = (ftContentTypes, ftRelationships, ftDocRelationships); TFileTypes = Set Of TFileType; { TFileInformation } TFileInformation = Class(TObject) Private FStream: TStream; Function GetStream: TStream; Public Index: Integer; ContentType: String; Path: String; FileType: String; MentionedIn: TFileTypes; XML: TIndentedStringList; // Free'd internally; //Image : TFPImage; { TODO: How are we going to handle images? } Constructor Create; Destructor Destroy; Override; Function ID: String; Function Filename: String; Procedure FreeStream; Property Stream: TStream read GetStream; // This creates a TSream, Call .FreeStream to free End; { TFileList } TFileList = Class(TObject) Private FList: TList; Function GetFile(AIndex: Integer): TFileInformation; Public Constructor Create; Destructor Destroy; Override; Function AddXMLFile(AContentType: String; APath: String; AFileType: String; AMentionedIn: TFileTypes): TFileInformation; Function Count: Integer; Property FileInformation[AIndex: Integer]: TFileInformation read GetFile; Default; End; { TvDOCXVectorialWriter } TvDOCXVectorialWriter = Class(TvCustomVectorialWriter) Private FData: TvVectorialDocument; FFiles: TFileList; Function PrepareContentTypes: String; Function PrepareRelationships: String; Function PrepareDocRelationships: String; Procedure PrepareDocument; Procedure PrepareStyles; // Only created if FData has Styles defined Procedure PrepareNumbering; // Only created if Numbered Styles exist Procedure PrepareTextRunStyle(ADoc: TIndentedStringList; AStyle: TvStyle); Function StyleNameToStyleID(AStyle: TvStyle): String; Public { General reading methods } Constructor Create; Override; Destructor Destroy; Override; Procedure WriteToFile(AFileName: String; AData: TvVectorialDocument); Override; Procedure WriteToStream(AStream: TStream; AData: TvVectorialDocument); Override; End; Implementation Uses strutils, htmlelements; Const XML_HEADER = ''; { OOXML general XML constants } // Note: No leading '/'. Add where required OOXML_PATH_TYPES = '[Content_Types].xml'; OOXML_PATH_RELS_RELS = '_rels/.rels'; OOXML_PATH_DOCUMENT_RELS = 'word/_rels/document.xml.rels'; OOXML_PATH_DOCUMENT = 'word/document.xml'; OOXML_PATH_STYLES = 'word/styles.xml'; OOXML_PATH_HEADER = 'word/header%d.xml'; // Use Format(OOXML_PATH_HEADER, [Index]); OOXML_PATH_FOOTER = 'word/footer%d.xml'; // Use Format(OOXML_PATH_HEADER, [Index]); OOXML_PATH_NUMBERING = 'word/numbering.xml'; OOXML_RELS = 'http://schemas.openxmlformats.org/officeDocument/2006/relationships'; OOXML_TYPE_DOCUMENT = OOXML_RELS + '/officeDocument'; OOXML_TYPE_STYLES = OOXML_RELS + '/styles'; OOXML_TYPE_HEADER = OOXML_RELS + '/header'; OOXML_TYPE_FOOTER = OOXML_RELS + '/footer'; OOXML_TYPE_NUMBERING = OOXML_RELS + '/numbering'; OOXML_CONTENTTYPE = 'application/vnd.openxmlformats-officedocument.wordprocessingml'; OOXML_CONTENTTYPE_DOCUMENT = OOXML_CONTENTTYPE + '.document.main+xml'; OOXML_CONTENTTYPE_STYLES = OOXML_CONTENTTYPE + '.styles+xml'; OOXML_CONTENTTYPE_HEADER = OOXML_CONTENTTYPE + '.header+xml'; OOXML_CONTENTTYPE_FOOTER = OOXML_CONTENTTYPE + '.footer+xml'; OOXML_CONTENTTYPE_NUMBERING = OOXML_CONTENTTYPE + '.numbering+xml'; // Shared between document.xml and each header.xml/footer.xml OOXML_DOCUMENT_NAMESPACE = 'xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" ' + 'xmlns:w="http://schemas.openxmlformats.org/wordprocessingml/2006/main" '; TAG_HEADER = 'hdr'; TAG_FOOTER = 'ftr'; // Lookups... LU_ALIGN: Array [TvStyleAlignment] Of String = ('left', 'right', 'both', 'center'); LU_NUMBERFORMAT: Array [TvNumberFormat] Of String = ('decimal', 'lowerLetter', 'lowerRoman', 'upperLetter', 'upperRoman'); LU_NUMBERFORMATFORUMLA: Array [TvNumberFormat] Of String = ('Arabic', 'alphabetic', 'roman', 'ALPHABETIC', 'Roman'); LU_ON_OFF: Array[Boolean] Of String = ('off', 'on'); LU_BORDERTYPE: Array[TvTableBorderType] Of String = ('single', 'dashed', 'double', 'none', 'default'); LU_V_ALIGN: Array[TvVerticalAlignment] Of String = ('top', 'bottom', 'center', 'both'); //ONE_POINT_IN_MM = 0.35278; // Generic Helper Units Function PointsToTwipsS(APoints: Double): String; Begin // 1 Twip = 1/20 of a point Result := IntToStr(Round(20 * APoints)); End; Function mmToPointS(AMillimetres: Double): String; Begin Result := IntToStr(Round((0.0393701 * 1440 * AMillimetres) / 20)); End; Function mmToTwipsS(AMillimetres: Double): String; Begin // 1 Twip = 1 / 1440 of an inch - sigh... Result := IntToStr(Round(0.0393701 * 1440 * AMillimetres)); End; Function DimAttribs(ADimension: TvDimension; AValueTag: String = 'w:w'; ATypeTag: String = 'w:type'): String; Var iValue: Integer; sType: String; Begin Case ADimension.Units Of dimMillimeter: Begin iValue := Round(0.0393701 * 1440 * ADimension.Value); sType := 'dxa'; // most values in docx must be in twips End; dimPercent: Begin iValue := Round(50 * ADimension.Value); sType := 'pct'; // 50ths of a percent End; dimPoint: Begin iValue := Round(20 * ADimension.Value); sType := 'dxa'; // most values in docx must be in twips End; End; Result := Format(' %s="%d" %s="%s" ', [AValueTag, iValue, ATypeTag, sType]); End; { TFileInformation } Constructor TFileInformation.Create; Begin FStream := nil; XML := nil; Path := ''; FileType := ''; ContentType := ''; Index := -1; MentionedIn := []; End; Destructor TFileInformation.Destroy; Begin If Assigned(XML) Then XML.Free; Inherited Destroy; End; Function TFileInformation.ID: String; Begin Result := 'rId' + IntToStr(Index); End; Function TFileInformation.Filename: String; Var i: Integer; Begin i := RPos('/', Path); If i > 0 Then Result := Copy(Path, i + 1, Length(Path) - i) Else Result := Path; End; Function TFileInformation.GetStream: TStream; Begin If Not Assigned(FStream) Then Begin If Assigned(XML) Then Begin FStream := TMemoryStream.Create; XML.SaveToStream(FStream); FStream.Position := 0; End; (* { TODO : How are we going to handle images? } Else If Assigned(Image) Then Begin end; *) End; Result := FStream; End; Procedure TFileInformation.FreeStream; Begin If Assigned(FStream) Then Begin FStream.Free; FStream := nil; End; End; { TFileList } Function TFileList.GetFile(AIndex: Integer): TFileInformation; Begin Result := TFileInformation(FList[AIndex]); End; Constructor TFileList.Create; Begin FList := TList.Create; End; Destructor TFileList.Destroy; Begin While (FList.Count > 0) Do Begin TFileInformation(FList.Last).Free; FList.Delete(FList.Count - 1); End; Inherited Destroy; End; Function TFileList.AddXMLFile(AContentType: String; APath: String; AFileType: String; AMentionedIn: TFileTypes): TFileInformation; Begin Result := TFileInformation.Create; Result.ContentType := AContentType; Result.FileType := AFileType; Result.Path := APath; Result.MentionedIn := AMentionedIn; Result.XML := TIndentedStringList.Create; Result.Index := FList.Count; FList.Add(Result); End; Function TFileList.Count: Integer; Begin Result := FList.Count; End; { TIndentedStringList } Constructor TIndentedStringList.Create; Begin FIndent := ''; FIndentSteps := ' '; End; Function TIndentedStringList.Add(indBefore: TIndentOption; S: String; indAfter: TIndentOption): Integer; Begin If indBefore = indInc Then IncIndent Else If indAfter = indDec Then DecIndent; Result := Inherited Add(FIndent + S); If indAfter = indInc Then IncIndent Else If indBefore = indDec Then DecIndent; End; Function TIndentedStringList.Add(Const S: String): Integer; Begin Result := Inherited Add(FIndent + S); End; Function TIndentedStringList.Add(Const S: String; indAfter: TIndentOption): Integer; Begin Result := Add(indNone, S, indAfter); End; Procedure TIndentedStringList.DecIndent; Begin FIndent := Copy(FIndent, 1, Length(FIndent) - Length(FIndentSteps)); End; Procedure TIndentedStringList.IncIndent; Begin FIndent := FIndent + FIndentSteps; End; { TvDOCXVectorialWriter } Constructor TvDOCXVectorialWriter.Create; Begin Inherited Create; FFiles := TFileList.Create; End; Destructor TvDOCXVectorialWriter.Destroy; Begin // Free's all the XML IndentedStringLists automagically FFiles.Free; FFiles := nil; Inherited Destroy; End; Function TvDOCXVectorialWriter.PrepareContentTypes: String; Var i: Integer; Begin Result := XML_HEADER + LineEnding + '' + LineEnding + ' ' + LineEnding + ' ' + LineEnding; For i := 0 To FFiles.Count - 1 Do If ftContentTypes In FFiles[i].MentionedIn Then Result := Result + ' ' + LineEnding; Result := Result + ''; End; Function TvDOCXVectorialWriter.PrepareRelationships: String; Var i: Integer; Begin Result := XML_HEADER + LineEnding + '' + LineEnding; For i := 0 To FFiles.Count - 1 Do If ftRelationships In FFiles[i].MentionedIn Then Result := Result + ' ' + LineEnding; Result := Result + ''; End; Function TvDOCXVectorialWriter.PrepareDocRelationships: String; Var i: Integer; Begin Result := XML_HEADER + LineEnding + '' + LineEnding; For i := 0 To FFiles.Count - 1 Do If ftDocRelationships In FFiles[i].MentionedIn Then Result := Result + ' ' + LineEnding; Result := Result + ''; End; Procedure TvDOCXVectorialWriter.PrepareDocument; Var // Generally this is document.xml, may also be header.xml or footer.xml though.. oDocXML: TIndentedStringList; iPage: Integer; Procedure ProcessRichText(ARichText: TvRichText); Forward; Procedure AddTextRun(sText: String; AStyle: TvStyle); Var iLen, iStart, i: Integer; sTemp: String; Begin // Don't both writing null Text Runs.. If sText <> '' Then Begin i := 1; iStart := 1; iLen := Length(sText); // Place all text between Tabs and CRs into individual Text Runs, // and render the Tabs and CRs appropriately While i <= iLen Do Begin If (sText[i] In [#10, #09, #13]) Or (i = iLen) Then Begin // Add the text before this point into a single Text Run If i > iStart Then Begin // If end of line AND end of line isn't a special char, then // inc(i) to ensure the math in the Copy works :-) If (i = iLen) And Not (sText[i] In [#10, #09, #13]) Then Inc(i); sTemp := Copy(sText, iStart, i - iStart); oDocXML.Add(indInc, ''); If Assigned(AStyle) Then Begin oDocXML.Add(indInc, ''); oDocXML.Add(' '); oDocXML.Add(indDec, ''); End; oDocXML.Add(' ' + EscapeHTML(sTemp) + ''); oDocXML.Add(indDec, ''); End; // Deal with the Tabs, LF and CRs appropriately If sText[i] = #09 Then oDocXML.Add(' ') Else If sText[i] In [#10, #11, #13] Then Begin oDocXML.Add(' '); // Now deal with CRLF by skipping over any trailing LF If (i < iLen) And (sText[i] = #13) Then If sText[i + 1] = #10 Then Inc(i); End; iStart := i + 1; End; Inc(i); End; End; End; Procedure AddField(AField : TvField); var sInstruction: String; sDefault: String; Begin sInstruction := ''; sDefault := ''; Case AField.Kind of vfkNumPages: Begin sInstruction := ' NUMPAGES \* '+LU_NUMBERFORMATFORUMLA[AField.NumberFormat]+' \* MERGEFORMAT '; sDefault := IntToStr(FData.GetPageCount); End; vfkPage: Begin sInstruction := ' PAGE \* '+LU_NUMBERFORMATFORUMLA[AField.NumberFormat]+' \* MERGEFORMAT '; sDefault := IntToStr(iPage+1); End; vfkAuthor: Begin sInstruction := ' AUTHOR \* Caps \* MERGEFORMAT '; sDefault := 'FPVECTORIAL'; End; vfkDateCreated: Begin sInstruction := ' CREATEDATE \@ "'+AField.DateFormat+'" \* MERGEFORMAT '; sDefault := DateToStr(Now); End; vfkDate: Begin sInstruction := ' DATE \@ "'+AField.DateFormat+'" \* MERGEFORMAT '; sDefault := DateToStr(Now); End; end; If sInstruction<>'' Then Begin If Assigned(AField.Style) Then Begin oDocXML.Add(indInc, ''); oDocXML.Add(' '); oDocXML.Add(indDec, ''); End; // Start the Formula oDocXML.Add(''); // Add the Instruction oDocXML.Add(''+ sInstruction+ ''); // SEPARATE the Field (above) from the result (below) oDocXML.Add(''); // Add the default text oDocXML.Add(''+sDefault+''); // End the Forumla oDocXML.Add(''); end; end; Procedure ProcessParagraph(AParagraph: TvParagraph; AListLevel : integer = -1; ANumID : Integer = -1); Var i: Integer; oEntity: TvEntity; sTemp: String; Begin oDocXML.Add(indInc, ''); // Add the Paragraph Properties oDocXML.Add(indInc, '', indInc); If Assigned(AParagraph.Style) Then oDocXML.Add(Format('', [StyleNameToStyleID(AParagraph.Style)])); If (AListLevel<>-1) Then Begin oDocXML.Add(''); oDocXML.Add(indInc, Format('', [AListLevel])); oDocXML.Add(indDec, Format('', [ANumID])); oDocXML.Add(''); End; oDocXML.Add(indDec, '', indDec); For i := 0 To AParagraph.GetEntitiesCount - 1 Do Begin oEntity := AParagraph.GetEntity(i); // Adding the TvText like this means each line in the StringList // will result in a
adding to the XML If oEntity Is TvText Then Begin sTemp := TvText(oEntity).Value.Text; // Strip out the trailing line break // added by TStringList.Text If DefaultTextLineBreakStyle = tlbsCRLF Then sTemp := Copy(sTemp, 1, Length(sTemp) - 2) Else sTemp := Copy(sTemp, 1, Length(sTemp) - 1); AddTextRun(sTemp, TvText(oEntity).Style); End Else If oEntity is TvField Then AddField(TvField(oEntity)) Else { TODO : What other entities in TvParagraph do I need to process } Raise Exception.Create('Unsupported Entity: ' + oEntity.ClassName); End; oDocXML.Add(indDec, '
'); End; Procedure ProcessList(AList: TvList); Var i: Integer; oEntity: TvEntity; Begin For i := 0 To AList.GetEntitiesCount - 1 Do Begin oEntity := AList.GetEntity(i); If oEntity Is TvParagraph Then Begin If Not Assigned(TvParagraph(oEntity).Style) Then TvParagraph(oEntity).Style := AList.Style; ProcessParagraph(TvParagraph(oEntity), AList.GetLevel(), FData.FindListStyleIndex(AList.ListStyle) + 1); End Else If oEntity Is TvList Then ProcessList(TvList(oEntity)) Else Raise Exception.Create('Unsupported entity ' + oEntity.ClassName); End; End; Procedure ProcessHeaderFooter(AElement: TvRichText; ATag: String); Var oTemp: TIndentedStringList; oFile: TFileInformation; Begin // If Header or Footer contains no elements, don't add them... If AElement.GetEntitiesCount > 0 Then Begin // Create additional XML files for each Header and Footer If ATag = TAG_HEADER Then oFile := FFiles.AddXMLFile(OOXML_CONTENTTYPE_HEADER, Format(OOXML_PATH_HEADER, [FFiles.Count]), OOXML_TYPE_HEADER, [ftContentTypes, ftDocRelationships]) Else oFile := FFiles.AddXMLFile(OOXML_CONTENTTYPE_FOOTER, Format(OOXML_PATH_FOOTER, [FFiles.Count]), OOXML_TYPE_FOOTER, [ftContentTypes, ftDocRelationships]); // For the next few steps, all the ProcessXXX routines will be working on the header or footer... oTemp := oDocXML; oDocXML := oFile.XML; oDocXML.Add(XML_HEADER); oDocXML.Add(Format('', [ATag, OOXML_DOCUMENT_NAMESPACE + 'xml:space="preserve"'])); ProcessRichText(AElement); // Close the new xml file... oDocXML.Add(Format('', [ATag])); // ProcessXXX routines will now resume working on document.xml oDocXML := oTemp; { TODO : FPVectorial currently doesn't support Odd or Even Page Header/Footers } // Add the reference to the newly created Header or Footer into the main document If ATag = TAG_HEADER Then oDocXML.Add('') Else oDocXML.Add(''); End; End; Procedure FinalisePage(APageSequence: TvTextPageSequence; ALastPage: Boolean); Var dWidth, dHeight: Double; sTemp: String; Begin // For the final pagesequence only w:sectPr shouldn't be wrapped inside w:p or w:pPr If Not ALastPage Then Begin oDocXML.Add(indInc, ''); oDocXML.Add(indInc, ''); End; oDocXML.Add(indInc, '', indInc); ProcessHeaderFooter(APageSequence.Header, TAG_HEADER); ProcessHeaderFooter(APageSequence.Footer, TAG_FOOTER); // Define the Page Layout dWidth := APageSequence.Width; If dWidth = 0 Then dWidth := FData.Width; If dWidth=0 Then dWidth := 210; // Default A4 dHeight := APageSequence.Height; If dHeight = 0 Then dHeight := FData.Height; If dHeight=0 Then dHeight := 297; // Default A4 If ((dWidth <> 0) And (dHeight <> 0)) Then Begin sTemp := Format('' Else sTemp := sTemp + ' w:orient="landscape"/>'; oDocXML.Add(sTemp); End; { TODO : Ensure these other properties can be set } // // // oDocXML.Add(indDec, '', indDec); If Not ALastPage Then Begin oDocXML.Add(indDec, ''); oDocXML.Add(indDec, ''); End; End; Procedure AddTableBorderProperty(ATag: String; ABorder: TvTableBorder); Var sAttrib: String; Begin If ABorder.LineType <> tbtDefault Then Begin sAttrib := ''; If ABorder.LineType <> tbtNone Then sAttrib := sAttrib + 'w:val="' + LU_BORDERTYPE[ABorder.LineType] + '" '; sAttrib := sAttrib + 'w:space="' + mmToPointS(ABorder.Spacing) + '" '; If ABorder.Width <> 0 Then // Eights of a Point?? Really, they're just making this up... sAttrib := sAttrib + 'w:sz="' + mmToPointS(Min(96, Max(2, 8 * ABorder.Width))) + '" ' Else // 4 is the minimum sAttrib := sAttrib + 'w:sz="4" '; If ABorder.Color <> FPColor(0, 0, 0, 0) Then sAttrib := sAttrib + 'w:color="' + FPColorToRGBHexString(ABorder.Color) + '" ' Else sAttrib := sAttrib + 'w:color="auto" '; oDocXML.Add(Format('<%s %s/>', [ATag, Trim(sAttrib)])); End; End; Procedure ProcessTable(ATable: TvTable); Var i, j, k: Integer; oRow: TvTableRow; oCell: TvTableCell; //sTemp : String; Begin oDocXML.Add(indInc, ''); // Add the table properties oDocXML.Add(indInc, '', indInc); If ATable.PreferredWidth.Value <> 0 Then oDocXML.Add(Format('', [DimAttribs(ATable.PreferredWidth)])); oDocXML.Add(indNone, '', indInc); AddTableBorderProperty('w:left', ATable.Borders.Left); AddTableBorderProperty('w:right', ATable.Borders.Right); AddTableBorderProperty('w:top', ATable.Borders.Top); AddTableBorderProperty('w:bottom', ATable.Borders.Bottom); AddTableBorderProperty('w:insideH', ATable.Borders.InsideHoriz); AddTableBorderProperty('w:insideV', ATable.Borders.InsideVert); oDocXML.Add(indNone, '', indDec); If Assigned(ATable.Style) Then oDocXML.Add(''); If ATable.SpacingBetweenCells <> 0 Then oDocXML.Add(''); If ATable.BackgroundColor <> FPColor(0, 0, 0, 0) Then oDocXML.Add(Format('', [FPColorToRGBHexString(ATable.BackgroundColor)])); oDocXML.Add(indDec, '', indDec); // Define the grid. Grid is used to determine cell widths // and boundaries oDocXML.Add(indInc, '', indInc); // Percent cannot be set here, only absolutes If ATable.ColWidthsUnits = dimMillimeter Then For k := Low(ATable.ColWidths) To High(ATable.ColWidths) Do oDocXML.Add(Format('', [mmToTwipsS(ATable.ColWidths[k])])) Else If ATable.ColWidthsUnits = dimPoint Then For k := Low(ATable.ColWidths) To High(ATable.ColWidths) Do oDocXML.Add(Format('', [IntToStr(Round(20 * ATable.ColWidths[k]))])); oDocXML.Add(indDec, '', indDec); For i := 0 To ATable.GetRowCount - 1 Do Begin oRow := ATable.GetRow(i); oDocXML.Add(indInc, ''); // Add the Row Properties oDocXML.Add(indInc, '', indInc); If oRow.Header Then oDocXML.Add(''); If Not oRow.AllowSplitAcrossPage Then oDocXML.Add(''); If oRow.CellSpacing <> 0 Then oDocXML.Add(''); { TODO : w:hRule="exact", "auto" } If oRow.Height <> 0 Then oDocXML.Add(''); // Row Background Colour can't be applied here, have to apply to each cell in turn... oDocXML.Add(indDec, '', indDec); For j := 0 To oRow.GetCellCount - 1 Do Begin oCell := oRow.GetCell(j); oDocXML.Add(indInc, ''); // Add the Cell Properties oDocXML.Add(indInc, '', indInc); oDocXML.Add(indNone, '', indInc); AddTableBorderProperty('w:left', oCell.Borders.Left); AddTableBorderProperty('w:right', oCell.Borders.Right); AddTableBorderProperty('w:top', oCell.Borders.Top); AddTableBorderProperty('w:bottom', oCell.Borders.Bottom); oDocXML.Add(indNone, '', indDec); // Row background color can't be applied at the row level, so we'll // apply it to each cell in turn (only if the cell doesn't have it's // own value assigned) If oCell.BackgroundColor <> FPColor(0, 0, 0, 0) Then oDocXML.Add(Format('', [FPColorToRGBHexString(oCell.BackgroundColor)])) Else If oRow.BackgroundColor <> FPColor(0, 0, 0, 0) Then oDocXML.Add(Format('', [FPColorToRGBHexString(oRow.BackgroundColor)])); // Either use Cell Preferred Width, or ColWidths if defined as % If oCell.PreferredWidth.Value <> 0 Then oDocXML.Add(Format('', [DimAttribs(oCell.PreferredWidth)])) Else If (j <= High(ATable.ColWidths)) Then oDocXML.Add(Format('', [DimAttribs(Dimension(ATable.ColWidths[j], ATable.ColWidthsUnits))])); If ATable.ColWidthsUnits <> dimPercent Then oDocXML.Add(''); oDocXML.Add(''); oDocXML.Add(indDec, '', indDec); ProcessRichText(oCell); oDocXML.Add(indDec, ''); End; oDocXML.Add(indDec, ''); End; oDocXML.Add(indDec, ''); End; (* Procedure ProcessImage(AImage : TvImage); begin end; *) Procedure ProcessRichText(ARichText: TvRichText); Var i: Integer; oEntity: TvEntity; Begin For i := 0 To ARichText.GetEntitiesCount - 1 Do Begin oEntity := ARichText.GetEntity(i); If oEntity Is TvParagraph Then ProcessParagraph(TvParagraph(oEntity)) Else If oEntity Is TvList Then ProcessList(TvList(oEntity)) Else If oEntity Is TvTable Then ProcessTable(TvTable(oEntity)) Else If oEntity Is TvRichText Then ProcessRichText(TvRichText(oEntity)) (* Else If oEntity Is TvImage Then ProcessImage(TvImage(oEntity)) *) Else Raise Exception.Create('Unsupported entity ' + oEntity.ClassName); End; End; Var oPage: TvPage; oPageSequence: TvTextPageSequence; oFile: TFileInformation; Begin oFile := FFiles.AddXMLFile(OOXML_CONTENTTYPE_DOCUMENT, OOXML_PATH_DOCUMENT, OOXML_TYPE_DOCUMENT, [ftContentTypes, ftRelationships]); oDocXML := oFile.XML; oDocXML.Clear; oDocXML.Add(XML_HEADER); oDocXML.Add(Format('', [OOXML_DOCUMENT_NAMESPACE + 'xml:space="preserve"'])); oDocXML.Add(indInc, ''); For iPage := 0 To FData.GetPageCount - 1 Do Begin oPage := FData.GetPageAsText(iPage); If oPage Is TvTextPageSequence Then Begin oPageSequence := TvTextPageSequence(oPage); ProcessRichText(oPageSequence.MainText); // Add any dimensions, headers, footers etc FinalisePage(oPageSequence, iPage = FData.GetPageCount - 1); End; End; oDocXML.Add(indDec, ''); oDocXML.Add(''); End; Function TvDOCXVectorialWriter.StyleNameToStyleID(AStyle: TvStyle): String; Begin If Trim(AStyle.Name) <> '' Then Result := StringReplace(AStyle.Name, ' ', '', [rfReplaceAll, rfIgnoreCase]) Else Begin Result := Format('StyleID%d', [FData.FindStyleIndex(AStyle)]); AStyle.Name := Result; // Saves having to do the FindIndex later... End; End; Procedure TvDOCXVectorialWriter.PrepareTextRunStyle(ADoc: TIndentedStringList; AStyle: TvStyle); Begin ADoc.Add(indInc, '', indInc); If (spbfFontName In AStyle.SetElements) And (AStyle.Font.Name <> '') Then ADoc.Add(''); If spbfFontSize In AStyle.SetElements Then { TODO : Where does the magic Font.Size*2 come from? Confirm... } ADoc.Add(''); If spbfFontBold In AStyle.SetElements Then ADoc.Add(''); If spbfFontItalic In AStyle.SetElements Then ADoc.Add(''); If spbfFontUnderline In AStyle.SetElements Then ADoc.Add(''); If spbfFontStrikeThrough In AStyle.SetElements Then ADoc.Add(''); If CompareColors(AStyle.Font.Color, FPColor(0, 0, 0, 0)) <> 0 Then ADoc.Add(''); // Can Word handled re-oriented text? I hope not... If AStyle.Font.Orientation <> 0 Then; ADoc.DecIndent; // Don't bother adding an empty tag.. If ADoc[ADoc.Count - 1] <> '' Then ADoc.Add(indDec, '') Else Begin ADoc.Delete(ADoc.Count - 1); ADoc.DecIndent; End; End; Procedure TvDOCXVectorialWriter.PrepareStyles; Var sType, sTemp: String; i: Integer; oXML: TIndentedStringList; oStyle: TvStyle; oFile: TFileInformation; Begin // Only add this file if there are any styles defined... If FData.GetStyleCount > 0 Then Begin oFile := FFiles.AddXMLFile(OOXML_CONTENTTYPE_STYLES, OOXML_PATH_STYLES, OOXML_TYPE_STYLES, [ftContentTypes, ftDocRelationships]); oXML := oFile.XML; oXML.Clear; oXML.Add(XML_HEADER); oXML.Add(Format('', [OOXML_DOCUMENT_NAMESPACE])); For i := 0 To FData.GetStyleCount - 1 Do Begin oStyle := FData.GetStyle(i); If oStyle.GetKind In [vskTextBody, vskHeading] Then sType := 'paragraph' Else If oStyle.GetKind In [vskTextSpan] Then sType := 'character' Else { TODO : handle the other StyleKinds } Raise Exception.Create('Unsupported StyleKind in ' + oStyle.Name); oXML.Add(indInc, ''); // Add the name and inheritance values oXML.Add(' '); If Assigned(oStyle.Parent) Then oXML.Add(' '); { TODO : doesn't always need to be set, but I don't yet understand the rules... } oXML.Add(' '); // Latent Style Primary Style Setting. { TODO : Specification states you CANNOT redeclare a identical property declared in a parent. At the moment code is relying on Styles correctly defined up through hierarchy } If sType = 'paragraph' Then Begin // Add the Paragraph Properties oXML.Add(indInc, '', indInc); // Define Before and After spacing If (sseMarginTop In oStyle.SetElements) Or (sseMarginBottom In oStyle.SetElements) Then Begin sTemp := ''; If sseMarginTop In oStyle.SetElements Then sTemp := sTemp + ' w:before="' + mmToTwipsS(oStyle.MarginTop) + '"'; If sseMarginBottom In oStyle.SetElements Then sTemp := sTemp + ' w:after="' + mmToTwipsS(oStyle.MarginBottom) + '"'; oXML.Add(Format('', [sTemp])); End; If (sseMarginLeft In oStyle.SetElements) Or (sseMarginRight In oStyle.SetElements) Then Begin sTemp := ''; If sseMarginLeft In oStyle.SetElements Then sTemp := sTemp + ' w:left="' + mmToTwipsS(oStyle.MarginLeft) + '"'; If sseMarginRight In oStyle.SetElements Then sTemp := sTemp + ' w:right="' + mmToTwipsS(oStyle.MarginRight) + '"'; oXML.Add(Format('', [sTemp])); End; // Alignment If spbfAlignment In oStyle.SetElements Then oXML.Add(''); // Suppress Spacing between identical paragraphs... If oStyle.SuppressSpacingBetweenSameParagraphs Then oXML.Add(''); oXML.DecIndent; If oXML[oXML.Count - 1] <> '' Then oXML.Add(indDec, '') Else Begin oXML.Delete(oXML.Count - 1); oXML.DecIndent; End; End; // Now add the actual formatting (rPr = Run Properties). PrepareTextRunStyle(oXML, oStyle); oXML.Add(indDec, ' '); End; oXML.Add(''); End; End; Procedure TvDOCXVectorialWriter.PrepareNumbering; Var oXML: TIndentedStringList; oStyle: TvListStyle; oFile: TFileInformation; i: Integer; j: Integer; oListLevelStyle: TvListLevelStyle; sTotalLeader: String; sCurrentLeader: String; slvlText: String; Begin // Only add this file if there are any List styles defined... If FData.GetListStyleCount > 0 Then Begin oFile := FFiles.AddXMLFile(OOXML_CONTENTTYPE_NUMBERING, OOXML_PATH_NUMBERING, OOXML_TYPE_NUMBERING, [ftContentTypes, ftDocRelationships]); oXML := oFile.XML; oXML.Clear; oXML.Add(XML_HEADER); oXML.Add(Format('', [OOXML_DOCUMENT_NAMESPACE])); For i := 0 To FData.GetListStyleCount - 1 Do Begin oStyle := FData.GetListStyle(i); // abstractNumID allows us to group different list styles together. // The way fpvectorial uses it, there will be a one to one relationship // between abstractNumID and numID. // abstractNumId is 0 based // numID is 1 based. Go figure... oXML.Add(indInc, Format('', [i]), indInc); sTotalLeader := ''; For j := 0 To oStyle.GetListLevelStyleCount-1 Do Begin oListLevelStyle := oStyle.GetListLevelStyle(j); oXML.Add(Format('', [oListLevelStyle.Level]), indInc); with oListLevelStyle do sCurrentLeader := Format('%s%s%d%s', [Prefix, '%', Level + 1, Suffix]); sTotalLeader := sTotalLeader + sCurrentLeader; If oListLevelStyle.Kind=vlskBullet Then slvlText := oListLevelStyle.Bullet Else If oListLevelStyle.DisplayLevels Then slvlText := sTotalLeader Else slvlText := sCurrentLeader; If oListLevelStyle.Kind=vlskBullet Then oXML.Add('') Else Begin // Numbered Lists oXML.Add(Format('', [oListLevelStyle.Start])); oXML.Add(''); End; oXML.Add(''); oXML.Add(''); oXML.Add(''); oXML.Add(Format(' ', [mmToTwipsS(oListLevelStyle.MarginLeft), mmToTwipsS(oListLevelStyle.HangingIndent)])); oXML.Add(''); oXML.Add(''); oXML.Add(Format(' ', [oListLevelStyle.LeaderFontName, oListLevelStyle.LeaderFontName])); oXML.Add(''); oXML.Add('', indDec); end; oXML.Add(indDec, '', indDec); End; For i := 0 To FData.GetListStyleCount - 1 Do begin oXML.Add(indInc, Format('', [i + 1])); oXML.Add(Format(' ', [i])); oXML.Add(indDec, ''); end; oXML.Add(''); End; End; Procedure TvDOCXVectorialWriter.WriteToFile(AFileName: String; AData: TvVectorialDocument); Var oStream: TFileStream; Begin If ExtractFileExt(AFilename) = '' Then AFilename := AFilename + STR_DOCX_EXTENSION; oStream := TFileStream.Create(AFileName, fmCreate); Try WriteToStream(oStream, AData); Finally FreeAndNil(oStream); End; End; Procedure TvDOCXVectorialWriter.WriteToStream(AStream: TStream; AData: TvVectorialDocument); Var oContentTypes, oRelsRels, oDocumentRels: TStringStream; oZip: TZipper; i: Integer; Begin FData := AData; PrepareStyles; PrepareDocument; PrepareNumbering; // These documents need building up with details of all included files, // not worth the overhead of handling as StringLists oContentTypes := TStringStream.Create(PrepareContentTypes); oRelsRels := TStringStream.Create(PrepareRelationships); oDocumentRels := TStringStream.Create(PrepareDocRelationships); oZip := TZipper.Create; Try oZip.Entries.AddFileEntry(oContentTypes, OOXML_PATH_TYPES); oZip.Entries.AddFileEntry(oRelsRels, OOXML_PATH_RELS_RELS); oZip.Entries.AddFileEntry(oDocumentRels, OOXML_PATH_DOCUMENT_RELS); For i := 0 To FFiles.Count - 1 Do oZip.Entries.AddFileEntry(FFiles[i].Stream, FFiles[i].Path); oZip.SaveToStream(AStream); Finally oZip.Free; For i := 0 To FFiles.Count - 1 Do FFiles[i].FreeStream; oContentTypes.Free; oRelsRels.Free; oDocumentRels.Free; End; End; Initialization RegisterVectorialWriter(TvDOCXVectorialWriter, vfDOCX); End.