Problem with TGDIPlusCanvas.TextWidth

[Jens Gr.]

Hello,
I have a problem with the TGDIPlusCanvas.TextWidth function in the TDraw3D box (with Std v2014.12.140923 on Win7 32bit). If I use the following code:

Code: Select all

procedure TForm1.Draw3D1Paint(Sender: TObject; const ARect: TRect);
var
  s:String;
  x,y:Integer;
begin
  x:=10; y:=10;
  with Draw3D1.Canvas do begin
    Font.Height:=-11;
    s:='XXXXXXXXXXXXXXXXXXXXXXXXXXX';
    Brush.Color:=clSilver;
    FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
    TextOut(x,y,s);
    s:='AAAAAAAAAAAAAAAAAAAAAAAAAAA';
    y:=y+20;
    Brush.Color:=clSilver;
    FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
    TextOut(x,y,s);
    s:='FFFFFFFFFFFFFFFFFFFFFFFFFFF';
    y:=y+20;
    Brush.Color:=clSilver;
    FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
    TextOut(x,y,s);
  end;
end;

The result is:

img1.png (808 Bytes) Viewed 20477 times

If I use the normal GDI canvas all rectangles are filled full with text. I think, the value of the TextWidth function is sometimes to large.
What is wrong??

The other problem is: If I use a positive value for Font.Height, no text is displayed.

Thank you
Jens

[jens.mertelmeyer]

I have a feeling that this is going to be another prime example of why the with-statement in Pascal is a terrible abomination.

I refactored your code a bit. Please have a look at the produced output.

noWith.png (16.95 KiB) Viewed 20449 times

withWith.png (17.88 KiB) Viewed 20444 times

The code:

Code: Select all

procedure printText(
	const	onCanvas:	TTeeCanvas;
	const   atPosition:	TPoint;
	const	text: 		String
);
var
	backgroundRect: TRect;
begin
	Assert( Assigned(onCanvas) );

	onCanvas.Brush.Color := clSilver;
	backgroundRect := TRect.Create(
		atPosition.X,
		atPosition.Y,
		atPosition.X + onCanvas.TextWidth(text),
		atPosition.Y + onCanvas.TextHeight(text)
	  );

	onCanvas.FillRect(backgroundRect);
	onCanvas.TextOut(atPosition.X, atPosition.Y, text);
end;

procedure TForm5.Draw3D1Paint(Sender: TObject; const ARect: TRect);
const
	fontSize: Integer = 12;
var
	s:String;
	textPositon: TPoint;
	myCanvas: TTeeCanvas;
	x,y :Integer;
begin

	if not useWithAbominationCheckbox.Checked then begin
		textPositon := TPoint.Create(10, 10);

		myCanvas := Draw3D1.Canvas;
		myCanvas.Font.Size := fontSize;
		myCanvas.Brush.Color := clSilver;

		printText(myCanvas, textPositon, 'XXXXXXXXXXXXXXXXXXXXXXXXXXX');

		textPositon.Offset(0, 20);
		printText(myCanvas, textPositon, 'AAAAAAAAAAAAAAAAAAAAAAAAAAA');

		textPositon.Offset(0, 20);
		printText(myCanvas, textPositon, 'FFFFFFFFFFFFFFFFFFFFFFFFFFF');

		textPositon.Offset(0, 20);
		printText(myCanvas, textPositon, '... ..');

	end else begin
		x := 10; y:=10;
		with Draw3D1.Canvas do begin
			Font.Height:=-11;
			s:='XXXXXXXXXXXXXXXXXXXXXXXXXXX';
			Brush.Color:=clSilver;
			FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
			TextOut(x,y,s);
			s:='AAAAAAAAAAAAAAAAAAAAAAAAAAA';
			y:=y+20;
			Brush.Color:=clSilver;
			FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
			TextOut(x,y,s);
			s:='FFFFFFFFFFFFFFFFFFFFFFFFFFF';
			y:=y+20;
			Brush.Color:=clSilver;
			FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
			TextOut(x,y,s);
		end;
	end;
end;

procedure TForm5.useWithAbominationCheckboxClick(Sender: TObject);
begin
	Draw3D1.Invalidate();
