FastReport_2022_VCL/LibD28x64/frxExportPPTX.pas
2024-01-01 16:13:08 +01:00

831 lines
32 KiB
ObjectPascal

{******************************************}
{ }
{ FastReport VCL }
{ PPTX export }
{ }
{ Copyright (c) 1998-2021 }
{ }
{******************************************}
unit frxExportPPTX;
interface
{$I frx.inc}
uses
{$IFNDEF FPC}
Windows, Messages, ShellAPI,
{$ELSE}
LCLType, LCLIntf, LazHelper,
{$ENDIF}
SysUtils, Classes, Graphics,
frxClass, ComCtrls, frxZip, frxImageConverter,
frxExportBaseDialog, frxStorage
{$IFDEF DELPHI16}
, System.UITypes
{$ENDIF}
;
type
TWriteRelationship = procedure(IntertNum: Integer; Rid, Path: String) of object;
{$IFDEF DELPHI16}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
TfrxPPTXExport = class(TfrxBaseDialogExportFilter)
private
FDocFolder: string;
FContentTypes: TStream; // [Content_Types].xml
FPresentation: TStream; // ppt/presentation.xml
FPresentationRels: TStream; // ppt/_rels/presentation.xml.rels
FRels: TStream; // _rels/.rels
FSlide: TStream; // ppt/slides/slideNNN.xml
FSlideRels: TStream; // ppt/slides/_rels/slideNNN.xml.rels
FSlideId: Integer;
FObjectId: Integer;
FPage: TfrxReportPage;
FWidth, FHeight: Integer;
FPictureType: TfrxPictureType;
FWriteRelationship: TWriteRelationship;
NumPictListPage: TListHashTable;
function SubPath(const s: string): string;
procedure AddTextBox(Obj: TfrxCustomMemoView);
procedure AddLine(Line: TfrxFrameLine; x, y, dx, dy: Integer);
procedure AddPicture(Obj: TfrxView);
function GetObjRect(Obj: TfrxView): TRect;
procedure HashRelationship(IntertNum: Integer; Rid, Path: String);
procedure NonHashRelationship(IntertNum: Integer; Rid, Path: String);
protected
function EnableCalculateHash: Boolean; override;
public
constructor Create(Owner: TComponent); override;
class function GetDescription: string; override;
class function ExportDialogClass: TfrxBaseExportDialogClass; override;
function Start: Boolean; override;
procedure Finish; override;
procedure StartPage(Page: TfrxReportPage; Index: Integer); override;
procedure FinishPage(Page: TfrxReportPage; Index: Integer); override;
procedure ExportObject(Obj: TfrxComponent); override;
published
property OpenAfterExport;
property OverwritePrompt;
property PictureType: TfrxPictureType read FPictureType write FPictureType;
end;
implementation
uses
frxUtils, frxFileUtils, frxUnicodeUtils, frxRes, frxrcExports, frxGraphicUtils,
frxOfficeOpen, frxExportPPTXDialog, frxPlatformServices;
const
LenFactor = 12000;
FileExt: string = '.pptx';
{ TfrxPPTXExport }
function TfrxPPTXExport.GetObjRect(Obj: TfrxView): TRect;
begin
Result.Left := Trunc(Obj.AbsLeft * LenFactor);
Result.Top := Trunc(Obj.AbsTop * LenFactor);
Result.Right := Result.Left + Trunc(Obj.Width * LenFactor);
Result.Bottom := Result.Top + Trunc(Obj.Height * LenFactor);
if Result.Left > Result.Right then Exchange(Result.Left, Result.Right);
if Result.Top > Result.Bottom then Exchange(Result.Top, Result.Bottom);
end;
procedure TfrxPPTXExport.HashRelationship(IntertNum: Integer; Rid, Path: String);
begin
if (NumPictListPage.GetValue(IntertNum) = nil) then
begin
NonHashRelationship(IntertNum, Rid, Path);
NumPictListPage.SetValue(IntertNum, Pointer(1));
end;
end;
procedure TfrxPPTXExport.NonHashRelationship(IntertNum: Integer; Rid, Path: String);
begin
WriteStr(FSlideRels, Format('<Relationship Id="%s" Type="http://schemas.openxmlformats.' +
'org/officeDocument/2006/relationships/image" Target="../media/%s"/>', [Rid, Path]));
end;
function TfrxPPTXExport.EnableCalculateHash: Boolean;
begin
Result := True;
end;
function TfrxPPTXExport.SubPath(const s: string): string;
begin
Result := FDocFolder + '\' + s;
end;
class function TfrxPPTXExport.GetDescription: string;
begin
Result := frxGet(9201);
end;
function TfrxPPTXExport.Start: Boolean;
begin
Result := False; // Default
if (FileName = '') and not Assigned(Stream) then
Exit;
Result := True;
{ file structure }
FDocFolder := IOTransport.TempFilter.BasePath;
CreateDirs(IOTransport.TempFilter, ['_rels', 'docProps', 'ppt', 'ppt\theme', 'ppt\_rels',
'ppt\media', 'ppt\slides', 'ppt\slides\_rels', 'ppt\slideLayouts',
'ppt\slideLayouts\_rels', 'ppt\slideMasters', 'ppt\slideMasters\_rels']);
{ [Content_Types].xml }
FContentTypes := IOTransport.TempFilter.GetStream(SubPath('[Content_Types].xml'));
//TFileStream.Create(SubPath('[Content_Types].xml'), fmCreate);
with TfrxWriter.Create(FContentTypes) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<Types xmlns="http://schemas.openxmlformats.org/package/2006/content-types">',
'<Default Extension="rels" ContentType="application/vnd.openxmlformats-package.relationships+xml"/>',
'<Default Extension="xml" ContentType="application/xml"/>',
'<Default Extension="emf" ContentType="image/emf"/>',
'<Override PartName="/ppt/presentation.xml" ContentType="application/vnd.openxmlformats-officedocument.presentationml.presentation.main+xml"/>',
'<Override PartName="/docProps/core.xml" ContentType="application/vnd.openxmlformats-package.core-properties+xml"/>',
'<Override PartName="/docProps/app.xml" ContentType="application/vnd.openxmlformats-officedocument.extended-properties+xml"/>',
'<Override PartName="/ppt/tableStyles.xml" ContentType="application/vnd.openxmlformats-officedocument.presentationml.tableStyles+xml"/>',
'<Override PartName="/ppt/presProps.xml" ContentType="application/vnd.openxmlformats-officedocument.presentationml.presProps+xml"/>',
'<Override PartName="/ppt/viewProps.xml" ContentType="application/vnd.openxmlformats-officedocument.presentationml.viewProps+xml"/>',
'<Override PartName="/ppt/theme/theme.xml" ContentType="application/vnd.openxmlformats-officedocument.theme+xml"/>',
'<Override PartName="/ppt/slideLayouts/slideLayout.xml" ContentType="application/vnd.openxmlformats-officedocument.presentationml.slideLayout+xml"/>',
'<Override PartName="/ppt/slideMasters/slideMaster.xml" ContentType="application/vnd.openxmlformats-officedocument.presentationml.slideMaster+xml"/>']);
Free;
end;
{ _rels/.rels }
FRels := IOTransport.TempFilter.GetStream(SubPath('_rels\.rels'));
//TFileStream.Create(SubPath('_rels/.rels'), fmCreate);
with TfrxWriter.Create(FRels) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">',
'<Relationship Id="rId1" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" Target="docProps/core.xml"/>',
'<Relationship Id="rId2" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" Target="ppt/presentation.xml"/>',
'<Relationship Id="rId3" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties" Target="docProps/app.xml"/>',
'</Relationships>']);
Free;
end;
{ docProps/core.xml }
with TfrxFileWriter.Create(IOTransport.TempFilter.GetStream(SubPath('docProps\core.xml'))) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<cp:coreProperties xmlns:cp="http://schemas.openxmlformats.org/package/2006/metadata/core-properties"',
' xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:dcterms="http://purl.org/dc/terms/" xmlns:dcmitype="http://purl.org/dc/dcmitype/" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">',
'<dc:title>' + Report.ReportOptions.Name + '</dc:title>',
'<dc:subject></dc:subject>',
'<dc:creator>' + Report.ReportOptions.Author + '</dc:creator>',
'<cp:keywords></cp:keywords>',
'<dc:description>' + Report.ReportOptions.Description.Text + '</dc:description>',
'<cp:lastModifiedBy>' + Report.ReportOptions.Author + '</cp:lastModifiedBy>',
'<cp:revision>2</cp:revision>',
{$IfDef EXPORT_TEST}
'<dcterms:created xsi:type="dcterms:W3CDTF">2019-01-12T11:06:45Z</dcterms:created>',
'<dcterms:modified xsi:type="dcterms:W3CDTF">2019-01-12T11:06:45Z</dcterms:modified>',
{$Else}
'<dcterms:created xsi:type="dcterms:W3CDTF">' + FormatDateTime('yyyy"-"mm"-"dd"T"hh":"nn":"ss"Z"', DateTimeToUTC(Now)) + '</dcterms:created>',
'<dcterms:modified xsi:type="dcterms:W3CDTF">' + FormatDateTime('yyyy"-"mm"-"dd"T"hh":"nn":"ss"Z"', DateTimeToUTC(Now)) + '</dcterms:modified>',
{$EndIf}
'</cp:coreProperties>'], True);
Free;
end;
{ docProps/app.xml }
with TfrxFileWriter.Create(IOTransport.TempFilter.GetStream(SubPath('docProps\app.xml'))) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<Properties xmlns="http://schemas.openxmlformats.org/officeDocument/2006/extended-properties" xmlns:vt="http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes">',
'<TotalTime>0</TotalTime><Words>0</Words><PresentationFormat>Arbitrary</PresentationFormat>',
'<Paragraphs>0</Paragraphs><Slides>1</Slides><Notes>0</Notes><HiddenSlides>0</HiddenSlides>',
'<MMClips>0</MMClips><ScaleCrop>false</ScaleCrop><HeadingPairs><vt:vector size="4" baseType="variant">',
'<vt:variant><vt:lpstr>Subject</vt:lpstr></vt:variant><vt:variant><vt:i4>2</vt:i4></vt:variant>',
'<vt:variant><vt:lpstr>Slide Headers</vt:lpstr></vt:variant><vt:variant><vt:i4>1</vt:i4></vt:variant>',
'</vt:vector></HeadingPairs><TitlesOfParts><vt:vector size="3" baseType="lpstr"><vt:lpstr>Office Theme</vt:lpstr>',
'<vt:lpstr>Office Theme</vt:lpstr><vt:lpstr>Slide 1</vt:lpstr></vt:vector>',
'</TitlesOfParts><LinksUpToDate>false</LinksUpToDate><SharedDoc>false</SharedDoc>',
'<HyperlinksChanged>false</HyperlinksChanged><AppVersion>12.0000</AppVersion></Properties>']);
Free;
end;
{ ppt/presentation.xml }
FPresentation := IOTransport.TempFilter.GetStream(SubPath('ppt\presentation.xml'));
//TFileStream.Create(SubPath('ppt/presentation.xml'), fmCreate);
with TfrxWriter.Create(FPresentation) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<p:presentation xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main"',
' xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" ',
'xmlns:p="http://schemas.openxmlformats.org/presentationml/2006/main" ',
'saveSubsetFonts="1"><p:sldMasterIdLst><p:sldMasterId id="2147483648" r:id="rId0"/>',
'</p:sldMasterIdLst><p:sldIdLst>']);
Free;
end;
{ ppt/presProps.xml }
with TfrxFileWriter.Create(IOTransport.TempFilter.GetStream(SubPath('ppt\presProps.xml'))) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<p:presentationPr xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main"',
' xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" ',
'xmlns:p="http://schemas.openxmlformats.org/presentationml/2006/main"/>']);
Free;
end;
{ ppt/tableStyles.xml }
with TfrxFileWriter.Create(IOTransport.TempFilter.GetStream(SubPath('ppt\tableStyles.xml'))) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<a:tblStyleLst xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" def="{5C22544A-7EE6-4342-B048-85BDC9FD1C3A}"/>']);
Free;
end;
{ ppt/_rels/presentation.xml.rels }
FPresentationRels := IOTransport.TempFilter.GetStream(SubPath('ppt\_rels\presentation.xml.rels'));
//TFileStream.Create(SubPath('ppt/_rels/presentation.xml.rels'), fmCreate);
with TfrxWriter.Create(FPresentationRels) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">',
'<Relationship Id="rId0" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideMaster" Target="slideMasters/slideMaster.xml"/>',
'<Relationship Id="rIdpp" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/presProps" Target="presProps.xml"/>',
'<Relationship Id="rIdvp" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/viewProps" Target="viewProps.xml"/>',
'<Relationship Id="rIdt" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme" Target="theme/theme.xml"/>',
'<Relationship Id="rIdts" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/tableStyles" Target="tableStyles.xml"/>']);
Free;
end;
{ ppt/slideLayouts/_rels/slideLayout.xml.rels }
with TfrxFileWriter.Create(IOTransport.TempFilter.GetStream(SubPath('ppt\slideLayouts\_rels\slideLayout.xml.rels'))) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">',
'<Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideMaster" Target="../slideMasters/slideMaster.xml"/>',
'</Relationships>']);
Free;
end;
{ ppt/slideLayouts/slideLayout.xml }
with TfrxFileWriter.Create(IOTransport.TempFilter.GetStream(SubPath('ppt\slideLayouts\slideLayout.xml'))) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<p:sldLayout xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" ',
'xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" ',
'xmlns:p="http://schemas.openxmlformats.org/presentationml/2006/main" type="blank" preserve="1">',
'<p:cSld name="Blank"><p:spTree><p:nvGrpSpPr><p:cNvPr id="1" name=""/><p:cNvGrpSpPr/>',
'<p:nvPr/></p:nvGrpSpPr><p:grpSpPr><a:xfrm><a:off x="0" y="0"/><a:ext cx="0" cy="0"/>',
'<a:chOff x="0" y="0"/><a:chExt cx="0" cy="0"/></a:xfrm></p:grpSpPr></p:spTree>',
'</p:cSld><p:clrMapOvr><a:masterClrMapping/></p:clrMapOvr></p:sldLayout>']);
Free;
end;
{ ppt/slideMasters/_rels/slideMaster.xml.rels }
with TfrxFileWriter.Create(IOTransport.TempFilter.GetStream(SubPath('ppt\slideMasters\_rels\slideMaster.xml.rels'))) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">',
'<Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout" Target="../slideLayouts/slideLayout.xml"/>',
'<Relationship Id="rId2" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme" Target="../theme/theme.xml"/>',
'</Relationships>']);
Free;
end;
{ ppt/slideMasters/slideMaster.xml }
with TfrxFileWriter.Create(IOTransport.TempFilter.GetStream(SubPath('ppt\slideMasters\slideMaster.xml'))) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<p:sldMaster xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" xmlns:p="http://schemas.openxmlformats.org/presentationml/2006/main">',
'<p:cSld><p:bg><p:bgRef idx="1001"><a:schemeClr val="bg1"/></p:bgRef></p:bg><p:spTree>',
'<p:nvGrpSpPr><p:cNvPr id="1" name=""/><p:cNvGrpSpPr/><p:nvPr/></p:nvGrpSpPr><p:grpSpPr>',
'<a:xfrm><a:off x="0" y="0"/><a:ext cx="0" cy="0"/><a:chOff x="0" y="0"/><a:chExt cx="0" cy="0"/>',
'</a:xfrm></p:grpSpPr></p:spTree></p:cSld>',
'<p:clrMap bg1="lt1" tx1="dk1" bg2="lt2" tx2="dk2" accent1="accent1" ',
'accent2="accent2" accent3="accent3" accent4="accent4" accent5="accent5" ',
'accent6="accent6" hlink="hlink" folHlink="folHlink"/><p:sldLayoutIdLst>',
'<p:sldLayoutId id="2147483649" r:id="rId1"/></p:sldLayoutIdLst><p:txStyles><p:titleStyle>',
'</p:titleStyle><p:bodyStyle></p:bodyStyle><p:otherStyle><a:defPPr><a:defRPr ',
'lang="en-US"/></a:defPPr></p:otherStyle></p:txStyles></p:sldMaster>']);
Free;
end;
{ ppt/theme/theme.xml }
with TResourceStream.Create(HInstance, 'OfficeOpenTheme', 'XML') do
begin
SaveToStream(IOTransport.TempFilter.GetStream(SubPath('ppt\theme\theme.xml')));
Free;
end;
{ ppt/viewProps.xml }
with TfrxFileWriter.Create(IOTransport.TempFilter.GetStream(SubPath('ppt\viewProps.xml'))) do
begin
Write('<?xml version="1.0" encoding="UTF-8" standalone="yes"?>' +
'<p:viewPr xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" xmlns:p="http://schemas.openxmlformats.org/presentationml/2006/main" lastView="sldThumbnailView">' +
'<p:normalViewPr showOutlineIcons="0"><p:restoredLeft sz="15620" autoAdjust="0"/>' +
'<p:restoredTop sz="94660" autoAdjust="0"/></p:normalViewPr><p:slideViewPr>' +
'<p:cSldViewPr><p:cViewPr varScale="1"><p:scale><a:sx n="104" d="100"/>' +
'<a:sy n="104" d="100"/></p:scale><p:origin x="-222" y="-90"/></p:cViewPr>' +
'<p:guideLst><p:guide orient="horz" pos="2160"/><p:guide pos="2880"/>' +
'</p:guideLst></p:cSldViewPr></p:slideViewPr><p:outlineViewPr><p:cViewPr>' +
'<p:scale><a:sx n="33" d="100" /><a:sy n="33" d="100"/></p:scale><p:origin x="0" y="0"/>' +
'</p:cViewPr></p:outlineViewPr><p:notesTextViewPr><p:cViewPr><p:scale><a:sx n="100" d="100"/>' +
'<a:sy n="100" d="100"/></p:scale><p:origin x="0" y="0"/></p:cViewPr></p:notesTextViewPr>' +
'<p:gridSpacing cx="73736200" cy="73736200"/></p:viewPr>');
Free;
end;
if (CalculatePictureHash) then
FWriteRelationship := HashRelationship
else
FWriteRelationship := NonHashRelationship;
end;
procedure TfrxPPTXExport.StartPage(Page: TfrxReportPage; Index: Integer);
begin
FSlideId := Index + 1;
FPage := Page;
FWidth := Trunc(Page.Width * LenFactor);
FHeight := Trunc(Page.Height * LenFactor);
{ [Content_Types].xml }
WriteStr(FContentTypes, Format('<Override PartName="/ppt/slides/slide%d.xml" ' +
'ContentType="application/vnd.openxmlformats-officedocument.presentationml.' +
'slide+xml"/>', [FSlideId]));
{ ppt/presentation.xml }
WriteStr(FPresentation, Format('<p:sldId id="%d" r:id="rId%d"/>',
[255 + FSlideId, FSlideId]));
{ ppt/_rels/presentation.xml.rels }
WriteStr(FPresentationRels, Format('<Relationship Id="rId%d" ' +
'Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" ' +
'Target="slides/slide%d.xml"/>', [FSlideId, FSlideId]));
{ ppt/slides/slideNNN.xml }
FSlide := IOTransport.TempFilter.GetStream(SubPath(Format('ppt\slides\slide%d.xml', [FSlideId])));
//TFileStream.Create(SubPath(Format('ppt/slides/slide%d.xml',
// [FSlideId])), fmCreate);
with TfrxWriter.Create(FSlide) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<p:sld xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" xmlns:p="http://schemas.openxmlformats.org/presentationml/2006/main">',
'<p:cSld><p:spTree><p:nvGrpSpPr><p:cNvPr id="1" name=""/><p:cNvGrpSpPr/><p:nvPr/>',
'</p:nvGrpSpPr><p:grpSpPr><a:xfrm><a:off x="0" y="0"/><a:ext cx="0" cy="0"/>',
'<a:chOff x="0" y="0"/><a:chExt cx="0" cy="0"/></a:xfrm></p:grpSpPr>']);
Free;
end;
{ ppt/slides/_rels/slideNNN.xml.rels }
FSlideRels := IOTransport.TempFilter.GetStream(SubPath(Format('ppt\slides\_rels\slide%d.xml.rels',
[FSlideId])));
// TFileStream.Create(SubPath(Format('ppt/slides/_rels/slide%d.xml.rels',
// [FSlideId])), fmCreate);
with TfrxWriter.Create(FSlideRels) do
begin
Write(['<?xml version="1.0" encoding="UTF-8" standalone="yes"?>',
'<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">',
'<Relationship Id="rId0" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout" Target="../slideLayouts/slideLayout.xml"/>']);
Free;
end;
if (CalculatePictureHash) then
NumPictListPage := TListHashTable.Create;
end;
function BorderStyle(style: TfrxFrameStyle): String;
begin
case style of
fsSolid: Result := 'solid';
fsDash: Result := 'dashed';
fsDot: Result := 'sysDot';
fsDashDot: Result := 'sysDashDot';
fsDashDotDot: Result := 'sysDashDotDot';
fsDouble: Result := 'solid';
fsAltDot: Result := 'sysDot';
fsSquare: Result := 'solid';
else Result := 'solid';
end;
end;
procedure TfrxPPTXExport.AddLine(Line: TfrxFrameLine; x, y, dx, dy: Integer);
var
Width: Integer;
begin
Inc(FObjectId);
with TfrxWriter.Create(FSlide) do
begin
Width := Trunc(Line.Width * LenFactor);
if Line.Style = fsDouble then Width := Width * 3;
Write([Format('<p:cxnSp><p:nvCxnSpPr><p:cNvPr id="%d" name="Line%d"/><p:cNvCxnSpPr/>' +
'<p:nvPr/></p:nvCxnSpPr><p:spPr><a:xfrm><a:off x="%d" y="%d"/><a:ext cx="%d" ' +
'cy="%d"/></a:xfrm><a:prstGeom prst="line"><a:avLst/></a:prstGeom><a:ln w="%d">' +
'<a:solidFill><a:srgbClr val="%s"/></a:solidFill><a:prstDash val="%s"/></a:ln>' +
'</p:spPr><p:style><a:lnRef idx="1"><a:schemeClr val="accent1"/></a:lnRef><a:fillRef idx="0">' +
'<a:schemeClr val="accent1"/></a:fillRef><a:effectRef idx="0"><a:schemeClr val="accent1"/>' +
'</a:effectRef><a:fontRef idx="minor"><a:schemeClr val="tx1"/></a:fontRef></p:style>' +
'</p:cxnSp>', [FObjectId + 1, FObjectId, x, y, dx, dy, Width,
ColorText(Line.Color), BorderStyle(Line.Style)])]);
Free;
end;
end;
procedure TfrxPPTXExport.AddPicture(Obj: TfrxView);
var
{$IFDEF FPC}
m: TBitMap;
fr: frxClass.TfrxRect;
dx, dy, {fdx, fdy,} dpx, dpy: Double;
{$ELSE}
m: TMetafile;
{$ENDIF}
Rid, Path: string;
r: TRect;
IntertNum: Integer;
begin
if Obj.Height * Obj.Width = 0 then Exit;
Inc(FObjectId);
{$IFDEF FPC}
fr := Obj.GetRealBounds;
dx := fr.Right - fr.Left;
dy := fr.Bottom - fr.Top;
dpx := Obj.AbsLeft;// - fdx;
dpy := Obj.AbsTop;// - fdy;
if Round(dx) = 0 then
dx := 1;
if dx < 0 then
dpx := dpx + dx;
if Round(dy) = 0 then
dy := 1;
if dy < 0 then
dpy := dpy - dy;
m := TBitmap.Create();
m.Height := Round(Obj.Height);
m.Width := Round(Obj.Width);
m.Canvas.Brush.Color := ClWhite;
m.Canvas.FillRect(0, 0, m.Width, m.Height);
try
Obj.Draw(m.Canvas, 1, 1, -dpx, -dpy);
except
// charts throw exceptions when numbers are malformed
end;
{$ELSE}
m := TMetafile(Obj.GetVectorGraphic(True));
{$ENDIF}
IntertNum := FfrxPictureHashMap.FindOrAddGraphic(m, phmData, FObjectId);
Rid := 'rIdp' + IntToStr(IntertNum);
r := GetObjRect(Obj);
Path := 'image' + IntToStr(IntertNum) + '.emf';
with TfrxWriter.Create(FSlide) do
begin
Write(Format('<p:pic><p:nvPicPr><p:cNvPr id="%d" name="Picture4" descr="Picture%d"/>' +
'<p:cNvPicPr><a:picLocks noChangeAspect="1"/></p:cNvPicPr><p:nvPr/></p:nvPicPr>' +
'<p:blipFill><a:blip r:embed="%s" cstate="print"/><a:stretch><a:fillRect/>' +
'</a:stretch></p:blipFill><p:spPr><a:xfrm><a:off x="%d" y="%d"/>' +
'<a:ext cx="%d" cy="%d"/></a:xfrm><a:prstGeom prst="rect"><a:avLst/></a:prstGeom>' +
'<a:noFill/></p:spPr></p:pic>', [FObjectId, FObjectId + 1, Rid, r.Left, r.Top,
r.Right - r.Left + 1, r.Bottom - r.Top + 1]));
Free;
end;
FWriteRelationship(IntertNum, Rid, Path);
if (FfrxPictureHashMap.isLastNew) then
SaveGraphicAs(m, IOTransport.TempFilter.GetStream(SubPath('ppt\media\' + Path)), PictureType);
m.Free;
with Obj.Frame do
begin
if ftLeft in Typ then AddLine(LeftLine, r.Left, r.Top, 0, r.Bottom - r.Top + 1);
if ftRight in Typ then AddLine(RightLine, r.Right, r.Top, 0, r.Bottom - r.Top + 1);
if ftTop in Typ then AddLine(TopLine, r.Left, r.Top, r.Right - r.Left + 1, 0);
if ftBottom in Typ then AddLine(BottomLine, r.Left, r.Bottom, r.Right - r.Left + 1, 0);
end;
end;
procedure TfrxPPTXExport.AddTextBox(Obj: TfrxCustomMemoView);
const
HMap: array[0..3] of string = ('l', 'r', 'ctr', 'just');
VMap: array[0..2] of string = ('t', 'b', 'ctr');
function b2s(b: Boolean): string;
begin
if b then
Result := '1'
else
Result := '0';
end;
function bs(b: Boolean; const s: string): string;
begin
if b then
Result := s
else
Result := '';
end;
function strToPPTX(bobj: TfrxCustomMemoView): String;
var
i, iPos: integer;
s1: {$IFDEF FPCUNICODE}String{$ELSE}WideString{$ENDIF};
SharStr, sChunk: String;
TagList: TfrxHTMLTagsList;
Tag, PrevTag: TfrxHTMLTag;
bStyleChanged, bEOF: Boolean;
begin
if bobj.Memo.Text <> '' then
s1 := bobj.Memo.Text
else
s1 := ' ';
if bobj.AllowHTMLTags and (s1 <> ' ') then
begin
TagList := TfrxHTMLTagsList.Create;
SharStr := '';
TagList.ExpandHTMLTags(s1);
if (TagList.Count = 1) and (TagList.Items[0].Count > 0) then
begin
PrevTag := TagList.Items[0].Items[0];
i := 1;
iPos := 1;
repeat
Tag := TagList.Items[0].Items[i - 1];
bStyleChanged := (Tag.Style <> PrevTag.Style) or (Tag.Color <> PrevTag.Color) or (Tag.SubType <> PrevTag.SubType);
bEOF := i = frxLength(s1);
if bStyleChanged or bEOF then
begin
{$IFNDEF Linux}
if bEOF then
dec(i);
{$ENDIF}
sChunk := (String(Utf8Encode(frxCopy(s1, iPos, i - iPos))));
iPos := i;
if sChunk <> '' then
begin
SharStr := SharStr + Format('<a:r><a:rPr lang="en-US"' +
' sz="%d" b="%s" i="%s"%s%s smtClean="0"',
[bobj.Font.Size * 100,
b2s((fsBold in bobj.Font.Style) or (fsBold in PrevTag.Style)),
b2s((fsItalic in bobj.Font.Style) or (fsItalic in PrevTag.Style)),
bs((fsUnderline in bobj.Font.Style) or (fsUnderline in PrevTag.Style), ' u="sng"'),
bs((fsStrikeOut in bobj.Font.Style) or (fsStrikeOut in PrevTag.Style), ' strike="sngStrike"')]);
if PrevTag.SubType = ssSubscript then
SharStr := SharStr + ' baseline="-40000"'
else
if PrevTag.SubType = ssSuperscript then
SharStr := SharStr + ' baseline="30000"';
SharStr := SharStr + '><a:solidFill>';
if PrevTag.Color <> 0 then
SharStr := SharStr + '<a:srgbClr val="' + ColorText(PrevTag.Color or $010101) + '" />'
else
SharStr := SharStr + '<a:srgbClr val="' + ColorText(bobj.Font.Color or $010101) + '" />';
SharStr := SharStr + Format('</a:solidFill><a:latin typeface="%s"/></a:rPr><a:t>', [bobj.Font.Name]);
// note: in unicode delphi12+ Utf8Encode has no effect: when converted to widestring it does utf8decode automatically
SharStr := SharStr + String(Utf8Encode(CleanTrash(Escape(sChunk))));
SharStr := SharStr + '</a:t></a:r>';
end;
end;
PrevTag := Tag;
Inc(i);
until bEOF;
end;
TagList.Free;
Result := SharStr;
end
else
begin
Result := '';
Result := Result + Format('<a:r><a:rPr lang="en-US"' +
' sz="%d" b="%s" i="%s" %s smtClean="0"><a:solidFill><a:srgbClr val="%s" ' +
'/></a:solidFill><a:latin typeface="%s"/></a:rPr><a:t>',
[bobj.Font.Size * 100, b2s(fsBold in bobj.Font.Style), b2s(fsItalic in bobj.Font.Style),
bs(fsUnderline in bobj.Font.Style, 'u="sng"'), ColorText(bobj.Font.Color or $010101),
// RGBSwap(bobj.Font.Color) or $010101,
bobj.Font.Name]);
// note: in unicode delphi12+ Utf8Encode has no effect: when converted to widestring it does utf8decode automatically
Result := Result + String(Utf8Encode(CleanTrash(Escape(s1))));
Result := Result + '</a:t></a:r>';
end;
end;
var
r: TRect;
begin
Inc(FObjectId);
r := GetObjRect(Obj);
with TfrxWriter.Create(FSlide) do
begin
Write('<p:sp>');
Write('<p:nvSpPr><p:cNvPr id="%d" name="TextBox' +
'%d"/><p:cNvSpPr><a:spLocks noGrp="1"/></p:cNvSpPr><p:nvPr>' +
'<p:ph/></p:nvPr></p:nvSpPr>', [1 + FObjectId, FObjectId]);
Write('<p:spPr><a:xfrm><a:off x="%d" y="%d"/><a:ext cx="%d" cy="%d' +
'"/></a:xfrm><a:prstGeom prst="rect"><a:avLst/></a:prstGeom>' +
'%s</p:spPr>',
[r.Left, r.Top, r.Right - r.Left + 1, r.Bottom - r.Top + 1,
bs(Obj.Color <> clNone, Format('<a:solidFill><a:srgbClr val="%s"/></a:solidFill>',
[ColorText(Obj.Color or $010101)]))]);
// [RGBSwap(Obj.Color) or $010101]))]);
Write(Format('<p:txBody><a:bodyPr vert="horz" lIns="45720" tIns="22860"' +
' rIns="45720" bIns="22860" rtlCol="0" anchor="%s"><a:normAutofit/></a:bodyPr>' +
'<a:lstStyle/><a:p><a:pPr algn="%s"/>', [VMap[Integer(Obj.VAlign)],
HMap[Integer(Obj.HAlign)]]), {$IFDEF Delphi12}True{$ELSE}False{$ENDIF});
// note: in unicode delphi12+ Utf8Encode has no effect: when converted to widestring it does utf8decode automatically
Write(strToPPTX(obj), {$IFDEF Delphi12}True{$ELSE}False{$ENDIF});
Write('</a:p></p:txBody></p:sp>');
with Obj.Frame do
begin
if ftLeft in Typ then AddLine(LeftLine, r.Left, r.Top, 0, r.Bottom - r.Top + 1);
if ftRight in Typ then AddLine(RightLine, r.Right, r.Top, 0, r.Bottom - r.Top + 1);
if ftTop in Typ then AddLine(TopLine, r.Left, r.Top, r.Right - r.Left + 1, 0);
if ftBottom in Typ then AddLine(BottomLine, r.Left, r.Bottom, r.Right - r.Left + 1, 0);
end;
Free;
end;
end;
constructor TfrxPPTXExport.Create(Owner: TComponent);
begin
inherited;
DefaultExt := '.pptx';
FilterDesc := frxGet(9205);
FObjectId := 0;
end;
class function TfrxPPTXExport.ExportDialogClass: TfrxBaseExportDialogClass;
begin
Result := TfrxPPTXExportDialog;
end;
procedure TfrxPPTXExport.ExportObject(Obj: TfrxComponent);
var
v: TfrxView;
begin
if not (Obj is TfrxView) then Exit;
v := Obj as TfrxView;
if IsPageBG(v) or not (vsExport in v.Visibility) then
Exit;
if v is TfrxCustomMemoView then
AddTextBox(v as TfrxCustomMemoView)
else
AddPicture(v);
end;
procedure TfrxPPTXExport.FinishPage(Page: TfrxReportPage; Index: Integer);
begin
{ ppt/slides/_rels/slideNNN.xml.rels }
WriteStr(FSlideRels, '</Relationships>');
{ ppt/slides/slideNNN.xml }
WriteStr(FSlide, '</p:spTree></p:cSld><p:clrMapOvr><a:masterClrMapping/></p:clrMapOvr></p:sld>');
{ close files }
IOTransport.TempFilter.DoFilterProcessStream(FSlideRels, Self);
IOTransport.TempFilter.DoFilterProcessStream(FSlide, Self);
if (CalculatePictureHash) then
FreeAndNil(NumPictListPage);
end;
procedure TfrxPPTXExport.Finish;
var
Zip: TfrxZipArchive;
f: TStream;
FileNames: TStrings;
begin
WriteStr(FContentTypes, '</Types>');
FileNames := TStringList.Create;
{ ppt/presentation.xml }
with TfrxWriter.Create(FPresentation) do
begin
Write('</p:sldIdLst><p:sldSz cx="%d" cy="%d" type="custom"/>' +
'<p:notesSz cx="6858000" cy="9144000"/><p:defaultTextStyle><a:defPPr><a:defRPr ' +
'lang="en-US"/></a:defPPr></p:defaultTextStyle></p:presentation>',
[FWidth, FHeight]);
Free;
end;
{ ppt/_rels/presentation.xml.rels }
WriteStr(FPresentationRels, '</Relationships>');
{ close files }
IOTransport.TempFilter.FilterAccess := faRead;
IOTransport.TempFilter.LoadClosedStreams;
FileNames.Clear;
IOTransport.TempFilter.CopyStreamsNames(FileNames, True);
// FContentTypes.Free;
// FRels.Free;
// FPresentation.Free;
// FPresentationRels.Free;
{ compress data }
if Assigned(Stream) then
f := Stream
else
try
f := IOTransport.GetStream(FileName);
except
f := nil;
end;
if Assigned(f) then
begin
Zip := TfrxZipArchive.Create;
try
Zip.RootFolder := AnsiString(FDocFolder + '\');
// Zip.AddDir(AnsiString(FDocFolder));
Zip.SaveToStreamFromList(f, FileNames);
// Zip.SaveToStream(f);
finally
Zip.Free;
end;
end;
if not Assigned(Stream) then
begin
IOTransport.DoFilterProcessStream(f, Self);
IOTransport.FreeStream(f);
end;
IOTransport.TempFilter.CloseAllStreams;
FileNames.Free;
DeleteFolder(FDocFolder);
end;
initialization
//FormatSettings.DecimalSeparator := '.';
end.