paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-07-24 20:36:13 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL, fix postscriptcanvas clipping, single moveto/lineto didn't work, fix font size of default font

Browse Source 
git-svn-id: trunk@23928 -
This commit is contained in:
jesus 2010-03-10 20:05:26 +00:00
parent b6218b0cd8
commit 132fcd9eee
1 changed files with 74 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
lcl/postscriptcanvas.pas
View File

@ -71,6 +71,9 @@ Type
FPsUnicode : TPSUnicode;
FFs : TFormatSettings;
fSaveCount : Integer;
FClipRect : TRect;
FClipping : boolean;
FClipSaved : boolean;
procedure psDrawRect(ARect:TRect);
procedure WriteHeader(St : String);
@ -100,6 +103,9 @@ Type
procedure GetRGBImage(SrcGraph: TGraphic; Lst : TStringList);
procedure PixelsToPoints(const PixX,PixY: Integer; out PtX,PtY:Single);
function GetFontSize: Integer;
procedure RestoreClip;
procedure SaveClip;
protected
procedure CreateHandle; override;
procedure CreateBrush; override;
@ -113,7 +119,11 @@ Type
procedure RegionChanging(APen: TObject); override;
procedure RequiredState(ReqState: TCanvasState); override;
procedure DoEllipseAndFill(const Bounds: TRect); override;
procedure SetClipRect(const ARect:TRect);override;
function GetClipRect: TRect; override;
procedure SetClipRect(const ARect: TRect); override;
function GetClipping: Boolean; override;
procedure SetClipping(const AValue: boolean); override;
procedure BeginDoc; override;
procedure EndDoc; override;
@ -1057,6 +1067,34 @@ begin
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 FClipSaved then
begin
Self.WriteComment('Restoring Old clip rect');
Self.Write('cliprestore');
FClipSaved := false;
end;
end;
procedure TPostScriptPrinterCanvas.SaveClip;
begin
Self.WriteComment('Pushing and Setting current clip rect');
Self.Write('clipsave');
psDrawRect(FClipRect);
Write(FBuffer);
Self.Write('clip');
FClipSaved := true;
end;
procedure TPostScriptPrinterCanvas.CreateHandle;
begin
SetHandle(1); // set dummy handle
@ -1119,6 +1157,11 @@ begin
Ellipse(Bounds.Left, Bounds.Top, Bounds.Right, Bounds.Bottom);
end;
function TPostScriptPrinterCanvas.GetClipRect: TRect;
begin
Result:=FClipRect;
end;
constructor TPostScriptPrinterCanvas.Create(APrinter: TPrinter);
begin
inherited Create(APrinter);
@ -1134,6 +1177,7 @@ begin
Ffs.DecimalSeparator:='.';
Ffs.ThousandSeparator:=#0;
FClipping := true;
end;
destructor TPostScriptPrinterCanvas.Destroy;
@ -1471,8 +1515,6 @@ var
begin
RequiredState([csHandleValid]);
write('stroke');
WriteComment(Format('DoMoveTo(%d,%d)',[x1,y1]));
SetPosition(X1,Y1);
@ -1494,7 +1536,7 @@ begin
UpdateLineColor(clNone);
UpdateLineWidth;
UpdateLineStyle;
write(Format('%f %f lineto',[pp.fx,pp.fy],FFs));
write(Format('%f %f lineto stroke',[pp.fx,pp.fy],FFs));
changed;
end;
@ -1945,11 +1987,11 @@ begin
UpdateFont;
FPSUnicode.Font:=MappedFontName;
FPSUnicode.FontSize:=Abs(Font.Size);
FPSUnicode.FontSize:=Abs(GetFontSize);
FPSUnicode.FontStyle:=FontStyleToInt(Font.Style);
//The Y origin for ps text it's Left bottom corner
pp.fy := pp.fy - abs(Font.Size); // in points
pp.fy := pp.fy - abs(GetFontSize); // in points
saved:=false;
@ -1958,7 +2000,7 @@ begin
PenUnder:=0.5;
if fsBold in Font.Style then
PenUnder:=1.0;
PosUnder:=(Abs(Round(Font.Size/3))*-1)+2;
PosUnder:=(Abs(Round(GetFontSize/3))*-1)+2;
rotate();
Write(format('%f %f uli',[pp.fx,pp.fy],FFs));
FPSUnicode.OutputString(MapedString(Text));
@ -1981,7 +2023,7 @@ begin
end;
function TPostScriptPrinterCanvas.TextExtent(const Text: string): TSize;
Var IndexFont,i : Integer;
var IndexFont,i : Integer;
FontName : string;
c: Char;
begin
@ -1989,7 +2031,7 @@ begin
Result.cY := 0;
if Text='' then Exit;
RequiredState([csHandleValid, csFontValid]);
Result.cY:=round((Abs(Font.Size)/72)*YDPI); // points to inches and then to pixels
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
FontName:=MappedFontName;
IndexFont:=0; //By default, use Courier metrics
@ -2008,7 +2050,7 @@ begin
if (c in [#32..#255]) then
Inc(Result.cX,cFontPSMetrics[IndexFont].Widths[Ord(c)]);
end;
Result.cX:=Round(Result.cX*Abs(Font.Size/72)*0.001*XDPI);
Result.cX:=Round(Result.cX*Abs(GetFontSize/72)*0.001*XDPI);
end;
//Draw an Picture
@ -2172,33 +2214,30 @@ end;
procedure TPostScriptPrinterCanvas.SetClipRect(const ARect:TRect);
begin
inherited SetClipRect(ARect);
if (fSaveCount>0) then // restore original clipping
if FClipping then
RestoreClip;
FClipRect := ARect;
if FClipping then
SaveClip;
end;
function TPostScriptPrinterCanvas.GetClipping: Boolean;
begin
Result:=FClipping;
end;
procedure TPostScriptPrinterCanvas.SetClipping(const AValue: boolean);
begin
if FClipping<>AValue then
begin
Self.Write('grestore');
dec(fSaveCount);
if FClipping then
RestoreClip
else
SaveClip;
FClipping := AValue;
end;
// if the rect is empty or max-possible - do not clip
if (IsRectEmpty(ARect) or IsMaxClip(ARect)) then
exit;
// save PS state and clip
UpdateLineWidth;
UpdateLineColor;
UpdateFillColor;
UpdateFont;
Self.Write('gsave');
Self.WriteComment('This is clip path');
inc(fSaveCount);
Self.WriteB('[] 0 setdash');
psDrawRect(ARect);
Self.WriteB('clip');
Self.WriteB('stroke');
Self.Write(fBuffer);
// Self.MovetoLastpos;
end;
procedure TPostScriptPrinterCanvas.FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle);