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

Question

我有一些代码可以自定义绘图.基本上它是具有WYSIWYG编辑器的表单填充程序.编辑器允许设置缩放级别.我的标签宽度相对于表单上的其他内容跳到不同的大小时出现问题.

我用来输出文本的代码示例如下.我很确定这个问题与字体大小的变化有关,与其他所有内容的缩放程度不相符.缩放级别必须更改足以在文本更改之前将字体提升到下一个大小,即使表单上的其他内容在每次更改时都移动了几个像素.

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

我考虑过限制缩放级别 - 现在我有一个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函数似乎仍然选择完整的字体大小.除了我自己不需要计算字体的高度之外,文本似乎没有任何改变 - 地图模式对我来说也是如此.

我确实找到了这个非常有用的网页"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使用整数坐标系,因此只能使用某些离散字体高度.例如,如果您在比例值为100%时有20像素高的字体,那么您基本上只能设置5%倍数的比例值.更糟糕的是,即使使用TrueType字体,并非所有这些都会产生令人满意的结果.

Windows已经有了处理这个问题的工具多年了,VCL遗憾地没有包装(它也没有内部使用) - 映射模式.Windows NT引入了转换,但SetMapMode()已经在16位Windows中提供了IIRC.

通过设置类似的模式MM_HIMETRIC或MM_HIENGLISH(取决于您是以米还是弗隆测量),您可以计算字体高度和边界矩形,并且因为像素非常小,所以可以精细地放大或缩小.

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

SynEdit组件套件曾经有一个打印预览控件(在SynEditPrintPreview.pas文件中),它使用MM_ANISOTROPIC映射模式允许以不同的缩放级别预览可打印文本.如果它仍然在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乘21的文本行像素大小.对于中间的所有整数缩放级别,您将具有此文本的整数宽度和非整数高度.但是文本输出不能以这种方式工作,您不能设置文本行的宽度并让系统计算它的高度.因此,唯一的方法是将字体高度强制为20像素以进行100%到104%的缩放,但设置高度为21像素的字体为105%到109%缩放,依此类推.然后,对于大多数缩放值,文本将太窄.或者将字体高度设置为21像素,从103%缩放开始,然后使用文本太宽.

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

• 计算缩放值的字体高度.在设备上下文中选择此高度的字体.
• 调用GetTextExtentExPoint()API函数来计算默认字符位置的数组.最后一个有效值应该是整个字符串的宽度.
• 通过将预期宽度除以实际文本宽度来计算这些字符位置的比例值.
• 将所有字符位置乘以此比例值,并将它们四舍五入为最接近的整数.根据比例值高于或低于1.0,这将在战略位置插入额外的像素,或者将一些角色移近一些.
• 在调用中使用计算出的字符位置数组ExtTextOut().

这是未经测试的,可能包含一些错误或疏忽,但希望这可以让您平滑地缩放文本宽度,与文本高度无关.也许你的申请值得付出努力？