From af4bb981dfbc5b48b297ea0fe95721cbf19e6c38 Mon Sep 17 00:00:00 2001 From: jesus Date: Sun, 4 Apr 2010 23:46:49 +0000 Subject: [PATCH] tpipro, fix print preview empty pages under unix git-svn-id: trunk@24419 - --- components/turbopower_ipro/iphtml.pas | 63 ++++++++++++++++++-- lcl/graphics.pp | 7 +++ lcl/include/canvas.inc | 14 +++++ lcl/postscriptcanvas.pas | 86 ++++++++++++++++++++++----- 4 files changed, 149 insertions(+), 21 deletions(-) diff --git a/components/turbopower_ipro/iphtml.pas b/components/turbopower_ipro/iphtml.pas index 4b26d2f7ac..4452753a8b 100644 --- a/components/turbopower_ipro/iphtml.pas +++ b/components/turbopower_ipro/iphtml.pas @@ -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; diff --git a/lcl/graphics.pp b/lcl/graphics.pp index ff180d258b..26e85594b9 100644 --- a/lcl/graphics.pp +++ b/lcl/graphics.pp @@ -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; diff --git a/lcl/include/canvas.inc b/lcl/include/canvas.inc index 5181a29ac0..969a8f1ed5 100644 --- a/lcl/include/canvas.inc +++ b/lcl/include/canvas.inc @@ -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 diff --git a/lcl/postscriptcanvas.pas b/lcl/postscriptcanvas.pas index 5a21896ee8..afb51671e9 100644 --- a/lcl/postscriptcanvas.pas +++ b/lcl/postscriptcanvas.pas @@ -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