delphi - 如何在不更改有效文本宽度的情况下绘制缩放文本？

Question

我有一些执行自定义绘图的代码。基本上它是具有所见即所得编辑器的表格填充程序。编辑器允许设置缩放级别。我的标签宽度相对于表单上的其他所有内容跳转到不同大小时遇到​​问题。

我用来输出文本的代码示例如下。我很确定问题与字体大小的变化与其他所有内容的缩放方式不匹配有关。缩放级别必须改变足够大，以便在文本更改之前将字体提升到下一个大小，即使表单上的所有其他内容都随着每次更改而移动几个像素。

这会导致两个不同的问题 - 文本可能看起来很小但有很多空白，或者文本将是两个大的并且与下一个控件重叠。当我有一行完整的文本时，事情看起来真的很糟糕。一个单词标签的变化不足以导致任何问题。

我曾考虑过限制缩放级别 - 现在我有一个以 1% 为增量的滑块。但我看不出任何一组级别比任何其他级别更好。我的表单有多个不同字体大小的标签，它们在不同时间在较短和较长之间跳跃。

MultDiv 函数对结果进行四舍五入。我可以截断这个值以确保我总是更小而不是更长，但这看起来同样糟糕，因为在这些缩放级别下间隙看起来要大得多。

代码注意事项:

这是目前在 Delphi 7 上的。这是我们最后一个没有向前推进的项目，因此欢迎提供与 Delphi 新版本相关的答案。

我们对此进行了调查，我确实看到存在 ExtDrawText 函数。但是，更改为该功能似乎并没有什么不同。

边界框的右侧设置为 0 并且文本绘制时没有剪切，因为我们用于构建表单定义的工具不会跟踪文本的右边界。我们只是在视觉上将其排列到正确的位置。

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;

编辑:

在这里使用 mghie 的答案是我修改后的测试应用程序。设置 MapMode 后，缩放代码消失了。但是，TextOut 函数似乎仍在选择完整的字体大小。除了我不需要自己计算字体的高度之外，文本似乎没有任何变化 - map 模式为我完成了这项工作。

我确实找到了这个网页 "The GDI Coordinate Systems"这非常有用，但它没有解决文本大小问题。

这是我的测试应用程序。它会随着您调整表单大小而调整大小，并绘制了一个网格，因此您可以看到文本的结尾是如何跳动的。

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

根本问题是您试图通过更改 Height 来缩放文本。 .鉴于 Windows API 使用整数坐标系，因此只有某些离散的字体高度是可能的。例如，如果您的字体高 20 像素，缩放值为 100%，那么您基本上只能设置为 5% 倍数的缩放值。更糟糕的是，即使使用 TrueType 字体，也并非所有这些字体都能提供令人满意的结果。

多年来，Windows 已经有了处理这个问题的工具，遗憾的是 VCL 没有包装(并且它也没有真正在内部使用) - 映射模式。 Windows NT 介绍 transformations ，但是 SetMapMode() 已经在 16 位 Windows IIRC 中可用。

通过设置像 MM_HIMETRIC 这样的模式或 MM_HIENGLISH (取决于您以米还是弗隆来衡量)您可以计算字体高度和边界矩形，并且由于像素非常小，因此可以精细地放大或缩小。

通过设置 MM_ISOTROPIC或 MM_ANISOTROPIC在 OTOH 模式下，您可以继续使用相同的字体高度和边界矩形值，并且只要缩放值发生变化，您就可以调整页面空间和设备空间之间的转换矩阵。

SynEdit 组件套件曾经有一个使用 MM_ANISOTROPIC 的打印预览控件(在 SynEditPrintPreview.pas 文件中)。映射模式以允许在不同缩放级别预览可打印文本。如果它仍然在 SynEdit 中或者如果您可以找到旧版本，这可能很有用。

编辑:

为方便起见，使用 Delphi 4 和 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;

第二次编辑:

我对此进行了更多思考，并且我认为对于您的问题，在用户代码中进行缩放实际上可能是实现这一点的唯一方法。

让我们用一个例子来看看它。如果您的文本行宽度为 500 像素，字体高度为 20 像素，缩放系数为 100%，那么您必须将缩放级别增加到 105% 才能获得 525 x 21 的文本行像素大小。对于介于两者之间的所有整数缩放级别，您将拥有此文本的整数宽度和非整数高度。但是文本输出不是这样工作的，你不能设置一行文本的宽度并让系统计算它的高度。因此，唯一的方法是将字体高度强制为 20 像素以进行 100% 到 104% 的缩放，但将字体设置为 21 像素高度以进行 105% 到 109% 的缩放，依此类推。那么对于大多数缩放值，文本将太窄。或者将字体高度设置为 21 像素，缩放比例为 103%，然后文本太宽。

但是通过一些额外的工作，您可以实现每个缩放步骤的文本宽度增加 5 个像素。 ExtTextOut() API 调用将可选的字符来源整数数组作为最后一个参数。我知道的大多数代码示例都没有使用它，但您可以使用它在某些字符之间插入额外的像素以将文本行的宽度拉伸(stretch)到所需的值，或者将字符靠得更近以缩小宽度。它或多或少会像这样:

计算缩放值的字体高度。在设备上下文中选择这种高度的字体。

调用 GetTextExtentExPoint() 用于计算默认字符位置数组的 API 函数。最后一个有效值应该是整个字符串的宽度。

通过将预期宽度除以实际文本宽度来计算这些字符位置的比例值。

将所有字符位置乘以这个比例值，并将它们四舍五入到最接近的整数。根据比例值高于或低于 1.0，这将在关键位置插入额外的像素，或将一些字符移近一些。

在对 ExtTextOut() 的调用中使用计算出的字符位置数组.

这是未经测试的，可能包含一些错误或疏忽，但希望这能让您独立于文本高度平滑地缩放文本宽度。也许为您的应用程序付出努力是值得的？