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

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

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

我考虑过限制缩放级别 – 现在我有一个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,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,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),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,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;