+5  A: 

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?

mghie
Now you are just showing off :-). Brilliant Code. However, I'm still running into the same problems. I could have really simplified my zoom code if I knew about the MapModes. But when I try it I still see my text sizes jump around. I'm editing my post with my sample app using your code and what I saw in SynEdit.
Mark Elder
There's probably not much you can do once you come to the limits of the Windows text rendering. To smoothly scale the width of a line of text without "jumping" you would need to scale the height in the sub pixel range. I have only ever seen this in DVI viewers, which do their own rendering of glyphs. I will have a look at your code later this evening.
mghie
Your code actually shows the issue even better than mine with some slight changes. If you take out changing the lfEscapement, use a longer string, and keep the left side of the write text constant you can see a stair step effect. OutString := 'foo bar bazfoo bar bazfoo bar bazfoo bar bazfoo bar bazfoo bar bazfoo bar bazabcdefghijklmnopqrstuvwxyaz'; Windows.TextOut(DC, -15000, xy, PChar(OutString), Length(OutString));I don't think I really need sub pixel scaling, but it seems like Windows does not have per pixel scaling with fonts. At least now I know am not missing something easy.
Mark Elder
Now I see what you are talking about with sub pixel. I ran this with one letter and then took a screen shot and zoomed in. With one letter I can see it adjusting by a single pixel. The problem is with that happening for all the letters in the string. Thanks for all your help.
Mark Elder
A: 

Solution, introduced by mghie works well with graphics but fails while scaling fonts.
There are another method of scaling with opposite properties: SetWorldTransform . This method works well while scaling TrueType fonts, but fails when drawing graphics with GDI.

Therefore my suggestion is swithcing DC mode with mghie's method for drawing lines and use SetWorldTransform while painting text. Results not so clear, but looks even better ...

Here is code for OnPaint event handler for example from question text, which uses both methods:

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;
  NewFont: HFONT;
  oldGraphicMode : integer;
  transform : TXForm;
begin

  Canvas.Brush.Style := bsClear;

  SetMapperFlags(DC, 1);

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

  DC := Self.Canvas.Handle;

  // Mode switch for drawing graphics
  OldMode := SetMapMode(DC, MM_ISOTROPIC);
  try
    SetWindowExtEx(DC, PhysicalWidth, PhysicalHeight, nil);
    SetViewportExtEx(DC, Self.Width, Self.Height, nil);
    DrawGrid(Self.Canvas);
  finally
    SetMapMode(DC, OldMode);
  end;

  // Mode switch for text output
  oldGraphicMode := Windows.SetGraphicsMode(DC, GM_ADVANCED);
  try
    //x' = x * eM11 + y * eM21 + eDx,
    transform.eM11 := Width / PhysicalWidth;
    transform.eM21 := 0;
    transform.eDx := 0;
    //y' = x * eM12 + y * eM22 + eDy,
    transform.eM12 := 0;
    transform.eM22 := Height / PhysicalHeight;
    transform.eDy := 0;

    Windows.SetWorldTransform(DC, transform);
    try
      NewFont := CreateFontIndirect(LF);
      try
        OldFont := Windows.SelectObject(DC, NewFont);
        try
          OutputText(Self.Canvas, 3, ShortString);
          OutputText(Self.Canvas, 4, MediumString);
          OutputText(Self.Canvas, 5, LongString);
        finally
          Windows.SelectObject(DC, OldFont);
        end;
      finally
        Windows.DeleteObject(NewFont);
      end;
    finally
      transform.eM11 := 1;
      transform.eM22 := 1;
      Windows.SetWorldTransform(DC, transform);
    end;

  finally
    Windows.SetGraphicsMode(DC, oldGraphicMode);
  end;