end;

[Yeray]

Hi Jens,

Changing this:

Code: Select all

      with Draw3D1.Canvas do begin
         Font.Height:=-11;

For this:

Code: Select all

      with Draw3D1.Canvas do begin
         Font.Size:=fontSize;

Seems to make your example code to draw the same when the checkbox is checked and when it's unchecked.

[jens.mertelmeyer]

And that's a good thing, I suppose?

[Jens Gr.]

Hello,

Thank you for the new code. But I think, this is not the solution. If you use Font.Size=8 (this is on 96dpi screens the same as font.height=-11), you will see the same bad result....

Can it be the problem with the TGPGraphics.MeasureString limitations??
Please see: http://www.codeproject.com/Articles/211 ... imitations

I think, this is important, because the TextWidth function is the base function for correct displaying centered and right bounded text.

Jens G.

[Yeray]

Hi Jens

I've added this to the public tracker to further investigate it:
http://bugs.teechart.net/show_bug.cgi?id=1055

[Yeray]

Hi Jens,

A bit more on this.

There's a new, special and internal function, called InternalTextwidth.
GDIPlus can return the width "normal" or "shrunk" (typographic).
"Normal" is like in GDI. It returns a width with margins included. I'm afraid we can't control this.
"Shrunk" (typographic) should be similar to what's described in the article you posted.

There are many blog posts regarding this subject. Ie:
http://theartofdev.com/2014/04/21/text- ... i-revised/

At the moment, we are only using this "typographic" technique on the legend when using GDIPlus and when the text is right aligned (TA_RIGHT) or centered (TA_CENTER), for better positioning on places like the legend.

Code: Select all

Function TGDIPlusCanvas.InternalTextWidth(const St:String; TypoGraphic:Boolean=False):Integer;

  procedure ApplyShadow(const AShadow:TTeeShadow);
  begin
    if Assigned(AShadow) and AShadow.Visible then
       Inc(result,Abs(AShadow.HorizSize));
  end;

var tmpBox : TGPRectF;
begin
  if TypoGraphic then
     FGraphics.MeasureString(St,Length(St),FGPFont,TeeZeroPoint,TGPStringFormat.GenericTypographic,tmpBox)
  else
     FGraphics.MeasureString(St,Length(St),FGPFont,TeeZeroPoint,tmpBox);

  result:=Round(tmpBox.Width{+0.5});

  ApplyShadow(TFontAccess(Font).FShadow);
  ApplyShadow(TFontAccess(Font).FEmboss);
end;

Function TGDIPlusCanvas.TextWidth(const St:String):Integer;
begin
  result:=InternalTextWidth(St);
end;

[Jens Gr.]

Hi Yeray,

I am a little confused. I have checked the same code with the old GDI Canvas and the buggy result is as follow:

Bild1.png (3.44 KiB) Viewed 20361 times

Here the code:

Code: Select all

const
  fHeight=-11;

procedure TForm1.Draw3D1Paint(Sender: TObject; const ARect: TRect);
var
  s:String;
  x,y:Integer;
begin
  x:=10; y:=10;
  with Draw3D1.Canvas do begin
     Font.Height:=fHeight;
     TextOut(x,y,ClassName); y:=y+20;
     s:='XXXXXXXXXXXXXXXXXXXXXXXXXXX';
     Brush.Color:=clSilver;
     FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
     TextOut(x,y,s); y:=y+20;
     s:='FFFFFFFFFFFFFFFFFFFFFFFFFFF';
     Brush.Color:=clSilver;
     FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
     TextOut(x,y,s); y:=y+20;
     s:='AAAAAAAAAAAAAAAAAAAAAAAAAAAA';
     Brush.Color:=clSilver;
     FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
     TextOut(x,y,s); y:=y+20;
     TextOut(x,y,'FFFFFFFFFFFFFFFFFFFFFFFFFFF<b>HH</b> ',True); y:=y+20;
     TextOut(x,y,'AAAAAAAAAAAAAAAAAAAAAAAAAAA<b>HH</b> ',True);
  end;
