Как в firemonkey масштабировать прямоугольник

Bitmap DrawLine

— создать битмап, рисовать на нем, не делая его видимым.

— нашлепать на канву панели подготовленный битмап.

На деле не получается нарисовать линию на битмапе. Т.е после процедуры Draw2 прожимаю процедуру Draw — получаю на панели красный прямоугольник битмапа без нарисованной линии.

Посоветуйте чего-нибуть, спасибо!

 //BITMAP Bm:= TBitmap.Create; bm.Width:= round (Panel.Width/2); bm.Height:= round (Panel.Height/2); bm.Canvas.BeginScene(); bm.Canvas.Clear(TAlphacolorrec.Red); //($FF484848); bm.Canvas.EndScene; procedure TChart.Draw2; var A,B:TPointF; begin A:=TPointF.Create(0,0); B:=TPointF.Create(200, 200); bm.Canvas.BeginScene(); bm.Canvas.DrawLine(A,B,1); bm.Canvas.EndScene; end; procedure TChart.Draw; var A: TPointF; R: TRectF; begin A.X:= Panel.Position.X+3; A.Y:= Panel.Position.Y+3; R:= TRectF.Create(A, bm.Width , bm.Height); panel.Canvas.BeginScene(); Panel.Canvas.DrawBitmap(bm,r,r, 20); panel.Canvas.EndScene; end;

Небольшой обмен опытом. О размере текста, TTextLaout.

Функция для расчета размера прямоугольника, занимаемого однострочным текстом.

Параметры:

Text — Текст
Font — Шрифт с которым будет выводиться текст
Size — если 0, то Font.Size будет использоваться из Font, иначе из данного параметра

Исходный код:

uses System.Types, FMX.Types, FMX.Graphics, FMX.TextLayout, System.Math, System.SysUtils; function CalcTextSize(Text: string; Font: TFont; Size: Single = 0): TSizeF; var TextLayout: TTextLayout; begin TextLayout := TTextLayoutManager.DefaultTextLayout.Create; try TextLayout.BeginUpdate; try TextLayout.Text := Text; TextLayout.MaxSize := TPointF.Create(9999, 9999); TextLayout.Font.Assign(Font); if not SameValue(0, Size) then begin TextLayout.Font.Size := Size; end; TextLayout.WordWrap := False; TextLayout.Trimming := TTextTrimming.None; TextLayout.HorizontalAlign := TTextAlign.Leading; TextLayout.VerticalAlign := TTextAlign.Leading; finally TextLayout.EndUpdate; end; Result.Width := TextLayout.Width; Result.Height := TextLayout.Height; finally TextLayout.Free; end; end;

function FontSizeForBox (Text: string; Font: TFont; Width, Height: Single; MaxFontSize: Single = cMaxFontSize): Integer;

Функция возвращающая максимально возможный размер шрифта, для текста вписанного в заданный прямоугольник.

Параметры:

Text — Текст
Font — Шрифт с которым будет выводиться текст
Width, Height — Ширина и высота прямоугольника
MaxFontSize — Максимально возможный размер шрифта

Исходный код:

uses System.Types, FMX.Types, FMX.Graphics, FMX.TextLayout, System.Math, System.SysUtils; const cMaxFontSize = 512; function FontSizeForBox(Text: string; Font: TFont; Width, Height: Single; MaxFontSize: Single = cMaxFontSize): Integer; var Size, Max, Min, MaxIterations: Integer; Current: TSizeF; begin Max := Trunc(MaxFontSize); Min := 0; MaxIterations := 20; repeat Size := (Max + Min) div 2; Current := CalcTextSize(Text, Font, Size); if ((Abs(Width - Current.Width) < 1) and (Width >= Current.Width)) and ((Abs(Height - Current.Height) < 1) and (Height >= Current.Height)) then break else if (Width < Current.Width) or (Height < Current.Height) then Max := Size else Min := Size; Dec(MaxIterations); until MaxIterations = 0; Result := Size; end;

Также данные функции можно найти в этом юните

Разное от программиста.

В Delphi XE3 у Firemonkey появилась возможность стилизовать неклиентскую область окон приложения. Для этого используются новые имена стилей: для Windows это windowborderstyle и toolwindowstyle, для Mac OS используется единственный стиль macborderstyle. Информации, как создать такие стили нет, во всяком случае я не нашел, поэтому всё что будет написано дальше является результатом исследования кода класса TWindowBorder и его потомков под каждую платформу. В общем, можно сказать, что создать собственный стиль неклиентской области дело довольно простое. Стиль подразумевает наличие некоторых предопределенных элементов ( например ‘client’ отвечает за клиентскую область окна, а ‘title’ за его текстовый заголовок ) из которых формируется внешний вид окна. Так же имя элемента стиля отвечает за обозначение действия какой-либо области окна. Например элементы c именем стиля ‘left’ и ‘right’ отвечают за изменение горизонтального размера окна, а ‘caption’ за его перемещение ( элементов с одинаковым именем стиля может быть несколько, что в результате даст несколько зон отвечающих за одно и то же действие ) То есть при клике на этих элементах будет выполняться соответствующее им действие. В общем, кто имел опыт работы с WinAPI, в части обработки оконных сообщений, наверняка провели параллель с такой вещью, как HITTEST, и оказались правы – механизм работает один-в-один. Это был блеск. Теперь о нищете.

Нищета

Воодушевившись открывшимися новыми возможностями я решил сделать стиль имитирующий окна Mac OS X Leon. За основу был взят незамысловатый скриншот:

и еще несколько изображений окон, где присутствовали кнопки в заголовке окна. Я не ставил себе целью сделать сразу полнофункциональный стиль, для начала хотелось добиться схожести с оригиналом. Вооружившись дизайнером стилей и в очередной раз убедившись, что пользоваться оным невозможно, было решено дизайнить стиль прямо на форме ( ведь любой стиль это просто набор компонентов ). Затем с формы стиль был скопирован в файл macosx.style и загружен в компонент класса TStyleBook, который был назначен форме. В редакторе стилей созданный стиль выглядел вот так:

Сглаживания на кнопке нет т.к. делал я все под Windows XP, а у Firemonkey на этой ОC сглаживание не работает ( работало до Delphi XE2 Update 4 hotfix 1, но хотфиксом его сломали да так и не починили ). Для создания эффекта тени пришлось генерировать картинку в GIMP т.к. стандартный эффект TShadowEffect такую тень отрисовать не способен ( при значении свойства Softness равном единице тень уже имеет видимую глазу структуру, а при значениях больше единицы и вовсе превращается в клетчатое пятно ). Но с картинкой возникает проблема. При изменении размера окна тень должна растягиваться без артефактов поэтому просто масштабировать картинку нельзя, её нужно делить на области: четыре имеющих постоянный размер ( расположены в углах ), две растягивающиеся горизонтально и две растягивающие вертикально. Итого получается восемь частей. Каждую такую часть можно было представить компонентом TImage в который был бы загружен файл соответствующей части изображения. Однако, в Delphi XE3, для поддержки растровых стилей Firemonkey, появился класс TSubImage способный отрисовывать указанную область изображения на которое он ссылается. Это удобнее, чем делать множество файлов. Но, этот класс не доступен в дизайнере, поэтому мне пришлось установить в IDE пакет регистрирующий его. В общем, после некоторого непредвиденного траха с пакетом, тень была готова. Заголовок с кнопкой и клиенсткую область сделать труда не составило. Хотя нет, подобрать градиент для кнопки было сложно т.к. элементы выделения ( белые кружочки для изменения размеров ) полностью перекрывали маленькую кнопку и изменяющийся градиент было не видно 🙂 В результате схожесть не попиксельная, но довольно близка к оригиналу. Итак, стиль готов, первый запуск:

styledwindowblackshadow

Легкое недоумение. Пробую максимизировать окно, оно максимизируется так, как будто тень является клиентской областью т.е. я вижу не распахнутую на весь экран клиентскую область, а клиентскую область в окружении черной рамки. Хорошо, с максимизацией разберемся как нибудь позже, но почему тень не прозрачная… Я же помню, что у меню были прозрачные тени. Ищу в файле стилей стиль для меню ( menuviewstyle ). Вижу, что тень сделана с помощью эффекта TShadowEffect, но место под неё зарезервировано с помощью свойств Margin и Padding у элементов стиля. Попробовал и я у своей тени выставить отрицательный Padding, вот что из этого вышло:

Тень совсем пропала, а кроме этого на каждое изменение размеров окна генерируется четыре исключительных ситуации EZeroDivide. В общем трюк не сработал. Начал смотреть, что же там происходит под капотом модуля FMX.Platform.Win отвечающем за взаимодействие с платформой Windows. А там все печально. Оказалось, что по изображению полученному отрисовкой стиля формируется регион ( регион в терминологии Win32 ) и назначается окну. Всё, прощай прозрачная тень, прощайте сглаженные уголки окна и да здравствуют зазубрины 🙁 Но, как же, тогда отрисовывается тень у меню? А для меню используются композитные окна ( см. TFrom.Transparency ). В общем, тоска зеленая 🙁

Плавное масштабирование текста

Масштабирование текста – задача не столь тривиальная, как может показаться с первого взгляда. При простом изменении размера шрифта мы не можем получить плавного и пропорционального изменения ширины текста. Изменения происходят «скачкообразно», что сильно мешает в разработке разного рода редакторов, графиков, диаграмм, везде, где используется масштабирование.

Как пример. Разрабатывал редактор печатей. В силу специфики предметной области, работа ведется с «микроскопическими» шрифтами, размер у которых и дробный, и чрезвычайно мелкий. Без масштаба не обойтись. Однако, если при максимальном масштабе выставили все тексты как надо, сделали выравнивание, и все красиво, то при возвращении в «нормальный» масштаб, все форматирование может «полететь».

При большом масштабе логотип справа выглядит хорошо. В процессе уменьшения масштаба периодически возникает ситуация, представленная на рисунке слева – надписи «расползаются».

Надпись состоит из двух частей. Слева видим как-бы слитный текст, выглядящий как единое целое. Но при уменьшении масштаба между надписями ощутимо возникает пробел.
Функция масштаба в таких проектах – вещь крайне принципиальная. И то, что сделали при большом масштабе, должно выглядеть также при любом масштабе. Никакие «малые» сдвиги и погрешности недопустимы.

Тестовое приложение

Для проверки методов масштаба сделаем небольшое приложение. Исходник представлен в архиве.