end;
ThinkJet
Maybe I am doing something wrong, but I am actually seeing bigger jumps in the width of the string with this code.
Mark Elder
Yes, there are my error while editing post. Odd line with DeleteObject(SelectObject(DC, OldFont)) must be deleted. I corrected the example and remove the line. But now I found solution which promises to be more clean but requires more resources. After testing I post exaple here.
ThinkJet
+1  A: 

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;
ThinkJet
Thanks for the input. I see where that would work but I'm going to go with the solution of adjusting the per letter spacing. This way I still get ClearType fonts.
Mark Elder
Ok, thanks for response. But there are some issues with letter spacing solution: 1. Jumps in font height not eliminated 2. Algorithm of pixel insertion must be very smart to produce good look. 3. Suppose you reach bound between "shrink" and "expand" ... Take attetion that in example at top of page you always select font of same height and scale it with mapping. Really you must select font with scaled height and output text in normal(not mapped) mode. I post another "answer" with OnClick handler, wich illustrates difference between methods.
ThinkJet
+1  A: 

OK based on mghie's suggestion to alter the spaces between the chars here is what I came up with. I didn't end up using the array of char spacing but instead used SetTextCharacterExtra and SetTextJustification.

The SetTExtCharacterExtra function has this note:

This function is supported mainly for compatibility with existing applications. New applications should generally avoid calling this function, because it is incompatible with complex scripts (scripts that require text shaping; Arabic script is an example of this).

The recommended approach is that instead of calling this function and then TextOut, applications should call ExtTextOut and use its lpDx parameter to supply widths.

I may change my code to use that but for now this approach works quite well. Below is my modified function.

const
   LineHeight = 20;

procedure DrawGrid(Output: TCanvas; ZoomLevel: integer);
var
  StartPt: TPoint;
  EndPt: TPoint;

  ZoomedStartPt: TPoint;
  ZoomedEndPt: TPoint;

  ZoomedIncrement: integer;
  LineCount: integer;
  HeaderString: string;
  OutputBox: TRect;
begin
  ZoomedIncrement := MulDiv(LineHeight, ZoomLevel, 100);

  if (ZoomedIncrement = 0) then
    exit;

  Output.Pen.Style := psSolid;
  Output.Pen.Width := 1;


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

  EndPt.X := 1000;
  EndPt.Y := LineHeight;

  LineCount := 0;
  while StartPt.Y < 1000 do
  begin
    StartPt.Y := StartPt.Y + LineHeight;
    EndPt.Y := EndPt.Y + LineHeight;

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

    ZoomedStartPt.X :=  MulDiv(StartPt.X, ZoomLevel, 100);
    ZoomedStartPt.Y :=  MulDiv(StartPt.Y, ZoomLevel, 100);
    ZoomedEndPt.X :=  MulDiv(EndPt.X, ZoomLevel, 100);
    ZoomedEndPt.Y :=  MulDiv(EndPt.Y, ZoomLevel, 100);

    Output.MoveTo(ZoomedStartPt.X, ZoomedStartPt.Y);
    Output.LineTo(ZoomedEndPt.X, ZoomedEndPt.Y);
  end;


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

  EndPt.X := 0;
  EndPt.Y := 1000;



  LineCount := 0;
  while StartPt.X < 1000 do
  begin
    StartPt.X := StartPt.X + LineHeight;
    EndPt.X := EndPt.X + LineHeight;

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

    ZoomedStartPt.X :=  MulDiv(StartPt.X, ZoomLevel, 100);
    ZoomedStartPt.Y :=  MulDiv(StartPt.Y, ZoomLevel, 100);
    ZoomedEndPt.X :=  MulDiv(EndPt.X, ZoomLevel, 100);
    ZoomedEndPt.Y :=  MulDiv(EndPt.Y, ZoomLevel, 100);

    Output.MoveTo(ZoomedStartPt.X, ZoomedStartPt.Y);
    Output.LineTo(ZoomedEndPt.X, ZoomedEndPt.Y);

    if Output.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);


      OutputBox.Left := MulDiv(OutputBox.Left, ZoomLevel, 100);
      OutputBox.Right := MulDiv(OutputBox.Right, ZoomLevel, 100);
      OutputBox.Top := MulDiv(OutputBox.Top, ZoomLevel, 100);
      OutputBox.Bottom := MulDiv(OutputBox.Bottom, ZoomLevel, 100);


      DrawText(Output.Handle, PChar(HeaderString), Length(HeaderString),
        OutputBox, DT_BOTTOM + DT_SINGLELINE + DT_NOPREFIX + DT_CENTER);
    end;
  end;