end;
procedure TForm1.cbGDIPlusClick(Sender: TObject);
begin
  if cbGDIPlus.Checked then begin
    Draw3D1.Canvas:=TGDIPlusCanvas.Create;
  end else begin
    Draw3D1.Canvas:=TTeeCanvas3D.Create;
    TCanvasAccess(Draw3D1.Canvas).FontQuality:=fqDefault;
  end;
end;

In the source code I can find in VCLTee.TeeGDIPlus the lines:

Code: Select all

  FGraphics.MeasureString(St,Length(St),FGPFont,TeeZeroPoint, {TGPStringFormat.GenericTypographic,} tmpBox);

If I remove the comments to use Typographic, the result is better, but not good:

Bild2.png (1.82 KiB) Viewed 20357 times

I cannot found your function "InternalTextWidth" in my source code. Is there a new source code version greater v2014.12.140923 ??

Thanks,
Jens

[Jens Gr.]

Hi,
I have spent a few hours and checked the function MeasureCharacterRanges. I think, this is a good alternative for the GDI TextSize function. Here is the code:

Code: Select all

function TextSizeGP(Graphics:TGPgraphics; Text:string; Font:TGPFont):TSize;
var
  format:TGPStringFormat;
  rect:TGPRectF;
  ranges: TCharacterRange;
  regions:array [0..0] of TGPRegion;
begin
  Result.cx:=0; Result.cy:=0;
  if length(Text)=0 then exit;
  if Text[length(Text)]=' ' then Text[length(Text)]:='-';
  format:=TGPStringFormat.Create;
  rect.X:=0; rect.Y:=0; rect.Width:=9999999;  rect.Height:=9999999;
  ranges := MakeCharacterRange(0,length(Text));
  format.SetMeasurableCharacterRanges(1,@ranges);
  regions[0]:=TGPRegion.Create;
  Graphics.MeasureCharacterRanges(text, -1, font, rect, format, 1, regions);
  regions[0].GetBounds(rect,graphics);
  result.cx:=Trunc(rect.Width +rect.X);
  result.cy:=Trunc(rect.Height +rect.Y);
end;

And here the result:

Bild1.png (1.52 KiB) Viewed 20338 times

kind regards,
Jens

[Jens Gr.]

Hi,

Long silence? I hope, you are interested in a solution...

Here is a source code sample for better GDI+ text results. I have deleted your special code for publication. If you need the full code, please contact me per E-Mail.

Code: Select all

  TTeeFontMetric=record
    Name : String;
    Height : Integer;
    Style : TFontStyles;
    OX,OY:Single;
    BaseLine:Integer;
    TextHeight:Integer;
    Rotation:Integer; //0..359
  end;

procedure TGDIPlusCanvas.DoChangedFont;
begin
  if Assigned(FGPFont) and ((Font.Name<>FontMetric.Name) or (Font.Height<>FontMetric.Height) or (Font.Style<>FontMetric.Style)) then
    FreeAndNil(FGPFont);
end;

procedure TGDIPlusCanvas.NeedGPFont;
var
  tmpFontStyle : TFontStyle;
  tmpHeight:Integer;
  Family:TGPFontFamily;
  tmpQuality : TGDIPlusFontQuality;
  R: TGPRectF;
