How do I draw zoomed text without changing effective text width?

Question

I have some code that does custom drawing. Basically it is form fill program that has a WYSIWYG editor. The editor allows a zoom level to be set. I am having problems with the width of my labels jumping to different sizes relative to everything else on the form.

An example of the code I am using to output the text is below. I'm pretty sure the problem is related to the change in font size not matching up with how everything else scales. The zoom level must change by enough to bump the font up to the next size before the text changes, even though everything else on the form is moving by a few pixels with every changes.

This leads to two different problems - the text can either look way to small with lots of white space, or the text will be two large and overlap the next control. Things look really bad when I have a full line of text. A one word label does not change enough to cause any problems.

I have thought about limiting the zoom levels - right now I have a slider in 1% increments. But I can't see that any one set of levels is better than any other. My forms have multiple labels in different font sizes that jump between shorter and longer at different times.

The MultDiv function rounds the result. I could truncate this value to make sure I am always smaller versus longer, but that looks just as bad because the gaps look that much larger at those zoom levels.

Notes on the code:

This is currently on Delphi 7. This is our last project that has not moved forward, so answers related to newer versions of Delphi are welcome.

We looking into this I did see that a ExtDrawText function exists. However, changing to that function did not seem to make a difference.

The right of the bounding box is set to 0 and the text is drawn with no clipping because the tool that we use to build the form definition does not keep track of the right boundary of the text. We just visually line it up to the correct location.

procedure OutputText(Canvas: TCanvas; LineNumber: integer; CurrentZoomLevel: integer; FontSize: integer; Text: string);
const
  FormatFlags = DT_BOTTOM + DT_SINGLELINE + DT_NOPREFIX + DT_LEFT + DT_NOCLIP;
var
  OutputBox: TRect;
  ZoomedLineHeight: integer;
begin
  ZoomedLineHeight := MulDiv(UnZoomedLineHeight, CurrentZoomLevel, 96);
  Canvas.Font.Height := -MulDiv(FontSize, CurrentZoomLevel, 96);

  OutputBox.Left := ZoomedLineHeight;
  OutputBox.Right := 0;
  OutputBox.Top := (LineNumber * ZoomedLineHeight);
  OutputBox.Bottom := OutputBox.Top + ZoomedLineHeight;

  DrawText(Canvas.Handle, PChar(Text), length(Text), OutputBox, FormatFlags);
end;

Edit:

Using mghie's answer here is my modified test app. The zooming code is gone with setting the MapMode. However, the TextOut function still seems to be picking a full font size. Nothing seem to have changed for the text other than I don't need to calculate the hight of the font myself - the map mode does that for me.

I did find this webpage "The GDI Coordinate Systems" that was very useful, but it didn't address text size.

Here is my test app. It is resizing as you resize the form and has a grid drawn so you can see how the end of the text jumps around.

procedure DrawGrid(Canvas: TCanvas);
var
  StartPt: TPoint;
  EndPt: TPoint;
  LineCount: integer;
  HeaderString: string;
  OutputBox: TRect;
begin
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Width := 1;
  StartPt.X := 0;
  StartPt.Y := LineHeight;
  EndPt.X := Canvas.ClipRect.Right;
  EndPt.Y := LineHeight;

  LineCount := 0;
  while (StartPt.Y < Canvas.ClipRect.Bottom) do
  begin
    StartPt.Y := StartPt.Y + LineHeight;
    EndPt.Y := EndPt.Y + LineHeight;

    Inc(LineCount);
    if LineCount mod 5 = 0 then
      Canvas.Pen.Color := clRed
    else
      Canvas.Pen.Color := clBlack;

    Canvas.MoveTo(StartPt.X, StartPt.Y);
    Canvas.LineTo(EndPt.X, EndPt.Y);
  end;

  StartPt.X := 0;
  StartPt.Y := 2 * LineHeight;

  EndPt.X := 0;
  EndPt.Y := Canvas.ClipRect.Bottom;

  LineCount := 0;
  while StartPt.X < Canvas.ClipRect.Right do
  begin
    StartPt.X := StartPt.X + LineHeight;
    EndPt.X := EndPt.X + LineHeight;

    Inc(LineCount);
    if LineCount mod 5 = 0 then
      Canvas.Pen.Color := clRed
    else
      Canvas.Pen.Color := clBlack;

    Canvas.MoveTo(StartPt.X, StartPt.Y);
    Canvas.LineTo(EndPt.X, EndPt.Y);

    if Canvas.Pen.Color = clRed then
    begin
      HeaderString := IntToStr(LineCount);
      OutputBox.Left := StartPt.X - (4 * LineHeight);
      OutputBox.Right := StartPt.X + (4 * LineHeight);
      OutputBox.Top := 0;
      OutputBox.Bottom := OutputBox.Top + (LineHeight * 2);
      DrawText(Canvas.Handle, PChar(HeaderString), Length(HeaderString),
        OutputBox, DT_BOTTOM + DT_SINGLELINE + DT_NOPREFIX + DT_CENTER);
    end;
  end;

