我有一些定制绘图代码，基本上是一个WYSIWYG编辑器的表单填充程序。编辑器允许设置缩放级别。我在标签宽度方面存在问题，相对于表单中的其他所有内容，我的标签宽度会跳跃到不同的大小。
下面是我用于输出文本的代码示例。我很确定问题与字体大小的更改不匹配以及与其他所有内容的比例不对应有关。缩放级别必须更改足够才能将字体升级到下一个大小，即使表单上的所有其他内容都随着每次更改移动几个像素。
这导致两个不同的问题 - 文本可以看起来太小，有很多空白空间，或者文本将过大并重叠下一个控件。当我有一行完整的文本时，情况看起来非常糟糕。一个单词的标签不会改变到足以引起任何问题。
我考虑限制缩放级别 - 现在我有一个1％增量的滑块。但我无法看到任何一组级别比其他级别更好。我的表单具有不同字体大小的多个标签，在不同时间内跳转较短或较长的标签。
MultDiv函数对结果进行舍入。我可以截断此值以确保我始终比较小而不是更长，但在这些缩放级别下间隙看起来一样大，看起来同样糟糕。
代码说明：
当前使用的是Delphi 7。这是我们最后一个没有向前发展的项目，因此欢迎与新版本的Delphi相关的答案。
当我们查看时，我看到了ExtDrawText函数存在。然而，更改为该函数似乎没有什么差异。
由于用于构建表单定义的工具无法跟踪文本的右边界，因此边界框的右侧设置为0，并且未剪切文本。我们只是将其视觉上对齐到正确位置。
下面是我用于输出文本的代码示例。我很确定问题与字体大小的更改不匹配以及与其他所有内容的比例不对应有关。缩放级别必须更改足够才能将字体升级到下一个大小，即使表单上的所有其他内容都随着每次更改移动几个像素。
这导致两个不同的问题 - 文本可以看起来太小，有很多空白空间，或者文本将过大并重叠下一个控件。当我有一行完整的文本时，情况看起来非常糟糕。一个单词的标签不会改变到足以引起任何问题。
我考虑限制缩放级别 - 现在我有一个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函数似乎仍然选择完整的字体大小。文本似乎没有改变，除了我不需要自己计算字体的高度-地图模式可以为我完成。
我发现这个网页“GDI坐标系统”非常有用，但它没有涉及文本大小。
这是我的测试应用程序。它会随着您调整窗体大小而进行调整，并绘制出网格，以便您可以看到文本末尾如何跳动。
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;
