mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-17 03:49:30 +02:00
tpipro, fix print preview empty pages under unix
git-svn-id: trunk@24419 -
This commit is contained in:
jesus
parent
e51a89e626
commit
af4bb981df
@ -3829,8 +3829,13 @@ var
|
||||
begin
|
||||
ScreenDC := GetDC(0);
|
||||
try
|
||||
Aspect := GetDeviceCaps(PrinterDC, LOGPIXELSX)
|
||||
/ GetDeviceCaps(ScreenDC, LOGPIXELSX);
|
||||
Aspect :=
|
||||
{$IFDEF IP_LAZARUS}
|
||||
Printer.XDPI
|
||||
{$ELSE}
|
||||
GetDeviceCaps(PrinterDC, LOGPIXELSX)
|
||||
{$ENDIF}
|
||||
/ GetDeviceCaps(ScreenDC, LOGPIXELSX);
|
||||
finally
|
||||
ReleaseDC(0, ScreenDC);
|
||||
end;
|
||||
@ -10267,7 +10272,11 @@ var
|
||||
procedure ApplyProps;
|
||||
var
|
||||
Changed : Boolean;
|
||||
{$IFDEF IP_LAZARUS}
|
||||
TextMetrics : TLCLTextMetric;
|
||||
{$ELSE}
|
||||
TextMetrics : TTextMetric;
|
||||
{$ENDIF}
|
||||
begin
|
||||
with CurElement.Props do begin
|
||||
if (CurProps = nil) or not AIsEqualTo(CurProps) then begin
|
||||
@ -10304,10 +10313,17 @@ var
|
||||
end;
|
||||
if Changed then begin
|
||||
if PropA.tmHeight = 0 then begin
|
||||
{$IFDEF IP_LAZARUS}
|
||||
aCanvas.GetTextMetrics(TextMetrics);
|
||||
PropA.tmAscent := TextMetrics.Ascender;
|
||||
PropA.tmDescent := TextMetrics.Descender;
|
||||
PropA.tmHeight := TextMetrics.Height;
|
||||
{$ELSE}
|
||||
GetTextMetrics(aCanvas.Handle, TextMetrics);
|
||||
PropA.tmAscent := TextMetrics.tmAscent;
|
||||
PropA.tmDescent := TextMetrics.tmDescent;
|
||||
PropA.tmHeight := TextMetrics.tmHeight;
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
@ -10836,7 +10852,11 @@ var
|
||||
|
||||
procedure ApplyProps;
|
||||
var
|
||||
TextMetrics : TTextMetric;
|
||||
{$IFDEF IP_LAZARUS}
|
||||
TextMetrics : TLCLTextMetric;
|
||||
{$ELSE}
|
||||
TExtMetrics : TTextMetric;
|
||||
{$ENDIF}
|
||||
begin
|
||||
with CurElement.Props do begin
|
||||
if (CurProps = nil) or not AIsEqualTo(CurProps) then begin
|
||||
@ -10856,10 +10876,17 @@ var
|
||||
aCanvas.Font.Name := FontName;
|
||||
aCanvas.Font.Size := FontSize;
|
||||
aCanvas.Font.Style := FontStyle;
|
||||
{$IFDEF IP_LAZARUS}
|
||||
Owner.Target.GetTextMetrics(TextMetrics);
|
||||
PropA.tmAscent := TextMetrics.Ascender;
|
||||
PropA.tmDescent := TextMetrics.Descender;
|
||||
PropA.tmHeight := TextMetrics.Height;
|
||||
{$ELSE}
|
||||
GetTextMetrics(Owner.Target.Handle, TextMetrics);
|
||||
PropA.tmAscent := TextMetrics.tmAscent;
|
||||
PropA.tmDescent := TextMetrics.tmDescent;
|
||||
PropA.tmHeight := TextMetrics.tmHeight;
|
||||
{$ENDIF}
|
||||
end;
|
||||
tmHeight := PropA.tmHeight;
|
||||
tmAscent := PropA.tmAscent;
|
||||
@ -10876,6 +10903,16 @@ var
|
||||
end;
|
||||
|
||||
procedure InitMetrics;
|
||||
{$IFDEF IP_LAZARUS}
|
||||
var
|
||||
TextMetrics : TLCLTextMetric;
|
||||
begin
|
||||
aCanvas.GetTextMetrics(TextMetrics);
|
||||
tmAscent := TextMetrics.Ascender;
|
||||
tmDescent := TextMetrics.Descender;
|
||||
tmHeight := TextMetrics.Height;
|
||||
end;
|
||||
{$ELSE}
|
||||
var
|
||||
TextMetrics : TTextMetric;
|
||||
begin
|
||||
@ -10884,6 +10921,7 @@ var
|
||||
tmDescent := TextMetrics.tmDescent;
|
||||
tmHeight := TextMetrics.tmHeight;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{!!.10 rewritten
|
||||
procedure SetWordInfoLength(NewLength : Integer);
|
||||
@ -17266,8 +17304,8 @@ begin
|
||||
else
|
||||
Canvas.FillRect(CR);
|
||||
{$IFDEF IP_LAZARUS_DBG}
|
||||
DebugBox(CR, clYellow);
|
||||
Debugbox(Canvas.ClipRect,clLime, true);
|
||||
DebugBox(Canvas, CR, clYellow);
|
||||
Debugbox(Canvas, Canvas.ClipRect, clLime, true);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
@ -17288,12 +17326,27 @@ begin
|
||||
Printed := False;
|
||||
ScaleBitmaps := True;
|
||||
GetRelativeAspect(Printer.Canvas.Handle);
|
||||
{$IF DEFINED(IP_LAZARUS) AND NOT DEFINED(WINDOWS)}
|
||||
// this test looks weird, according to most references consulted, the number
|
||||
// of colors in a display is NColors = 1 shl (bitsPerPixel * Planes). A mono
|
||||
// printer should have 2 colors, somebody else needs to clarify.
|
||||
BWPrinter := false;
|
||||
{$ELSE}
|
||||
BWPrinter := GetDeviceCaps(Printer.Canvas.Handle, PLANES) = 1;
|
||||
{$ENDIF}
|
||||
{$IFDEF IP_LAZARUS}
|
||||
LogPixX := Printer.XDPI;
|
||||
{$ELSE}
|
||||
LogPixX := GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSX);
|
||||
{$ENDIF}
|
||||
LMarginPix := round(HtmlPanel.PrintSettings.MarginLeft * LogPixX);
|
||||
RMarginPix := round(HtmlPanel.PrintSettings.MarginRight * LogPixX);
|
||||
PrintWidth := Printer.PageWidth - LMarginPix - RMarginPix;
|
||||
{$IFDEF IP_LAZARUS}
|
||||
LogPixY := Printer.YDPI;
|
||||
{$ELSE}
|
||||
LogPixY := GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);
|
||||
{$ENDIF}
|
||||
TMarginPix := round(HtmlPanel.PrintSettings.MarginTop * LogPixY);
|
||||
BMarginPix := round(HtmlPanel.PrintSettings.MarginBottom * LogPixY);
|
||||
PrintHeight := Printer.PageHeight - TMarginPix - BMarginPix;
|
||||
|
||||
@ -955,6 +955,12 @@ type
|
||||
amOff // disabled
|
||||
);
|
||||
|
||||
TLCLTextMetric = record
|
||||
Ascender: Integer;
|
||||
Descender: Integer;
|
||||
Height: Integer;
|
||||
end;
|
||||
|
||||
{ TCanvas }
|
||||
|
||||
TCanvas = class(TFPCustomCanvas)
|
||||
@ -1083,6 +1089,7 @@ type
|
||||
procedure Frame(X1,Y1,X2,Y2: Integer); // border using pen
|
||||
procedure FrameRect(const ARect: TRect); virtual; // border using brush
|
||||
procedure FrameRect(X1,Y1,X2,Y2: Integer); // border using brush
|
||||
function GetTextMetrics(out TM: TLCLTextMetric): boolean; virtual;
|
||||
procedure GradientFill(ARect: TRect; AStart, AStop: TColor; ADirection: TGradientDirection);
|
||||
procedure RadialPie(x1, y1, x2, y2,
|
||||
StartAngle16Deg, Angle16DegLength: Integer); virtual;
|
||||
|
||||
@ -1003,6 +1003,20 @@ begin
|
||||
FrameRect(Rect(X1, Y1, X2, Y2));
|
||||
end;
|
||||
|
||||
function TCanvas.GetTextMetrics(out TM: TLCLTextMetric): boolean;
|
||||
var
|
||||
TTM: TTextMetric;
|
||||
begin
|
||||
RequiredState([csHandleValid]);
|
||||
Fillchar(TM, SizeOf(TM), 0);
|
||||
Result := LCLIntf.GetTextMetrics(FHandle, TTM);
|
||||
if Result then begin
|
||||
TM.Ascender := TTM.tmAscent;
|
||||
TM.Descender := TTM.tmDescent;
|
||||
TM.Height := TTM.tmHeight;
|
||||
end;
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Method: TCanvas.Rectangle
|
||||
Params: X1,Y1,X2,Y2
|
||||
|
||||
@ -107,6 +107,9 @@ Type
|
||||
procedure RestoreClip;
|
||||
procedure SaveClip;
|
||||
procedure CheckLastPos;
|
||||
function GetFontIndex: Integer;
|
||||
function FontUnitsToPixelsX(const Value:Integer): Integer;
|
||||
function FontUnitsToPixelsY(const Value:Integer): Integer;
|
||||
protected
|
||||
procedure CreateHandle; override;
|
||||
procedure CreateBrush; override;
|
||||
@ -164,6 +167,7 @@ Type
|
||||
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;
|
||||
@ -197,6 +201,7 @@ Type
|
||||
TFontsWidths = Array[32..255] of Integer;
|
||||
TFontPSMetrics = Record
|
||||
Name : string;
|
||||
ULPos, ULThickness, Ascender, Descender: Integer;
|
||||
Widths : TFontsWidths;
|
||||
end;
|
||||
|
||||
@ -209,6 +214,7 @@ 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,
|
||||
@ -234,6 +240,7 @@ Const
|
||||
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,
|
||||
@ -259,6 +266,7 @@ Const
|
||||
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,
|
||||
@ -284,6 +292,7 @@ Const
|
||||
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,
|
||||
@ -309,6 +318,7 @@ Const
|
||||
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,
|
||||
@ -334,6 +344,7 @@ Const
|
||||
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,
|
||||
@ -359,6 +370,7 @@ Const
|
||||
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,
|
||||
@ -384,6 +396,7 @@ Const
|
||||
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,
|
||||
@ -409,6 +422,7 @@ Const
|
||||
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,
|
||||
@ -434,6 +448,7 @@ Const
|
||||
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,
|
||||
@ -459,6 +474,7 @@ Const
|
||||
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,
|
||||
@ -484,6 +500,7 @@ Const
|
||||
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,
|
||||
@ -509,6 +526,7 @@ Const
|
||||
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,
|
||||
@ -860,7 +878,7 @@ function TPostScriptPrinterCanvas.MappedFontName: string;
|
||||
Var Atr : string;
|
||||
begin
|
||||
Atr:='';
|
||||
Result:='Helvetica';
|
||||
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
|
||||
@ -872,6 +890,9 @@ begin
|
||||
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
|
||||
@ -1089,6 +1110,35 @@ begin
|
||||
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;
|
||||
|
||||
procedure TPostScriptPrinterCanvas.CreateHandle;
|
||||
begin
|
||||
SetHandle(1); // set dummy handle
|
||||
@ -2024,9 +2074,9 @@ begin
|
||||
end;
|
||||
|
||||
function TPostScriptPrinterCanvas.TextExtent(const Text: string): TSize;
|
||||
var IndexFont,i : Integer;
|
||||
FontName : string;
|
||||
c: Char;
|
||||
var
|
||||
IndexFont,i : Integer;
|
||||
c: Char;
|
||||
begin
|
||||
Result.cX := 0;
|
||||
Result.cY := 0;
|
||||
@ -2034,24 +2084,14 @@ begin
|
||||
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
|
||||
FontName:=MappedFontName;
|
||||
IndexFont:=0; //By default, use Courier metrics
|
||||
for i:=0 to High(cFontPSMetrics) do
|
||||
begin
|
||||
if cFontPSMetrics[i].Name=FontName then
|
||||
begin
|
||||
IndexFont:=i;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
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:=Round(Result.cX*Abs(GetFontSize/72)*0.001*XDPI);
|
||||
Result.cX:=FontUnitsToPixelsX(Result.cX);
|
||||
end;
|
||||
|
||||
//Draw an Picture
|
||||
@ -2126,6 +2166,20 @@ begin
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user