paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-22 13:39:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL, PostscriptCanvas: improved underline position

Browse Source 
git-svn-id: trunk@46908 -
This commit is contained in:
jesus 2014-11-20 20:13:11 +00:00
parent 80a15d2141
commit dd67f6e7bc
1 changed files with 26 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
lcl/postscriptcanvas.pas
View File

@ -79,7 +79,7 @@ Type
procedure psDrawRect(ARect:TRect);
procedure WriteHeader(St : String);
procedure Write(const St : String; Lst : TstringList = nil); overload;
procedure Write(const St : String; Lst : TStringList = nil); overload;
procedure WriteB(const St : string);
procedure ClearBuffer;
procedure Write(Lst : TStringList); overload;
@ -112,6 +112,7 @@ Type
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;
@ -665,7 +666,7 @@ begin
end;
//Write an instruction in the document
procedure TPostScriptPrinterCanvas.Write(const St: String; Lst : TStringList = Nil);
procedure TPostScriptPrinterCanvas.Write(const St: String; Lst: TStringList = nil);
begin
If not Assigned(Lst) then
Lst:=fDocument;
@ -1152,6 +1153,17 @@ 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
@ -2040,10 +2052,11 @@ end;
//Out the text at the X,Y coord. Set the font
procedure TPostScriptPrinterCanvas.TextOut(X, Y: Integer; const Text: String);
var
PenUnder : Real;
PenUnder : Double;
PosUnder : Integer;
pp:TpsPoint;
saved:boolean;
FontIndex: Integer;
procedure rotate;
begin
@ -2073,10 +2086,19 @@ begin
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;
PosUnder:=(Abs(Round(GetFontSize/3))*-1)+2;
{$endif}
Write(format('%f %f uli',[pp.fx,pp.fy],FFs));
if Font.Orientation<>0 then
rotate();