end;



function CountSpaces(S: string): integer;
var
  i: integer;
begin
  result := 0;
  for i := 1 to Length(S) do
  begin
    if (S[i] = ' ') then
      result := result + 1;
  end;
end;


procedure OutputText(Canvas: TCanvas; LineNumber: integer; CurrentZoomLevel: integer; FontSize: integer; Text: string;
  AdjustChars: boolean = true; AdjustSpaces: boolean = true);
var
  DC: HDC;

  UnzoomedStringWidth: integer;
  UnzoomedFontHeight: integer;

  ZoomedLineHeight: integer;
  ZoomedStringWidth: integer;
  ZoomedFontHeight: integer;
  OutputBox: TRect;

  ExtraPixels: integer;
  StringWidth: integer;
  TextOutSize: TSize;
  TextLength: integer;

  SpacesCount: integer;

  PixelsPerChar: Integer;

  Report: string;

begin
  DC := Canvas.Handle;

  // First find the box where the string would be for unzoomed text
  UnzoomedFontHeight := -MulDiv(FontSize, GetDeviceCaps(Canvas.Handle, LOGPIXELSY), 72);
  Canvas.Font.Height := UnzoomedFontHeight;
  UnzoomedStringWidth := Canvas.TextWidth(Text);

  // Now figure out the zoomed sizes for the font and the box where
  // the string will be drawn
  ZoomedLineHeight := MulDiv(LineHeight, CurrentZoomLevel, 96);
  ZoomedFontHeight := -MulDiv(-UnzoomedFontHeight, CurrentZoomLevel, 96);
  ZoomedStringWidth := MulDiv(UnzoomedStringWidth, CurrentZoomLevel, 96);

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

  Canvas.Font.Height := ZoomedFontHeight;

  TextLength := Length(Text);

  Windows.GetTextExtentPoint32(Canvas.Handle, PChar(Text), TextLength, TextOutSize);
  ExtraPixels := ZoomedStringWidth - TextOutSize.cx;

  PixelsPerChar := Round(ExtraPixels / TextLength);

  // If we let extra push past two pixels in our out we will end up with either
  // letters overlapping or really wide text.  A maximum of 1 pixel adjustment
  // outside the spaces seem to help keep the text looking normal and
  // removes some of the pressure on the spaces adjustment.  Also is needed
  // for short 1 word labels.

  if PixelsPerChar > 1 then
    PixelsPerChar := 1;

  if PixelsPerChar < -1 then
    PixelsPerChar := -1;

  if (PixelsPerChar <> 0) and (AdjustChars = true) then
  begin
    Windows.SetTextCharacterExtra(Canvas.Handle, PixelsPerChar);
    ExtraPixels := ExtraPixels - (PixelsPerChar * TextLength);
  end;

  // What ever is left over do with spaces
  if (ExtraPixels <> 0) and (AdjustSpaces = true) then
  begin
    SpacesCount := CountSpaces(Text);
    Windows.SetTextJustification(Canvas.Handle, ExtraPixels, SpacesCount);
  end;

  Windows.SetTextAlign(Canvas.Handle, TA_LEFT + TA_BASELINE);
  Windows.ExtTextOut(Canvas.Handle, OutputBox.Left, OutputBox.Top, 0, @OutputBox, PChar(Text), TextLength, nil);

  Windows.GetTextExtentPoint32(Canvas.Handle, PChar(Text), TextLength, TextOutSize);


  // Reset these values to 0
  Windows.SetTextCharacterExtra(Canvas.Handle, 0);
  Windows.SetTextJustification(Canvas.Handle, 0, 0);


  Report := 'T=' + IntToStr(ZoomedStringWidth); // Target
  Report := Report + ': A=' + IntToStr(TextOutSize.cx); // Actual
  Windows.TextOut(Canvas.Handle, OutputBox.Right + 30, OutputBox.Top, PChar(Report), Length(Report));
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.';

  PhysicalWidth = 700;

var
  ZoomLevel: integer;
