Как я рисую масштабируемый текст, не изменяя эффективную текстовую ширину?

Решение, предложенное mghie , хорошо работает с графикой, но не работает при масштабировании шрифтов.
Есть еще один метод масштабирования с противоположными свойствами: SetWorldTransform . Этот метод хорошо работает при масштабировании шрифтов TrueType, но не работает при рисовании графики с помощью GDI.

Поэтому я предлагаю переключить режим DC с помощью метода mghie для рисования линий и использовать SetWorldTransform при рисовании текста. Результаты не так понятны, но выглядят даже лучше ...

Вот код для обработчика событий OnPaint, например, из текста вопроса, который использует оба метода:

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;

Хорошо, основываясь на предложении Мги изменить промежутки между символами, вот что я придумал. В итоге я не использовал массив интервалов между символами, а вместо этого использовал SetTextCharacterExtra и SetTextJustification.

Функция SetTExtCharacterExtra имеет следующее примечание:

Эта функция поддерживается, в основном, для совместимость с существующим приложения. Новые приложения должны как правило, избегайте вызова этой функции, потому что это несовместимо с сложные сценарии (сценарии, требующие формирование текста; арабская вязь - это Пример этого).

Рекомендуемый подход заключается в том, чтобы вместо того, чтобы вызывать эту функцию и а потом "ТекстОут", заявки должны звонить ExtTextOut и использовать его lpDx параметр чтобы поставлять ширины.

Я могу изменить свой код, чтобы использовать это, но пока этот подход работает достаточно хорошо. Ниже приведена моя модифицированная функция.

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;

Есть тестовый код для сравнения различных решений.
Код выводит реальную ширину длинной масштабируемой строки в файл font_cmp.csv.

Ссылка на картинку сравнения

Пример кода:

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;

Другой способ решения проблемы масштабирования шрифта - закрасить его в растровое изображение в памяти и затем растянуть с помощью StretchBlt() до нужного размера.
. Та же идея, что и в предыдущем ответе, но реализация более ясна.

Базовые шаги:

1. Установите режим отображения MM_ISOTROPIC с помощью SetMapMode()
2. Определите отображение координат с помощью SetWindowExtEx() и SetViewPortExtEx()
3. Draw lines and graphics
4. Restore mapping mode
5. Create bitmap (Создать растровое изображение). с оригинальным размером
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, который теперь содержит текст, на холсте формы
10. Уничтожить обе битовые карты

Далее следует код, например, сверху страницы.

Во-первых, я создаю одну новую функцию для вывода текста для очистки кода в обработчике OnPaint:

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;

А дальше - код для события OnPaint:

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;