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

时间：2009-12-16 22:40:26

标签： delphi winapi

我有一些自定义绘图的代码。基本上它是具有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;

5 个答案:

答案 0 :(得分：9)

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

多年来，Windows已经有了解决这个问题的工具，VCL遗憾地不会包装（并且内部也没有使用它） - 映射模式。 Windows NT引入了transformations，但{16}已经在16位Windows中提供了SetMapMode()。

通过设置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()。
    • 的调用中使用计算出的字符位置数组

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

答案 1 :(得分：2)

处理字体缩放的另一种方法是将其绘制到内存中的位图，然后使用StretchBlt()拉伸到所需的大小。
与之前的答案相同，但实现更清晰。

基本步骤是：

  1. 使用SetMapMode()
    2. 设置MM_ISOTROPIC映射模式
  2. 使用SetWindowExtEx()和SetViewPortExtEx()
    3. 定义坐标映射
  3. 绘制线条和图形
  4. 恢复映射模式
  5. 创建原始大小的位图
  6. 在位图上绘制文字
  7. 创建所需大小的透明位图
  8. 在HALFTONE模式下将带有文字的位图内容复制到StretchBlt()的透明位图
  9. 在表单画布上绘制透明位图，现在包含文本
  10. 销毁两个位图

    11. 接下来是代码，例如从页面顶部开始。

    首先，我在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;

答案 2 :(得分：1)

基于mghie建议改变字符之间的空格，这是我想出来的。我最终没有使用char间距数组，而是使用了SetTextCharacterExtra和SetTextJustification。

SetTextCharacterExtra函数有这个注释：

  

此功能主要支持   与现有的兼容性   应用。新应用程序应该   通常避免调用此函数，   因为它与...不相容   复杂脚本（需要的脚本）   文字塑造;阿拉伯文字是一个   例如。）

     

推荐的方法是   而不是调用此函数和   然后是TextOut，应用程序应该调用   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;

答案 3 :(得分：1)

有测试代码可以比较不同的解决方案 代码将长缩放行的实际宽度输出到font_cmp.csv文件。

Link了解比较的图片

示例代码：

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;

答案 4 :(得分：0)

由 mghie 引入的解决方案适用于图形，但在缩放字体时失败 还有另一种使用相反属性进行缩放的方法：SetWorldTransform。此方法在缩放TrueType字体时效果很好，但在使用GDI绘制图形时失败。

因此我的建议是使用 mghie 的方法切换DC模式以绘制线条，并在绘制文本时使用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;
相关问题
最新问题