begin
  if Assigned(FGPFont) or not (Assigned(Font) and Assigned(FGraphics)) then Exit;
  if Font.Height<3 then
    tmpHeight:=Max(1,abs(Font.Height))
  else begin
    //Simple trick
    tmpHeight:=Font.Height;
    Font.Height:=-tmpHeight;
    while (Font.Height<-3) and (TextHeight('X')>tmpHeight) do
      Font.Height:=Font.Height+1;
    exit;
  end;
  FGPFont.Free;
  tmpFontStyle:=FontStyleRegular;
  if Font.Style<>[] then // optimization
  begin
    if fsBold in Font.Style then tmpFontStyle:=tmpFontStyle or FontStyleBold;
    if fsItalic in Font.Style then tmpFontStyle:=tmpFontStyle or FontStyleItalic;
    if fsUnderline in Font.Style then tmpFontStyle:=tmpFontStyle or FontStyleUnderline;
    if fsStrikeOut in Font.Style then tmpFontStyle:=tmpFontStyle or FontStyleStrikeout;
  end;
  FGPFont:=TGPFont.Create(Font.Name,tmpHeight,tmpFontStyle,UnitPixel);
  FontMetric.Name:=Font.Name;
  FontMetric.Height:=tmpHeight;
  FontMetric.Style:=Font.Style;
  R:=CalcTextRange('X');
  FontMetric.OX:=R.X;
  FontMetric.OY:=R.Y;
  FontMetric.TextHeight:=Round(R.Height+R.Y+0.1);
  Family:=TGPFontFamily.Create;
  FGPFont.GetFamily(Family);
  FontMetric.BaseLine:=Round(FGPFont.GetSize*Family.GetCellAscent(FGPFont.GetStyle)/Family.GetEmHeight(FGPFont.GetStyle))+Round(R.Y-0.1);
  Family.Free;
end;

function TGDIPlusCanvas.CalcTextRange(const Text:string):TGPRectF;
var
  format:TGPStringFormat;
  rect:TGPRectF;
  ranges: TCharacterRange;
  regions:array [0..0] of TGPRegion;
begin
  Result.Width:=0; Result.Height:=0; Result.X:=0; Result.Y:=0;
  if length(Text)=0 then exit;
  NeedGPFont;
  format:=TGPStringFormat.Create(StringFormatFlagsMeasureTrailingSpaces);
  rect.X:=0; rect.Y:=0; rect.Width:=9999999;  rect.Height:=9999999;
  ranges := MakeCharacterRange(0,length(Text));
  format.SetMeasurableCharacterRanges(1,@ranges);
  regions[0]:=TGPRegion.Create;
  FGraphics.MeasureCharacterRanges(text, -1, FGPFont, rect, format, 1, regions);
  regions[0].GetBounds(Result,FGraphics);
  regions[0].Free;
  format.Free;
end;

Function TGDIPlusCanvas.TextSize(const St:String):TPointFloat;
begin
  NeedGPFont;
  if (FontMetric.Rotation mod 90)<>0 then with CalcTextRange(St) do
    Result.x:=Round(Width+X*2-FontMetric.OX)  //Approximation
  else
    Result.x:=Round(CalcTextRange(St).Width);  //Excat Textwidth
  Result.y:=FontMetric.TextHeight;
end;

Function TGDIPlusCanvas.TextWidth(const St:String):Integer;
begin
  Result:=Round(TextSize(St).x);
end;

Function TGDIPlusCanvas.TextHeight(const St:String):Integer;
begin
  Result:=Round(TextSize('').y);
end;

Procedure TGDIPlusCanvas.TextOut(X,Y:Single; const Text:String);
var
  Origin : TGPPointF;
  matrix : TGPMatrix;
  tmpBack: TCanvasBackMode;
begin
  Origin.X:=X; Origin.Y:=Y;
  NeedGPFont;
  matrix:=nil;
  FontMetric.Rotation:=(Round(ITextRotation)+360000000) mod 360; //0..359
  if (FontMetric.Rotation<>0) then begin
    matrix:=TGPMatrix.Create;
    if FGraphics.GetTransform(matrix) = Ok then
       if matrix.RotateAt(FontMetric.Rotation,Origin) = Ok then
          FGraphics.MultiplyTransform(matrix);
  end;

  case TextAlign and (TA_RIGHT or TA_CENTER) of
  TA_RIGHT: Origin.X:=Origin.X-TextWidth(Text);
  TA_CENTER: Origin.X:=Origin.X-(TextWidth(Text) div 2); //avoid half pixels
  end;
  case TextAlign and (TA_BOTTOM or TA_BASELINE) of
  TA_BOTTOM: Origin.Y:=Origin.Y-TextHeight(Text);
  TA_BASELINE: Origin.Y:=Origin.Y-FontMetric.BaseLine;
  end;

  tmpBack:=BackMode;
  if (BackMode=cbmOpaque) then begin
    Brush.Color:=BackColor;
    FillRect(CalcTextRect(Origin,Text));
  end;

  FGPBrush.Free;
  FGPBrush:=TextBrush(Font.Color,Origin,Text);

  Origin.X:=Origin.X-(FontMetric.OX*0.6); //negative Offset
  if (FontMetric.Rotation mod 90)<>0 then Origin.Y:=Origin.Y+FontMetric.OY; //Bug or Feature???
  FGraphics.DrawString(Text,Length(Text),FGPFont,Origin,FGPBrush);

  BackMode:=tmpBack;
  if Assigned(matrix) then begin
    if FGraphics.ResetTransform = Ok then FreeAndNil(matrix);
    FontMetric.Rotation:=0;
  end;