Вверху панель с органами управления. Включая ползунок с масштабом и выбор метода масштабирования в выпадающем списке;
Все функции масштаба имеют следующий тип:

 TxDrawZoomFunc = function (ACanvas : TCanvas; // где рисуем текст ARect : TRect; // область рисования AZoom, ASize : double;// масштаб, размер шрифта AText : string // текст для отрисовки ) : boolean; // результат операции

Функции регистрируются вместе с названием в списке строк. Именно он и представлен в выпадающем списке: GDrawZoomFuncList: Tstrings = nil;
Чтобы видеть — продергивается ли текст, и насколько продергивается, рисуем сетку, зависящую от масштаба;
Вместе с текстом рисуется «расчетный» прямоугольник, который вычисляется как область текста при нормальном размере шрифта, помноженную на масштаб:

//****************************************************************************** // Получить расчетный прямоугольник текста с учетом масштаба //****************************************************************************** function DrawZoomCalcRect (ACanvas : TCanvas; ARect : TRect; AZoom, ASize : double; AText : string) : TRect; var siz : TSize; begin //-- шрифт в первозданном виде, без масштаба --------------------------------- ACanvas.Font.Height := -trunc(ASize * ACanvas.Font.PixelsPerInch/72); //-- получить прямоугольник области текста в его первозданном виде ----------- GetTextExtentPoint32(ACanvas.Handle,PWideChar(AText),Length(AText), siz); //---------------------------------------------------------------------------- // применяем масштаб, получаем расчетный прямоугольник для текста, // каким он должен быть после масштабирования //---------------------------------------------------------------------------- result := ARect; result.Right := result.Left + round (AZoom * siz.Width); result.Bottom := result.Top + round (AZoom * siz.Height); end;

Во всех методах масштаба рассчитывается глобальная переменная GDiffWidth: extended. Это отношение расчетной ширины к получившейся. Нужно для анализа результатов тестирования.

Используется ряд вспомогательных функций:

//****************************************************************************** // ширина и высота прямоугольника //****************************************************************************** function WidthRect (ARect : TRect) : Integer; begin result := ARect.Right - ARect.Left; end; function HeightRect (ARect : TRect) : Integer; begin result := ARect.Bottom - ARect.Top; end; //****************************************************************************** // Проверить валидность осмновных параметров отрисовки //****************************************************************************** function CheckParamsValid (ACanvas : TCanvas; ARect : TRect; AObject : TObject; AObjChecked : boolean = true) : boolean; begin result := (ACanvas <> nil) and ((not AObjChecked) or (AObject <> nil)) and (WidthRect (ARect) > 0) and (HeightRect (ARect)>0); end; //****************************************************************************** // Создать битмап с размерами ARect //****************************************************************************** function CreateBmpRect (ARect : TRect) : TBitmap; begin result := TBitmap.Create; result.Width := abs (WidthRect (ARect)); result.Height := abs (HeightRect (ARect)); end;

Метод 1 «В лоб». Дробный размер шрифта

Если решать проблему «в лоб», то напрашивается такой способ: менять высоту шрифта в зависимости от масштаба. Для этого подойдет такой параметр, как Font.Height. Это высота шрифта в пикселях, и по логике вещей, это должно привести к плавному изменению масштаба.

ASize – размер шрифта, который может быть дробным
AZoom – масштаб.

1 дюйм = 25.4 мм = 72 пункта

Таким образом, первая функция масштабирования выглядит следующим образом

//****************************************************************************** // Масштаб "в лоб" // 1 дюйм = 25.4 мм = 72 пункта //****************************************************************************** function DrawZoomTextSimple (ACanvas : TCanvas; ARect : TRect; AZoom, ASize : double; AText : string) : boolean; var rct : TRect; begin result := CheckParamsValid(ACanvas,ARect,nil,false) and (AText<>''); if not result then exit; rct := DrawZoomCalcRect(ACanvas, ARect, AZoom, ASize, AText); with Acanvas do begin Pen.Color := clGreen; Pen.Width := 1; Rectangle(rct); Font.Height := -trunc(AZoom * ASize * Font.PixelsPerInch / 72); TextOut (ARect.Left, ARect.Top, AText); GDiffWidth := WidthRect(rct) / TextWidth(AText); end; end;

Результат виден на рисунке.

Если слева двойка краем четко расположена на серой линии, то при незначительном изменении масштаба на правом рисунке, серая линия пересекает двойку по центру.

Метод 2 «Мировые координаты» SetGraphicsMode

Понятно, что топором блоху не подковать. Надо использовать инструментарий, который предоставляет Windows.

function SetGraphicsMode(hdc: HDC; iMode: Integer): Integer;

DC Дескриптор контекста устройства.
iMode Определяет графический режим. Этот параметр может быть одним из нижеследующих значений:
GM_COMPATIBLE: Устанавливает графический режим, который является совместимым с 16-разрядными Windows. Это — режим по умолчанию.
GM_ADVANCED: Устанавливает улучшенный графический режим, который дает возможность преобразования мирового пространства. В том числе, в этом режиме доступна трансформация масштаба. Вот ее и задействуем.

Перевести DC в режим GM_ADVANCED;
Проинициализировать поля структуры TXForm (которая на самом деле представляет собой матрицу). Преобразование будет осуществляться по следующим формулам:

//****************************************************************************** // Масштаб SetGraphicsMode (GM_ADVANCED) // Применяем трансформацию масштаба //****************************************************************************** function DrawZoomTextWorldMode(ACanvas : TCanvas; ARect : TRect; AZoom, ASize : double; AText : string) : boolean; var rct : TRect; oldM : integer; xFrm : TXForm; begin result := CheckParamsValid(ACanvas,ARect,nil,false) and (AText <> ''); if not result then exit; //-- получим прямоугольник текста в первозданном виде, масштаб=1 ------------- rct := DrawZoomCalcRect(ACanvas,ARect,1,ASize,AText); //-- назначаем "продвинутый" режим контексту устройства ---------------------- oldM := SetGraphicsMode(ACanvas.Handle, GM_ADVANCED); try //-- обнуляем матрицу ------------------------------------------------------ FillChar(xFrm,SizeOf(xFrm),0); //-- устанавливаем нужный коэффициенты ------------------------------------- // x' = x * eM11 + y * eM21 + eDx // y' = x * eM12 + y * eM22 + eDy xFrm.eM11 := AZoom; xFrm.eM22 := AZoom; //-- назначили матрицу преобразования -------------------------------------- SetWorldTransform(ACanvas.Handle, xFrm); //-- рисуем так, как будто ничего не знаем про масштаб --------------------- with Acanvas do begin Pen.Color := clRed; Pen.Width := 1; Rectangle (rct); TextOut (rct.Left, rct.Top, AText); //-- ситаем коеффициент различия расчетной/реальной ширины текста -------- GDiffWidth := WidthRect(rct)/TextWidth(AText); end; finally //-- вернем матрицу преобразования на место -------------------------------- xFrm.eM11 := 1; xFrm.eM22 := 1; SetWorldTransform(ACanvas.Handle, xFrm); //-- возвращаем режим на место --------------------------------------------- SetGraphicsMode(ACanvas.Handle, oldM); end; end;

Ситуация, аналогичная предыдущей. Слева двойка уютно расположилась между серых границ клеток, справа линия клеток ее пересекает. Т.е. от «продергивания» при масштабе не избавились.

Однако, положительные моменты тут есть: можно рисовать, не заботясь о масштабе. Т.е., у нас есть некая очень большая функция, рисующая что-то очень несоразмерно крутое, но без учета масштаба. Мы можем перед ее вызовом назначить матрицу преобразования, получив, тем самым, возможность масштабировать. Задействовав, при этом, параметры eDx и eDy, получим еще и перемещение.

Следует обратить внимание, что толщина линий также меняется в зависимости от масштаба. Дополнительные вкусности и трансформации – не по теме статьи.

Между тем, нужный результат не достигнут.

Метод 3 «Масштаб» SetMapMode / MM_ISOTROPIC

Преобразование координат средствами Windows на методе 2 SetGraphicsMode(GM_ADVANCED) не заканчивается. Рассмотрим связку следующих функций:

function SetMapMode(DC: HDC; p2: Integer): Integer; function SetWindowExtEx(DC: HDC; XExt, YExt: Integer; Size: PSize): BOOL; function SetViewportExtEx(DC: HDC; XExt, YExt: Integer; Size: PSize): BOOL;

Функция SetMapMode заставляет выбранный контекст устройства считать пиксель чем-то иным. Допустим, пиксель может быть на самом деле 0.001 дюйма. Это зависит от параметра p2, который может принимать следующие значения:

MM_ISOTROPIC – произвольное масштабирование с одинаковым масштабом по обеим осям. Коэффициент масштаба задается парой SetWindowExt и SetViewportExt, о чем ниже.
MM_ANISOTROPIC – произвольное масштабирование по каждой из осей. Коэффициент масштаба задается парой SetWindowExt и SetViewportExt, о чем ниже.
MM_HIENGLISH — 0.001 дюйма. X слева — направо, Y снизу — вверх.
MM_LOENGLISH — 0.01 дюйма. X слева — направо, Y снизу — вверх.
MM_HIMETRIC — 0.01 милиметра. X слева — направо, Y снизу — вверх.
MM_LOMETRIC — 0.1 милиметра. X слева — направо, Y снизу — вверх.
MM_TEXT – Пиксель в пиксель. X слева — направо, Y снизу — вверх.
MM_TWIPS — 1/20 точки. (Точка = 1 inch /72, следовательно, twip = 1 inch /1440). X слева — направо, Y снизу — вверх.

Но нас интересует масштаб. Причем самый обычный, одинаковый на всех осях. Поэтому используем p2= MM_ISOTROPIC.

После установки режима нам надо задать коэффициент масштаба. Это делается парой функций SetWindowExtEx / SetViewportExtEx

Установка логического окна вывода
SetWindowExtEx(DC, логическая ширина, логическая высота, nil);
Установка реального окна вывода
SetViewportExtEx(DC, реальная ширина, реальная высота, nil);

Коэффициент масштаба таков: F = (реальная величина) / (логическая величина).
Т.к. масштаб должен быть одинаков по обеим осям, Windows выбирает наименьший коэффициент.

Что такое логическая величина. Если Вы хотите отразить некую картинку, то это будут ее ширина и высота, а реальной величиной – область в пикселях, куда необходимо отразить.

Функции преобразования таковы:
x’ = x * F
y’ = y * F

Таким образом, реальная величина для ширины: Zoom * Width и высоты: Zoom * Height.
Третья функция масштабирования выглядит так:

//****************************************************************************** // Масштаб: новый режим отображение SetMapMode/SetWindowExtEx/SetViewportExtEx //****************************************************************************** function DrawZoomTextMapMode (ACanvas : TCanvas; ARect : TRect; AZoom, ASize : double; AText : string) : boolean; var DC : HDC; rct : TRect; Old : integer; w,h : Integer; begin result := CheckParamsValid(ACanvas,ARect,nil,false); if not result then exit; //-- получим расчетный прямоугольник, каким он должен быть после масштаба ---- rct := DrawZoomCalcRect(ACanvas,ARect,1,ASize,AText) and (AText <> ''); //-- применим масштаб ко все области отображения ----------------------------- DC := ACanvas.Handle; w := WidthRect(ARect); h := heightRect(ARect); //-- В изотропном режиме отображения MM_ISOTROPIC масштаб вдоль осей X и Y //-- всегда одинаковый (т.е. для обоих осей одинаковые логические единицы длины) Old := SetMapMode(DC, MM_ISOTROPIC); //-- установка логического окна вывода ---------------------- SetWindowExtEx(DC, w, h, nil); //-- установка реального окна вывода ------------------------ SetViewportExtEx(DC, round(AZoom*W), round(AZoom*H), nil); //-- рисуем ------------------------------------------------- try with ACanvas do begin Pen.Color := clPurple; Pen.Width := 1; Rectangle(rct); TextOut (ARect.Left, ARect.Top, AText); GDiffWidth := WidthRect(rct)/TextWidth(AText); end; finally SetMapMode(DC, Old); end; end;

Однако, результат по-прежнему не радует:

Ситуация абсолютно идентичная двум предыдущим.

Плюсы метода аналогичны методу 2 – можно не заботиться об масштабе во время написания функция «рисования», но тут нет возможности перемещения. Трансформация перемещения – сугубо ручная работа.

Вообще, эта функция не заточена под трансформации. Она больше подходит для отображения чего-либо в единицах этого чего-либо. Это некий «переводчик» с одного языка единиц измерения на язык экранного представления.

Метод 4 «Дюймы» SetMapMode / MM_HIENGLISH

Но попробуем еще один вариант. В методе 3 функция SetMapMode подробно расписана. В том числе упоминались флаги перевода из метрических систем в экранные. Попробуем поработать в дюймовой системе координат. Почему не в миллиметрах – чтобы избежать дополнительных преобразований. У нас ведь все равно изначально некие дюймовый показатели. Зачем их дополнительно делать на 25.4 (см.метод 1).

Что сподвигло. Все ж таки величина 0.001 дюйма – это очень малая дискрета. А вдруг?
Четвертая функция масштабирования такова:

//****************************************************************************** // Масштаб новый режим отображение SetMapMode/SetWindowExtEx/SetViewportExtEx // MM_HIENGLISH - Каждый логический модуль преобразован в 0.001 дюйма. //****************************************************************************** function DrawZoomTextMapModeHIENGLISH(ACanvas : TCanvas; ARect : TRect; AZoom, ASize : double; AText : string) : boolean; var DC : HDC; Old: integer; pnt : TPoint; rct : TRect; siz : TSize; tmp : Integer; begin result := CheckParamsValid(ACanvas,ARect,nil,false) and (AText <> ''); if not result then exit; //-- тут масштаб не нужен, нужен фиксированный размер шрифта --------- ACanvas.Font.Height := -trunc(ASize * ACanvas.Font.PixelsPerInch / 72); tmp := ACanvas.Font.Height; DC := ACanvas.Handle; //-- Число пикселей на горизонтальный логический дюйм ------------------------ pnt.X := GetDeviceCaps(DC,LogPixelsX); //-- Число пикселей на вертикальный логический дюйм -------------------------- pnt.Y := GetDeviceCaps(DC,LogPixelsY); //-- считаем размер в дюймах (0.001 дюймов)----------------------------------- GetTextExtentPoint32(DC,PWideChar(AText),Length(AText), siz); rct.Top := -round(1000* AZoom * ARect.Top / pnt.Y); rct.Left := round(1000* AZoom * ARect.Left / pnt.X); rct.Right := rct.Left + round(1000* AZoom * siz.Width / pnt.X); rct.Bottom := rct.Top - round(1000* AZoom * siz.Height / pnt.Y); ACanvas.Font.Height := -round(rct.Bottom-rct.Top) ; Old := SetMapMode(DC, MM_HIENGLISH); try with Acanvas do begin Pen.Color := clTeal; Pen.Width := 1; Rectangle (rct); TextOut (rct.Left, rct.Top, AText); GDiffWidth := WidthRect(rct) / TextWidth(AText); end; finally SetMapMode(DC, Old); ACanvas.Font.Height := tmp; end; end;

К сожалению, результат ничем не лучше предыдущих:

Метод 5 «Посимвольная отрисовка»

Во всех предыдущих методах такое ощущение, что целочисленная часть TLogFont. lfHeight ощутимо портит жизнь и не позволяет осуществить «тонкую» настройку под определенный масштаб. Эх… была б она дробной… Ну ладно, попробуем решить проблему иначе.

Основная идея такая: проход по всем символам текста, подсчет начала по оси X, где должен быть выведен символ. Коэффициент пересчета вычисляется изначально, как отношение расчетной ширины и реальной.

//****************************************************************************** // Масштаб посимвольной отрисовкой //****************************************************************************** function DrawZoomTextChar(ACanvas : TCanvas; ARect : TRect; AZoom, ASize : double; AText : string) : boolean; var rct : TRect; fct : double; i : Integer; w : Integer; begin result := CheckParamsValid(ACanvas,ARect,nil,false) and (AText <> ''); if not result then exit; //-- считаем, каким дорлжен стать прямоугольник текста при масштабе ---------- rct := DrawZoomCalcRect(ACanvas,ARect,AZoom,ASize,AText); try with ACanvas do begin Pen.Color := clMaroon; Pen.Width := 1; Rectangle(rct); GDiffWidth := WidthRect (rct); //-- отмасштабировали шрифт ---------------------------------------------- Font.Height := -trunc(AZoom * ASize * Font.PixelsPerInch/72); //-- отношение "правидьной" ширины к реальной ---------------------------- fct := WidthRect (rct)/TextWidth(AText); //-- проходим по всем символам строки, считаем координаты начала, выводим w := 0; for i := 1 to Length(AText) do begin TextOut (rct.Left, rct.Top, AText[i]); w := w + TextWidth(AText[i]); //-- сместили начало следующего символа относительно общего начала ----- rct.Left := round (ARect.Left + w * fct); end; GDiffWidth := GDiffWidth / (rct.Left-ARect.Left); end; except result := false; end; end;

Поразительно, но работает:

Двойка намертво прилипла к линии и не покидает ее при любом масштабе.

Первый успешный метод масштабирования. Цель достигнута, но хотелось бы более качественного решения.

Метод 6 «Bitmap буфер»

Предыдущий метод состоял в том, что происходила посимвольная «подгонка» под требуемый рассчитанный заранее размер путем сдвига начала отрисовки каждого символа. А что если все то же самое сделать на основе bitmap?

Идея заключается в том, что текст вначале рисуется на некий промежуточный битмап в заданном масштабе. Назовем ее «боевой» матрицей. Затем происходит stretch копирование на другую битмап-матрицу, у которой установлен размер, согласно посчитанным значениям. После этого происходит «прозрачное» копирование на «рабочую» канву.

//****************************************************************************** // Масштаб с использованием TBitmap и StretchDraw //****************************************************************************** function DrawZoomTextBitmap(ACanvas : TCanvas; ARect : TRect; AZoom, ASize : double; AText : string) : boolean; var rct: TRect; val: TRect; siz: TSize; bmp: TBitmap; // битмап-буфер "боевая" матрица dst: TBitmap; // битмап-stretch приемник begin result := CheckParamsValid(ACanvas,ARect,nil,false) and (AText <> ''); if not result then exit; //-- считаем, каким дорлжен стать прямоугольник текста при масштабе ---------- rct := DrawZoomCalcRect(Acanvas,Arect,AZoom,ASize,AText); //-- находим реальный прямоугольник при масштабе ----------------------------- ACanvas.Font.Height := -trunc(AZoom * ASize * ACanvas.Font.PixelsPerInch / 72); GetTextExtentPoint32(ACanvas.Handle,PWideChar(AText),Length(AText), siz); val := ARect; val.Right := val.Left + siz.Width; val.Bottom := val.Top + siz.Height; //-- битмап-буфер, на котором рисуем текст ----------------------------------- bmp := CreateBMPRect (val);// имеет реальный, не "расчетный" размер try with bmp.Canvas do begin Font.Assign(ACanvas.Font); Brush.Color := clWhite; TextOut(0,0,AText); end; //-- создаем буфер с расчетными размерами ---------------------------------- dst := CreateBmpRect(rct); //-- растягиваем/стягиваем "боевую" матрицу под размер, который должен быть dst.Canvas.StretchDraw(dst.Canvas.ClipRect,bmp); //-- рисуем с прозрачностью на канву --------------------------------------- dst.TransparentColor := clWhite; dst.Transparent := true; with ACanvas do begin Pen.Color := clBlue; Pen.Width := 1; Rectangle(rct); ACanvas.Draw(rct.Left,rct.Top,dst); end; GDiffWidth := WidthRect(rct) / dst.Width; finally if dst <> nil then dst.Free; bmp.Free; end; end;

И этот метод также работает отменно:

Текст как будто прилип к своим клеткам. Чрезвычайно плавное масштабирование.

Второй успешный метод масштабирования. Цель достигнута, но хотелось бы еще более качественного решения. Слишком ресурсоёмки два последних метода. Это вот прямо чувствуется.

Метод 7 «GDI+» Масштаб размером шрифта

Вот и подошли к однозначно правильному и великолепному средству, как масштабирование и вывод текста силами GDI+.

Здесь комментировать особо нечего. Основное, это изменение размера шрифта, согласно масштабу. И вывод текста средствами GDI+, с использованием антиалиасинга (TextRenderingHintAntiAlias). Все остальное вполне понятно по исходнику:

//****************************************************************************** // Масштаб GDI+ с изменением размера шрифта //****************************************************************************** function DrawZoomTextGDIPlus(ACanvas : TCanvas; ARect : TRect; AZoom, ASize : double; AText : string) : boolean; var clr : TColor; grp : TGPGraphics; brh : TGPSolidBrush; nam : TGPFontFamily; fsl : FontStyle; src : TGPRectF; fnt : TGPFont; begin result := CheckParamsValid(ACanvas,ARect,nil,false) and (AText<>''); if not result then exit; ACanvas.Font.Height := -trunc(AZoom * ASize * ACanvas.Font.PixelsPerInch / 72); grp := TGPGraphics.Create(ACanvas.Handle); try with ACanvas do begin clr := Font.Color; //-- создаем название шрифта --------------------------------------------- nam := TGPFontFamily.Create(Font.Name); //-- определяем стиль шрифта --------------------------------------------- fsl := FontStyleRegular; if fsBold in Font.Style then fsl := fsl + FontStyleBold; if fsItalic in Font.Style then fsl := fsl + FontStyleItalic; if fsUnderline in Font.Style then fsl := fsl + FontStyleUnderline; if fsStrikeOut in Font.Style then fsl := fsl + FontStyleStrikeout; //-- устанавливаем антиалиасинг с "растягиванием" по расчетной ширине ---- grp.SetTextRenderingHint(TextRenderingHintAntiAlias); //-- создаем кисть для шрифта, цвет шрифта ------------------------------- brh := TGPSolidBrush.Create(MakeColor(GetRValue(clr), GetGValue(clr), GetBValue(clr))); //-- создаем шрифт без масштаба, в "родном" размере ---------------------- Fnt := TGPFont.Create(nam, ASize * Font.PixelsPerInch / 72, fsl, UnitPixel); //-- получаем "опоясывающий" прямоугольник ------------------------------- grp.MeasureString(AText,-1,fnt,MakePoint(ARect.Left*1.0, ARect.Top*1.0),src); //-- рисуем "опоясывающий" прямоугольник ------------------------------- Pen.Color := clNavy; pen.Width := 1; Rectangle (round(src.X),round(src.Y), round(src.X + AZoom*src.Width), round(src.Y + AZoom*src.Height)); //-- считаем и апоминаем ширину, какой она должна быть ------------------- GDiffWidth := AZoom*src.Width; Fnt.Free; //-- создаем шрифт с учетом масштаба ------------------------------------- Fnt := TGPFont.Create(nam, AZoom * ASize * Font.PixelsPerInch / 72, fsl, UnitPixel); grp.SetTextRenderingHint(TextRenderingHintAntiAlias); grp.DrawString(AText, -1, Fnt, MakePoint(ARect.Left*1.0, ARect.Top*1.0), brh); //-- получаем реальные размеры текста с учетом масштаба ------------------ grp.MeasureString(AText,-1,fnt,MakePoint(ARect.Left*1.0, ARect.Top*1.0),src); GDiffWidth := GDiffWidth / src.Width; end; except result := false; end; Fnt.free; brh.free; nam.free; grp.free; end;

Результат естественным образом превзошел все ожидания. Скрины приводить не буду, т.к. они похожи на приведенные выше, в двух последних методах. Ощутить мощь GDI+ лучше запустив исполняемый файл.

Метод 8 «GDI+» Трансформация масштаба

И снова GDI+. Но на этот раз будем использовать трансформацию масштаба. Т.е. рисуем текст в его «нормальном» размере, а его масштабированием будет заниматься движок GDI+. Трансформация осуществляется вызовом ScaleTransform(AZoom,AZoom).

//****************************************************************************** // Масштаб GDI+ с применением трансофрмации масштаба //****************************************************************************** function DrawZoomTextGDIPlusScale(ACanvas : TCanvas; ARect : TRect; AZoom, ASize : double; AText : string) : boolean; var clr : TColor; grp : TGPGraphics; brh : TGPSolidBrush; nam : TGPFontFamily; fsl : FontStyle; src : TGPRectF; fnt : TGPFont; pnt : TGPPointF; begin result := CheckParamsValid(ACanvas,ARect,nil,false) and (AText<>''); if not result then exit; grp := TGPGraphics.Create(ACanvas.Handle); try with ACanvas do begin clr := Font.Color; pnt := MakePoint(ARect.Left*1.0, ARect.Top*1.0); //-- создаем название шрифта --------------------------------------------- nam := TGPFontFamily.Create(Font.Name); //-- определяем стиль шрифта --------------------------------------------- fsl := FontStyleRegular; if fsBold in Font.Style then fsl := fsl + FontStyleBold; if fsItalic in Font.Style then fsl := fsl + FontStyleItalic; if fsUnderline in Font.Style then fsl := fsl + FontStyleUnderline; if fsStrikeOut in Font.Style then fsl := fsl + FontStyleStrikeout; //-- устанавливаем антиалиасинг с "растягиванием" по расчетной ширине ---- grp.SetTextRenderingHint(TextRenderingHintAntiAlias); //-- создаем кисть для шрифта, цвет шрифта ------------------------------- brh := TGPSolidBrush.Create(MakeColor(GetRValue(clr), GetGValue(clr), GetBValue(clr))); //-- создаем шрифт без масштаба, в "родном" размере ---------------------- Fnt := TGPFont.Create(nam, ASize * Font.PixelsPerInch / 72, fsl, UnitPixel); //-- получаем "опоясывающий" прямоугольник ------------------------------- grp.MeasureString(AText,-1,fnt,pnt,src); //-- рисуем "опоясывающий" прямоугольник ------------------------------- Pen.Color := $00BC6C01; pen.Width := 1; Rectangle (round(AZoom*src.X),round(AZoom*src.Y), round(AZoom*(src.X + src.Width)), round(AZoom*(src.Y + src.Height))); //-- применяем трансформацию масштаба ---------------------------------- grp.ScaleTransform(AZoom,AZoom); grp.DrawString(AText, -1, Fnt, pnt, brh); GDiffWidth := 1; end; except result := false; end; Fnt.free; brh.free; nam.free; grp.free; end;

Самый лучший результат из всех вышеперечисленных.

Результаты тестов

В тестовой программе можно запустить сбор статистики, нажав кнопку «Start». Будет произведен последовательный перебор всех представленных методов на всех возможных в программе масштабах. По окончании работы будет выведена следующая диаграмма:

Первый столбец – среднее время отрисовки в миллисекундах. Второй – относительное отклонение расчетных величин от фактических. Проще говоря, первый столбец – сколь мало времени занимает операция, второй — сколь высок результат масштабирования.

Как видно, методы делятся на 2 группы – первые 4 с неудовлетворительным результатом масштаба, вторые 4 – масштабирование удачное, то, чего хотелось.

Странно, но самый топорный первый метод по скорости показал лучше результаты, чем его навороченные собратья по группе неудачников. Правда, отклонения у него от расчетных значений самые большие.

Безусловный победитель – метод 8 «GDI+» с трансформацией масштаба.
Поэтому оформим отрисовку текста в GDI+ отдельной функцией.

Функция плавного масштабирования текста с поворотом на заданный угол и антиалиасингом

//****************************************************************************** // Рисуем текст GDI+ //****************************************************************************** function DrawGDIPlusText (ACanvas : TCanvas; ARect : TRect; Angle, ASize : double; AText : string; AZoom : double = 1) : boolean; var clr : TColor; grp : TGPGraphics; brh : TGPSolidBrush; nam : TGPFontFamily; fsl : FontStyle; fnt : TGPFont; pnt : TGPPointF; begin result := CheckParamsValid(ACanvas,ARect,nil,false) and (AText<>''); if not result then exit; grp := TGPGraphics.Create(ACanvas.Handle); try with ACanvas do begin clr := Font.Color; //-- создаем название шрифта --------------------------------------------- nam := TGPFontFamily.Create(Font.Name); //-- определяем стиль шрифта --------------------------------------------- fsl := FontStyleRegular; if fsBold in Font.Style then fsl := fsl + FontStyleBold; if fsItalic in Font.Style then fsl := fsl + FontStyleItalic; if fsUnderline in Font.Style then fsl := fsl + FontStyleUnderline; if fsStrikeOut in Font.Style then fsl := fsl + FontStyleStrikeout; //-- создаем кисть для шрифта, цвет шрифта ------------------------------- brh := TGPSolidBrush.Create(MakeColor(GetRValue(clr),GetGValue(clr),GetBValue(clr))); //-- создаем шрифт без масштаба, в "родном" размере ---------------------- Fnt := TGPFont.Create(nam, ASize * Font.PixelsPerInch / 72, fsl, UnitPixel); //-- устанавливаем антиалиасинг с "растягиванием" по расчетной ширине ---- grp.SetTextRenderingHint(TextRenderingHintAntiAlias); //-- готовим точку начала отрисовки -------------------------------------- pnt := MakePoint(ARect.Left*1.0, ARect.Top*1.0); //-- точка трансформации, если угол, то вращение будет вокруг этих координат grp.TranslateTransform(pnt.X,pnt.y); //-- если указан угол, применяем трансформацию вращения ------------------ if Angle <> 0 then begin //-- применяем трансформацию вращения ---------------------------------- grp.RotateTransform(Angle); end; //-- рисуем текст теперь от начала "новых" координат ------------------- pnt := MakePoint(0.0,0.0); //-- если указан масштаб, применяем трансформацию масштаба ------------------ if AZoom <> 1 then begin grp.ScaleTransform(AZoom,AZoom); end; //-- рисуем текст без указания длины ------------------------------------- grp.DrawString(AText, -1, Fnt, pnt, brh); end; except result := false; end; Fnt.free; brh.free; nam.free; grp.free; end;

Небольшие выводы и комментарии

В дополнение к описанным функциям и их возможностям хочется добавить следующее: для SetMapMode существует пара функций
SetWindowOrgEx – устанавливает точку начала координат логического пространства.
SetViewportOrgEx – устанавливает точку начала координат физического пространства.
Проще говоря, вызвав SetViewportOrgEx (DC,100,100,nil), мы сделаем точку (100,100) началом координат и последующий вызов TextOut(0,0,’Center here’) нарисует этот текст от точки (100,100);
В GDI+ для установки нового начала координат используется метод TranslateTransform (см. листинг функции DrawGDIPlusText).

В форме:

 type TFmMain = class(TForm) … private FList : TxZoomStatList; // класс статистики (utlZoomStat) FListPoint : TPoint; FMouseDown : boolean; FMousePoint: TPoint; FProcessing : boolean; … End; procedure TFmMain.pbMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin FMouseDown := (Button = mbLeft) and //-- статистика - последняя в списке ----------------- (ComboBox1.ItemIndex=ComboBox1.Items.Count-1); if FMouseDown then begin //-- сохраняем точку, где началось перетаскивание ---------------- FMousePoint := Point(X,Y); //-- запоминаем текущие смещения --------------------------------- FListPoint := Point(FList.OffX, FList.OffY); end; end; procedure TFmMain.pbMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if FMouseDown then begin //-- расчет новых смещенией ------------------------------------------ FList.OffX := FListPoint.X + X-FMousePoint.X; FList.OffY := FListPoint.Y + Y-FMousePoint.Y; //-- рисуем статистику ----------------------------------------------- pbPaint(Sender); end; end; procedure TFmMain.pbMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin //-- сброс перетаскивания --------------------- FMouseDown := false; end;

Описание класса статистики

type //****************************************************************************** // Запись по статистике //****************************************************************************** PxZoomStat = ^TxZoomStat; TxZoomStat = packed record FIndex : Integer; FColor : TColor; FName : string; FCount : Integer; FTime : extended; FDiff : extended; FTimeC : extended; FDiffC : extended; FTimeR : TRect; FDiffR : TRect; end; TxZoomStatList = class private FOffX : Integer; FOffY : Integer; FList : TList; FGDIPlus : boolean; function GetCount : Integer; function GetItem (Index : Integer) : PxZoomStat; public Constructor Create; virtual; Destructor Destroy; override; function Add (AIndex : Integer; AName : string; ATime, ADiff : Extended) : Integer; overload; function Add (AIndex : Integer; ATime, ADiff : Extended) : PxZoomStat; overload; procedure Delete (Index : Integer); procedure Clear; property Count : Integer read GetCount; property Items[Index : Integer] : PxZoomStat read GetItem; default; //-------------------------------------------------------------------------- property GDIPlus : boolean read FGDIPlus write FGDIPlus; property OffX : Integer read FOffX write FOffX; property OffY : Integer read FOffY write FOffY; end;

Рисуем статистику. DrawZoomStatList:

//****************************************************************************** // Рисуем статистику // Суть в следующем. Вся графика рисуется так, как будто никакого масштаба и // перетаскивания нет. По сути, можно рисовать вообще в абсолютных координатах. // Масштаб и перемещение осуществляется за счет вызова // SetGraphicsMode(DC, GM_ADVANCED); //****************************************************************************** function DrawZoomStatList(ACanvas : TCanvas; ARect : TRect; AZoom, ASize : double; AText : string) : boolean; var lst : TxZoomStatList; // экземпляр списка со статистикой (реализован в utlZoomStat) rct : TRect; val : TRect; str : string; i : Integer; p : PxZoomStat; wBar : Integer; //------------------------------------------------------------------------------ maxTime : Extended; maxDiff : Extended; minTime : Extended; minDiff : Extended; wTime : Extended; wDiff : Extended; //-- масштаб ------------------------------------------------------------------- DC : HDC; fnt : hFont; tmp : hFont; //-------------------------------------- oldM : integer; xFrm : TXForm; begin lst := xGZoomList(false); result := CheckParamsValid(ACanvas,ARect,lst,true); if not result then exit; DC := ACanvas.Handle; maxTime :=-1; maxDiff :=-1; minTime := MaxInt; minDiff := MaxInt; for i := 0 to lst.Count-1 do begin p := lst[i]; if (p = nil) or (p^.FCount = 0) then continue; p^.FTimeC := p^.FTime / p^.FCount; p^.FDiffC := p^.FDiff / p^.FCount; if p^.FTimeC > maxTime then maxTime := p^.FTimeC; if p^.FTimeC < minTime then minTime := p^.FTimeC; if p^.FDiffC >maxDiff then maxDiff := p^.FDiffC; if p^.FDiffC < minDiff then minDiff := p^.FDiffC; end; wTime := (maxTime - minTime) * 0.1; minTime := minTime - wTime; maxTime := maxTime + wTime; wDiff := (maxDiff - minDiff) * 0.1; minDiff := minDiff - wDiff; maxDiff := maxDiff + wDiff; with ACanvas do begin Font.Height := -trunc(ASize * Font.PixelsPerInch/72); wBar := TextWidth('F=0000.00000') div 2; // ширина столбца зависит от шрифта end; //-- применим масштаб ко все области отображения ----------------------------- oldM := SetGraphicsMode(DC, GM_ADVANCED); //-- обнуляем матрицу ------------------------------------------------------ FillChar(xFrm,SizeOf(xFrm),0); //-- устанавливаем нужный коэффициенты ------------------------------------- xFrm.eM11 := AZoom; // если масштаб задается другим способом, здесь =1 xFrm.eM22 := AZoom; // если масштаб задается другим способом, здесь =1 xFrm.eDx := lst.FOffX; // смещение по X, посчитаны в главном окне программы xFrm.eDy := lst.FOffY; // смещение по Y, посчитаны в главном окне программы //-- назначили матрицу преобразования -------------------------------------- SetWorldTransform(DC, xFrm); rct := ARect; rct.Top := rct.Top + 10; rct.Bottom := rct.Top + round ( ASize * 190/6.5); // высота столбца зависит от шрифта if wTime <>0 then wTime := (rct.Bottom - rct.Top) / (minTime - maxTime); if wDiff <> 0 then wDiff := (rct.Bottom - rct.Top) / (minDiff - maxDiff); try with ACanvas do begin val := rct; val.Left := val.Left + wBar; val.Right := val.Left + wBar; Pen.Width := 1; for i := 0 to lst.Count-1 do begin p := lst[i]; if (p = nil) or (p^.FCount = 0) then continue; Pen.Color := Darker(p^.FColor,10); //-- первый столбец времени ------------------------------- OffsetRect (val,wBar,0); Brush.Color := Lighter(p^.FColor,50); val.Top := val.Bottom-round (wTime*(minTime-p^.FTimeC)); Rectangle(val); p^.FTimeR := val; //-- второй столбец коэффициента -------------------------- OffsetRect (val,wBar,0); Brush.Color := Lighter(p^.FColor,10); val.Top := val.Bottom-round (wDiff*(minDiff-p^.FDiffC)); Rectangle(val); p^.FDiffR := val; OffsetRect (val,wBar,0); end; for i := 0 to lst.Count-1 do begin p := lst[i]; if (p = nil) or (p^.FCount = 0) then continue; Brush.Style := bsClear; Font.Color := Darker(p^.FColor,10); val := p^.FTimeR; str := 't='+FormatFLoat('#0.000#',p^.FTimeC); OffsetRect(val,-1,HeightRect(val)+2); if lst.GDIPlus then DrawGDIPlusText (ACanvas, val, 0, ASize, str) else TextOut (val.Left,val.Top,str); Font.Color := Darker(p^.FColor,30); val := p^.FDiffR; str := 'f='+FormatFLoat('#0.000#',p^.FDiffC); OffsetRect(val,1,-TextHeight(str)-2); if lst.GDIPlus then DrawGDIPlusText (ACanvas, val, 0, ASize, str) else TextOut (val.Left, val.Top,str); val := p^.FDiffR; str := p^.FName; val.Top := val.Bottom+TextHeight(str)+2; val.Bottom := ARect.Bottom; if lst.GDIPlus then DrawGDIPlusText (ACanvas, val, 30, ASize, str) else begin fnt := CreateRotatedFont(Font, -30); tmp := SelectObject(DC,fnt); try TextOut (val.Left,val.Top, str); finally SelectObject(DC, tmp); DeleteObject(fnt); end; end; end; end; finally xFrm.eM11 := 1; xFrm.eM22 := 1; xFrm.eDx := 0; xFrm.eDy := 0; SetWorldTransform(DC, xFrm); //-- возвращаем режим на место --------------------------------------------- SetGraphicsMode(DC, oldM); end; end;

Работа с векторной графикой
Delphi
API
Разработка под Windows