Delphi/FastReport_2022_VCL
Delphi/FastReport_2022_VCL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
b867fa72b3
FastReport_2022_VCL/LibD28/frxEMFtoPDFExport.pas

2187 lines
56 KiB
ObjectPascal
Raw Normal View History

Inicijalizacija
2024-01-01 16:13:08 +01:00
{******************************************}
{ }
{ FastReport VCL }
{ EMF to PDF Export }
{ }
{ Copyright (c) 1998-2021 }
{ by Fast Reports Inc. }
{ }
{******************************************}
unit frxEMFtoPDFExport;
interface
{$I frx.inc}
uses Windows, Graphics, Classes, frxExportHelpers, frxEMFAbstractExport,
frxEMFFormat, frxExportPDFHelpers, frxClass, frxAnaliticGeometry, frxUtils;
type
TBezierResult = record
P0, P1, P2, P3: TfrxPoint;
end;
TPDFDeviceContext = class (TDeviceContext);
TEMFtoPDFExport = class (TEMFAbstractExport)
private
FForceMitterLineJoin: Boolean;
FForceButtLineCap: Boolean;
FForceNullBrush: Boolean;
FTransparency: Boolean;
FForceAnsi: Boolean;
FClipped: Boolean;
FPictureDPI: Integer;
FPrecision: Integer;
procedure Put(const S: AnsiString);
procedure PutCRLF(const S: AnsiString); {$IFDEF Delphi12} overload;
procedure PutCRLF(const S: String); overload; {$ENDIF}
procedure PutLF(const S: AnsiString); {$IFDEF Delphi12} overload;
procedure PutLF(const S: String); overload; {$ENDIF}
function pdfSize(emfSize: Extended): Extended;
function pdfFrxPoint(emfP: TPoint): TfrxPoint; overload;
function pdfFrxPoint(emfSP: TSmallPoint): TfrxPoint; overload;
function pdfFrxPoint(emfDP: TfrxPoint): TfrxPoint; overload;
function pdfFrxRect(emfR: TRect): TfrxRect;
// function emfSize2Str(emfSize: Extended): String;
function emfPoint2Str(emfP: TPoint): String; overload;
function emfPoint2Str(emfSP: TSmallPoint): String; overload;
function emfPoint2Str(emfFP: TfrxPoint): String; overload;
function emfRect2Str(emfR: TRect): String;
function EvenOdd: String;
function IsNullBrush: Boolean;
function IsNullPen: Boolean;
function BezierCurve(Center, Radius: TfrxPoint; startAngle, arcAngle: Double): TBezierResult;
procedure cmd_AngleArc(Center, Radius: TfrxPoint; StartAngle, SweepAngle: Single);
procedure cmd_RoundRect(l, t, r, b, rx, ry: Extended);
procedure cmdPathPainting(Options: integer);
procedure cmdPathParams(Options: integer);
procedure cmdSetClippingPath;
procedure cmdCloseSubpath;
procedure cmdAppendAngleArcToPath(AngleArc: TEMRAngleArc);
procedure cmdAppendArcToPath(Arc: TEMRArc);
procedure cmdAppendPieToPath(Pie: TEMRPie);
procedure cmdAppendEllipsToPath(emfRect: TRect);
procedure cmdAppendRectangleToPath(emfRect: TRect; IsCompartible: Boolean = False);
procedure cmdAppendEMFRectangleToPath(emfRect: TRect);
procedure cmdAppendRoundRectToPath(emfRect: TRect; emfCorners: TSize);
procedure cmdMoveTo(X, Y: extended); overload;
procedure cmdMoveTo(emfP: TPoint); overload;
procedure cmdMoveTo(emfSP: TSmallPoint); overload;
procedure cmdMoveTo(emfFP: TfrxPoint); overload;
procedure cmdLineTo(X, Y: extended); overload;
procedure cmdLineTo(emfP: TPoint); overload;
procedure cmdLineTo(emfSP: TSmallPoint); overload;
procedure cmdLineTo(emfDP: TfrxPoint); overload;
procedure cmdSetLineDashPattern(PenStyle: LongWord; Width: Extended);
procedure cmdSetStrokeColor(Color: TColor);
procedure cmdSetFillColor(Color: TColor);
procedure cmdSetLineWidth(Width: Extended); overload;
procedure cmdSetLineWidth(PDFWidth: String); overload;
procedure cmdSetMiterLimit(MiterLimit: Extended);
procedure cmdSetLineCap(PenEndCap: Integer);
procedure cmdSetLineJoin(PenLineJoin: Integer);
procedure cmdAppendCurvedSegment2final(emfSP1, emfSP3: TSmallPoint); overload;
procedure cmdAppendCurvedSegment2final(emfP1, emfP3: TPoint); overload;
procedure cmdAppendCurvedSegment3(emfSP1, emfSP2, emfSP3: TSmallPoint); overload;
procedure cmdAppendCurvedSegment3(emfP1, emfP2, emfP3: TPoint); overload;
procedure cmdAppendCurvedSegment3(emfDP1, emfDP2, emfDP3: TfrxPoint); overload;
procedure cmdPolyBezier(Options: integer = 0);
procedure cmdPolyBezier16(Options: integer = 0);
procedure cmdPolyLine(Options: integer = 0);
procedure cmdPolyLine16(Options: integer = 0);
procedure cmdPolyPolyLine(Options: integer = 0);
procedure cmdPolyPolyLine16(Options: integer = 0);
procedure cmdCreateExtSelectClipRgn;
procedure cmdSaveGraphicsState;
procedure cmdRestoreGraphicsState;
procedure cmdBitmap(emfRect: TRect; dwRop: LongWord; EMRBitmap: TEMRBitmap);
procedure cmdTranslationAndScaling(Sx, Sy, Tx, Ty: Extended);
protected
FPDFRect: TfrxRect;
FLastClipRect: TRect;
FEMFtoPDFFactor: TfrxPoint;
FPOH: TPDFObjectsHelper;
FRotation2D: TRotation2D;
FRealizationList: TStringList;
FqQBalance: Integer;
procedure Comment(CommentString: String = ''); override;
procedure CommentAboutRealization;
procedure CommentTextRect(rtl: TRect; Color: TColor = clRed);
procedure RealizationListFill(RealizedCommands: array of String);
function NormalizeRect(const Rect: TRect): TRect;
procedure DCCreate; override;
function FontCreate: TEMFFont; override;
function PDFDeviceContext: TPDFDeviceContext;
function IsSameCharacterWidth(FontName: string): Boolean;
procedure DrawFontLines(FontSize: Double; TextPosition: TfrxPoint; TextWidth: Extended);
procedure DrawFigureStart;
procedure DrawFigureFinish(Options: integer);
function FillStrokeOptions(Options: integer): integer;
procedure DoEMR_AngleArc; override;
procedure DoEMR_Arc; override;
procedure DoEMR_AlphaBlend; override;
procedure DoEMR_BitBlt; override;
procedure DoEMR_CloseFigure; override;
procedure DoEMR_Ellipse; override;
procedure DoEMR_EoF; override;
procedure DoEMR_ExtSelectClipRgn; override;
procedure DoEMR_ExtTextOutW; override;
procedure DoEMR_FillPath; override;
procedure DoEMR_FillRgn; override;
procedure DoEMR_Header; override;
procedure DoEMR_IntersectClipRect; override;
procedure DoEMR_LineTo; override;
procedure DoEMR_MaskBlt; override;
procedure DoEMR_MoveToEx; override;
procedure DoEMR_Pie; override;
procedure DoEMR_PolyBezier; override;
procedure DoEMR_PolyBezier16; override;
procedure DoEMR_PolyBezierTo; override;
procedure DoEMR_PolyBezierTo16; override;
procedure DoEMR_PolyDraw; override;
procedure DoEMR_PolyDraw16; override;
procedure DoEMR_Polygon; override;
procedure DoEMR_Polygon16; override;
procedure DoEMR_Polyline; override;
procedure DoEMR_Polyline16; override;
procedure DoEMR_PolylineTo; override;
procedure DoEMR_PolylineTo16; override;
procedure DoEMR_PolyPolygon; override;
procedure DoEMR_PolyPolygon16; override;
procedure DoEMR_PolyPolyline; override;
procedure DoEMR_PolyPolyline16; override;
procedure DoEMR_Rectangle; override;
procedure DoEMR_RestoreDC; override;
procedure DoEMR_RoundRect; override;
procedure DoEMR_SaveDC; override;
procedure DoEMR_SelectClipPath; override;
procedure DoEMR_StretchBlt; override;
procedure DoEMR_StretchDIBits; override;
procedure DoEMR_StrokeAndFillPath; override;
procedure DoEMR_StrokePath; override;
procedure DoEMR_TransparentBlt; override;
procedure DoStart; override;
procedure DoFinish; override;
public
constructor Create(InStream, OutStream: TStream; APDFRect: TfrxRect; APOH: TPDFObjectsHelper);
destructor Destroy; override;
property ForceMitterLineJoin: Boolean read FForceMitterLineJoin write FForceMitterLineJoin;
property ForceButtLineCap: Boolean write FForceButtLineCap;
property ForceNullBrush: Boolean write FForceNullBrush;
property Transparency: Boolean write FTransparency;
property ForceAnsi: Boolean write FForceAnsi;
property Clipped: Boolean write FClipped;
property PictureDPI: Integer write FPictureDPI;
property Precision: Integer write FPrecision;
end;
implementation
uses
Contnrs, SysUtils, Types, Math, frxPictureGraphics
{$IFDEF DELPHI16}
, UITypes
{$ENDIF} {It is necessary to prevent H2443}
;
type
TEMFPDFSizeConverter = class
private
FDev: Double; // EMR_ExtTextOutW.rclBounds
FLog: Double; // EMR_ExtTextOutW.emrtext.ptlReference // WordTransform etc...
FPDF: Double;
FChar: Double;
procedure SetDev(const Value: Double);
procedure SetLog(const Value: Double);
procedure SetPDF(const Value: Double);
procedure SetChar(const Value: Double);
protected
FExport: TEMFtoPDFExport;
FEMFPDFFactor: Double;
FFont: TEMFFont;
public
constructor Create(AExport: TEMFtoPDFExport);
destructor Destroy; override;
function LogToDev(Value: Double): Double;
property Dev: Double read FDev write SetDev;
property Log: Double read FLog write SetLog;
property PDF: Double read FPDF write SetPDF;
property Char: Double read FChar write SetChar;
end;
const
// Path-Painting Operators
ppEnd = $0;
ppClose = $1;
ppStroke = $2;
ppFill = $4;
ppWithTo = $8; // To resets the current position
ppBkFill = $10; // Ignored when ppFill not setted
ppAsIsFill = $20; // Ignored when ppFill not setted
ppFontStroke = $40; // Need for Undeline and StrokeOut, dont use DC.Pen
{ Utility routines }
procedure Swap(var E1, E2: Extended);
var
Temp: Extended;
begin
Temp := E1;
E1 := E2;
E2 := Temp;
end;
function PenStyle2Str(PenStyle: LongWord; Width: Extended): String;
var
Dash, Dot: string;
begin
Dash := Float2Str(6 * Width) + ' ';
Dot := Float2Str(2 * Width) + ' ';
case PenStyle of
PS_SOLID:
Result := '';
PS_DASH:
Result := Dash;
PS_DOT:
Result := Dot + Dash;
PS_DASHDOT:
Result := Dash + Dash + Dot + Dash;
PS_DASHDOTDOT:
Result := Dash + Dash + Dot + Dash + Dot + Dash;
PS_NULL:
Result := '';
PS_INSIDEFRAME:
Result := '';
PS_ALTERNATE:
Result := Dot + Dot;
else // PS_USERSTYLE:
Result := Dash + Dot;
end;
if Result <> '' then
Delete(Result, Length(Result), 1);
end;
{ TEMFtoPDFExport }
function TEMFtoPDFExport.BezierCurve(Center, Radius: TfrxPoint; StartAngle, ArcAngle: Double): TBezierResult;
function Rad(Degree: Double): Extended;
begin
Result := Degree * Pi / 180;
end;
var
Cos1, Sin1, Cos2, Sin2, Aux, Alpha: Extended;
begin
SinCos(Rad(StartAngle), Sin1, Cos1);
SinCos(Rad(StartAngle + ArcAngle), Sin2, Cos2);
//point p1. Start point
Result.P0 := frxPoint(Center.X + Radius.X * Cos1, Center.Y - Radius.Y * Sin1);
//point p2. End point
Result.P3 := frxPoint(Center.X + Radius.X * Cos2, Center.Y - Radius.Y * Sin2);
//Alpha constant
Aux := Tan(Rad(ArcAngle / 2));
Alpha := Sin(Rad(ArcAngle)) * (Sqrt(4 + 3 * Aux * Aux) - 1.0) / 3.0;
//point q1. First control point
Result.P1 := frxPoint(Result.P0.X - Alpha * Radius.X * Sin1,
Result.P0.Y - Alpha * Radius.Y * Cos1);
//point q2. Second control point.
Result.P2 := frxPoint(Result.P3.X + Alpha * Radius.X * Sin2,
Result.P3.Y + Alpha * Radius.Y * Cos2);
end;
procedure TEMFtoPDFExport.cmdAppendAngleArcToPath(AngleArc: TEMRAngleArc);
begin
with AngleArc do
cmd_AngleArc(ToFrxPoint(ptlCenter), frxPoint(nRadius, nRadius), eStartAngle, eSweepAngle);
end;
procedure TEMFtoPDFExport.cmdAppendArcToPath(Arc: TEMRArc);
var
Center, Radius, AspectRatio: TfrxPoint;
StartAngle, EndAngle, SweepAngle: Extended;
begin
AspectRatio := frxPoint(1.0, 1.0);
with NormalizeRect(Arc.rclBox) do
begin
Center := frxPoint((Right + Left) / 2, (Bottom + Top) / 2);
Radius := frxPoint((Right - Left) / 2, (Bottom - Top) / 2);
if (Right - Left) > (Bottom - Top) then
AspectRatio.X := (Bottom - Top) / (Right - Left)
else if (Bottom - Top) > (Right - Left) then
AspectRatio.Y := (Right - Left) / (Bottom - Top);
end;
with Arc do
begin
StartAngle := ArcTan2((ptlStart.Y - Center.Y) * AspectRatio.Y,
(ptlStart.X - Center.X) * AspectRatio.X) / Pi * 180;
EndAngle := ArcTan2((ptlEnd.Y - Center.Y) * AspectRatio.Y,
(ptlEnd.X - Center.X) * AspectRatio.X) / Pi * 180;
end;
if FDC.iArcDirection = AD_CLOCKWISE then
Swap(StartAngle, EndAngle);
SweepAngle := StartAngle - EndAngle;
if SweepAngle = 0.0 then
SweepAngle := 360 - 1e-4
else if SweepAngle < 0 then
SweepAngle := SweepAngle + 360;
cmd_AngleArc(Center, Radius, -StartAngle, SweepAngle);
end;
procedure TEMFtoPDFExport.cmdAppendCurvedSegment2final(emfSP1, emfSP3: TSmallPoint);
begin
PutLF(emfPoint2Str(emfSP1) + ' ' + emfPoint2Str(emfSP3) + ' v');
end;
procedure TEMFtoPDFExport.cmdAppendCurvedSegment2final(emfP1, emfP3: TPoint);
begin
PutLF(emfPoint2Str(emfP1) + ' ' + emfPoint2Str(emfP3) + ' v');
end;
procedure TEMFtoPDFExport.cmdAppendCurvedSegment3(emfDP1, emfDP2, emfDP3: TfrxPoint);
begin
PutLF(emfPoint2Str(emfDP1) + ' ' + emfPoint2Str(emfDP2) + ' ' + emfPoint2Str(emfDP3) + ' c');
end;
procedure TEMFtoPDFExport.cmdAppendCurvedSegment3(emfP1, emfP2, emfP3: TPoint);
begin
PutLF(emfPoint2Str(emfP1) + ' ' + emfPoint2Str(emfP2) + ' ' + emfPoint2Str(emfP3) + ' c');
end;
procedure TEMFtoPDFExport.cmdAppendCurvedSegment3(emfSP1, emfSP2, emfSP3: TSmallPoint);
begin
PutLF(emfPoint2Str(emfSP1) + ' ' + emfPoint2Str(emfSP2) + ' ' + emfPoint2Str(emfSP3) + ' c');
end;
procedure TEMFtoPDFExport.cmdAppendEllipsToPath(emfRect: TRect);
begin
with pdfFrxRect(emfRect) do
cmd_RoundRect(Left, Top, Right, Bottom, (Right - Left) / 2, (Top - Bottom) / 2);
end;
procedure TEMFtoPDFExport.cmdAppendEMFRectangleToPath(emfRect: TRect);
begin
EnableTransform := False;
try
cmdAppendRectangleToPath(emfRect);
finally
EnableTransform := True;
end;
end;
procedure TEMFtoPDFExport.cmdAppendPieToPath(Pie: TEMRPie);
var
Center: TfrxPoint;
begin
cmdAppendArcToPath(Pie);
with NormalizeRect(Pie.rclBox) do
Center := frxPoint((Right + Left) / 2, (Bottom + Top) / 2);
cmdLineTo(Center);
end;
procedure TEMFtoPDFExport.cmdAppendRectangleToPath(emfRect: TRect; IsCompartible: Boolean = False);
begin
FScalingOnly := IsCompartible;
try
PutLF(emfRect2Str(emfRect) + ' re'); // Begin new subpath
finally
FScalingOnly := False;
end;
end;
procedure TEMFtoPDFExport.cmdAppendRoundRectToPath(emfRect: TRect; emfCorners: TSize);
begin
with pdfFrxRect(emfRect), emfCorners do
cmd_RoundRect(Left, Top, Right, Bottom, pdfSize(cx) / 2, pdfSize(cy) / 2);
end;
procedure TEMFtoPDFExport.cmdBitmap(emfRect: TRect; dwRop: LongWord; EMRBitmap: TEMRBitmap);
var
pdfRect: TfrxRect;
TempBitmap: TBitMap;
XObjectStream: TMemoryStream;
XObjectHash: TfrxPDFXObjectHash;
PicIndex: Integer;
Graphic: TGraphic;
Size: TSize;
procedure ReferenceToXObject;
begin
FPOH.PageXObjects.Add(PicIndex);
cmdSaveGraphicsState;
cmdTranslationAndScaling(pdfRect.Right - pdfRect.Left,
pdfRect.Top - pdfRect.Bottom, pdfRect.Left, pdfRect.Bottom);
PutCRLF('/Im' + IntToStr(PicIndex) + ' Do');
cmdRestoreGraphicsState;
end;
procedure OutOpaque;
function GetBitmapWithDPI: TBitmap;
var
Factor: Double;
function CalcFactor(Bitmap: TBitmap): Double;
var
SC: TEMFPDFSizeConverter;
ImageDeviceRect: TDoubleRect;
ImageInchSize, ImageActualDPI: TDoublePoint;
begin
SC := TEMFPDFSizeConverter.Create(Self);
try
ImageDeviceRect := DoubleRect(
SC.LogToDev(emfRect.Left), SC.LogToDev(emfRect.Top),
SC.LogToDev(emfRect.Right), SC.LogToDev(emfRect.Bottom));
finally
SC.Free;
end;
ImageInchSize := DoublePoint(
Abs(ImageDeviceRect.Right - ImageDeviceRect.Left) / FDC.DeviceDPI.X,
Abs(ImageDeviceRect.Bottom - ImageDeviceRect.Top) / FDC.DeviceDPI.X);
ImageActualDPI := DoublePoint(
Bitmap.Width / ImageInchSize.X, Bitmap.Width / ImageInchSize.Y);
Factor := FPictureDPI / Sqrt(ImageActualDPI.X * ImageActualDPI.Y);
Result := Factor;
end;
var
BM: TBitmap;
begin
Result := EMRBitmap.GetBitmap;
if (FPictureDPI <= 0) or (CalcFactor(Result) >= 1) then
Exit;
BM := TBitmap.Create;
BM.PixelFormat := Result.PixelFormat;
BM.Width := Round(Result.Width * Factor);
BM.Height := Round(Result.Height * Factor);
BM.Canvas.StretchDraw(BM.Canvas.ClipRect, Result);
Result.Free;
Result := BM;
end;
var
Image: TGraphic;
begin
TempBitmap := GetBitmapWithDPI; // EMRBitmap.GetBitmap;
try
Image := GetGraphicFormats.Convert(TempBitmap, 'JPG', pf24bit, FPOH.Quality);
try
XObjectStream := TMemoryStream.Create;
try
Image.SaveToStream(XObjectStream);
XObjectStream.Position := 0;
GetStreamHash(XObjectHash, XObjectStream);
PicIndex := FPOH.FindXObject(XObjectHash);
if PicIndex = -1 then
PicIndex := FPOH.OutXObjectImage(XObjectHash, Image, XObjectStream);
finally
XObjectStream.Free;
end;
finally
Image.Free;
end;
finally
TempBitmap.Free;
end;
ReferenceToXObject;
end;
begin
pdfRect := pdfFrxRect(emfRect);
case dwRop of // https://msdn.microsoft.com/en-us/library/cc250408.aspx
PATCOPY {P}:
begin
DrawFigureStart;
cmdAppendRectangleToPath(emfRect);
DrawFigureFinish(ppFill);
end;
$1FF0000: // 32 bit here
if FTransparency then
begin
Graphic := TEMRAlphaBlendObj(EMRBitmap).GetARGBGraphic;
try
Size.cx := Round(pdfRect.Right - pdfRect.Left);
Size.cy := Round(pdfRect.Top - pdfRect.Bottom);
PicIndex := FPOH.OutTransparentGraphic(Graphic, Size);
finally
Graphic.Free;
end;
ReferenceToXObject;
end
else
OutOpaque;
SRCCOPY {S}, SRCPAINT {DSo}, SRCAND {DSa}, SRCINVERT {DSx}:
OutOpaque;
$AA0029: {D}
begin
// Do nothing
end;
else
Comment(' Unsupported dwRop: ' + IntToStr(dwRop));
end;
end;
procedure TEMFtoPDFExport.cmdCloseSubpath;
begin
PutLF('h');
end;
procedure TEMFtoPDFExport.cmdCreateExtSelectClipRgn;
var
PRegionData: PRgnData;
Size, i: Integer;
R: TRect;
begin
if FDC.ClipRgn <> HRGN(nil) then
begin
Size := GetRegionData(FDC.ClipRgn, 0, nil);
if Size > 0 then
begin
GetMem(PRegionData, Size);
try
GetRegionData(FDC.ClipRgn, Size, PRegionData);
for i := 0 to PRegionData^.rdh.nCount - 1 do
begin
Move(PRegionData^.Buffer[i * SizeOf(TRect)], R, SizeOf(TRect));
cmdAppendEMFRectangleToPath(R);
FLastClipRect := R;
end;
cmdSetClippingPath;
cmdPathPainting(ppEnd);
finally
FreeMem(PRegionData, Size);
end;
end;
end;
end;
procedure TEMFtoPDFExport.cmdLineTo(emfDP: TfrxPoint);
begin
PutLF(emfPoint2Str(emfDP) + ' l'); // Append straight line segment to path
end;
procedure TEMFtoPDFExport.cmdLineTo(emfP: TPoint);
begin
PutLF(emfPoint2Str(emfP) + ' l'); // Append straight line segment to path
end;
procedure TEMFtoPDFExport.cmdLineTo(emfSP: TSmallPoint);
begin
PutLF(emfPoint2Str(emfSP) + ' l'); // Append straight line segment to path
end;
procedure TEMFtoPDFExport.cmdLineTo(X, Y: extended);
begin
PutLF(frxPoint2Str(X, Y) + ' l'); // Append straight line segment to path
end;
procedure TEMFtoPDFExport.cmdMoveTo(emfFP: TfrxPoint);
begin
PutLF(emfPoint2Str(emfFP) + ' m'); // Begin new subpath
end;
procedure TEMFtoPDFExport.cmdMoveTo(emfP: TPoint);
begin
PutLF(emfPoint2Str(emfP) + ' m'); // Begin new subpath
end;
procedure TEMFtoPDFExport.cmdMoveTo(emfSP: TSmallPoint);
begin
PutLF(emfPoint2Str(emfSP) + ' m'); // Begin new subpath
end;
procedure TEMFtoPDFExport.cmdMoveTo(X, Y: extended);
begin
PutLF(frxPoint2Str(X, Y, FPrecision) + ' m'); // Begin new subpath
end;
procedure TEMFtoPDFExport.cmdPathPainting(Options: integer);
begin
cmdPathParams(Options);
case Options and (ppEnd or ppClose or ppStroke or ppFontStroke or ppFill) of
ppEnd: PutLF('n');
ppStroke, ppFontStroke: PutLF('S');
ppStroke + ppClose: PutLF('s');
ppFill, ppFill + ppClose: PutLF('f' + EvenOdd);
ppFill + ppStroke: PutLF('B' + EvenOdd);
ppFill + ppStroke + ppClose: PutLF('b' + EvenOdd);
else
raise Exception.Create('Invalid Patch Painting');
end;
end;
procedure TEMFtoPDFExport.cmdPathParams(Options: integer);
begin
if IsInclude(Options, ppFill) then
if IsInclude(Options, ppBkFill) then
cmdSetFillColor(FDC.BkColor)
else if not IsInclude(Options, ppAsIsFill) then
cmdSetFillColor(FDC.BrushColor);
if IsInclude(Options, ppStroke) then
begin
cmdSetLineDashPattern(FDC.PenStyle, pdfSize(FDC.PenWidth));
cmdSetStrokeColor(FDC.PenColor);
cmdSetLineWidth(pdfSize(FDC.PenWidth));
cmdSetMiterLimit(FDC.MiterLimit);
cmdSetLineCap(FDC.PenEndCap);
cmdSetLineJoin(FDC.PenLineJoin);
end;
end;
procedure TEMFtoPDFExport.cmdPolyBezier(Options: integer = 0);
var
Point: integer;
begin
with PLast^ do
begin
if IsInclude(Options, ppWithTo) then
Point := 0
else
begin
cmdMoveTo(Polyline.aptl[0]);
Point := 1;
end;
while True do
case Integer(Polyline.cptl) - Point of
0, 1:
Break;
2, 4:
begin
cmdAppendCurvedSegment2final(Polyline.aptl[Point],
Polyline.aptl[Point + 1]);
Inc(Point, 2);
end;
else
cmdAppendCurvedSegment3(Polyline.aptl[Point],
Polyline.aptl[Point + 1], Polyline.aptl[Point + 2]);
Inc(Point, 3);
end;
end;
end;
procedure TEMFtoPDFExport.cmdPolyBezier16(Options: integer = 0);
var
Point: integer;
begin
with PLast^ do
begin
if IsInclude(Options, ppWithTo) then
Point := 0
else
begin
cmdMoveTo(Polyline16.apts[0]);
Point := 1;
end;
while True do
case Integer(Polyline16.cpts) - Point of
0, 1:
Break;
2, 4:
begin
cmdAppendCurvedSegment2final(Polyline16.apts[Point],
Polyline16.apts[Point + 1]);
Inc(Point, 2);
end;
else
cmdAppendCurvedSegment3(Polyline16.apts[Point],
Polyline16.apts[Point + 1], Polyline16.apts[Point + 2]);
Inc(Point, 3);
end;
end;
end;
procedure TEMFtoPDFExport.cmdPolyLine(Options: integer = 0);
var
Point: integer;
begin
with PLast^ do
begin
if IsInclude(Options, ppWithTo) then
cmdLineTo(Polyline.aptl[0])
else
cmdMoveTo(Polyline.aptl[0]);
for Point := 1 to Polyline.cptl - 1 do
cmdLineTo(Polyline.aptl[Point])
end;
if IsInclude(Options, ppClose) then
cmdCloseSubpath;
end;
procedure TEMFtoPDFExport.cmdPolyLine16(Options: integer = 0);
var
Point: integer;
begin
with PLast^ do
begin
if IsInclude(Options, ppWithTo) then
cmdLineTo(Polyline16.apts[0])
else
cmdMoveTo(Polyline16.apts[0]);
for Point := 1 to Polyline16.cpts - 1 do
cmdLineTo(Polyline16.apts[Point])
end;
if IsInclude(Options, ppClose) then
cmdCloseSubpath;
end;
procedure TEMFtoPDFExport.cmdPolyPolyLine(Options: integer = 0);
var
Poly, Point: integer;
begin
with FEMRList.Last as TEMRPolyPolygonObj do
begin
for Poly := 0 to P^.PolyPolygon.nPolys - 1 do
begin
if IsInclude(Options, ppWithTo) then
cmdLineTo(PolyPoint[Poly, 0])
else
cmdMoveTo(PolyPoint[Poly, 0]);
for Point := 1 to P^.PolyPolygon.aPolyCounts[Poly] - 1 do
cmdLineTo(PolyPoint[Poly, Point]);
end;
end;
if IsInclude(Options, ppClose) then
cmdCloseSubpath;
end;
procedure TEMFtoPDFExport.cmdPolyPolyLine16(Options: integer = 0);
var
Poly, Point: integer;
begin
with FEMRList.Last as TEMRPolyPolygon16Obj do
begin
for Poly := 0 to P^.PolyPolygon16.nPolys - 1 do
begin
if IsInclude(Options, ppWithTo) then
cmdLineTo(PolyPoint[Poly, 0])
else
cmdMoveTo(PolyPoint[Poly, 0]);
for Point := 1 to P^.PolyPolygon16.aPolyCounts[Poly] - 1 do
cmdLineTo(PolyPoint[Poly, Point]);
end;
end;
if IsInclude(Options, ppClose) then
cmdCloseSubpath;
end;
procedure TEMFtoPDFExport.cmdRestoreGraphicsState;
begin
PutLF('Q');
FqQBalance := FqQBalance - 1;
end;
procedure TEMFtoPDFExport.cmdSaveGraphicsState;
begin
PutLF('q');
FqQBalance := FqQBalance + 1;
end;
procedure TEMFtoPDFExport.cmdSetClippingPath;
begin
PutLF('W' + EvenOdd);
end;
procedure TEMFtoPDFExport.cmdSetFillColor(Color: TColor);
begin
PutLF(Color2Str(Color) + ' rg'); // Set RGB color for nonstroking operations
end;
procedure TEMFtoPDFExport.cmdSetLineCap(PenEndCap: Integer);
begin
if FForceButtLineCap then
PutLF('2 J')
else
case FDC.PenEndCap of
PS_ENDCAP_ROUND:
PutLF('1 J');
PS_ENDCAP_SQUARE:
PutLF('2 J');
else // PS_ENDCAP_FLAT
PutLF('0 J');
end;
end;
procedure TEMFtoPDFExport.cmdSetLineDashPattern(PenStyle: LongWord; Width: Extended);
begin
PutLF('[' + PenStyle2Str(PenStyle, Width) + '] 0 d');
end;
procedure TEMFtoPDFExport.cmdSetLineJoin(PenLineJoin: Integer);
begin
if FForceMitterLineJoin then
PutLF('0 j')
else
case FDC.PenLineJoin of
PS_JOIN_ROUND:
PutLF('1 j');
PS_JOIN_BEVEL:
PutLF('2 j');
else // PS_JOIN_MITER
PutLF('0 j');
end;
end;
procedure TEMFtoPDFExport.cmdSetLineWidth(PDFWidth: String);
begin
PutLF(PDFWidth + ' w');
end;
procedure TEMFtoPDFExport.cmdSetLineWidth(Width: Extended);
begin
cmdSetLineWidth(Float2Str(Width, 2));
end;
procedure TEMFtoPDFExport.cmdSetMiterLimit(MiterLimit: Extended);
begin
PutLF(Float2Str(MiterLimit) + ' M');
end;
procedure TEMFtoPDFExport.cmdSetStrokeColor(Color: TColor);
begin
PutLF(Color2Str(Color) + ' RG'); // Set RGB color for stroking operations
end;
procedure TEMFtoPDFExport.cmdTranslationAndScaling(Sx, Sy, Tx, Ty: Extended);
begin
PutLF(Float2Str(Sx) + ' 0 0 ' + Float2Str(Sy) + ' ' +
Float2Str(Tx, FPrecision) + ' ' + Float2Str(Ty, FPrecision) + ' cm');
end;
procedure TEMFtoPDFExport.cmd_AngleArc(Center, Radius: TfrxPoint; StartAngle, SweepAngle: Single);
const
MaxAnglePerCurve = 45;
var
n, i: Integer;
ActualArcAngle: Double;
Bezier: TBezierResult;
begin
n := Ceil(Abs(SweepAngle / MaxAnglePerCurve));
ActualArcAngle := SweepAngle / n;
for i := 0 to n - 1 do
begin
Bezier := BezierCurve(Center, Radius, StartAngle + i * ActualArcAngle, ActualArcAngle);
if i = 0 then
cmdMoveTo(Bezier.P0);
cmdAppendCurvedSegment3(Bezier.P1, Bezier.P2, Bezier.P3);
end;
end;
procedure TEMFtoPDFExport.cmd_RoundRect(l, t, r, b, rx, ry: Extended);
procedure Corner(x1, y1, x2, y2, x3, y3: Extended);
begin
PutLF(Float2Str(x1, FPrecision) + ' ' + Float2Str(y1, FPrecision) + ' ' +
Float2Str(x2, FPrecision) + ' ' + Float2Str(y2, FPrecision) + ' ' +
Float2Str(x3, FPrecision) + ' ' + Float2Str(y3, FPrecision) + ' c');
end;
begin
CmdMoveTo(l + rx, b);
CmdLineTo(r - rx, b); // bottom
Corner(r - rx / 2, b, r, b + ry / 2, r, b + ry); // right-bottom
CmdLineTo(r, t - ry); // right
Corner(r, t - ry / 2, r - rx / 2, t, r - rx, t); // right-top
CmdLineTo(l + rx, t); // top
Corner(l + rx / 2, t, l, t - ry / 2, l, t - ry); // left-top
CmdLineTo(l, b + ry); // left
Corner(l, b + ry / 2, l + rx / 2, b, l + rx, b); // left-bottom
end;
procedure TEMFtoPDFExport.Comment(CommentString: String);
begin
if CommentString <> '' then
PutCRLF('%--'+ CommentString)
else if ShowComments then
begin
CommentAboutRealization;
PutCRLF('%--' + Parsing);
end;
end;
procedure TEMFtoPDFExport.CommentAboutRealization;
var
CommandName, Value: String;
i: integer;
begin
CommandName := Copy(Parsing, 1, Pos(' ', Parsing + ' ') - 1);
if FRealizationList.IndexOf(CommandName) <> -1 then // OK
Exit;
i := FRealizationList.IndexOfName(CommandName);
Value := IfStr(i <> -1, FRealizationList.ValueFromIndex[i], '0');
PutCRLF('% Realization: ' + Value);
end;
procedure TEMFtoPDFExport.CommentTextRect(rtl: TRect; Color: TColor = clRed);
var
XFactor, YFactor: Extended;
P1, P2: TfrxPoint;
begin
XFactor := 1 / FDC.XFormScale.X;
YFactor := 1 / FDC.XFormScale.Y;
P1 := pdfFrxPoint(frxPoint(rtl.Left * XFactor, rtl.Top * YFactor));
P2 := pdfFrxPoint(frxPoint(rtl.Right * XFactor, rtl.Bottom * YFactor));
Comment('Comment ExtTextOutW.rclBounds >>>>>>');
Comment(IntToStr(rtl.Left) + ', ' + IntToStr(rtl.Right) +
' (' + IntToStr(rtl.Right - rtl.Left) + ') -=> ' +
frFloat2Str(P1.X, 2) + ', ' + frFloat2Str(P2.X, 2) +
' (' + frFloat2Str(P2.X - P1.X, 2) + ')');
cmdSaveGraphicsState;
PutLF('[] 0 d');
cmdSetLineWidth(0.25);
cmdMoveTo(P1.X, P1.Y);
cmdLineTo(P1.X, P2.Y);
cmdLineTo(P2.X, P1.Y);
cmdLineTo(P2.X, P2.Y);
cmdSetStrokeColor(Color);
PutLF('S');
cmdRestoreGraphicsState;
Comment('Comment ExtTextOutW.rclBounds <<<<<<');
end;
constructor TEMFtoPDFExport.Create(InStream, OutStream: TStream; APDFRect: TfrxRect; APOH: TPDFObjectsHelper);
begin
inherited Create(InStream, OutStream);
FPDFRect := APDFRect;
FPOH := APOH;
FLastClipRect := Rect(0, 0, 0, 0);
FForceMitterLineJoin := False;
FForceButtLineCap := False;
FForceNullBrush := False;
FTransparency := False;
FForceAnsi := False;
FClipped := True;
FPictureDPI := 0;
FPrecision := 2;
FRotation2D := TRotation2D.Create;
FRealizationList := TStringList.Create;
FRealizationList.NameValueSeparator := '=';
RealizationListFill([
'EMR_AbortPath=?',
'EMR_AngleArc',
'EMR_Arc',
'EMR_AlphaBlend',
'EMR_BeginPath',
'EMR_BitBlt',
'EMR_BrushOrgEx',
'EMR_CloseFigure',
'EMR_CreateBrushIndirect',
'EMR_CreateMonoBrush',
'EMR_CreatePen',
'EMR_DeleteObject',
'EMR_PolyDraw',
'EMR_PolyDraw16',
'EMR_Ellipse',
'EMR_EndPath',
'EMR_EoF',
'EMR_ExtCreateFontIndirectW',
'EMR_ExtCreatePen',
'EMR_ExtSelectClipRgn',
'EMR_ExtTextOutW',
'EMR_FillPath',
'EMR_FillRgn',
'EMR_GDIComment',
'EMR_Header',
'EMR_IntersectClipRect',
'EMR_LineTo',
'EMR_MaskBlt',
'EMR_ModifyWorldTransform',
'EMR_MoveToEx',
'EMR_PolyBezier',
'EMR_PolyBezier16',
'EMR_PolyBezierTo',
'EMR_PolyBezierTo16',
'EMR_Polygon',
'EMR_Polygon16',
'EMR_Polyline',
'EMR_Polyline16',
'EMR_PolylineTo',
'EMR_PolylineTo16',
'EMR_PolyPolygon',
'EMR_PolyPolygon16',
'EMR_PolyPolyline',
'EMR_PolyPolyline16',
'EMR_Rectangle',
'EMR_RestoreDC',
'EMR_RoundRect',
'EMR_SaveDC',
'EMR_SelectClipPath',
'EMR_SelectObject',
'EMR_SetArcDirection',
'EMR_SetBkColor',
'EMR_SetBkMode',
'EMR_SetICMMode',
'EMR_SetLayout',
'EMR_SetMetaRgn',
'EMR_SetMiterLimit',
'EMR_SetPolyFillMode',
'EMR_SetRop2',
'EMR_SetTextAlign',
'EMR_SetTextColor',
'EMR_SetStretchBltMode',
'EMR_SetWorldTransform',
'EMR_StretchDIBits',
'EMR_StretchBlt',
'EMR_StrokeAndFillPath',
'EMR_StrokePath',
'EMR_TransparentBlt'
]);
end;
procedure TEMFtoPDFExport.DCCreate;
begin
FDC := TPDFDeviceContext.Create;
end;
destructor TEMFtoPDFExport.Destroy;
begin
FRotation2D.Free;
FRealizationList.Free;
inherited;
end;
procedure TEMFtoPDFExport.DoEMR_AlphaBlend;
begin
inherited;
with PLast^.AlphaBlend do
cmdBitMap(Bounds(xDest, yDest, cxDest, cyDest), dwRop,
FEMRList.Last as TEMRAlphaBlendObj);
end;
procedure TEMFtoPDFExport.DoEMR_AngleArc;
begin
inherited;
DrawFigureStart;
with PLast^ do
cmdAppendAngleArcToPath(AngleArc);
DrawFigureFinish(ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_Arc;
begin
inherited;
DrawFigureStart;
with PLast^ do
cmdAppendArcToPath(Arc);
DrawFigureFinish(ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_BitBlt;
begin
inherited;
with PLast^.BitBlt do
cmdBitMap(Bounds(xDest, yDest, cxDest, cyDest), dwRop, FEMRList.Last as TEMRBitBltObj);
end;
procedure TEMFtoPDFExport.DoEMR_CloseFigure;
begin
inherited;
cmdCloseSubpath;
end;
procedure TEMFtoPDFExport.DoEMR_Ellipse;
begin
inherited;
DrawFigureStart;
with PLast^ do
cmdAppendEllipsToPath(Ellipse.rclBox);
DrawFigureFinish(ppFill + ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_EoF;
begin
inherited;
while FqQBalance > 0 do
cmdRestoreGraphicsState;
end;
procedure TEMFtoPDFExport.DoEMR_ExtSelectClipRgn;
begin
inherited DoEMR_ExtSelectClipRgn;
case PLast^.ExtSelectClipRgn.iMode of
RGN_AND:
cmdCreateExtSelectClipRgn;
RGN_OR,
RGN_XOR,
RGN_DIFF:
Comment('Ignored ExtSelectClipRgn.iMode'); // Implement when data with this iMode is found
RGN_COPY:
begin
cmdRestoreGraphicsState;
cmdSaveGraphicsState;
end;
end;
end;
procedure TEMFtoPDFExport.DoEMR_ExtTextOutW;
function IsCompatible: Boolean;
begin
Result := PLast^.ExtTextOutW.iGraphicsMode = GM_COMPATIBLE;
end;
function IsAdvanced: Boolean;
begin
Result := PLast^.ExtTextOutW.iGraphicsMode = GM_ADVANCED;
end;
procedure DrawRotation(var pdfTextPosition: TfrxPoint);
var
LineOrientation, SumOrientation: LongInt; // specifies the angle, in tenths of degrees
SumRadian: Single;
begin
if IsAdvanced then
LineOrientation := FDC.LineOrientation
else // GM_COMPATIBLE
LineOrientation := 0;
SumOrientation := FDC.FontOrientation + LineOrientation;
if SumOrientation <> 0 then
begin
SumRadian := SumOrientation / 10.0 * Pi / 180.0;
FRotation2D.Init(SumRadian, frxPoint(0.0, 0.0), FPrecision);
PutLF(FRotation2D.Matrix + ' cm');
pdfTextPosition := FRotation2D.Turn(pdfTextPosition);
end;
end;
var
EMRExtTextOutWObj: TEMRExtTextOutWObj;
Font: TEMFFont;
RS: TRemapedString;
function pdfDX: TDoubleArray;
var
i: Integer;
OutputDx: TLongWordDinArray;
SC: TEMFPDFSizeConverter;
begin
SC := TEMFPDFSizeConverter.Create(Self);
try
OutputDx := EMRExtTextOutWObj.OutputDx;
SetLength(Result, Length(OutputDx));
for i := 0 to High(OutputDx) do
begin
SC.Log := LongInt(OutputDx[i]);
Result[i] := SC.Char;
end;
finally
SC.Free;
end;
end;
var
FontIndex: Integer;
MovedTextPosition, ShiftSign, pdfTextPosition: TfrxPoint;
Simulation: String;
SimulateBold: Boolean;
AlCorr: TfrxPoint; // Alignment correction
IsRTL, IsRTLOptions, IsGlyphOut: Boolean;
LogRect: TRect;
XFactor, YFactor: Extended;
R: TfrxRect;
RoundFontSize: Integer;
AverageDx: Boolean;
const
YCorr: array[TfrxVAlign] of Extended = (0.92, -0.23, 0.0);
XCorr: array[TfrxHalign] of Extended = (0.0, -1.0, -0.5, 0.0);
procedure DoOutputString(const AOutputString: WideString);
var
pdfFont: TfrxPDFFont;
begin
if AOutputString = '' then Exit;
Font := FontCreate;
try
with PLast^.ExtTextOutW do
if IsInclude(emrtext.fOptions, ETO_CLIPPED) then
begin
cmdAppendRectangleToPath(emrtext.rcl, IsCompatible);
cmdSetClippingPath;
cmdPathPainting(ppEnd);
end;
AlCorr.X := Sin(FDC.FontRadian) * YCorr[FDC.VAlign] * FDC.FontSize
+ Cos(FDC.FontRadian) * XCorr[FDC.HAlign] * EMRExtTextOutWObj.TextLength;
AlCorr.Y := Cos(FDC.FontRadian) * YCorr[FDC.VAlign] * FDC.FontSize +
- Sin(FDC.FontRadian) * XCorr[FDC.HAlign] * EMRExtTextOutWObj.TextLength;
ShiftSign := frxPoint(1.0, 1.0);
if IsCompatible then // Need testing for GM_ADVANCED
ShiftSign := frxPoint(Sign(FDC.XForm.eM11), Sign(FDC.XForm.eM22));
with PLast^.ExtTextOutW.emrtext.ptlReference do
MovedTextPosition := frxPoint(
X + ShiftSign.X * (AlCorr.X),
Y + ShiftSign.Y * (AlCorr.Y - FDC.FontSize * (1.0 - Font.DownSizeFactor)));
pdfTextPosition := pdfFrxPoint(MovedTextPosition);
{ cut all bottom outbound text }
if FClipped and (LogRect.Bottom = LogRect.Top) and (FLastClipRect.Bottom <> 0) and
(FLastClipRect.Bottom < MovedTextPosition.Y) then
Exit;
{ TODO : Needs rework }
if (FDC.FontFamily = 'Cambria Math') then
begin
R := pdfFrxRect(LogRect);
pdfTextPosition.Y := pdfTextPosition.Y
- (R.Top - R.Bottom - Font.Size) / 2.25;
end
else if (FDC.FontFamily = 'Segoe UI Symbol') then
begin
R := pdfFrxRect(LogRect);
pdfTextPosition.Y := pdfTextPosition.Y
- (R.Top - R.Bottom - Font.Size) / 2.5;
end;
DrawRotation({var} pdfTextPosition);
if (FDC.FontOrientation > -1800) and (FDC.FontOrientation <= -1) and
(FDC.XForm.eM22 < 0) and IsCompatible then
PutLF('-1 0 0 -1 ' +
Float2Str(2 * pdfTextPosition.X, FPrecision) + ' ' +
Float2Str(2 * (pdfTextPosition.Y + Font.PreciseSize * (1 - tpPt)), FPrecision) +
' cm');
if FPOH.IsBBox then
begin
PutLF('/Tx BMC');
cmdSaveGraphicsState;
end;
PutLF('BT'); // Begin text object
FontIndex := FPOH.GetObjFontNumber(Font);
if IsAdvanced then
PutLF(FPOH.Fonts[FontIndex].Name +
AnsiString(' ' + frFloat2Str(Font.PreciseSize * (1 - tpPt)) + ' Tf'))
else
PutLF(FPOH.Fonts[FontIndex].Name +
AnsiString(' ' + frFloat2Str(EMFPDFFontSize(Font), 3) + ' Tf'));
PutLF('[] 0 d');
cmdSetFillColor(Font.Color);
PutLF(frxPoint2Str(pdfTextPosition, FPrecision) + ' Td'); // Move text position
pdfFont := FPOH.Fonts[FontIndex];
pdfFont.ForceAnsi := FForceAnsi;
try
pdfFont.SameCharacterWidth := IsSameCharacterWidth(FDC.FontFamily);
try
RS := pdfFont.SoftRemapString(AOutputString, IsRTL, IsGlyphOut);
finally
pdfFont.SameCharacterWidth := False;
end;
RoundFontSize := Round(pdfSize(FDC.FontSize));
AverageDx := RoundFontSize <= 20;
finally
pdfFont.ForceAnsi := False;
end;
if IsNeedsItalicSimulation(Font, Simulation) then
PutLF(Simulation + ' ' + frxPoint2Str(pdfTextPosition) + ' Tm');
SimulateBold := IsNeedsBoldSimulation(Font, Simulation);
if SimulateBold then
PutLF(Simulation);
if IsRTLOptions or not RS.IsValidCharWidth or RS.IsHasLigatures then
PutLF('<' + StrToHex(RS.Data) + '> Tj') // Show text
else
PutLF('[<' + StrToHexDx(RS, pdfDX, AverageDx) + '>] TJ');
PutLF('ET'); // End text object
if FPOH.IsBBox then
begin
PutLF('EMC');
cmdRestoreGraphicsState;
end;
if SimulateBold then
PutLF('0 Tr');
if FDC.FontUnderline or FDC.FontStrikeOut then
if PLast^.ExtTextOutW.iGraphicsMode = GM_ADVANCED then
DrawFontLines(Font.PreciseSize, pdfTextPosition, pdfSize(EMRExtTextOutWObj.TextLength))
else
DrawFontLines(Font.Size, pdfTextPosition, pdfSize(EMRExtTextOutWObj.TextLength));
finally
Font.Free;
end;
end;
begin
inherited DoEMR_ExtTextOutW;
cmdSaveGraphicsState;
with PLast^.ExtTextOutW do
if IsInclude(emrtext.fOptions, ETO_OPAQUE) then
begin
cmdAppendRectangleToPath(emrtext.rcl, IsCompatible);
cmdPathPainting(ppFill + ppBkFill); // Use BkColor
end;
XFactor := 1 / FDC.XFormScale.X;
YFactor := 1 / FDC.XFormScale.Y;
with PLast^.ExtTextOutW.rclBounds do
LogRect := Rect(Floor((Left - FDC.DeviceTopLeft.X) * XFactor),
Floor((Top - FDC.DeviceTopLeft.Y) * YFactor),
Ceil((Right - FDC.DeviceTopLeft.X)* XFactor),
Ceil((Bottom - FDC.DeviceTopLeft.Y) * YFactor));
if FDC.BkMode = OPAQUE then
begin
cmdAppendRectangleToPath(LogRect);
cmdPathPainting(ppFill);
end;
IsRTLOptions := IsInclude(PLast^.ExtTextOutW.emrtext.fOptions, ETO_RTLREADING)
or IsInclude(FDC.TextAlignmentMode, TA_RTLREADING)
or IsInclude(FDC.Layout, EMR_LAYOUT_RTL);
IsRTL := IsRTLOptions and
(FDC.FontCharSet in [ARABIC_CHARSET, HEBREW_CHARSET]);
IsGlyphOut := not IsRTL and
IsInclude(PLast^.ExtTextOutW.emrtext.fOptions, ETO_GLYPH_INDEX);
{ disable back conversion in OutputString }
if IsGlyphOut then
PLast^.ExtTextOutW.emrtext.fOptions := PLast^.ExtTextOutW.emrtext.fOptions and not ETO_GLYPH_INDEX;
EMRExtTextOutWObj := FEMRList.Last as TEMRExtTextOutWObj;
DoOutputString(EMRExtTextOutWObj.OutputString(FDC.FontFamily, IsRTL));
cmdRestoreGraphicsState;
end;
procedure TEMFtoPDFExport.DoEMR_FillPath;
begin
inherited DoEMR_FillPath;
cmdPathPainting(ppFill);
end;
procedure TEMFtoPDFExport.DoEMR_FillRgn;
var
PRD: PRgnData;
RectCount, i: Integer;
R: TRect;
begin
inherited DoEMR_FillRgn;
cmdSaveGraphicsState;
PRD := @PLast^.FillRgn.RgnData;
RectCount := PRD^.rdh.nCount;
cmdSetFillColor(BrushAverageColor(PLast^.FillRgn.ihBrush));
for i := 0 to RectCount - 1 do
begin
Move(PRD^.Buffer[i * SizeOf(TRect)], R, SizeOf(TRect));
cmdAppendRectangleToPath(R);
end;
cmdPathPainting(ppFill + ppAsIsFill);
cmdRestoreGraphicsState;
end;
procedure TEMFtoPDFExport.DoEMR_Header;
var
rWidth, rHeight: double;
begin
inherited DoEMR_Header;
with PLast^.Header do
begin
rWidth := szlDevice.cx / szlMillimeters.cx * (rclFrame.Right - rclFrame.Left) / 100;
rHeight := szlDevice.cy / szlMillimeters.cy * (rclFrame.Bottom - rclFrame.Top) / 100;
end;
FEMFtoPDFFactor := frxPoint(
(FPDFRect.Right - FPDFRect.Left) / rWidth,
(FPDFRect.Top - FPDFRect.Bottom) / rHeight);
FqQBalance := 0;
end;
procedure TEMFtoPDFExport.DoEMR_IntersectClipRect;
begin
inherited DoEMR_IntersectClipRect;
with PLast^.IntersectClipRect.rclClip do
if (Right = Left) or (Bottom = Top) then
Exit;
FLastClipRect := PLast^.IntersectClipRect.rclClip;
cmdAppendRectangleToPath(PLast^.IntersectClipRect.rclClip);
cmdSetClippingPath;
cmdPathPainting(ppEnd);
end;
procedure TEMFtoPDFExport.DoEMR_LineTo;
begin
inherited;
// Specifies a line from the current position up to the specified point.
DrawFigureStart;
cmdLineTo(FDC.PositionNext);
DrawFigureFinish(ppStroke + ppWithTo);
end;
procedure TEMFtoPDFExport.DoEMR_MaskBlt;
begin
inherited;
with PLast^.MaskBlt do
cmdBitMap(Bounds(xDest, yDest, cxDest, cyDest), dwRop, FEMRList.Last as TEMRBitBltObj);
end;
procedure TEMFtoPDFExport.DoEMR_MoveToEx;
begin
inherited;
cmdMoveTo(FDC.PositionNext);
end;
procedure TEMFtoPDFExport.DoEMR_Pie;
begin
inherited;
DrawFigureStart;
with PLast^ do
cmdAppendPieToPath(Pie);
DrawFigureFinish(ppClose + ppFill + ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_PolyBezier;
begin
inherited;
DrawFigureStart;
cmdPolyBezier;
DrawFigureFinish(ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_PolyBezier16;
begin
inherited;
DrawFigureStart;
cmdPolyBezier16;
DrawFigureFinish(ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_PolyBezierTo;
begin
inherited;
DrawFigureStart;
cmdPolyBezier(ppWithTo);
DrawFigureFinish(ppStroke + ppWithTo);
end;
procedure TEMFtoPDFExport.DoEMR_PolyBezierTo16;
begin
inherited;
// Specifies one or more Bezier curves based on the current position.
DrawFigureStart;
cmdPolyBezier16(ppWithTo);
DrawFigureFinish(ppStroke + ppWithTo);
end;
procedure TEMFtoPDFExport.DoEMR_PolyDraw;
var
Point, T, Count: integer;
begin
inherited;
DrawFigureStart;
Point := 0;
Count := PLast^.PolyDraw.cptl;
with FEMRList.Last as TEMRPolyDrawObj do
while Point <= Count - 1 do
begin
T := Types[Point];
if IsInclude(T, PT_MOVETO) {PT_MOVETO - MUST be first test} then
cmdMoveTo(P.PolyDraw.aptl[Point])
else if IsInclude(T, PT_LINETO) then
cmdLineTo(P.PolyDraw.aptl[Point])
else if IsInclude(T, PT_BEZIERTO) then
if Point + 2 <= Count - 1 then
begin
cmdAppendCurvedSegment3(P.PolyDraw.aptl[Point],
P.PolyDraw.aptl[Point + 1],
P.PolyDraw.aptl[Point + 2]);
Point := Point + 2;
end
else if Point + 1 <= Count - 1 then
begin
cmdAppendCurvedSegment2final(P.PolyDraw.aptl[Point],
P.PolyDraw.aptl[Point + 1]);
Point := Point + 1;
end;
if IsInclude(T, PT_CLOSEFIGURE) then
cmdCloseSubpath;
Point := Point + 1;
end;
DrawFigureFinish(ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_PolyDraw16;
var
Point, T, Count: integer;
begin
inherited;
DrawFigureStart;
Point := 0;
Count := PLast^.PolyDraw16.cpts;
with FEMRList.Last as TEMRPolyDraw16Obj do
while Point <= Count - 1 do
begin
T := Types[Point];
if IsInclude(T, PT_MOVETO) {PT_MOVETO - MUST be first test} then
cmdMoveTo(P.PolyDraw16.apts[Point])
else if IsInclude(T, PT_LINETO) then
cmdLineTo(P.PolyDraw16.apts[Point])
else if IsInclude(T, PT_BEZIERTO) then
if Point + 2 <= Count - 1 then
begin
cmdAppendCurvedSegment3(P.PolyDraw16.apts[Point],
P.PolyDraw16.apts[Point + 1],
P.PolyDraw16.apts[Point + 2]);
Point := Point + 2;
end
else if Point + 1 <= Count - 1 then
begin
cmdAppendCurvedSegment2final(P.PolyDraw16.apts[Point],
P.PolyDraw16.apts[Point + 1]);
Point := Point + 1;
end;
if IsInclude(T, PT_CLOSEFIGURE) then
cmdCloseSubpath;
Point := Point + 1;
end;
DrawFigureFinish(ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_Polygon;
begin
inherited;
if PLast^.Polyline.cptl > 1 then
begin
DrawFigureStart;
cmdPolyLine(ppClose);
DrawFigureFinish(ppFill + ppStroke);
end;
end;
procedure TEMFtoPDFExport.DoEMR_Polygon16;
begin
inherited;
// The polygon SHOULD be outlined using the current pen and filled using
// the current brush and polygon fill mode. The polygon SHOULD be closed
// automatically by drawing a line from the last vertex to the first.
if PLast^.Polyline16.cpts > 1 then
begin
DrawFigureStart;
cmdPolyLine16(ppClose);
DrawFigureFinish(ppFill + ppStroke);
end;
end;
procedure TEMFtoPDFExport.DoEMR_Polyline;
begin
inherited;
if PLast^.Polyline.cptl > 1 then
begin
DrawFigureStart;
cmdPolyLine;
DrawFigureFinish(ppStroke);
end;
end;
procedure TEMFtoPDFExport.DoEMR_Polyline16;
begin
inherited;
if PLast^.Polyline16.cpts > 1 then
begin
DrawFigureStart;
cmdPolyLine16;
DrawFigureFinish(ppStroke);
end;
end;
procedure TEMFtoPDFExport.DoEMR_PolylineTo;
begin
inherited;
if PLast^.Polyline.cptl > 1 then
begin
DrawFigureStart;
cmdPolyLine(ppWithTo);
DrawFigureFinish(ppStroke + ppWithTo);
end;
end;
procedure TEMFtoPDFExport.DoEMR_PolylineTo16;
begin
inherited;
if PLast^.Polyline16.cpts > 1 then
begin
DrawFigureStart;
cmdPolyLine16(ppWithTo);
DrawFigureFinish(ppStroke + ppWithTo);
end;
end;
procedure TEMFtoPDFExport.DoEMR_PolyPolygon;
begin
inherited;
if PLast^.PolyPolyline.nPolys > 0 then
begin
DrawFigureStart;
cmdPolyPolyLine(ppClose);
DrawFigureFinish(ppFill + ppStroke);
end;
end;
procedure TEMFtoPDFExport.DoEMR_PolyPolygon16;
begin
inherited;
if PLast^.PolyPolyline16.nPolys > 0 then
begin
DrawFigureStart;
cmdPolyPolyLine16(ppClose);
DrawFigureFinish(ppFill + ppStroke);
end;
end;
procedure TEMFtoPDFExport.DoEMR_PolyPolyline;
begin
inherited;
if PLast^.PolyPolyline.nPolys > 0 then
begin
DrawFigureStart;
cmdPolyPolyLine(ppEnd);
DrawFigureFinish(ppStroke);
end;
end;
procedure TEMFtoPDFExport.DoEMR_PolyPolyline16;
begin
inherited;
if PLast^.PolyPolyline16.nPolys > 0 then
begin
DrawFigureStart;
cmdPolyPolyLine16(ppEnd);
DrawFigureFinish(ppStroke);
end;
end;
procedure TEMFtoPDFExport.DoEMR_Rectangle;
begin
inherited DoEMR_Rectangle;
DrawFigureStart;
cmdAppendRectangleToPath(PLast^.Rectangle.rclBox);
DrawFigureFinish(ppFill + ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_RestoreDC;
var
i: integer;
begin
inherited DoEMR_RestoreDC;
for i := PLast^.RestoreDC.iRelative to -1 do
cmdRestoreGraphicsState;
end;
procedure TEMFtoPDFExport.DoEMR_RoundRect;
begin
inherited;
DrawFigureStart;
with PLast^ do
cmdAppendRoundRectToPath(RoundRect.rclBox, RoundRect.szlCorner);
DrawFigureFinish(ppFill + ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_SaveDC;
begin
inherited DoEMR_SaveDC;
cmdSaveGraphicsState;
end;
procedure TEMFtoPDFExport.DoEMR_SelectClipPath;
begin
inherited;
cmdSetClippingPath;
cmdPathPainting(ppEnd);
end;
procedure TEMFtoPDFExport.DoEMR_StretchBlt;
begin
inherited;
with PLast^.StretchBlt do
cmdBitMap(Bounds(xDest, yDest, cxDest, cyDest), dwRop, FEMRList.Last as TEMRStretchBltObj);
end;
procedure TEMFtoPDFExport.DoEMR_StretchDIBits;
begin
inherited;
with PLast^.StretchDIBits do
cmdBitMap(Bounds(xDest, yDest, cxDest, cyDest), dwRop, FEMRList.Last as TEMRStretchDIBitsObj);
end;
procedure TEMFtoPDFExport.DoEMR_StrokeAndFillPath;
begin
inherited;
cmdPathPainting(ppFill + ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_StrokePath;
begin
inherited;
cmdPathPainting(ppStroke);
end;
procedure TEMFtoPDFExport.DoEMR_TransparentBlt;
begin
inherited;
with PLast^.TransparentBlt do
cmdBitMap(Bounds(xDest, yDest, cxDest, cyDest), dwRop, FEMRList.Last as TEMRTransparentBltObj);
end;
procedure TEMFtoPDFExport.DoFinish;
begin
inherited;
cmdRestoreGraphicsState;
end;
procedure TEMFtoPDFExport.DoStart;
begin // Before EMR_Header
inherited;
cmdSaveGraphicsState;
if FClipped then
begin
PutLF(frxRect2Str(FPDFRect, FPrecision) + ' re');
cmdSetClippingPath;
cmdPathPainting(ppEnd);
end;
end;
procedure TEMFtoPDFExport.DrawFigureFinish(Options: integer);
begin
if not FDC.IsPathBracketOpened then
begin
cmdPathPainting(FillStrokeOptions(Options));
cmdRestoreGraphicsState;
if IsInclude(Options, ppWithTo) then
cmdMoveTo(FDC.PositionNext);
end;
end;
procedure TEMFtoPDFExport.DrawFigureStart;
begin
if not FDC.IsPathBracketOpened then
cmdSaveGraphicsState;
end;
procedure TEMFtoPDFExport.DrawFontLines(FontSize: Double; TextPosition: TfrxPoint; TextWidth: Extended);
procedure DrawLine(Shift, Width: Extended);
var
Y: Extended;
begin
Y := TextPosition.Y + FontSize * Shift;
cmdMoveTo(TextPosition.X, Y);
cmdLineTo(TextPosition.X + TextWidth, Y);
cmdSetLineWidth(Width);
cmdPathPainting(ppFontStroke);
end;
begin
cmdSetLineDashPattern(PS_SOLID, 0);
cmdSetStrokeColor(FDC.TextColor);
if FDC.FontUnderline then
DrawLine(UnderlineShift, FontSize * UnderlineWidth);
if FDC.FontStrikeOut then
DrawLine(StrikeOutShift, FontSize * StrikeOutWidth);
end;
function TEMFtoPDFExport.emfPoint2Str(emfSP: TSmallPoint): String;
begin
Result := frxPoint2Str(pdfFrxPoint(emfSP), FPrecision);
end;
function TEMFtoPDFExport.emfPoint2Str(emfP: TPoint): String;
begin
Result := frxPoint2Str(pdfFrxPoint(emfP), FPrecision);
end;
function TEMFtoPDFExport.emfPoint2Str(emfFP: TfrxPoint): String;
begin
Result := frxPoint2Str(pdfFrxPoint(emfFP), FPrecision);
end;
function TEMFtoPDFExport.emfRect2Str(emfR: TRect): String;
begin
Result := frxRect2Str(pdfFrxRect(emfR), FPrecision);
end;
//function TEMFtoPDFExport.emfSize2Str(emfSize: Extended): String;
//begin
// Result := Float2Str(pdfSize(emfSize));
//end;
function TEMFtoPDFExport.EvenOdd: String;
begin
Result := IfStr(FDC.PolyFillMode = ALTERNATE, '*');
end;
function TEMFtoPDFExport.FillStrokeOptions(Options: integer): integer;
begin
Result := IfInt(IsInclude(Options, ppStroke) and not IsNullPen, ppStroke) +
IfInt(IsInclude(Options, ppFill) and not IsNullBrush, ppFill);
end;
function TEMFtoPDFExport.FontCreate: TEMFFont;
var
FontIndex: Integer;
begin
Result := inherited FontCreate;
if FDC.IsFontHeight then
begin
FontIndex := FPOH.GetObjFontNumber(Result);
Result.DownSizeFactor := FPOH.Fonts[FontIndex].FontHeightToPointSizeFactor;
end
else
Result.DownSizeFactor := 1.0;
Result.PreciseSize := pdfSize(FDC.FontSize * Result.DownSizeFactor);
Result.Size := Round(Result.PreciseSize);
end;
function TEMFtoPDFExport.IsNullBrush: Boolean;
begin
Result := FForceNullBrush or
(FDC.BrushStyle in [BS_NULL, BS_PATTERN8X8, BS_DIBPATTERN8X8, BS_MONOPATTERN]);
end;
function TEMFtoPDFExport.IsNullPen: Boolean;
begin
Result := FDC.PenStyle in [PS_NULL];
end;
function TEMFtoPDFExport.IsSameCharacterWidth(FontName: string): Boolean;
begin
Result := (Pos('Arial', FontName) = 1)
or (Pos('Calibri', FontName) = 1)
or (Pos('Cambria', FontName) = 1)
// or (Pos('Garamond', FontName) = 1)
// or (Pos('Georgia', FontName) = 1)
or (Pos('Gotham', FontName) = 1)
or (Pos('Meiryo', FontName) = 1)
// or (Pos('Tahoma', FontName) = 1)
or (Pos('Times New Roman', FontName) = 1)
// or (Pos('Trebuchet MS', FontName) = 1)
// or (Pos('Verdana', FontName) = 1)
;
end;
function TEMFtoPDFExport.NormalizeRect(const Rect: TRect): TRect;
begin
Result := Rect;
if Result.Left > Result.Right then
begin
Result.Left := Rect.Right;
Result.Right := Rect.Left;
end;
if Result.Top > Result.Bottom then
begin
Result.Top := Rect.Bottom;
Result.Bottom := Rect.Top;
end;
end;
function TEMFtoPDFExport.PDFDeviceContext: TPDFDeviceContext;
begin
Result := FDC as TPDFDeviceContext;
end;
function TEMFtoPDFExport.pdfFrxPoint(emfP: TPoint): TfrxPoint;
begin
Result := LogToDevPoint(emfP);
Result.X := FPDFRect.Left + Result.X * FEMFtoPDFFactor.X;
Result.Y := FPDFRect.Top - Result.Y * FEMFtoPDFFactor.Y;
end;
function TEMFtoPDFExport.pdfFrxPoint(emfSP: TSmallPoint): TfrxPoint;
begin
Result := LogToDevPoint(emfSP);
Result.X := FPDFRect.Left + Result.X * FEMFtoPDFFactor.X;
Result.Y := FPDFRect.Top - Result.Y * FEMFtoPDFFactor.Y;
end;
function TEMFtoPDFExport.pdfFrxPoint(emfDP: TfrxPoint): TfrxPoint;
begin
Result := LogToDevPoint(emfDP);
Result.X := FPDFRect.Left + Result.X * FEMFtoPDFFactor.X;
Result.Y := FPDFRect.Top - Result.Y * FEMFtoPDFFactor.Y;
end;
function TEMFtoPDFExport.pdfFrxRect(emfR: TRect): TfrxRect;
var
TopLeft, BottomRight: TfrxPoint;
begin
TopLeft := pdfFrxPoint(emfR.TopLeft);
BottomRight := pdfFrxPoint(emfR.BottomRight);
Result.Left := Min(TopLeft.X, BottomRight.X);
Result.Right := Max(TopLeft.X, BottomRight.X);
Result.Top := Max(TopLeft.Y, BottomRight.Y); // Max !
Result.Bottom := Min(TopLeft.Y, BottomRight.Y); // Min !
end;
function TEMFtoPDFExport.pdfSize(emfSize: Extended): Extended;
begin
Result := LogToDevSize(emfSize) * (FEMFtoPDFFactor.X + FEMFtoPDFFactor.Y) / 2;
end;
procedure TEMFtoPDFExport.Put(const S: AnsiString);
begin
FOutStream.Write(S[1], Length(S));
end;
procedure TEMFtoPDFExport.PutCRLF(const S: AnsiString);
begin
Put(S + AnsiString(#13#10));
end;
procedure TEMFtoPDFExport.PutLF(const S: AnsiString);
begin
Put(S + AnsiString(#10));
end;
{$IFDEF Delphi12}
procedure TEMFtoPDFExport.PutCRLF(const S: String);
begin
PutCRLF(AnsiString(S));
end;
procedure TEMFtoPDFExport.PutLF(const S: String);
begin
PutLF(AnsiString(S));
end;
{$ENDIF}
procedure TEMFtoPDFExport.RealizationListFill(RealizedCommands: array of String);
var
i: integer;
begin
for i := Low(RealizedCommands) to High(RealizedCommands) do
FRealizationList.Add(RealizedCommands[i]);
end;
{ TEMFPDFSizeConverter }
constructor TEMFPDFSizeConverter.Create(AExport: TEMFtoPDFExport);
begin
FExport := AExport;
FEMFPDFFactor := FExport.FEMFtoPDFFactor.X;
FFont := FExport.FontCreate;
end;
destructor TEMFPDFSizeConverter.Destroy;
begin
FFont.Free;
inherited;
end;
function TEMFPDFSizeConverter.LogToDev(Value: Double): Double;
begin
Log := Value;
Result := Dev;
end;
procedure TEMFPDFSizeConverter.SetChar(const Value: Double);
begin
FChar := Value;
FDev := FChar * FFont.Size / 1000 / FEMFPDFFactor;
FPDF := FDev * FEMFPDFFactor;
FLog := FDev * FEXport.FDC.XFormAverageScale;
end;
procedure TEMFPDFSizeConverter.SetDev(const Value: Double);
begin
FDev := Value;
FPDF := FDev * FEMFPDFFactor;
FChar := FDev * 1000 / Max(1, FFont.Size) * FEMFPDFFactor;
FLog := FDev * FEXport.FDC.XFormAverageScale;
end;
procedure TEMFPDFSizeConverter.SetLog(const Value: Double);
begin
FLog := Value;
FDev := FExport.LogToDevSizeX(FLog);
FPDF := FDev * FEMFPDFFactor;
FChar := FDev * 1000 / Max(1, FFont.Size) * FEMFPDFFactor;
end;
procedure TEMFPDFSizeConverter.SetPDF(const Value: Double);
begin
FPDF := Value;
FDev := FPDF / FEMFPDFFactor;
FChar := FDev * 1000 / Max(1, FFont.Size) * FEMFPDFFactor;
FLog := FDev * FEXport.FDC.XFormAverageScale;
end;
end.
Reference in New Issue Copy Permalink