paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 01:08:12 +02:00
Code Issues Packages Projects Releases Wiki Activity
main
lazarus/lcl/postscriptcanvas.pas
Juha c3891ad820 Reduce compiler warnings.
2023-07-03 06:23:49 +03:00

3028 lines
91 KiB
ObjectPascal
Raw Permalink Blame History

{
/***************************************************************************
PostScriptCanvas.pas
------------
PostScript Printer Canvas object
***************************************************************************/
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
Author: Olivier Guilbaud
Informations :
- Green Book Listing 9-1, on page 138 for Pattrens
- PostScriptPrinter unit of Tony Maro
- Piddle Project (Python language)
- Internet PostScript forums
Warnings :
- Draw and StretchDraw it's slow for big image
- Angles it's 1/16 of degre
ToDo :
- Implemente few methods
}
{
12 December 2012
TextRect implemented T. P. Launchbury
}
{$DEFINE ASCII85}
unit PostScriptCanvas;
{$mode objfpc}{$H+}
interface
uses
// RTL + FCL
Classes, SysUtils, strutils, Math, Types, FPImage,
// LCL
LCLType, LCLIntf, LCLProc,
Graphics, Forms, IntfGraphics, Printers, PostScriptUnicode,
// LazUtils
GraphType, GraphMath, LazFileUtils, IntegerList, LazUTF8;
Type
{ TPostScriptPrinterCanvas }
TpsPoint=record
fx,fy:single;
end;
TpsBounds=record
fx,fy,fwidth,fheight:single;
end;
TPsCanvasState = ( pcsPosValid, pcsClipping, pcsClipSaved );
TPsCanvasStatus = set of TPsCanvasState;
TPostScriptPrinterCanvas = Class(TFilePrinterCanvas)
private
fHeader : TStringList; //Header document
fDocument : TstringList; //Current document
fBuffer : TStringList; //PostScript temporary buffer
//Current values
fcBrushStyle : TBrushStyle;
fcPenColor : TColor; //Color of Pen and Brush
fcPenWidth : Integer;
fcPenStyle : TPenStyle;
FPsUnicode : TPSUnicode;
FFs : TFormatSettings;
fSaveCount : Integer;
FLazClipRect : TRect;
FStatus : TPsCanvasStatus;
procedure psDrawRect(ARect:TRect);
procedure WriteHeader(St : String);
procedure Write(const St : String; Lst : TStringList = nil); overload;
procedure WriteB(const St : string);
procedure ClearBuffer;
procedure Write(Lst : TStringList); overload;
procedure WriteComment(const St : string);
procedure WritePageTransform;
procedure WriteOrientation(UseHeader: boolean);
procedure WriteBoundingBox(UseHeader: boolean);
function TranslateCoord(cnvX,cnvY : Integer):TpsPoint;
function TxRectToBounds(aRect: TRect): TpsBounds;
procedure SetPosition(X,Y : Integer);
procedure UpdateLineWidth;
procedure UpdateLineColor(aColor : TColor = clNone);
procedure UpdateLineStyle;
procedure UpdateFillColor;
procedure UpdateFont;
function MappedFontName: string;
procedure MoveToLastPos;
procedure SetBrushFillPattern(Lst : TStringList; SetBorder,SetFill : Boolean);
procedure SetBrushFillPattern(SetBorder,SetFill : Boolean); overload;
procedure GetRGBImage(SrcGraph: TGraphic; Lst : TStringList);
procedure PixelsToPoints(const PixX,PixY: Integer; out PtX,PtY:Single);
function GetFontSize: Integer;
procedure RestoreClip;
procedure SaveClip;
procedure CheckLastPos;
function GetFontIndex: Integer;
function FontUnitsToPixelsX(const Value:Integer): Integer;
function FontUnitsToPixelsY(const Value:Integer): Integer;
function FontUnitsToPixelsY(const Value:Double): Integer;
protected
procedure CreateHandle; override;
procedure CreateBrush; override;
procedure CreateFont; override;
procedure CreatePen; override;
procedure CreateRegion; override;
procedure DeselectHandles; override;
procedure PenChanging(APen: TObject); override;
procedure FontChanging(APen: TObject); override;
procedure BrushChanging(APen: TObject); override;
procedure RegionChanging(APen: TObject); override;
procedure RequiredState(ReqState: TCanvasState); override;
procedure DoEllipseAndFill(const Bounds: TRect); override;
procedure RealizeAntialiasing; override;
function GetClipRect: TRect; override;
procedure SetClipRect(const ARect: TRect); override;
function GetClipping: Boolean; override;
procedure SetClipping(const AValue: boolean); override;
procedure DoMoveTo(X1,Y1: Integer); override;
procedure DoLineTo(X1,Y1: Integer); override;
public
constructor Create(APrinter : TPrinter); override;
destructor Destroy; override;
procedure BeginDoc; override;
procedure EndDoc; override;
procedure NewPage; override;
procedure SaveToFile(aFileName : string);
procedure Polyline(Points: PPoint; NumPts: Integer); override;
procedure PolyBezier(Points: PPoint; NumPts: Integer;
Filled: boolean = False;
Continuous: boolean = False); override;
procedure Rectangle(X1,Y1,X2,Y2: Integer); override;
procedure Frame(const ARect: TRect); override; // border using pen
procedure FrameRect(const ARect: TRect); override; // border using brush
procedure FillRect(const ARect: TRect); override;
procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY: Integer); override;
procedure Polygon(Points: PPoint; NumPts: Integer;
Winding: boolean = False); override;
procedure Ellipse(x1, y1, x2, y2: Integer); override;
procedure Arc(Left,Top,Right,Bottom,angle1,angle2: Integer); override;
procedure RadialPie(Left,Top,Right,Bottom,angle1,angle2: Integer); override;
procedure Chord(x1, y1, x2, y2, angle1, angle2: Integer); override;
procedure TextOut(X,Y: Integer; const Text: String); override;
function TextExtent(const Text: string): TSize; override;
procedure TextRect(ARect: TRect; X, Y: integer; const Text: string;
const Style: TTextStyle); override;
procedure Draw(X,Y: Integer; SrcGraphic: TGraphic); override;
procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); override;
function GetTextMetrics(out TM: TLCLTextMetric): boolean; override;
//** Methods not definined on PostScript
procedure FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle); override;
procedure CopyRect(const Dest: TRect; SrcCanvas: TCanvas; const Source: TRect); override;
//** Methods not implemented
procedure Arc(x,y,Right,Bottom,SX,SY,EX,EY: Integer); override;
procedure Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer); override;
procedure Frame3d(var ARect: TRect; const FrameWidth: integer;
const Style: TGraphicsBevelCut); override;
procedure Pie(EllipseX1,EllipseY1,EllipseX2,EllipseY2,
StartX,StartY,EndX,EndY: Integer); override;
procedure SetPixel(X,Y: Integer; Value: TColor); override;
end;
TPostScriptCanvas = Class(TPostScriptPrinterCanvas)
public
constructor Create; overload;
procedure BeginDoc; override;
procedure EndDoc; override;
procedure NewPage; override;
end;
implementation
Type
TFontsWidths = Array[32..255] of Integer;
TFontPSMetrics = Record
Name : string;
ULPos, ULThickness, Ascender, Descender: Integer;
Widths : TFontsWidths;
end;
Const
cFontPSMetrics : Array[0..12] of TFontPSMetrics =(
(Name : 'Courier';
ULPos : -100; ULThickness : 50; Ascender : 604; Descender : -186;
Widths: (600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600)
),
(Name : 'Courier-Bold';
ULPos : -100; ULThickness : 50; Ascender : 624; Descender : -205;
Widths: (600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600)
),
(Name : 'Courier-Oblique';
ULPos : -100; ULThickness : 50; Ascender : 604; Descender : -186;
Widths: (600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600)
),
(Name : 'Courier-BoldOblique';
ULPos : -100; ULThickness : 50; Ascender : 624; Descender : -205;
Widths: (600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600, 600, 600, 600, 600,
600, 600, 600, 600, 600, 600)
),
(Name : 'Helvetica';
ULPos : -151; ULThickness : 50; Ascender : 729; Descender : -218;
Widths: (278, 278, 355, 556, 556, 889, 667, 191,
333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
556, 556, 556, 556, 556, 556, 556, 556, 278, 278,
584, 584, 584, 556, 1015, 667, 667, 722, 722, 667,
611, 778, 722, 278, 500, 667, 556, 833, 722, 778,
667, 778, 722, 667, 611, 722, 667, 944, 667, 667,
611, 278, 278, 278, 469, 556, 333, 556, 556, 500,
556, 556, 278, 556, 556, 222, 222, 500, 222, 833,
556, 556, 556, 556, 333, 500, 278, 556, 500, 722,
500, 500, 500, 334, 260, 334, 584, 278, 278, 278,
278, 278, 278, 278, 278, 278, 278, 278, 278, 278,
278, 278, 278, 278, 278, 278, 278, 278, 278, 278,
278, 278, 278, 278, 278, 278, 278, 278, 278, 278,
278, 333, 556, 556, 556, 556, 260, 556, 333, 737,
370, 556, 584, 333, 737, 333, 400, 584, 333, 333,
333, 556, 537, 278, 333, 333, 365, 556, 834, 834,
834, 611, 667, 667, 667, 667, 667, 667, 1000, 722,
667, 667, 667, 667, 278, 278, 278, 278, 722, 722,
778, 778, 778, 778, 778, 584, 778, 722, 722, 722,
722, 667, 667, 611, 556, 556, 556, 556, 556, 556,
889, 500, 556, 556, 556, 556, 278, 278, 278, 278,
556, 556, 556, 556, 556, 556, 556, 584, 611, 556,
556, 556, 556, 500, 556, 500)
),
(Name : 'Helvetica-Bold';
ULPos : -155; ULThickness : 69; Ascender : 729; Descender : -218;
Widths: (278, 333, 474, 556, 556, 889, 722, 238,
333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
556, 556, 556, 556, 556, 556, 556, 556, 333, 333,
584, 584, 584, 611, 975, 722, 722, 722, 722, 667,
611, 778, 722, 278, 556, 722, 611, 833, 722, 778,
667, 778, 722, 667, 611, 722, 667, 944, 667, 667,
611, 333, 278, 333, 584, 556, 333, 556, 611, 556,
611, 556, 333, 611, 611, 278, 278, 556, 278, 889,
611, 611, 611, 611, 389, 556, 333, 611, 556, 778,
556, 556, 500, 389, 280, 389, 584, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
278, 333, 556, 556, 556, 556, 280, 556, 333, 737,
370, 556, 584, 333, 737, 333, 400, 584, 333, 333,
333, 611, 556, 278, 333, 333, 365, 556, 834, 834,
834, 611, 722, 722, 722, 722, 722, 722, 1000, 722,
667, 667, 667, 667, 278, 278, 278, 278, 722, 722,
778, 778, 778, 778, 778, 584, 778, 722, 722, 722,
722, 667, 667, 611, 556, 556, 556, 556, 556, 556,
889, 556, 556, 556, 556, 556, 278, 278, 278, 278,
611, 611, 611, 611, 611, 611, 611, 584, 611, 611,
611, 611, 611, 556, 611, 556)
),
(Name : 'Helvetica-Oblique';
ULPos : -151; ULThickness : 50; Ascender : 729; Descender : -213;
Widths: (278, 278, 355, 556, 556, 889, 667, 191,
333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
556, 556, 556, 556, 556, 556, 556, 556, 278, 278,
584, 584, 584, 556, 1015, 667, 667, 722, 722, 667,
611, 778, 722, 278, 500, 667, 556, 833, 722, 778,
667, 778, 722, 667, 611, 722, 667, 944, 667, 667,
611, 278, 278, 278, 469, 556, 333, 556, 556, 500,
556, 556, 278, 556, 556, 222, 222, 500, 222, 833,
556, 556, 556, 556, 333, 500, 278, 556, 500, 722,
500, 500, 500, 334, 260, 334, 584, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
278, 333, 556, 556, 556, 556, 260, 556, 333, 737,
370, 556, 584, 333, 737, 333, 400, 584, 333, 333,
333, 556, 537, 278, 333, 333, 365, 556, 834, 834,
834, 611, 667, 667, 667, 667, 667, 667, 1000, 722,
667, 667, 667, 667, 278, 278, 278, 278, 722, 722,
778, 778, 778, 778, 778, 584, 778, 722, 722, 722,
722, 667, 667, 611, 556, 556, 556, 556, 556, 556,
889, 500, 556, 556, 556, 556, 278, 278, 278, 278,
556, 556, 556, 556, 556, 556, 556, 584, 611, 556,
556, 556, 556, 500, 556, 500)
),
(Name : 'Helvetica-BoldOblique';
ULPos : -111; ULThickness : 69; Ascender : 729; Descender : -218;
Widths: (278, 333, 474, 556, 556, 889, 722, 238,
333, 333, 389, 584, 278, 333, 278, 278, 556, 556,
556, 556, 556, 556, 556, 556, 556, 556, 333, 333,
584, 584, 584, 611, 975, 722, 722, 722, 722, 667,
611, 778, 722, 278, 556, 722, 611, 833, 722, 778,
667, 778, 722, 667, 611, 722, 667, 944, 667, 667,
611, 333, 278, 333, 584, 556, 333, 556, 611, 556,
611, 556, 333, 611, 611, 278, 278, 556, 278, 889,
611, 611, 611, 611, 389, 556, 333, 611, 556, 778,
556, 556, 500, 389, 280, 389, 584, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
278, 333, 556, 556, 556, 556, 280, 556, 333, 737,
370, 556, 584, 333, 737, 333, 400, 584, 333, 333,
333, 611, 556, 278, 333, 333, 365, 556, 834, 834,
834, 611, 722, 722, 722, 722, 722, 722, 1000, 722,
667, 667, 667, 667, 278, 278, 278, 278, 722, 722,
778, 778, 778, 778, 778, 584, 778, 722, 722, 722,
722, 667, 667, 611, 556, 556, 556, 556, 556, 556,
889, 556, 556, 556, 556, 556, 278, 278, 278, 278,
611, 611, 611, 611, 611, 611, 611, 584, 611, 611,
611, 611, 611, 556, 611, 556)
),
(Name : 'Times-Roman';
ULPos : -100; ULThickness : 50; Ascender : 683; Descender : -217;
Widths: (250, 333, 408, 500, 500, 833, 778, 180,
333, 333, 500, 564, 250, 333, 250, 278, 500, 500,
500, 500, 500, 500, 500, 500, 500, 500, 278, 278,
564, 564, 564, 444, 921, 722, 667, 667, 722, 611,
556, 722, 722, 333, 389, 722, 611, 889, 722, 722,
556, 722, 667, 556, 611, 722, 722, 944, 722, 722,
611, 333, 278, 333, 469, 500, 333, 444, 500, 444,
500, 444, 333, 500, 500, 278, 278, 500, 278, 778,
500, 500, 500, 500, 333, 389, 278, 500, 500, 722,
500, 500, 444, 480, 200, 480, 541, 889, 889, 889,
889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
250, 333, 500, 500, 500, 500, 200, 500, 333, 760,
276, 500, 564, 333, 760, 333, 400, 564, 300, 300,
333, 500, 453, 250, 333, 300, 310, 500, 750, 750,
750, 444, 722, 722, 722, 722, 722, 722, 889, 667,
611, 611, 611, 611, 333, 333, 333, 333, 722, 722,
722, 722, 722, 722, 722, 564, 722, 722, 722, 722,
722, 722, 556, 500, 444, 444, 444, 444, 444, 444,
667, 444, 444, 444, 444, 444, 278, 278, 278, 278,
500, 500, 500, 500, 500, 500, 500, 564, 500, 500,
500, 500, 500, 500, 500, 500)
),
(Name : 'Times-Bold';
ULPos : -100; ULThickness : 50; Ascender : 676; Descender : -205;
Widths: (250, 333, 555, 500, 500, 1000, 833, 278,
333, 333, 500, 570, 250, 333, 250, 278, 500, 500,
500, 500, 500, 500, 500, 500, 500, 500, 333, 333,
570, 570, 570, 500, 930, 722, 667, 722, 722, 667,
611, 778, 778, 389, 500, 778, 667, 944, 722, 778,
611, 778, 722, 556, 667, 722, 722, 1000, 722, 722,
667, 333, 278, 333, 581, 500, 333, 500, 556, 444,
556, 444, 333, 500, 556, 278, 333, 556, 278, 833,
556, 500, 556, 556, 444, 389, 333, 556, 500, 722,
500, 500, 444, 394, 220, 394, 520, 944, 944, 944,
944, 944, 944, 944, 944, 944, 944, 944, 944, 944,
944, 944, 944, 944, 944, 944, 944, 944, 944, 944,
944, 944, 944, 944, 944, 944, 944, 944, 944, 944,
250, 333, 500, 500, 500, 500, 220, 500, 333, 747,
300, 500, 570, 333, 747, 333, 400, 570, 300, 300,
333, 556, 540, 250, 333, 300, 330, 500, 750, 750,
750, 500, 722, 722, 722, 722, 722, 722, 1000, 722,
667, 667, 667, 667, 389, 389, 389, 389, 722, 722,
778, 778, 778, 778, 778, 570, 778, 722, 722, 722,
722, 722, 611, 556, 500, 500, 500, 500, 500, 500,
722, 444, 444, 444, 444, 444, 278, 278, 278, 278,
500, 556, 500, 500, 500, 500, 500, 570, 500, 556,
556, 556, 556, 500, 556, 500)
),
(Name : 'Times-Italic';
ULPos : -100; ULThickness : 50; Ascender : 683; Descender : -205;
Widths: (250, 333, 420, 500, 500, 833, 778, 214,
333, 333, 500, 675, 250, 333, 250, 278, 500, 500,
500, 500, 500, 500, 500, 500, 500, 500, 333, 333,
675, 675, 675, 500, 920, 611, 611, 667, 722, 611,
611, 722, 722, 333, 444, 667, 556, 833, 667, 722,
611, 722, 611, 500, 556, 722, 611, 833, 611, 556,
556, 389, 278, 389, 422, 500, 333, 500, 500, 444,
500, 444, 278, 500, 500, 278, 278, 444, 278, 722,
500, 500, 500, 500, 389, 389, 278, 500, 444, 667,
444, 444, 389, 400, 275, 400, 541, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
833, 833, 833, 833, 833, 833, 833, 833, 833, 833,
250, 389, 500, 500, 500, 500, 275, 500, 333, 760,
276, 500, 675, 333, 760, 333, 400, 675, 300, 300,
333, 500, 523, 250, 333, 300, 310, 500, 750, 750,
750, 500, 611, 611, 611, 611, 611, 611, 889, 667,
611, 611, 611, 611, 333, 333, 333, 333, 722, 667,
722, 722, 722, 722, 722, 675, 722, 722, 722, 722,
722, 556, 611, 500, 500, 500, 500, 500, 500, 500,
667, 444, 444, 444, 444, 444, 278, 278, 278, 278,
500, 500, 500, 500, 500, 500, 500, 675, 500, 500,
500, 500, 500, 444, 500, 444)
),
(Name : 'Times-BoldItalic';
ULPos : -100; ULThickness : 50; Ascender : 699; Descender : -205;
Widths: (250, 389, 555, 500, 500, 833, 778, 278,
333, 333, 500, 570, 250, 333, 250, 278, 500, 500,
500, 500, 500, 500, 500, 500, 500, 500, 333, 333,
570, 570, 570, 500, 832, 667, 667, 667, 722, 667,
667, 722, 778, 389, 500, 667, 611, 889, 722, 722,
611, 722, 667, 556, 611, 722, 667, 889, 667, 611,
611, 333, 278, 333, 570, 500, 333, 500, 500, 444,
500, 444, 333, 500, 556, 278, 278, 500, 278, 778,
556, 500, 500, 500, 389, 389, 278, 556, 444, 667,
500, 444, 389, 348, 220, 348, 570, 889, 889, 889,
889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
889, 889, 889, 889, 889, 889, 889, 889, 889, 889,
250, 389, 500, 500, 500, 500, 220, 500, 333, 747,
266, 500, 606, 333, 747, 333, 400, 570, 300, 300,
333, 576, 500, 250, 333, 300, 300, 500, 750, 750,
750, 500, 667, 667, 667, 667, 667, 667, 944, 667,
667, 667, 667, 667, 389, 389, 389, 389, 722, 722,
722, 722, 722, 722, 722, 570, 722, 722, 722, 722,
722, 611, 611, 500, 500, 500, 500, 500, 500, 500,
722, 444, 444, 444, 444, 444, 278, 278, 278, 278,
500, 556, 500, 500, 500, 500, 500, 570, 500, 556,
556, 556, 556, 444, 500, 444)
),
(Name : 'Symbol';
ULPos : -229; ULThickness : 46; Ascender : 673; Descender : -222;
Widths: (250,333,713,500,549,833,778,439,
333,333,500,549,250,549,250,278,500,500,
500,500,500,500,500,500,500,500,278,278,
549,549,549,444,549,722,667,722,612,611,
763,603,722,333,631,722,686,889,722,722,
768,741,556,592,611,690,439,768,645,795,
611,333,863,333,658,500,500,631,549,549,
494,439,521,411,603,329,603,549,549,576,
521,549,549,521,549,603,439,576,713,686,
493,686,494,480,200,480,549,0,0,0,
0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,
0,620,247,549,167,713,500,753,753,753,
753,1042,987,603,987,603,400,549,411,549,
549,713,494,460,549,549,549,549,1000,603,
1000,658,823,686,795,987,768,768,823,768,
768,713,713,713,713,713,713,713,768,713,
790,790,890,823,549,250,713,603,603,1042,
987,603,987,603,494,329,790,790,786,713,
384,384,384,384,384,384,494,494,494,494,
0,329,274,686,686,686,384,384,384,384,
384,384,494,494,790, 250)
)
);
const
PageOpArr: array[boolean] of string[5] = ('Page','');
OrientArr: array[boolean] of string[10] = ('Landscape','Portrait');
{$IFDEF ASCII85}
type
{ TAscii85Encoder }
TAscii85Encoder=class
private
FStream: TMemoryStream;
FData: LongWord;
FCount: Integer;
FMaxWidth,FWritten: Integer;
procedure EmitData;
procedure WriteByte(const B:Byte);
public
destructor Destroy; override;
procedure Add(B: Byte);
procedure Finish;
property Stream: TMemoryStream read FStream;
property MaxWidth: Integer read FMaxWidth write FMaxWidth;
end;
{ TAscii85Encoder }
procedure TAscii85Encoder.EmitData;
const
Cn: array[0..4] of longword = (85*85*85*85,85*85*85,85*85,85,1);
var
B: byte;
i,n: Integer;
begin
if FCount=0 then
exit;
if FStream=nil then
FStream := TMemoryStream.Create;
if (FCount=4) and (FData=0) then
// special case, zeroed 5-tuple will be generated
WriteByte(ord('z'))
else begin
n := FCount;
while FCount<4 do begin
FData := (FData shl 8);
inc(FCount);
end;
for i:=0 to n do begin
B := byte((FData div Cn[i])+33);
FData := FData mod Cn[i];
WriteByte(B);
end;
end;
FCount := 0;
FData := 0;
end;
procedure TAscii85Encoder.WriteByte(const B: Byte);
var
e: string;
begin
FStream.WriteByte(B);
if FMaxWidth>0 then begin
Inc(FWritten);
if FWritten>=FMaxWidth then begin
// write lineending
e:=LineEnding;
FStream.Write(e[1],length(e));
FWritten := 0;
end;
end;
end;
destructor TAscii85Encoder.Destroy;
begin
if FStream<>nil then
FStream.Free;
inherited Destroy;
end;
procedure TAscii85Encoder.Add(B: Byte);
begin
FData := (FData shl 8) or B;
inc(FCount);
if FCount=4 then
EmitData;
end;
procedure TAscii85Encoder.Finish;
begin
EmitData;
FStream.WriteByte(ord('~'));
FStream.WriteByte(ord('>'));
FStream.Position:=0;
end;
{$ENDIF}
{ TPostScriptPrinterCanvas }
//Write an instruction in the header of document
procedure TPostScriptPrinterCanvas.WriteHeader(St: String);
begin
fHeader.Add(St);
end;
//Write an instruction in the document
procedure TPostScriptPrinterCanvas.Write(const St: String; Lst: TStringList = nil);
begin
If not Assigned(Lst) then
Lst:=fDocument;
Lst.Add(St);
end;
//Write data in fBuffer
procedure TPostScriptPrinterCanvas.WriteB(const St: string);
begin
Write(St,fBuffer);
end;
//Clear all data of Buffer
procedure TPostScriptPrinterCanvas.ClearBuffer;
begin
fBuffer.Clear;
end;
//Write all Lst.Strings in document
procedure TPostScriptPrinterCanvas.Write(Lst: TStringList);
begin
fDocument.AddStrings(Lst);
end;
//Write an comment in the document
procedure TPostScriptPrinterCanvas.WriteComment(const St: string);
begin
fDocument.Add('%'+St);
end;
procedure TPostScriptPrinterCanvas.WritePageTransform;
var
h,w:integer;
begin
case Orientation of
poReversePortrait:
begin
w:=round(PaperWidth*72/XDPI);
h:=round(PaperHeight*72/YDPI);
Write(format('%d %d translate 180 rotate',[w,h]));
end;
poLandscape:
begin
h:=round(PaperHeight*72/YDPI);
Write(format('%d 0 translate 90 rotate',[h]));
end;
poReverseLandscape:
begin
w:=round((PaperWidth-PaperHeight)*72/XDPI);
h:=round(PaperHeight*72/XDPI);
Write(format('%d %d translate 90 neg rotate',[w,h]));
end;
end;
end;
procedure TPostScriptPrinterCanvas.WriteOrientation(UseHeader: boolean);
var
L: TStringList;
begin
if UseHeader then
L := Fheader
else
L := nil;
Write('%%'+PageOpArr[UseHeader]+'Orientation: '+
OrientArr[(Orientation=poPortrait)or(Orientation=poReversePortrait)], L);
end;
procedure TPostScriptPrinterCanvas.WriteBoundingBox(UseHeader: boolean);
var
a,l,t,w,h: Integer;
Lst: TStringList;
begin
l := round(LeftMargin * 72 / XDPI);
t := round(TopMargin * 72 / YDPI);
w := round((PaperWidth - RightMargin) * 72 / XDPI);
h := round((PaperHeight - BottomMargin) * 72 / YDPI);
if (Orientation=poLandscape) or (Orientation=poReverseLandscape) then
begin
a := l; l := t; t := a;
a := w; w := h; h := a;
end;
if UseHeader then
Lst := FHeader
else
Lst := nil;
Write('%%'+PageOpArr[UseHeader]+Format('BoundingBox: %d %d %d %d',[l,t,w,h]),
Lst);
end;
//Convert an TCanvas Y point to PostScript Y point
//The TCanvas origine is corner Left,Top and PostScript is Left,Bottom
//Modify X and Y for use Left and Top margin
function TPostScriptPrinterCanvas.TranslateCoord(cnvX,cnvY : Integer):TpsPoint;
begin
PixelsToPoints(cnvX+LeftMargin, PageHeight+BottomMargin-cnvY,
Result.Fx, Result.Fy);
end;
function TPostScriptPrinterCanvas.TxRectToBounds(aRect: TRect): TpsBounds;
var
p1,p2: TPsPoint;
begin
p1 := TranslateCoord(aRect.Left, aRect.Top);
p2 := TranslateCoord(aRect.Right, aRect.Bottom);
Result.fx := p1.fx;
Result.fy := p2.fy;
Result.fwidth := p2.fx-p1.fx;
Result.fheight := p1.fy-p2.fy;
end;
//Save the last position
procedure TPostScriptPrinterCanvas.SetPosition(X, Y: Integer);
begin
SetInternalPenPos(Point(X,Y));
end;
//Init the width of line
procedure TPostScriptPrinterCanvas.UpdateLineWidth;
var
pw:single;
begin
if Pen.Width<>fcPenWidth then
begin
pw:=1/XDPI; // printer pixel in inches
pw:=Pen.Width*pw*72; // pen width in Points -> 1/72 inches
Write(Format('%.3f setlinewidth',[pw],FFs));
fcPenWidth:=Pen.Width;
end;
end;
//Init the color of line (pen)
procedure TPostScriptPrinterCanvas.UpdateLineColor(aColor : TColor = clNone);
Var R,G,B : Real;
RGBColor : TColorRef;
begin
if aColor=clNone then
aColor:=Pen.Color;
if aColor<>fcPenColor then
begin
RGBColor:=ColorToRGB(aColor);
R:=Red(RGBColor)/255;
G:=Green(RGBColor)/255;
B:=Blue(RGBColor)/255;
Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B],FFs)+' % '+ColorToString(aColor));
fcPenColor:=aColor;
end;
end;
//Init the style of line
procedure TPostScriptPrinterCanvas.UpdateLineStyle;
Var St : string;
begin
if (Pen.Style<>fcPenStyle) and (Pen.Style<>psClear) then
begin
Case Pen.Style of
psSolid : St:='[] 0';
psDash : St:='[5 2] 0';
psDot : St:='[1 3] 0';
psDashDot : St:='[5 2 2 2] 0';
psDashDotDot : St:='[5 2 2 2 2 2] 0';
else St:='';
end;
Write(Format('%s setdash',[St]));
fcPenStyle:=Pen.Style;
end;
end;
//Init the color for fill
procedure TPostScriptPrinterCanvas.UpdateFillColor;
Var R,G,B : Real;
RGBColor : TColorRef;
begin
if (Brush.Style=bsSolid) and (Brush.Color<>fcPenColor) then
begin
RGBColor:=ColorToRGB(Brush.Color);
R:=Red(RGBColor)/255;
G:=Green(RGBColor)/255;
B:=Blue(RGBColor)/255;
Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B],FFs)+' % '+ColorToString(Brush.Color));
fcPenColor:=Brush.Color;
end;
end;
//Update current font
procedure TPostScriptPrinterCanvas.UpdateFont;
Var R,G,B : Real;
RGBColor : TColorRef;
begin
if Font.Color=clNone then
Font.Color:=clBlack;
if Font.Size=0 then
Font.Size:=12;
if Font.Color<>fcPenColor then
begin
RGBColor:=ColorToRGB(Font.Color);
R:=Red(RGBColor)/255;
G:=Green(RGBColor)/255;
B:=Blue(RGBColor)/255;
Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B],FFs)+' % '+ColorToString(Font.Color));
fcPenColor:=Font.Color;
end;
end;
//Return an PostScript font Name
function TPostScriptPrinterCanvas.MappedFontName: string;
Var Atr : string;
begin
Atr:='';
Result := '';
if Copy(LowerCase(Font.Name),1,5)='times' then
Result:='Times';
if (LowerCase(Font.Name)='monospaced') or (Copy(LowerCase(Font.Name),1,7)='courier') then
Result:='Courier';
if LowerCase(Font.Name)='serif' then
Result:='Times';
if LowerCase(Font.Name)='sansserif' then
Result:='Helvetica';
if LowerCase(Font.Name)='symbol' then
Result:='Symbol';
if Result='' then
Result:='Helvetica';
if (fsBold in Font.Style) and ((Pos('Courier',Result)=1) or (Pos('Helvetica',Result)=1) or (Pos('Times',Result)=1)) then
Atr:=Atr+'Bold';
if (fsItalic in Font.Style) and ((Pos('Courier',Result)=1) or (Pos('Helvetica',Result)=1)) then
Atr:=Atr+'Oblique';
if (fsItalic in Font.Style) and (Pos('Times',Result)=1) then
Atr:=Atr+'Italic';
if (Result+Atr='Times') or (Result+Atr='Times') then
Result:='Times-Roman';
//WriteComment(Format('MapedFontName "%s" -> "%s"',[Font.Name,Result]));
if Atr <> '' then
Result:=Result+'-'+Atr;
end;
//Move pen at last pos
procedure TPostScriptPrinterCanvas.MoveToLastPos;
var
pp:TpsPoint;
begin
pp:=Self.TranslateCoord(PenPos.X,PenPos.Y);
write(Format('%f %f moveto',[pp.fx,pp.fy],Ffs)+' %last pos');
Include(FStatus, pcsPosValid);
end;
//Add at the PstScript sequence, the Fill Pattern/Color and Broder
//Use SetBorder and SetFill for initialize 1 or 2 sequence
procedure TPostScriptPrinterCanvas.SetBrushFillPattern(Lst: TStringList;
SetBorder, SetFill: Boolean);
var
s: string;
begin
If not Assigned(Lst) then Exit;
if SetFill then
begin
if (Brush.Color<>clNone) and (Brush.Style<>bsClear) then
begin
UpdateFillColor;
Case Brush.Style of
bsSolid : begin
Write(Lst);
Write('eofill');
end;
bsClear : ;
else
begin
UpdateLineColor(Brush.Color);
WriteStr(s, Brush.Style);
write(Format('/%s findfont %% a pattern font patternfill',[s]));
Write(Lst);
write('patternfill');
end;
end;
end;
end;
if SetBorder and ((Pen.Color<>clNone) and ((Pen.Color<>Brush.Color) or (Brush.Style<>bsSolid))) then
begin
UpdateLineColor(clNone);
UpdateLineWidth;
UpdateLineStyle;
Write(Lst);
Write('stroke');
end;
end;
procedure TPostScriptPrinterCanvas.SetBrushFillPattern(SetBorder, SetFill: Boolean);
begin
SetBrushFillPattern(fBuffer,SetBorder,SetFill);
end;
//Add in Lst, all RGB pixels of SrcGraph picture
procedure TPostScriptPrinterCanvas.GetRGBImage(SrcGraph: TGraphic;
Lst: TStringList);
var
SrcIntfImg : TLazIntfImage;
{$IFDEF ASCII85}
procedure TransferRGB;
var
px, py : Integer;
CurColor : TFPColor;
Encoder : TAscii85Encoder;
A : Byte;
Ratio : Single;
begin
Encoder := TAscii85Encoder.Create;
try
Encoder.MaxWidth:=75;
for py:=0 to SrcIntfImg.Height-1 do
begin
for px:=0 to SrcIntfImg.Width-1 do
begin
CurColor:=SrcIntfImg.Colors[px,py];
A := Hi(CurColor.alpha);
if A=0 then begin
Encoder.Add(255);
Encoder.Add(255);
Encoder.Add(255);
end else
if A=255 then begin
Encoder.Add(Hi(CurColor.Red));
Encoder.Add(Hi(CurColor.Green));
Encoder.Add(Hi(CurColor.Blue));
end else begin
Ratio := 1-(255-A)/255;
Encoder.Add(round(Hi(CurColor.Red )*Ratio+255*(1-Ratio)));
Encoder.Add(round(Hi(CurColor.Green)*Ratio+255*(1-Ratio)));
Encoder.Add(round(Hi(CurColor.Blue )*Ratio+255*(1-Ratio)));
end;
end;
end;
Encoder.Finish;
Encoder.Stream.Position:=0;
Lst.LoadFromStream(Encoder.Stream);
finally
Encoder.Free;
end;
end;
{$ELSE}
procedure TransferRGB;
var
px, py : Integer;
CurColor : TFPColor;
St : String;
begin
St:='';
for py:=0 to SrcIntfImg.Height-1 do
begin
for px:=0 to SrcIntfImg.Width-1 do
begin
CurColor:=SrcIntfImg.Colors[px,py];
St:=St+IntToHex(Hi(CurColor.Red),2)+
IntToHex(Hi(CurColor.Green),2)+
IntToHex(Hi(CurColor.Blue),2);
if Length(St)>=78 then
begin
Lst.Add(Copy(St,1,78));
System.Delete(St,1,78);
end;
end;
end;
if St<>'' then
Lst.Add(St);
end;
{$ENDIF}
procedure TransferRGBA;
begin
TransferRGB;
end;
begin
if (SrcGraph is TRasterImage) then
begin
SrcIntfImg:=TLazIntfImage.Create(0,0,[]);
Lst.BeginUpdate;
Try
SrcIntfImg.LoadFromBitmap(TRasterImage(SrcGraph).BitmapHandle,
TRasterImage(SrcGraph).MaskHandle);
if SrcIntfImg.DataDescription.Format<>ricfNone then
begin
if SrcIntfImg.DataDescription.AlphaPrec<>0 then
TransferRGBA
else
TransferRGB;
end;
finally
Lst.EndUpdate;
SrcIntfImg.Free;
end;
end;
end;
procedure TPostScriptPrinterCanvas.PixelsToPoints(const PixX,PixY: Integer;
out PtX,PtY:Single);
begin
PtX:=72*(PixX/XDPI); // pixels to points
PtY:=72*(PixY/YDPI);
end;
function TPostScriptPrinterCanvas.GetFontSize: Integer;
begin
if Font.Size=0 then
Result := 12
else
Result := Font.Size;
end;
procedure TPostScriptPrinterCanvas.RestoreClip;
begin
if pcsClipSaved in FStatus then
begin
Self.WriteComment('Restoring Old clip rect');
Self.Write('cliprestore');
Exclude(FStatus, pcsClipSaved);
end;
end;
procedure TPostScriptPrinterCanvas.SaveClip;
var
B: TpsBounds;
begin
Self.WriteComment('Pushing and Setting current clip rect');
Self.Write('clipsave');
B := TxRectToBounds(FLazClipRect);
Write(Format('%f %f %f %f rectclip',[B.fx, B.fy, B.fwidth, B.fheight],FFs));
Include(FStatus, pcsClipSaved);
end;
procedure TPostScriptPrinterCanvas.CheckLastPos;
begin
if not (pcsPosValid in FStatus) then
MoveToLastPos;
end;
function TPostScriptPrinterCanvas.GetFontIndex: Integer;
var
FontName: string;
i: Integer;
begin
FontName:=MappedFontName;
Result:=0; //By default, use Courier metrics
for i:=0 to High(cFontPSMetrics) do
begin
if cFontPSMetrics[i].Name=FontName then
begin
Result:=i;
Break;
end;
end;
end;
function TPostScriptPrinterCanvas.FontUnitsToPixelsX(const Value: Integer
): Integer;
begin
result := Round(Value*Abs(GetFontSize/72)*0.001*XDPI);
end;
function TPostScriptPrinterCanvas.FontUnitsToPixelsY(const Value: Integer
): Integer;
begin
result := Round(Value*Abs(GetFontSize/72)*0.001*YDPI);
end;
function TPostScriptPrinterCanvas.FontUnitsToPixelsY(const Value: Double
): Integer;
var
FontSize: Integer;
begin
FontSize := GetFontSize;
if FontSize<0 then
FontSize := -FontSize;
result := Round(Value*FontSize/72*0.001*YDPI);
end;
procedure TPostScriptPrinterCanvas.CreateHandle;
begin
SetHandle(1); // set dummy handle
end;
procedure TPostScriptPrinterCanvas.RealizeAntialiasing;
begin
// handle is dummy, so do nothing here
end;
procedure TPostScriptPrinterCanvas.CreateBrush;
begin
// handle is dummy, so do nothing here
end;
procedure TPostScriptPrinterCanvas.CreateFont;
begin
// handle is dummy, so do nothing here
end;
procedure TPostScriptPrinterCanvas.CreatePen;
begin
// handle is dummy, so do nothing here
end;
procedure TPostScriptPrinterCanvas.CreateRegion;
begin
// handle is dummy, so do nothing here
end;
procedure TPostScriptPrinterCanvas.DeselectHandles;
begin
// handle is dummy, so do nothing here
end;
procedure TPostScriptPrinterCanvas.PenChanging(APen: TObject);
begin
// handle is dummy, so do nothing here
end;
procedure TPostScriptPrinterCanvas.FontChanging(APen: TObject);
begin
// handle is dummy, so do nothing here
end;
procedure TPostScriptPrinterCanvas.BrushChanging(APen: TObject);
begin
// handle is dummy, so do nothing here
end;
procedure TPostScriptPrinterCanvas.RegionChanging(APen: TObject);
begin
// handle is dummy, so do nothing here
end;
procedure TPostScriptPrinterCanvas.RequiredState(ReqState: TCanvasState);
begin
if csHandleValid in ReqState then
inherited RequiredState([csHandleValid]);
// other states are anyway impossible, because handle is dummy
end;
procedure TPostScriptPrinterCanvas.DoEllipseAndFill(const Bounds: TRect);
begin
Ellipse(Bounds.Left, Bounds.Top, Bounds.Right, Bounds.Bottom);
end;
function TPostScriptPrinterCanvas.GetClipRect: TRect;
begin
Result:=FLazClipRect;
end;
constructor TPostScriptPrinterCanvas.Create(APrinter: TPrinter);
begin
inherited Create(APrinter);
fcBrushStyle:=bsClear;
fcPenColor :=clBlack;
fcPenWidth :=0;
fcPenStyle :=psSolid;
fHeader:=TStringListUTF8Fast.Create;
fBuffer:=TstringList.Create;
fDocument:=TStringList.Create;
Ffs.DecimalSeparator:='.';
Ffs.ThousandSeparator:=#0;
Include(FStatus, pcsClipping);
end;
destructor TPostScriptPrinterCanvas.Destroy;
begin
if FPSUnicode<>nil then
FPSUnicode.Free;
fBuffer.Free;
fHeader.Free;
fDocument.Free;
inherited Destroy;
end;
procedure TPostScriptPrinterCanvas.SaveToFile(aFileName: string);
Var
Lst : TStringList;
begin
Lst:=TStringList.Create;
try
Lst.AddStrings(fHeader);
Lst.AddStrings(fDocument);
Lst.SaveTofile(ExpandFileNameUTF8(aFileName));
finally
Lst.Free;
end;
end;
procedure TPostScriptPrinterCanvas.BeginDoc;
begin
inherited BeginDoc;
if FPSUnicode=nil then
FPSUnicode := TPSUnicode.Create;
FPSUnicode.OutLst := FDocument;
//Clear all existing values
//before starting an new document
fDocument.Clear;
fHeader.Clear;
Font.Size:=12;
Font.Color:=clBlack;
WriteHeader('%!PS-Adobe-3.0');
WriteBoundingBox(True);
WriteHeader('%%'+Format('Creator: Lazarus PostScriptCanvas for %s',[Application.ExeName]));
WriteHeader('%%'+Format('Title: %s',[Title]));
WriteHeader('%%CreationDate: '+DateTimeToStr(Now));
WriteOrientation(true);
WriteHeader('%%Pages: (atend)');
WriteHeader('%%PageResources: (atend)');
WriteHeader('%%PageOrder: Ascend');
WriteHeader('');
WriteHeader('%------------------------------------------------------------');
WriteHeader('%================== BEGIN SETUP==============================');
WriteHeader('');
WriteHeader('/RE { % /NewFontName [NewEncodingArray] /FontName RE -');
WriteHeader(' findfont dup length dict begin');
WriteHeader(' {');
WriteHeader(' 1 index /FID ne');
WriteHeader(' {def}');
WriteHeader(' {pop pop} ifelse');
WriteHeader(' } forall');
WriteHeader(' /Encoding exch def');
WriteHeader(' /FontName 1 index def');
WriteHeader(' currentdict definefont pop');
WriteHeader(' end');
WriteHeader('} bind def');
WriteHeader('');
WriteHeader('/scp {currentpoint /oldy exch def /oldx exch def } def');
WriteHeader('/rcp {oldx oldy moveto} bind def');
WriteHeader('/uli { 2 copy /uposy exch def /uposx exch def moveto } def');
WriteHeader('/ule { % underlinepenwidh underlinepos');
WriteHeader('scp gsave 0 exch rmoveto setlinewidth');
WriteHeader('uposx oldx sub 0 rlineto [] 0 setdash stroke grestore rcp } def');
WriteHeader('');
WriteHeader('%%BeginProcSet: patternfill 1.0 0');
WriteHeader('% width height matrix proc key cache');
WriteHeader('% definepattern -\> font');
WriteHeader('/definepattern { %def');
WriteHeader(' 7 dict begin');
WriteHeader(' /FontDict 9 dict def');
WriteHeader(' FontDict begin');
WriteHeader(' /cache exch def');
WriteHeader(' /key exch def');
WriteHeader(' /proc exch cvx def');
WriteHeader(' /mtx exch matrix invertmatrix def');
WriteHeader(' /height exch def');
WriteHeader(' /width exch def');
WriteHeader(' /ctm matrix currentmatrix def');
WriteHeader(' /ptm matrix identmatrix def');
WriteHeader(' /str');
WriteHeader(' (12345678901234567890123456789012)');
WriteHeader(' def');
WriteHeader(' end');
WriteHeader(' /FontBBox [ %def');
WriteHeader(' 0 0 FontDict /width get');
WriteHeader(' FontDict /height get');
WriteHeader(' ] def');
WriteHeader(' /FontMatrix FontDict /mtx get def');
WriteHeader(' /Encoding StandardEncoding def');
WriteHeader(' /FontType 3 def');
WriteHeader(' /BuildChar { %def');
WriteHeader(' pop begin');
WriteHeader(' FontDict begin');
WriteHeader(' width 0 cache { %ifelse');
WriteHeader(' 0 0 width height setcachedevice');
WriteHeader(' }{ %else');
WriteHeader(' setcharwidth');
WriteHeader(' } ifelse');
WriteHeader(' 0 0 moveto width 0 lineto');
WriteHeader(' width height lineto 0 height lineto');
WriteHeader(' closepath clip newpath');
WriteHeader(' gsave proc grestore');
WriteHeader(' end end');
WriteHeader(' } def');
WriteHeader(' FontDict /key get currentdict definefont');
WriteHeader(' end');
WriteHeader('} bind def');
WriteHeader('% dict patternpath -');
WriteHeader('% dict matrix patternpath -');
WriteHeader('/patternpath { %def');
WriteHeader(' dup type /dicttype eq { %ifelse');
WriteHeader(' begin FontDict /ctm get setmatrix');
WriteHeader(' }{ %else');
WriteHeader(' exch begin FontDict /ctm get setmatrix');
WriteHeader(' concat');
WriteHeader(' } ifelse');
WriteHeader(' currentdict setfont');
WriteHeader(' FontDict begin');
WriteHeader(' FontMatrix concat');
WriteHeader(' width 0 dtransform');
WriteHeader(' round width div exch round width div exch');
WriteHeader(' 0 height dtransform');
WriteHeader(' round height div exch');
WriteHeader(' round height div exch');
WriteHeader(' 0 0 transform round exch round exch');
WriteHeader(' ptm astore setmatrix');
WriteHeader(' ');
WriteHeader(' pathbbox');
WriteHeader(' height div ceiling height mul 4 1 roll');
WriteHeader(' width div ceiling width mul 4 1 roll');
WriteHeader(' height div floor height mul 4 1 roll');
WriteHeader(' width div floor width mul 4 1 roll');
WriteHeader(' ');
WriteHeader(' 2 index sub height div ceiling cvi exch');
WriteHeader(' 3 index sub width div ceiling cvi exch');
WriteHeader(' 4 2 roll moveto');
WriteHeader(' ');
WriteHeader(' FontMatrix ptm invertmatrix pop');
WriteHeader(' { %repeat');
WriteHeader(' gsave');
WriteHeader(' ptm concat');
WriteHeader(' dup str length idiv { %repeat');
WriteHeader(' str show');
WriteHeader(' } repeat');
WriteHeader(' dup str length mod str exch');
WriteHeader(' 0 exch getinterval show');
WriteHeader(' grestore');
WriteHeader(' 0 height rmoveto');
WriteHeader(' } repeat');
WriteHeader(' pop');
WriteHeader(' end end');
WriteHeader('} bind def');
WriteHeader('');
WriteHeader('% dict patternfill -');
WriteHeader('% dict matrix patternfill -');
WriteHeader('/patternfill { %def');
WriteHeader(' gsave');
WriteHeader(' clip patternpath');
WriteHeader(' grestore');
WriteHeader(' newpath');
WriteHeader('} bind def');
WriteHeader('');
WriteHeader('% dict patterneofill -');
WriteHeader('% dict matrix patterneofill -');
WriteHeader('/patterneofill { %def');
WriteHeader(' gsave');
WriteHeader(' eoclip patternpath');
WriteHeader(' grestore');
WriteHeader(' newpath');
WriteHeader('} bind def');
WriteHeader('');
WriteHeader('% dict patternstroke -');
WriteHeader('% dict matrix patternstroke -');
WriteHeader('/patternstroke { %def');
WriteHeader(' gsave');
WriteHeader(' strokepath clip patternpath');
WriteHeader(' grestore');
WriteHeader(' newpath');
WriteHeader('} bind def');
WriteHeader('');
WriteHeader('% dict ax ay string patternashow -');
WriteHeader('% dict matrix ax ay string patternashow -');
WriteHeader('/patternashow { %def');
WriteHeader(' (0) exch { %forall');
WriteHeader(' 2 copy 0 exch put pop dup');
WriteHeader(' false charpath ');
WriteHeader(' currentpoint');
WriteHeader(' 5 index type /dicttype eq { %ifelse');
WriteHeader(' 5 index patternfill');
WriteHeader(' }{ %else');
WriteHeader(' 6 index 6 index patternfill');
WriteHeader(' } ifelse');
WriteHeader(' moveto');
WriteHeader(' 3 copy pop rmoveto');
WriteHeader(' } forall');
WriteHeader(' pop pop pop');
WriteHeader(' dup type /dicttype ne { pop } if pop');
WriteHeader('} bind def');
WriteHeader('');
WriteHeader('% dict string patternshow -');
WriteHeader('% dict matrix string patternshow -');
WriteHeader('/patternshow { %def');
WriteHeader(' 0 exch 0 exch patternashow');
WriteHeader('} bind def');
WriteHeader('');
WriteHeader('/opaquepatternfill { %def');
WriteHeader(' gsave');
WriteHeader(' 1 setgray');
WriteHeader(' fill');
WriteHeader(' grestore');
WriteHeader(' patternfill');
WriteHeader('} bind def');
WriteHeader('');
WriteHeader('%%EndProcSet');
WriteHeader('%%EndProlog');
WriteHeader('');
WriteHeader('%%BeginSetup');
WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]');
WriteHeader('{ %definepattern');
WriteHeader(' 2 setlinecap');
WriteHeader(' 7.5 0 moveto 15 7.5 lineto');
WriteHeader(' 0 7.5 moveto 7.5 15 lineto');
WriteHeader(' 2 setlinewidth stroke');
WriteHeader('} bind');
WriteHeader('/bsBDiagonal true definepattern pop');
WriteHeader('');
WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]');
WriteHeader('{ %definepattern');
WriteHeader(' 2 setlinecap');
WriteHeader(' 7.5 0 moveto 0 7.5 lineto');
WriteHeader(' 15 7.5 moveto 7.5 15 lineto');
WriteHeader(' 2 setlinewidth stroke');
WriteHeader('} bind');
WriteHeader('/bsFDiagonal true definepattern pop');
WriteHeader('30 30 [300 72 div 0 0 300 72 div 0 0]');
WriteHeader('{ %definepattern');
WriteHeader(' 2 2 scale');
WriteHeader(' 2 setlinecap');
WriteHeader(' 7.5 0 moveto 15 7.5 lineto');
WriteHeader(' 0 7.5 moveto 7.5 15 lineto');
WriteHeader(' 7.5 0 moveto 0 7.5 lineto');
WriteHeader(' 15 7.5 moveto 7.5 15 lineto');
WriteHeader(' 0.5 setlinewidth stroke');
WriteHeader('} bind');
WriteHeader('/bsDiagCross true definepattern pop');
WriteHeader('');
WriteHeader('30 30 [300 72 div 0 0 300 72 div 0 0]');
WriteHeader('{ %definepattern');
WriteHeader(' 2 setlinecap');
WriteHeader(' 15 0 moveto 15 30 lineto');
WriteHeader(' 0 15 moveto 30 15 lineto');
WriteHeader(' 2 setlinewidth stroke');
WriteHeader('} bind');
WriteHeader('/bsCross true definepattern pop');
WriteHeader('');
WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]');
WriteHeader('{ %definepattern');
WriteHeader(' 2 setlinecap');
WriteHeader(' 0 7.5 moveto 15 7.5 lineto');
WriteHeader(' 2 setlinewidth stroke');
WriteHeader('} bind');
WriteHeader('/bsHorizontal true definepattern pop');
WriteHeader('');
WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]');
WriteHeader('{ %definepattern');
WriteHeader(' 2 setlinecap');
WriteHeader(' 7.5 0 moveto 7.5 15 lineto');
WriteHeader(' 2 setlinewidth stroke');
WriteHeader('} bind');
WriteHeader('/bsVertical true definepattern pop');
WriteHeader('%%EndSetup');
WriteHeader('%%====================== END SETUP =========================');
WriteHeader('');
WriteHeader('%%Page: 1 1');
WritePageTransform;
if assigned(printer) then
FLazClipRect:=printer.PaperSize.PaperRect.WorkRect;
end;
procedure TPostScriptPrinterCanvas.EndDoc;
var
I: Integer;
begin
Inherited EndDoc;
Write('stroke');
Write('showpage');
Write('%%EOF');
// update number of pages in header
I := FHeader.IndexOf('%%Pages: (atend)');
if I <> -1 then
FHeader[I] := '%%' + Format('Pages: %d', [PageNumber]);
if Trim(OutputFileName)<>'' then
SaveToFile(ExpandFileNameUTF8(OutputFileName));
if Assigned(fPsUnicode) then
FreeAndNil(fPsUnicode);
Self.fcPenWidth:=-2; // prevent cached line width affect new page
end;
procedure TPostScriptPrinterCanvas.NewPage;
begin
inherited NewPage;
Write('stroke');
Write('showpage');
Write('%%'+Format('Page: %d %d',[PageNumber, PageNumber]));
WriteBoundingBox(false);
WriteOrientation(false);
WritePageTransform;
write('newpath');
Self.fcPenWidth:=-1; // prevent cached line width affect new page
fSaveCount:=0;
UpdateLineWidth;
end;
//Move the current position
procedure TPostScriptPrinterCanvas.DoMoveTo(X1, Y1: Integer);
var
pp:TpsPoint;
begin
RequiredState([csHandleValid]);
WriteComment(Format('DoMoveTo(%d,%d)',[x1,y1]));
SetPosition(X1,Y1);
pp:=TranslateCoord(X1,Y1);
write(Format('%f %f moveto',[pp.fx,pp.fy],FFs));
Include(FStatus, pcsPosValid);
end;
//Drawe line
procedure TPostScriptPrinterCanvas.DoLineTo(X1, Y1: Integer);
var
pp:TpsPoint;
begin
checkLastPos;
Changing;
RequiredState([csHandleValid, csPenValid]);
WriteComment(Format('DoLineTo(%d,%d)',[x1,y1]));
SetPosition(X1,Y1);
pp:=TranslateCoord(X1,Y1);
UpdateLineColor(clNone);
UpdateLineWidth;
UpdateLineStyle;
write(Format('%f %f lineto stroke',[pp.fx,pp.fy],FFs));
changed;
Exclude(FStatus, pcsPosValid);
end;
procedure TPostScriptPrinterCanvas.Polyline(Points: PPoint; NumPts: Integer);
var
i : LongInt;
Lst: TStringList;
Pt : TPoint;
pp:TpsPoint;
begin
if (NumPts<=1) or not Assigned(Points) then Exit;
Changing;
RequiredState([csHandleValid, csPenValid]);
Lst:=TStringList.Create;
try
Pt:=Points[0];
pp:=TranslateCoord(Pt.x,Pt.y);
Write(Format('%f %f moveto',[pp.fx,pp.fy],FFs),Lst);
for i:=1 to NumPts-1 do
begin
Pt:=Points[i];
pp:=TranslateCoord(Pt.x,Pt.y);
SetPosition(Pt.x,Pt.y);
//TranslateCoord(Pt.x,Pt.y);
Write(Format('%f %f lineto',[pp.fx,pp.fy],FFs),Lst);
end;
UpdateLineColor(clNone);
UpdateLineWidth;
UpdateLineStyle;
write(Lst);
write('stroke');
finally
Lst.Free;
end;
MoveToLastPos;
Changed;
end;
procedure TPostScriptPrinterCanvas.PolyBezier(Points: PPoint; NumPts: Integer;
Filled: boolean; Continuous: boolean);
var
i : Integer;
St : String;
Pt : TPoint;
pp:TpsPoint;
begin
Changing;
RequiredState([csHandleValid, csBrushValid, csPenValid]);
if (NumPts>=4) then
begin
ClearBuffer;
St:='';
Pt:=Points[0];
pp:=TranslateCoord(Pt.x,Pt.y);
if Continuous then
WriteB('newpath');
WriteB(Format('%f %f moveto',[pp.fx,pp.fy],FFs));
for i:=1 to NumPts-1 do
begin
Pt:=Points[i];
pp:=TranslateCoord(Pt.x,Pt.y);
St:=St+Format(' %f %f',[pp.fx,pp.fy], FFs);
end;
WriteB(Format('%s curveto',[St]));
if Continuous then
writeB('closepath');
SetBrushFillPattern(True,Filled);
MoveToLastPos;
end;
Changed;
end;
// internal rect path
procedure TPostScriptPrinterCanvas.psDrawRect(ARect:TRect);
var
pp1,pp2:TpsPoint;
begin
pp1:=TranslateCoord(Arect.Left,Arect.Top);
pp2:=TranslateCoord(ARect.Right,Arect.Bottom);
ClearBuffer;
//Tempo draw rect
WriteB('newpath');
writeB(Format(' %f %f moveto',[pp1.fx,pp1.fy],FFs));
writeB(Format(' %f %f lineto',[pp2.fx,pp1.fy],FFs));
writeB(Format(' %f %f lineto',[pp2.fx,pp2.fy],FFs));
writeB(Format(' %f %f lineto',[pp1.fx,pp2.fy],FFs));
writeB('closepath');
end;
//Draw an Rectangle
procedure TPostScriptPrinterCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
begin
Changing;
RequiredState([csHandleValid, csBrushValid, csPenValid]);
writecomment(Format('Rectangle(%d,%d,%d,%d)',[x1,y1,x2,y2]));
psDrawRect(Types.Rect(x1,y1,x2,y2));
SetBrushFillPattern(True,True);
MoveToLastPos;
Changed;
end;
procedure TPostScriptPrinterCanvas.Frame(const ARect: TRect);
begin
Changing;
RequiredState([csHandleValid, csPenValid]);
psDrawRect(ARect);
SetBrushFillPattern(True,False);
MoveToLastPos;
Changed;
end;
procedure TPostScriptPrinterCanvas.FrameRect(const ARect: TRect);
var
CL : TColor;
begin
Changing;
RequiredState([csHandleValid, csBrushValid]);
CL:=Pen.Color;
try
Pen.Color:=Brush.Color;
Frame(aRect);
finally
Pen.Color:=CL;
end;
Changed;
end;
//Fill an Rectangular region
procedure TPostScriptPrinterCanvas.FillRect(const ARect: TRect);
begin
Changing;
RequiredState([csHandleValid, csBrushValid]);
Writecomment(Format('FillRect(%d,%d,%d,%d)',[Arect.Left,ARect.Top,Arect.Right,ARect.Bottom]));
psDrawRect(ARect);
SetBrushFillPattern(False,True);
MoveToLastPos;
Changed;
end;
procedure TPostScriptPrinterCanvas.RoundRect(X1, Y1, X2, Y2: Integer; RX,
RY: Integer);
var
ellipsePath : string;
//fs:TFormatSettings;
pp1,pp2,r:TpsPoint;
begin
Changing;
RequiredState([csHandleValid, csBrushValid, csPenValid]);
//fs.DecimalSeparator:='.';
//fs.ThousandSeparator:=#0;
X1:=Min(X1,X2);
X2:=Max(X1,X2);
Y1:=Min(Y1,Y2);
Y2:=Max(Y1,Y2);
writecomment(Format('RoundRect(%d,%d,%d,%d,%d,%d)',[x1,y1,x2,y2,Rx,Ry]));
pp1:=TranslateCoord(X1,Y1);
pp2:=TranslateCoord(X2,Y2);
ClearBuffer;
{Note: arcto command draws a line from current point to beginning of arc
save current matrix, translate to center of ellipse, scale by rx ry, and draw
a circle of unit radius in counterclockwise dir, return to original matrix
arguments are (cx, cy, rx, ry, startAngle, endAngle)}
ellipsePath:='matrix currentmatrix %f %f translate %f %f scale 0 0 1 %d %d arc setmatrix';
PixelsToPoints(RX,RY,r.fx,r.fy);
WriteB('newpath');
WriteB(Format(ellipsePath,[pp1.fx+r.fx,pp1.fy-r.fy,r.fx,r.fy,90,180],FFs));
WriteB(Format(ellipsePath,[pp1.fx+r.fx,pp2.fy+r.fy,r.fx,r.fy,180,270],FFs));
WriteB(Format(ellipsePath,[pp2.fx-r.fx,pp2.fy+r.fy,r.fx,r.fy,270,360],FFs));
WriteB(Format(ellipsePath,[pp2.fx-r.fx,pp1.fy-r.fy,r.fx,r.fy,0,90],FFs));
WriteB('closepath');
SetBrushFillPattern(True,True);
MoveToLastPos;
Changed;
end;
procedure TPostScriptPrinterCanvas.Polygon(Points: PPoint; NumPts: Integer;
Winding: boolean);
var
i : LongInt;
Pt : TPoint;
pp:TpsPoint;
begin
if (NumPts<=1) or not Assigned(Points) then Exit;
Changing;
RequiredState([csHandleValid, csBrushValid, csPenValid]);
ClearBuffer;
Pt:=Points[0];
pp:=TranslateCoord(Pt.x,Pt.y);
WriteB('newpath');
WriteB(Format('%f %f moveto',[pp.fx,pp.fy],FFs));
for i:=1 to NumPts-1 do
begin
Pt:=Points[i];
pp:=TranslateCoord(Pt.x,Pt.y);
WriteB(Format('%f %f lineto',[pp.fx,pp.fy], FFs));
end;
WriteB('closepath');
SetBrushFillPattern(True,True);
MoveToLastPos;
Changed;
end;
//Draw an Ellipse
procedure TPostScriptPrinterCanvas.Ellipse(x1, y1, x2, y2: Integer);
var xScale : Real;
yScale : Real;
cX, cY : Real;
rX,Ry : Real;
Code : string;
stAng : Integer;
ang : Integer;
//fs:TFormatSettings;
pp1,pp2:TpsPoint;
sinAng, cosAng: Real;
begin
Changing;
RequiredState([csHandleValid, csBrushValid, csPenValid]);
//fs.DecimalSeparator:='.';
//fs.ThousandSeparator:=#0;
writecomment(Format('Ellipse(%d,%d,%d,%d)',[x1,y1,x2,y2]));
pp1:=TranslateCoord(X1,Y1);
pp2:=TranslateCoord(X2,Y2);
//Init
StAng:=0;
Ang:=360;
//calculate centre of ellipse
cx:=(pp1.fx+pp2.fx)/2;
cy:=(pp1.fy+pp2.fy)/2;
rx:=(pp2.fx-pp1.fx)/2;
ry:=(pp2.fy-pp1.fy)/2;
//calculate semi-minor and semi-major axes of ellipse
xScale:=Abs((pp2.fx-pp1.fx)/2.0);
yScale:=Abs((pp2.fy-pp1.fy)/2.0);
Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %d %d %s setmatrix',
[cX,cY,xScale,yScale,StAng,Ang,'arc'],FFs);
ClearBuffer;
WriteB(Format('%.3f %.3f moveto',[cX,cY],FFs)); //move to center of circle
WriteB(Code);
SetBrushFillPattern(False,True);
//move current point to start of arc, note negative
//angle because y increases down
ClearBuffer;
SinCos(-StAng, sinAng, cosAng);
WriteB(Format('%.3f %.3f moveto',[cX+rX*cosAng,cY+rY*sinAng],FFs));
WriteB(Code);
SetBrushFillPattern(True,False);
MoveToLastPos;
Changed;
end;
//Draw an Arc
procedure TPostScriptPrinterCanvas.Arc(Left,Top,Right,Bottom, angle1,
angle2: Integer);
var xScale : Real;
yScale : Real;
cX, cY : Real;
rX,Ry : Real;
sinAngle1, cosAngle1: Real;
Code : string;
ang : string;
//fs:TFormatSettings;
pp1,pp2:TpsPoint;
begin
Changing;
RequiredState([csHandleValid, csBrushValid, csPenValid]);
//fs.DecimalSeparator:='.';
//fs.ThousandSeparator:=#0;
pp1:=TranslateCoord(Left,Top);
pp2:=TranslateCoord(Right,Bottom);
TranslateCoord(Right,Bottom);
//calculate centre of ellipse
cx:=pp1.fx;
cy:=pp1.fy;
rx:=pp2.fx-pp1.fx;
ry:=pp2.fy-pp1.fy;
if Angle2>=0 then
Ang:='arc'
else
Ang:='arcn';
//calculate semi-minor and semi-major axes of ellipse
xScale:=Abs((Right-Left)/2.0);
yScale:=Abs((Bottom-Top)/2.0);
Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix',
[cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang], FFs);
SinCos(-Angle1/16, sinAngle1, cosAngle1);
if (Pen.Color<>clNone) and ((Pen.Color<>Brush.Color) or (Brush.Style<>bsSolid)) then
begin
UpdateLineColor(clNone);
UpdateLineWidth;
UpdateLineStyle;
//move current point to start of arc, note negative
//angle because y increases down
write(Format('%.3f %.3f moveto',[cX+rX*CosAngle1,cY+rY*SinAngle1],FFs));
Write(Code);
write('stroke');
end;
MoveToLastPos;
Changed;
end;
procedure TPostScriptPrinterCanvas.RadialPie(Left, Top, Right, Bottom, angle1,
angle2: Integer);
var xScale : Real;
yScale : Real;
cX, cY : Real;
rX,Ry : Real;
Code : string;
ang : string;
SinAngle1, CosAngle1: Real;
begin
Changing;
RequiredState([csHandleValid, csBrushValid, csPenValid]);
writecomment(Format('RadialPie(%d,%d,%d,%d,%d,%d)',[Left,Top,Right-Left,Bottom-Top,Angle1,Angle2]));
TranslateCoord(Left,Top);
//calculate centre of ellipse
cx:=Left;
cy:=Top;
rx:=Right-Left;
ry:=Bottom-Top;
if Angle2>=0 then
Ang:='arc'
else
Ang:='arcn';
//calculate semi-minor and semi-major axes of ellipse
xScale:=Abs(rx);
yScale:=Abs(ry);
Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix',
[cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang],FFs);
//move current point to start of arc, note negative
//angle because y increases down
SinCos(-Angle1/16, sinAngle1, cosAngle1);
ClearBuffer;
writeB(Format('%.3f %.3f moveto',[cX+rX*CosAngle1,cY+rY*SinAngle1],FFs));
WriteB(Code);
writeB(Format('%d %d lineto',[Left,Top]));
writeB(Format('%.3f %.3f lineto',[cX+rX*CosAngle1,cY+rY*SinAngle1],FFs));
SetBrushFillPattern(False,True);
//move current point to start of arc, note negative
//angle because y increases down
ClearBuffer;
writeB(Format('%.3f %.3f moveto',[cX+rX*CosAngle1,cY+rY*SinAngle1],FFs));
WriteB(Code);
writeB(Format('%d %d lineto',[Left,Top]));
writeB(Format('%.3f %.3f lineto',[cX+rX*CosAngle1,cY+rY*SinAngle1],FFs));
SetBrushFillPattern(True,False);
MoveToLastPos;
Changed;
end;
function FontStyleToInt(AStyles: TFontStyles): Integer;
begin
result := 0;
if fsBold in AStyles then
result := result or (1 shl ord(fsBold));
if fsItalic in AStyles then
result := result or (1 shl ord(fsItalic));
if fsStrikeOut in AStyles then
result := result or (1 shl ord(fsStrikeout));
if fsUnderline in AStyles then
result := result or (1 shl ord(fsUnderline));
end;
//Out the text at the X,Y coord. Set the font
procedure TPostScriptPrinterCanvas.TextOut(X, Y: Integer; const Text: String);
var
PenUnder : Double;
PosUnder : Integer;
pp:TpsPoint;
saved:boolean;
FontIndex: Integer;
procedure rotate;
begin
write('gsave');
inc(fSaveCount);
Self.FPsUnicode.ResetLastFont;
saved:=true;
write(format('%.2f rotate',[Font.Orientation / 10],fFS));
end;
begin
pp:=TranslateCoord(X,Y);
UpdateFont;
FPSUnicode.Font:=MappedFontName;
FPSUnicode.FontSize:=Abs(GetFontSize);
FPSUnicode.FontStyle:=FontStyleToInt(Font.Style);
//The Y origin for ps text it's Left bottom corner (only if not rotated)
if Font.Orientation=0 then
pp.fy := pp.fy - abs(GetFontSize) // in points
else
pp.fx := pp.fx + abs(GetFontSize); // apply to X axis if rotated
saved:=false;
if fsUnderline in Font.Style then
begin
FontIndex := GetFontIndex;
PosUnder := FontUnitsToPixelsY(cFontPSMetrics[FontIndex].ULPos);
// The current heuristics produces better underline thickness
{$IFDEF UseFontUnderlineThickness}
PenUnder := FontUnitsToPixelsY(cFontPSMetrics[FontIndex].ULThickness);
{$else}
PenUnder:=0.5;
if fsBold in Font.Style then
PenUnder:=1.0;
{$endif}
Write(format('%f %f uli',[pp.fx,pp.fy],FFs));
if Font.Orientation<>0 then
rotate();
FPSUnicode.OutputString(Text);
write(Format('%.3f %d ule',[PenUnder,PosUnder],FFs));
end
else
begin
write(Format('%f %f moveto',[pp.fx,pp.fy],FFs));
if Font.Orientation<>0 then
rotate();
FPSUnicode.OutputString(Text);
end;
if saved then
begin
write('grestore');
dec(fSaveCount);
end;
MoveToLastPos;
end;
function TPostScriptPrinterCanvas.TextExtent(const Text: string): TSize;
var
IndexFont,i : Integer;
c: Char;
begin
Result.cX := 0;
Result.cY := 0;
if Text='' then Exit;
RequiredState([csHandleValid, csFontValid]);
Result.cY:=round((Abs(GetFontSize)/72)*YDPI); // points to inches and then to pixels
// Abs is not right - should also take internal leading into account
IndexFont := GetFontIndex;
for i:=1 to Length(Text) do
begin
c:=Text[i];
if (c in [#32..#255]) then
Inc(Result.cX,cFontPSMetrics[IndexFont].Widths[Ord(c)]);
end;
Result.cX:=FontUnitsToPixelsX(Result.cX);
end;
//Draw an Picture
procedure TPostScriptPrinterCanvas.Draw(X, Y: Integer; SrcGraphic: TGraphic);
begin
if not Assigned(SrcGraphic) then exit;
StretchDraw(Rect(X,Y,X+SrcGraphic.Width,Y+SrcGraphic.Height),SrcGraphic);
end;
//Draw an picture with scale size
procedure TPostScriptPrinterCanvas.StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic);
var X1,Y1,X2,Y2 : Integer;
DrawWidth : single;
DrawHeight: single;
ImgWidth : Integer;
ImgHeight : Integer;
pp1,pp2:TpsPoint;
begin
if not Assigned(SrcGraphic) then exit;
Changing;
RequiredState([csHandleValid]);
X1:=DestRect.Left;
Y1:=DestRect.Top;
X2:=DestRect.Right;
Y2:=DestRect.Bottom;
pp1:=TranslateCoord(X1,Y1);
pp2:=TransLateCoord(X2,Y2);
ImgWidth:=SrcGraphic.Width;
ImgHeight:=SrcGraphic.Height;
//if not FPImage then draw ab Rectangle because other wise PostScript
//interpreter wait infinite some RGB datas
DrawWidth:=pp2.fx-pp1.fx;
DrawHeight:=pp1.fy-pp2.fy;
ClearBuffer;
WriteB('gsave');
WriteB('/DeviceRGB setcolorspace');
writeB(Format('%f %f translate',[pp1.fx,pp1.fy-DrawHeight],FFs));
WriteB(Format('%f %f scale',[DrawWidth,DrawHeight],FFs));
{$IFDEF ASCII85}
WriteB('<<');
WriteB(' /ImageType 1');
WriteB(' /Width '+IntToStr(ImgWidth));
WriteB(' /Height '+IntToStr(ImgHeight));
WriteB(' /BitsPerComponent 8');
WriteB(' /Decode [0 1 0 1 0 1]');
WriteB(' /ImageMatrix '+Format('[%d %d %d %d %d %d]',[ImgWidth,0,0,-ImgHeight,0,ImgHeight]));
WriteB(' /DataSource currentfile /ASCII85Decode filter');
WriteB('>>');
WriteB('image');
Write(fBuffer);
ClearBuffer;
GetRGBImage(SrcGraphic,fBuffer);
{$ELSE}
WriteB(Format('/scanline %d 3 mul string def',[ImgWidth]));
// colorimage width height bits/comp matrix data0..dataN-1 multi? ncomp colorimage
WriteB(Format('%d %d %d',[ImgWidth,ImgHeight,8]));
WriteB(Format('[%d %d %d %d %d %d]',[ImgWidth,0,0,-ImgHeight,0,ImgHeight]));
WriteB('{ currentfile scanline readhexstring pop } false 3');
WriteB('colorimage');
GetRGBImage(SrcGraphic,fBuffer);
{$ENDIF}
WriteB('% end of image data');
WriteB('grestore');
Write(fBuffer);
Changed;
end;
function TPostScriptPrinterCanvas.GetTextMetrics(out TM: TLCLTextMetric): boolean;
var
FontIndex: Integer;
begin
FontIndex := GetFontIndex;
Result := FontIndex>=0;
if Result then
with CFontPSMetrics[FontIndex] do begin
TM.Ascender := FontUnitsToPixelsY( Ascender );
TM.Descender := FontUnitsToPixelsY( -Descender );
TM.Height := TM.Ascender + TM.Descender;
end;
end;
procedure TPostScriptPrinterCanvas.Arc(x, y, Right, Bottom, SX, SY, EX,
EY: Integer);
begin
//Not implemented
end;
procedure TPostScriptPrinterCanvas.Chord(x1, y1, x2, y2, angle1,angle2: Integer);
var xScale : Real;
yScale : Real;
cX, cY : Real;
rX,Ry : Real;
Code : string;
ang : string;
sinAngle1, cosAngle1: Real;
//pp:TpsPoint;
begin
Changing;
RequiredState([csHandleValid, csBrushValid, csPenValid]);
writecomment(Format('Chord(%d,%d,%d,%d,%d,%d)',[x1,y1,x2-x1,y2-y1,Angle1,Angle2]));
//pp:=TranslateCoord(x1, y1);
//calculate centre of ellipse
cx:=x1;
cy:=y1;
rx:=x2-x1;
ry:=y2-y1;
if Angle2>=0 then
Ang:='arc'
else
Ang:='arcn';
//calculate semi-minor and semi-major axes of ellipse
xScale:=Abs(rx);
yScale:=Abs(ry);
Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix',
[cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang],FFs);
//move current point to start of arc, note negative
//angle because y increases down.ClosePath for draw chord
SinCos(-Angle1/16, SinAngle1, CosAngle1);
ClearBuffer;
writeB('newpath');
writeB(Format('%.3f %.3f moveto',[cX+rX*CosAngle1,cY+rY*SinAngle1],FFs));
WriteB(Code);
writeB('closepath');
SetBrushFillPattern(True,True);
MoveToLastPos;
Changed;
end;
procedure TPostScriptPrinterCanvas.Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer);
begin
//Not implemented
end;
procedure TPostScriptPrinterCanvas.Frame3d(var ARect: TRect;
const FrameWidth: integer; const Style: TGraphicsBevelCut);
begin
//Not implemented
end;
procedure TPostScriptPrinterCanvas.Pie(EllipseX1, EllipseY1, EllipseX2,
EllipseY2, StartX, StartY, EndX, EndY: Integer);
begin
//Not implemented
end;
procedure TPostScriptPrinterCanvas.SetPixel(X, Y: Integer; Value: TColor);
begin
//Not implemented
end;
procedure TPostScriptPrinterCanvas.TextRect(ARect: TRect; X, Y: integer;
const Text: string; const Style: TTextStyle);
var
OldClip: TRect;
Options: longint;
ReqState: TCanvasState;
fRect: TRect;
Offset: Integer;
procedure WordWrap(AText: PChar; MaxWidthInPixel: integer;
out Lines: PPChar; out LineCount: integer);
function FindLineEnd(LineStart: integer): integer;
var
CharLen, LineStop, LineWidth, WordWidth, WordEnd, CharWidth: integer;
begin
// first search line break or text break
Result := LineStart;
while not (AText[Result] in [#0, #10, #13]) do
Inc(Result);
if Result <= LineStart + 1 then
exit;
lineStop := Result;
// get current line width in pixel
LineWidth := TextWidth(AText);
if LineWidth > MaxWidthInPixel then
begin
// line too long -> add words till line size reached
LineWidth := 0;
WordEnd := LineStart;
WordWidth := 0;
repeat
Result := WordEnd;
Inc(LineWidth, WordWidth);
// find word start
while AText[WordEnd] in [' ', #9] do
Inc(WordEnd);
// find word end
while not (AText[WordEnd] in [#0, ' ', #9, #10, #13]) do
Inc(WordEnd);
// calculate word width
if wordEnd = Result then break;
WordWidth := TextWidth(MidStr(AText, Result, WordEnd - Result));
until LineWidth + WordWidth > MaxWidthInPixel;
if LineWidth = 0 then
begin
// the first word is longer than the maximum width
// -> add chars till line size reached
Result := LineStart;
LineWidth := 0;
repeat
charLen := UTF8CodepointSize(@AText[Result]);
CharWidth := TextWidth(MidStr(AText, Result, charLen));
Inc(LineWidth, CharWidth);
if LineWidth > MaxWidthInPixel then
break;
if Result >= lineStop then
break;
Inc(Result, charLen);
until False;
// at least one char
if Result = LineStart then
begin
charLen := UTF8CodepointSize(@AText[Result]);
Inc(Result, charLen);
end;
end;
end;
end;
function IsEmptyText: boolean;
begin
if (AText = nil) or (AText[0] = #0) then
begin
// no text
GetMem(Lines, SizeOf(PChar));
Lines[0] := nil;
LineCount := 0;
Result := True;
end
else
Result := False;
end;
var
LinesList: TIntegerList;
LineStart, LineEnd, LineLen: integer;
ArraySize, TotalSize: integer;
i: integer;
CurLineEntry: PPChar;
CurLineStart: PChar;
begin
if IsEmptyText then
begin
Lines := nil;
LineCount := 0;
exit;
end;
LinesList := TIntegerList.Create;
LineStart := 0;
// find all line starts and line ends
repeat
LinesList.Add(LineStart);
// find line end
LineEnd := FindLineEnd(LineStart);
LinesList.Add(LineEnd);
// find next line start
LineStart := LineEnd;
if AText[LineStart] in [#10, #13] then
begin
// skip new line chars
Inc(LineStart);
if (AText[LineStart] in [#10, #13]) and
(AText[LineStart] <> AText[LineStart - 1]) then
Inc(LineStart);
end
else if AText[LineStart] in [' ', #9] then
begin
// skip space
while AText[LineStart] in [' ', #9] do
Inc(LineStart);
end;
until AText[LineStart] = #0;
// create mem block for 'Lines': array of PChar + all lines
LineCount := LinesList.Count shr 1;
ArraySize := (LineCount + 1) * SizeOf(PChar);
TotalSize := ArraySize;
i := 0;
while i < LinesList.Count do
begin
// add LineEnd - LineStart + 1 for the #0
LineLen := LinesList[i + 1] - LinesList[i] + 1;
Inc(TotalSize, LineLen);
Inc(i, 2);
end;
GetMem(Lines, TotalSize);
FillChar(Lines^, TotalSize, 0);
// create Lines
CurLineEntry := Lines;
CurLineStart := PChar(CurLineEntry) + ArraySize;
i := 0;
while i < LinesList.Count do
begin
// set the pointer to the start of the current line
CurLineEntry[i shr 1] := CurLineStart;
// copy the line
LineStart := LinesList[i];
LineEnd := LinesList[i + 1];
LineLen := LineEnd - LineStart;
if LineLen > 0 then
Move(AText[LineStart], CurLineStart^, LineLen);
Inc(CurLineStart, LineLen);
// add #0 as line end
CurLineStart^ := #0;
Inc(CurLineStart);
// next line
Inc(i, 2);
end;
CurLineEntry[i shr 1] := nil;
LinesList.Free;
end;
function DrawText(Str: PChar; Count: integer; var Rect: TRect;
Flags: cardinal): integer;
const
TabString = ' ';
var
pIndex: longint;
AStr: string;
TM: TLCLTextmetric;
theRect: TRect;
Lines: PPChar;
I, NumLines: longint;
l: longint;
Pt: TPoint;
SavedRect: TRect; // if font orientation <> 0
function LeftOffset: longint;
begin
if (Flags and DT_RIGHT) = DT_RIGHT then
Result := DT_RIGHT
else
if (Flags and DT_CENTER) = DT_CENTER then
Result := DT_CENTER
else
Result := DT_LEFT;
end;
function TopOffset: longint;
begin
if (Flags and DT_BOTTOM) = DT_BOTTOM then
Result := DT_BOTTOM
else
if (Flags and DT_VCENTER) = DT_VCENTER then
Result := DT_VCENTER
else
Result := DT_TOP;
end;
function CalcRect: boolean;
begin
Result := (Flags and DT_CALCRECT) = DT_CALCRECT;
end;
procedure DoCalcRect;
var
AP: TSize;
J, MaxWidth, LineWidth: integer;
begin
theRect := Rect;
MaxWidth := theRect.Right - theRect.Left;
if (Flags and DT_SINGLELINE) > 0 then
begin
// ignore word and line breaks
AP := TextExtent(PChar(AStr));
theRect.Bottom := theRect.Top + TM.Height;
if (Flags and DT_CALCRECT) <> 0 then
theRect.Right := theRect.Left + AP.cX
else
begin
theRect.Right := theRect.Left + Min(MaxWidth, AP.cX);
if (Flags and DT_VCENTER) > 0 then
begin
Types.OffsetRect(theRect, 0, ((Rect.Bottom - Rect.Top) -
(theRect.Bottom - theRect.Top)) div 2);
end
else
if (Flags and DT_BOTTOM) > 0 then
begin
Types.OffsetRect(theRect, 0, (Rect.Bottom - Rect.Top) -
(theRect.Bottom - theRect.Top));
end;
end;
end
else
begin
// consider line breaks
if (Flags and DT_WORDBREAK) = 0 then
begin
// do not break at word boundaries
AP := TextExtent(PChar(AStr));
MaxWidth := AP.cX;
end;
WordWrap(PChar(AStr), MaxWidth, Lines, NumLines);
if (Flags and DT_CALCRECT) <> 0 then
begin
LineWidth := 0;
if (Lines <> nil) then
begin
for J := 0 to NumLines - 1 do
begin
AP := TextExtent(Lines[J]);
LineWidth := Max(LineWidth, AP.cX);
end;
end;
LineWidth := Min(MaxWidth, LineWidth);
end
else
LineWidth := MaxWidth;
theRect.Right := theRect.Left + LineWidth;
theRect.Bottom := theRect.Top + NumLines * TM.Height;
if NumLines > 1 then
Inc(theRect.Bottom, ((NumLines - 1) * TM.Descender));// space between lines
end;
if not CalcRect then
case LeftOffset of
DT_CENTER:
begin
Offset := (Rect.Right - theRect.Right) div 2;
Types.OffsetRect(theRect, offset, 0);
end;
DT_RIGHT:
begin
Offset := Rect.Right - theRect.Right;
Types.OffsetRect(theRect, offset, 0);
end;
end;
end;
// if our Font.Orientation <> 0 we must recalculate X,Y offset
// also it works only with DT_TOP DT_LEFT.
procedure CalculateOffsetWithAngle(const AFontAngle: integer;
var TextLeft, TextTop: integer);
var
OffsX, OffsY: integer;
Angle: integer;
Size: TSize;
R: TRect;
begin
R := SavedRect;
OffsX := R.Right - R.Left;
OffsY := R.Bottom - R.Top;
Size.cX := OffsX;
Size.cy := OffsY;
Angle := AFontAngle div 10;
if Angle < 0 then
Angle := 360 + Angle;
if Angle <= 90 then
begin
OffsX := 0;
OffsY := Trunc(Size.cx * sin(Angle * Pi / 180));
end
else
if Angle <= 180 then
begin
OffsX := Trunc(Size.cx * -cos(Angle * Pi / 180));
OffsY := Trunc(Size.cx * sin(Angle * Pi / 180) + Size.cy *
cos((180 - Angle) * Pi / 180));
end
else
if Angle <= 270 then
begin
OffsX := Trunc(Size.cx * -cos(Angle * Pi / 180) + Size.cy *
sin((Angle - 180) * Pi / 180));
OffsY := Trunc(Size.cy * sin((270 - Angle) * Pi / 180));
end
else
if Angle <= 360 then
begin
OffsX := Trunc(Size.cy * sin((360 - Angle) * Pi / 180));
OffsY := 0;
end;
TextTop := OffsY;
TextLeft := OffsX;
end;
function NeedOffsetCalc: boolean;
begin
Result := (Font.Orientation <> 0) and (Flags and DT_SINGLELINE <> 0) and
(Flags and DT_VCENTER = 0) and (Flags and DT_CENTER = 0) and
(Flags and DT_RIGHT = 0) and (Flags and DT_BOTTOM = 0) and
(Flags and DT_CALCRECT = 0) and not IsRectEmpty(SavedRect);
end;
procedure DrawLineRaw(theLine: PChar; LineLength, TopPos: longint);
var
Points: array[0..1] of TSize;
LeftPos: longint;
begin
if LeftOffset <> DT_LEFT then
Points[0] := TextExtent(theLine)
else begin
Points[0].cx := 0;
Points[0].cy := 0;
end;
case LeftOffset of
DT_LEFT:
LeftPos := theRect.Left;
DT_CENTER:
LeftPos := theRect.Left + (theRect.Right - theRect.Left) div
2 - Points[0].cX div 2;
DT_RIGHT:
LeftPos := theRect.Right - Points[0].cX;
else
LeftPos := 0;
end;
Pt := Point(0, 0);
// Draw line of Text
if NeedOffsetCalc then
begin
Pt.X := SavedRect.Left;
Pt.Y := SavedRect.Top;
CalculateOffsetWithAngle(Font.Orientation, Pt.X, Pt.Y);
end;
TextOut(LeftPos + Pt.X, TopPos + Pt.Y, theLine);
end;
procedure DrawLine(theLine: PChar; LineLength, TopPos: longint);
var
Points: array[0..1] of TSize;
//LogP: TLogPen;
LeftPos: longint;
begin
FillByte({%H-}Points[0], SizeOf(Points[0]) * 2, 0);
if LeftOffset <> DT_Left then
Points[0] := TextExtent(theLine);
case LeftOffset of
DT_LEFT:
LeftPos := theRect.Left;
DT_CENTER:
LeftPos := theRect.Left + (theRect.Right - theRect.Left) div
2 - Points[0].cX div 2;
DT_RIGHT:
LeftPos := theRect.Right - Points[0].cX;
else
LeftPos := 0;
end;
Pt := Point(0, 0);
if NeedOffsetCalc then
begin
Pt.X := SavedRect.Left;
Pt.Y := SavedRect.Top;
CalculateOffsetWithAngle(Font.Orientation, Pt.X, Pt.Y);
end;
// Draw line of Text
TextOut(LeftPos + Pt.X, TopPos + Pt.Y, theLine);
// Draw Prefix
if (pIndex > 0) and (pIndex <= LineLength) then
begin
//LogP.lopnStyle := PS_SOLID;
//LogP.lopnWidth.X := 1;
//LogP.lopnColor := FcPenColor; // FIXME is this required?
{Get prefix line position}
Points[0] := TextExtent(theLine);
Points[0].cX := LeftPos + Points[0].cX;
Points[0].cY := TopPos + tm.Height - TM.Descender + 1;
Points[0] := TextExtent(aStr[pIndex]);
Points[1].cX := Points[0].cX + Points[1].cX;
Points[1].cY := Points[0].cY;
{Draw prefix line}
Polyline(PPoint(@Points[0]), 2);
end;
end;
begin
if (Str = nil) or (Str[0] = #0) then
Exit(0);
if (Count < -1) or (IsRectEmpty(Rect) and
((Flags and DT_CALCRECT = 0) and (Flags and DT_NOCLIP = 0))) then
Exit(0);
// Don't try to use StrLen(Str) in cases count >= 0
// In those cases str is NOT required to have a null terminator !
if Count = -1 then
Count := StrLen(Str);
Lines := nil;
NumLines := 0;
try
if (Flags and (DT_SINGLELINE or DT_CALCRECT or DT_NOPREFIX or
DT_NOCLIP or DT_EXPANDTABS)) = (DT_SINGLELINE or DT_NOPREFIX or
DT_NOCLIP) then
begin
LCLIntf.CopyRect(theRect, Rect);
SavedRect := Rect;
DrawLineRaw(Str, Count, Rect.Top);
Result := Rect.Bottom - Rect.Top;
Exit;
end;
SetLength(AStr, Count);
if Count > 0 then
System.Move(Str^, AStr[1], Count);
if (Flags and DT_EXPANDTABS) <> 0 then
AStr := StringReplace(AStr, #9, TabString, [rfReplaceAll]);
if (Flags and DT_NOPREFIX) <> DT_NOPREFIX then
pIndex := DeleteAmpersands(AStr)
else
pIndex := -1;
GetTextMetrics(TM{%H-});
DoCalcRect;
Result := theRect.Bottom - theRect.Top;
if (Flags and DT_CALCRECT) = DT_CALCRECT then
begin
LCLIntf.CopyRect(Rect, theRect);
exit;
end;
if (Flags and DT_NOCLIP) <> DT_NOCLIP then
begin
if theRect.Right > Rect.Right then
theRect.Right := Rect.Right;
if theRect.Bottom > Rect.Bottom then
theRect.Bottom := Rect.Bottom;
// FIXME I don't know what to do here
// IntersectClipRect( theRect.Left, theRect.Top,
// theRect.Right, theRect.Bottom);
end;
if (Flags and DT_SINGLELINE) = DT_SINGLELINE then
begin
SavedRect := TheRect;
DrawLine(PChar(AStr), length(AStr), theRect.Top);
Exit;
end;
// multiple lines
if Lines = nil then
Exit; // nothing to do
if NumLines = 0 then
Exit;
SavedRect := Classes.Rect(0, 0, 0, 0);
// no font orientation change if multilined text
for i := 0 to NumLines - 1 do
begin
if theRect.Top > theRect.Bottom then
Break;
if ((Flags and DT_EDITCONTROL) = DT_EDITCONTROL) and
(tm.Height > (theRect.Bottom - theRect.Top)) then
Break;
if Lines[i] <> nil then
begin
l := StrLen(Lines[i]);
DrawLine(Lines[i], l, theRect.Top);
Dec(pIndex, l + length(LineEnding));
end;
Inc(theRect.Top, (TM.Descender + TM.Height));// space between lines
end;
finally
Reallocmem(Lines, 0);
end;
end;
begin
//TODO: layout, etc.
Changing;
Options := 0;
case Style.Alignment of
taRightJustify:
Options := DT_RIGHT;
taCenter:
Options := DT_CENTER;
end;
case Style.Layout of
tlCenter:
Options := Options or DT_VCENTER;
tlBottom:
Options := Options or DT_BOTTOM;
end;
if Style.EndEllipsis then
Options := Options or DT_END_ELLIPSIS;
if Style.WordBreak then
begin
Options := Options or DT_WORDBREAK;
if Style.EndEllipsis then
Options := Options and not DT_END_ELLIPSIS;
end;
if Style.SingleLine then
Options := Options or DT_SINGLELINE;
if not Style.Clipping then
Options := Options or DT_NOCLIP;
if Style.ExpandTabs then
Options := Options or DT_EXPANDTABS;
if not Style.ShowPrefix then
Options := Options or DT_NOPREFIX;
if Style.RightToLeft then
Options := Options or DT_RTLREADING;
ReqState := [csHandleValid];
if not Style.SystemFont then
Include(ReqState, csFontValid);
if Style.Opaque then
Include(ReqState, csBrushValid);
// calculate text rectangle
fRect := ARect;
if Style.Alignment = taLeftJustify then
fRect.Left := X;
if Style.Layout = tlTop then
fRect.Top := Y;
if (Style.Alignment in [taRightJustify, taCenter]) or
(Style.Layout in [tlCenter, tlBottom]) then
begin
DrawText( pChar(Text), Length(Text), fRect, DT_CALCRECT or Options);
case Style.Alignment of
taRightJustify:
begin
Offset := ARect.Right - fRect.Right;
Types.OffsetRect(fRect, Offset, 0);
end;
taCenter:
begin
Offset := (ARect.Right - fRect.Right) div 2;
Types.OffsetRect(fRect, offset, 0);
end;
end;
case Style.Layout of
tlCenter:
begin
Offset := ((ARect.Bottom - ARect.Top) - (fRect.Bottom - fRect.Top)) div 2;
Types.OffsetRect(fRect, 0, offset);
end;
tlBottom:
begin
Offset := ARect.Bottom - fRect.Bottom;
Types.OffsetRect(fRect, 0, offset);
end;
end;
end;
if Style.Clipping then begin
OldClip := GetClipRect;
SetClipRect(ARect);
Options := Options or DT_NOCLIP; // no clipping as we are handling it here
end;
if Style.Opaque then
begin
FillRect(fRect)
end;
if Style.SystemFont then
UpdateFont();
DrawText(PChar(Text), Length(Text), fRect, Options);
if Style.Clipping then
SetClipRect(OldClip);
Changed;
end;
function IsMaxClip(ARect:TRect):boolean;
begin
Result:=(Arect.Right=MaxInt) and (ARect.Bottom=MaxInt) and (Arect.Left=0) and (ARect.Top=0);
end;
procedure TPostScriptPrinterCanvas.SetClipRect(const ARect:TRect);
begin
if pcsClipping in FStatus then
RestoreClip;
FLazClipRect := ARect;
if pcsClipping in FStatus then
SaveClip;
end;
function TPostScriptPrinterCanvas.GetClipping: Boolean;
begin
result := (pcsClipping in FStatus);
end;
procedure TPostScriptPrinterCanvas.SetClipping(const AValue: boolean);
begin
if GetClipping<>AValue then
begin
if GetClipping then
RestoreClip
else
SaveClip;
if AValue then
Include(FStatus, pcsClipping)
else
Exclude(FStatus, pcsClipping);
end;
end;
procedure TPostScriptPrinterCanvas.FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle);
begin
//Not implemented
end;
procedure TPostScriptPrinterCanvas.CopyRect(const Dest: TRect;
SrcCanvas: TCanvas; const Source: TRect);
begin
//Not implemented
end;
{ TPostScriptCanvas }
constructor TPostScriptCanvas.Create;
begin
Inherited Create(nil);
end;
procedure TPostScriptCanvas.BeginDoc;
begin
inherited BeginDoc;
end;
procedure TPostScriptCanvas.EndDoc;
begin
inherited EndDoc;
end;
procedure TPostScriptCanvas.NewPage;
begin
inherited NewPage;
end;
end.
Reference in New Issue View Git Blame Copy Permalink