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

image

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

image

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

image

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

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


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

image

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

  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. Это высота шрифта в пикселях, и по логике вещей, это должно привести к плавному изменению масштаба.

$Font.Height = -trunc(AZoom * ASize * Font.PixelsPerInch / 72);$

Где:

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

Откуда взялась формула. Высота шрифта в Windows выражается в пунктах, которые пришли, в свою очередь, из типографского дела.

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;

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

image

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

Результат неудовлетворительный.

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


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

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


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

Алгоритм работы следующий:

  1. Перевести DC в режим GM_ADVANCED;
  2. Проинициализировать поля структуры TXForm (которая на самом деле представляет собой матрицу). Преобразование будет осуществляться по следующим формулам:
    $x' = x * eM11 + y * eM21 + eDx$
    $y' = x * eM12 + y * eM22 + eDy$
    Как видно, чтобы осуществить масштаб, нас интересуют поля eM11 и eM22;
  3. Назначить матрицу преобразования: SetWorldTransform(DC, xFrm);
  4. Нарисовать текст в «обычных» координатах, без учета масштаба, в своем «обычном» размере;
  5. Вернуть трансформацию в изначальное состояние.
  6. Вернуть предыдущий режим.

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

//******************************************************************************
//  Масштаб 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;

Результат таков:

image

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

Однако, положительные моменты тут есть: можно рисовать, не заботясь о масштабе. Т.е., у нас есть некая очень большая функция, рисующая что-то очень несоразмерно крутое, но без учета масштаба. Мы можем перед ее вызовом назначить матрицу преобразования, получив, тем самым, возможность масштабировать. Задействовав, при этом, параметры 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 снизу — вверх.

Что значит фраза «X слева — направо, Y снизу — вверх». Это значит, что координаты по X вполне себе обычные, а вот по Y – отрицательные. Т.е., если нужно нарисовать эллипс в прямоугольнике (10,10,1000,1000), то чтобы его увидеть без дополнительных трансформаций, надо написать Ellipse (10,-10,1000,-1000).

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

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

  1. Установка логического окна вывода
    SetWindowExtEx(DC, логическая ширина, логическая высота, nil);
  2. Установка реального окна вывода
    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;

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

image

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

Плюсы метода аналогичны методу 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;

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

image

Метод 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;

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

image

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

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

Метод 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;

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

image

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

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

Метод 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». Будет произведен последовательный перебор всех представленных методов на всех возможных в программе масштабах. По окончании работы будет выведена следующая диаграмма:

image

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

Как видно, методы делятся на 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).

    Вообще, зачем нужны эти «игры» с началом координат. Когда надо вращать какой-то графический объект на заданный угол, легче всего это сделать вокруг начала системы координат. Это избавит программиста от дополнительных вычислений, а листинг – от лишних строк.
  • Безусловно, в ряде случаев выручит SetGraphicsMode. Например, нарисовать эллипс под углом. И вообще, вместо того, чтобы мучится с каждой фигурой отдельно, заставляя ее правильно отображаться под углом, легче применить трансформацию. Метод един для всех.
  • При использовании масштабирования и смещения лучше пользовать SetGraphicsMode и все трансформации описывать в одной матрице TXForm.
  • Если пишется некий визуальный графический редактор/график/диаграмма, все равно придется использовать всякие плюшки типа антиалиасинга, масштаба, трансформации, которые есть в GDI+, не точить ли софт сразу под GDI+? Отметая все осторожные наставления – типа, глючный, типа, ресурсоемкий. Не знаю, не замечал.
  • GDI+ прекрасно уживается с VCL классами. Можно на одном TCanvas одновременно рисовать и стандартными методами TCanvas, и Windows API GDI, и методами GDI+.
  • Трансформации GDI действуют и на GDI+. Трансформации GDI+ действуют только в рамках GDI+. Т.е. трансформация, установленная, например, через SetGraphicsMode, действует также и на систему координат GDI+.

В качестве демонстрации последних утверждений, функция вывода статистики написана с применением SetGraphicsMode, которая отвечает за масштаб и смещение, а вывод текста, в том числе и под углом, с помощью функции 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 XE 7(70 Кб)