end;

procedure OutputText(Canvas: TCanvas; LineNumber: integer; Text: string);
const
  FormatFlags = DT_BOTTOM + DT_SINGLELINE + DT_NOPREFIX + DT_LEFT + DT_NOCLIP;
var
  OutputBox: TRect;
begin
  OutputBox.Left := LineHeight;
  OutputBox.Right := 0;
  OutputBox.Top := (LineNumber * LineHeight);
  OutputBox.Bottom := OutputBox.Top + LineHeight;
  Windows.TextOut(Canvas.Handle, OutputBox.Left, OutputBox.Top, PChar(Text), Length(Text));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := false;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Invalidate;
end;

procedure TForm1.FormPaint(Sender: TObject);
const
  ShortString = 'Short';
  MediumString = 'This is a little longer';
  LongString = 'Here is something that is really long here is where I see the problem with zooming.';

  PhysicalHeight = 500;
  PhysicalWidth = 400;
var
  DC: HDC;
  OldMode, i, xy: integer;
  LF: TLogFont;
  OldFont: HFONT;

begin

  Canvas.Brush.Style := bsClear;

  FillChar(LF, SizeOf(TLogFont), 0);
  LF.lfOutPrecision := OUT_TT_ONLY_PRECIS;
  LF.lfFaceName := 'Arial';
  LF.lfHeight := -12;

  DC := Self.Canvas.Handle;
  OldMode := SetMapMode(DC, MM_ISOTROPIC);
  // OldMode := SetMapMode(DC, MM_HIMETRIC);

  SetWindowExtEx(DC, PhysicalWidth, PhysicalHeight, nil);
  SetViewportExtEx(DC, Self.Width, Self.Height, nil);

  try
    OldFont := Windows.SelectObject(DC, CreateFontIndirect(LF));

    DrawGrid(Self.Canvas);
    OutputText(Self.Canvas, 3, ShortString);
    OutputText(Self.Canvas, 4, MediumString);
    OutputText(Self.Canvas, 5, LongString);

    DeleteObject(SelectObject(DC, OldFont));
  finally
    SetMapMode(DC, OldMode);
  end;

end;

Answer 1

The fundamental problem is that you try to zoom the text by changing its Height. Given that the Windows API uses an integer coordinate system it follows that only certain discrete font heights are possible. If for example you have a font 20 pixels high at a scale value of 100%, then you can basically set only scale values that are multiples of 5%. Worse than that, even with TrueType fonts not all of those will give pleasing results.

Windows has had a facility to deal with this for years, which the VCL sadly doesn't wrap (and which it doesn't really make use of internally, either) - mapping modes. Windows NT introduced transformations, but SetMapMode() has been available in 16 bit Windows already IIRC.

By setting a mode like MM_HIMETRIC or MM_HIENGLISH (depending on whether you measure in meters or furlongs) you can calculate the font height and the bounding rectangle, and because pixels are very small it will be possible to finely zoom in or out.

By setting the MM_ISOTROPIC or MM_ANISOTROPIC modes OTOH you can keep using the same values for font height and bounding rectangle, and you would instead adjust the transformation matrix between page-space and device-space whenever the zoom value changes.

The SynEdit component suite used to have a print preview control (in the SynEditPrintPreview.pas file) that used the MM_ANISOTROPIC mapping mode to allow preview of the printable text at different zoom levels. This may be useful as an example if it's still in SynEdit or if you can locate the old versions.

Edit:

For your convenience a little demo, tested with Delphi 4 and Delphi 2009:

procedure TForm1.FormCreate(Sender: TObject);
begin
  ClientWidth := 1000;
  ClientHeight := 1000;
  DoubleBuffered := False;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  DC: HDC;
  OldMode, i, xy: integer;
  LF: TLogFont;
  OldFont: HFONT;
begin
  Canvas.Brush.Style := bsClear;

  FillChar(LF, SizeOf(TLogFont), 0);
  LF.lfOutPrecision := OUT_TT_ONLY_PRECIS;
  LF.lfFaceName := 'Arial';

  DC := Canvas.Handle;
  OldMode := SetMapMode(DC, MM_HIMETRIC);
  try
    SetViewportOrgEx(DC, ClientWidth div 2, ClientHeight div 2, nil);
    Canvas.Ellipse(-8000, -8000, 8000, 8000);

    for i := 42 to 200 do begin
      LF.lfHeight := -5 * i;
      LF.lfEscapement := 100 * i;
      OldFont := Windows.SelectObject(DC, CreateFontIndirect(LF));
      xy := 2000 - 100 * (i - 100);
      Windows.TextOut(DC, -xy, xy, 'foo bar baz', 11);
      DeleteObject(SelectObject(DC, OldFont));
    end;
  finally
    SetMapMode(DC, OldMode);
  end;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Invalidate;
end;

Second Edit:

I thought a bit more about this, and I think that for your problem doing the scaling in user code may actually be the only way to implement this.

Let's look at it with an example. If you have a line of text that would be 500 pixels wide with a font height of 20 pixels at a zoom factor of 100%, then you would have to increase the zoom level to 105% to get a line of text with 525 by 21 pixels size. For all integer zoom levels in between you would have an integer width and a non-integer height of this text. But text output doesn't work this way, you can't set the width of a line of text and have the system compute the height of it. So the only way to do it is to force the font height to 20 pixels for 100% to 104% zoom, but set a font of 21 pixels height for 105% to 109% zoom, and so on. Then the text will be too narrow for most of the zoom values. Or set the font height to 21 pixels starting with 103% zoom, and live with the text being too wide then.

But with a little additional work you can achieve the text width incrementing by 5 pixels for every zoom step. The ExtTextOut() API call takes an optional integer array of character origins as the last parameter. Most code samples I know don't use this, but you could use it to insert additional pixels between some characters to stretch the width of the line of text to the desired value, or to move characters closer together to shrink the width. It would go more or less like this:

• Calculate the font height for the zoom value. Select a font of this height into the device context.
• Call the GetTextExtentExPoint() API function to calculate an array of default character positions. The last valid value should be the width of the whole string.
• Calculate a scale value for those character positions by dividing the intended width by the real text width.
• Multiply all character positions by this scale value, and round them to the nearest integer. Depending on the scale value being higher or lower than 1.0 this will either insert additional pixels at strategic positions, or move some characters closer together.
• Use the calculated array of character positions in the call to ExtTextOut().

This is untested and may contain some errors or oversights, but hopefully this would allow you to smoothly scale the text width independently of the text height. Maybe it's worth the effort for your application?

Answer 2

Another way to deal with font scaling is to paint it to in-memory bitmap and then stretch with StretchBlt() to desired size.
Same idea as in previous answer, but realization are more clear.

Base steps is:

1. Set MM_ISOTROPIC mapping mode with SetMapMode()
2. Define coordinate mappings with SetWindowExtEx() and SetViewPortExtEx()
3. Draw lines and graphics
4. Restore mapping mode
5. Create bitmap with original size
6. Draw text on bitmap
7. Create transparent bitmap with desired size
8. Copy content of bitmap with text to transparent bitmap with StretchBlt() in HALFTONE mode
9. Draw transparent bitmap, which contains text now, on form's canvas
10. Destroy both bitmaps

Next is code for example from top of page.

Firstly, I create one new function for text output to cleanup code in OnPaint handler:

procedure DrawTestText(drawCanvas : TCanvas);
    const
      ShortString = 'Short';
      MediumString = 'This is a little longer';
      LongString = 'Here is something that is really long here is where I see the problem with zooming.';
    var
      LF             : TLogFont;
      OldFont        : HFONT;
      NewFont        : HFONT;
    begin

      FillChar(LF, SizeOf(TLogFont), 0);
      LF.lfOutPrecision := OUT_TT_ONLY_PRECIS;
      LF.lfFaceName := 'Arial';
      LF.lfHeight := -12;
      LF.lfQuality := PROOF_QUALITY;

      NewFont := CreateFontIndirect(LF);
      try
        OldFont := Windows.SelectObject(drawCanvas.Handle, NewFont);
        try
          OutputText(drawCanvas, 3, ShortString);
          OutputText(drawCanvas, 4, MediumString);
          OutputText(drawCanvas, 5, LongString);
        finally
          Windows.SelectObject(drawCanvas.Handle, OldFont);
        end;
      finally
        Windows.DeleteObject(NewFont);
      end;

    end;

And next is code for OnPaint event:

procedure TForm1.FormPaint(Sender: TObject);
const
  PhysicalHeight = 500;
  PhysicalWidth = 400;
var
  bmp            : TBitmap;
  bufferBitmap   : TBitmap;
  drawCanvas     : TCanvas;
  OldMapMode     : integer;
  OldStretchMode : integer;
  outHeight      : extended;
begin

  // compute desired height
  outHeight := PhysicalHeight * (ClientWidth / PhysicalWidth) ;

  // 1. Set MM_ISOTROPIC mapping mode with SetMapMode()
  OldMapMode := SetMapMode(Self.Canvas.Handle, MM_ISOTROPIC);
  try
    // 2. Define coordinate mappings with SetWindowExtEx() and SetViewPortExtEx()
    SetWindowExtEx(Self.Canvas.Handle, PhysicalWidth, PhysicalHeight, nil);
    SetViewportExtEx(Self.Canvas.Handle, Self.Width, round(outHeight), nil);
    SelectClipRgn(Self.Canvas.Handle, CreateRectRgn(0,0, Width, round(outHeight)));

    // 3. Draw lines and graphics
    DrawGrid(Self.Canvas);

  finally
    // 4. Restore mapping mode
    SetMapMode(Self.Canvas.Handle, OldMapMode);
  end;

  // 5. Create bitmap with original size
  bmp := TBitmap.Create;
  try
    bmp.Transparent := false;
    bmp.Width := PhysicalWidth;
    bmp.Height := PhysicalHeight;

    drawCanvas := bmp.Canvas;
    drawCanvas.Font.Assign(Self.Canvas.Font);
    drawCanvas.Brush.Assign(Self.Canvas.Brush);
    drawCanvas.Pen.Assign(Self.Canvas.Pen);

    drawCanvas.Brush.Style := bsSolid;
    drawCanvas.Brush.Color := Color;
    drawCanvas.FillRect(Rect(0,0,PhysicalWidth, PhysicalHeight));

    // 6. Draw text on bitmap
    DrawTestText(drawCanvas);

    // 7. Create transparent bitmap with desired size
    bufferBitmap := TBitmap.Create;
    try
      bufferBitmap.PixelFormat := pfDevice;
      bufferBitmap.TransparentColor := Color;
      bufferBitmap.Transparent := true;
      bufferBitmap.Width := ClientWidth;
      bufferBitmap.Height := round(outHeight);
      bufferBitmap.Canvas.Brush.Style := bsSolid;
      bufferBitmap.Canvas.Brush.Color := Color;
      bufferBitmap.Canvas.FillRect(Rect(0,0,bufferBitmap.Width, bufferBitmap.Height));

      // 8. Copy content of bitmap with text to transparent bitmap with StretchBlt() in HALFTONE mode
      OldStretchMode := SetStretchBltMode(bufferBitmap.Canvas.Handle, HALFTONE);
      try
        SetBrushOrgEx(bufferBitmap.Canvas.Handle, 0, 0, nil);
        StretchBlt(
          bufferBitmap.Canvas.Handle, 0, 0, bufferBitmap.Width, bufferBitmap.Height,
          drawCanvas.Handle,          0, 0, PhysicalWidth,      PhysicalHeight,
          SRCCOPY
        );

      finally
        SetStretchBltMode(bufferBitmap.Canvas.Handle, oldStretchMode);
      end;

      // 9. Draw transparent bitmap, which contains text now, on form's canvas
      Self.Canvas.Draw(0,0,bufferBitmap);

      // 10. Destroy both bitmaps
    finally
      bufferBitmap.Free;
    end;

  finally
    bmp.Free;
  end;

end;