Truly, the GDI+ text function are very strange. But the result with the new code is not bad and you can also use the HTML-Out functions with GDI+:

PicTee1.png (18.16 KiB) Viewed 20199 times

Code: Select all

procedure TForm1.Draw3D1Paint(Sender: TObject; const ARect: TRect);
var
  s:String;
  x,y,h,xp,yp:Integer;
  w:Single;
begin
  x:=10; y:=10;
  with Draw3D1.Canvas do begin
     Brush.Clear;
     h:=TextHeight('-');
     TextOut(x,y,Format('%s TH=%d FH=%d %s',[ClassName,h,Font.Height,Font.Name]));
     h:=h+5;
     y:=y+h;
     s:='XXXXXXXXXXXX█XXXXXXXXXXXXXXX';
     Brush.Color:=clSilver;
     FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
     TextOut(x,y,s); y:=y+h;
     s:='FFFFFFFFFFFF█FFFFFFFFFFFFFFF';
     Brush.Color:=clSilver;
     FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
     TextOut(x,y,s); y:=y+h;
     s:='AAAAAAAAAAAA█AAAAAAAAAAAAAAA';
     Brush.Color:=clSilver;
     FillRect(Rect(x,y,x+TextWidth(s),y+TextHeight(s)));
     TextOut(x,y,s); y:=y+h;
     Font.Style:=[];
     TextOut(x,y,'HtmlText<i>Out</i>: FFFF</b>FF<font color=#FF0000>F</font><font color=#00FF00>F</font><b>HH</b> ',True); y:=y+h;
     TextOut(x,y,'HtmlText<i>Out</i>: AAAA</b>AAAA<b>HH</b> ',True); y:=y+h;
     Font.Style:=[];
     y:=y+20;
     TextAlign:=TA_BASELINE;
     xp:=x; s:='H';
     Brush.Color:=clSilver;
     FillRect(Rect(x,y,x+300,y+1));
     for yp:=6 to 28 do begin
       Font.Height:=-yp;
       TextOut(xp,y,s);
       xp:=xp+TextWidth(s);
     end;
     Font.Height:=-11;
     s:='WWW█WWW';
     //TextAlign:=TA_RIGHT; h:=100;
     //TextAlign:=TA_CENTER; h:=50;
     //TextAlign:=TA_BASELINE;
     //TextAlign:=TA_BOTTOM;
     x:=(ARect.Left+Arect.Height) div 2; y:=y+110;
     Brush.Color:=clWhite;
     Ellipse(x-h,y-h,x+h,y+h);
     w:=0;
     while (w<360) do begin
       xp:=x+Round(h*cos(w/180*PI));
       yp:=y-Round(h*sin(w/180*PI));
       BackColor:=clSilver;
       BackMode:=cbmOpaque;
       RotateLabel(xp,yp,s,w);
       w:=w+45;
     end;
  end;
end;

I hope, I could help you and you can improve your software.

Another problem: Please look to the function TeEngine.TChartAxis.DrawAxisLabel. You define tmpAlign but don't use it. I think, all Axis Labels are drawn with center alignment. The result is not good.

Thanks,
Jens Gr.

[Narcís]

Hello Jens,

Thank you very much for your collaboration and many apologies for the lack of feedback from our side.

This needs to be investigated very carefully as it may provide the desired output but also involve performance regressions. MeasureCharacterRanges is more precise but very slow. We need to investigate if we can make some sort of caching to optimize performance and get the desired rendering output.