begin
  Canvas.Font.Name := 'Arial';
  ZoomLevel := Round((Self.Width / PhysicalWidth) * 100);
  DrawGrid(Self.Canvas, ZoomLevel);

  OutputText(Self.Canvas, 3, ZoomLevel, 12, ShortString);
  OutputText(Self.Canvas, 4, ZoomLevel, 12, MediumString);
  OutputText(Self.Canvas, 5, ZoomLevel, 12, LongString);
end;
Mark Elder
Big +1 for SetTextCharacterExtra. That's just helped enormously with a similar problem I'm having - thanks!
RichieHindle
A: 

There is test code to compare different solutions.
Code outputs real width of long scaled line to font_cmp.csv file.

Link to picture of comparasion

Example code:

procedure TForm1.Button1Click(Sender: TObject);
const
  LongString = 'Here is something that is really long here is where I see the problem with zooming.';
  PhysicalHeight = 500;
  PhysicalWidth = 400;
var
  bmp             : TBitmap;
  drawCanvas      : TCanvas;
  OldMapMode      : integer;
  OldStretchMode  : integer;
  outHeight       : extended;
  originalStrSize : TSize;
  scaledStrSize   : TSize;
  proposedStrSize : TSize;
  desiredWidth    : integer;
  LF              : TLogFont;
  OldFont         : HFONT;
  NewFont         : HFONT;
  cmpList         : TStringList;
  ratio           : extended;
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(Self.Canvas.Handle, NewFont);
    try
      GetTextExtentPoint32(Self.Canvas.Handle, PChar(LongString), Length(LongString), originalStrSize);
    finally
      Windows.SelectObject(Self.Canvas.Handle, OldFont);
    end;
  finally
    Windows.DeleteObject(NewFont);
  end;

  cmpList := TStringList.Create;
  try

    cmpList.Add(
      'OriginalLength' + ';' +
      'ProperLength'  + ';' +
      'ScaledLength'  + ';' +
      'MappedLength'  + ';' +
      'ScaledLengthDiff' + ';' +
      'MappedLengthDiff'
    );

    for desiredWidth := 1 to 3000 do begin
      // compute desired height
      ratio := desiredWidth / PhysicalWidth;
      outHeight := PhysicalHeight * ratio ;
      if(outHeight < 1) then outHeight := 1;

      LF.lfHeight := round(12*ratio) * (-1);
      NewFont := CreateFontIndirect(LF);
      try
        OldFont := Windows.SelectObject(Self.Canvas.Handle, NewFont);
        try
          GetTextExtentPoint32(Canvas.Handle, PChar(LongString), Length(LongString), scaledStrSize);
        finally
          Windows.SelectObject(Self.Canvas.Handle, OldFont);
        end;
      finally
        Windows.DeleteObject(NewFont);
      end;

      OldMapMode := SetMapMode(Self.Canvas.Handle, MM_ISOTROPIC);
      try
        SetWindowExtEx(Self.Canvas.Handle, PhysicalWidth, PhysicalHeight, nil);
        SetViewportExtEx(Self.Canvas.Handle, desiredWidth, round(outHeight), nil);

        LF.lfHeight := -12;
        NewFont := CreateFontIndirect(LF);
        try
          OldFont := Windows.SelectObject(Self.Canvas.Handle, NewFont);
          try
            GetTextExtentPoint32(Canvas.Handle, PChar(LongString), Length(LongString), proposedStrSize);
          finally
            Windows.SelectObject(Self.Canvas.Handle, OldFont);
          end;
        finally
          Windows.DeleteObject(NewFont);
        end;

      finally
        SetMapMode(Self.Canvas.Handle, OldMapMode);
      end;

      cmpList.Add(
        IntToStr(originalStrSize.cx) + ';' +
        IntToStr(round(ratio * originalStrSize.cx))  + ';' +
        IntToStr(scaledStrSize.cx)  + ';' +
        IntToStr(proposedStrSize.cx)  + ';' +
        IntToStr(round(ratio * originalStrSize.cx - scaledStrSize.cx)) + ';' +
        IntToStr(round(ratio * originalStrSize.cx - proposedStrSize.cx))
      );

    end;
    cmpList.SaveToFile('font_cmp.csv');

  finally
    cmpList.Free;
  end;

end;
ThinkJet