У меня есть некоторый код, который делает пользовательский рисунок. По сути, это программа для заполнения форм с редактором 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, похоже, по-прежнему выбирает полный размер шрифта. Кажется, что для текста ничего не изменилось, кроме того, что мне самому не нужно вычислять высоту шрифта - режим карты делает это для меня.
Я нашел эту веб-страницу "Системы координат 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;