Как в TMemo сделать вертикальное выравнивание, отступы и TextHint

Пролог


Итак, из-за чего все собственно и стряслось. Я пишу плагины для LedearTask. Также, в 2017 году, написал векторный редактор для турецкой фирмы станков по производству печатей MATUYA. Что LeaderTask, что MATUYA, выставили интересные требования – вертикальное выравнивание в многострочном редакторе, отступы и TextHint. TextHint имеется ввиду — такое серое приглашение ввести хоть что-нибудь, когда элемент ввода пуст.

image
LeaderTask: плагин «Лестница Целей» (ввод и хинт по центру в многострочном редакторе)

image
Matuya Stamp Systems (ввод текста выровнен по правому и нижнему краю)

Как известно, вертикального выравнивания, в отличии от горизонтального, в стандартном Windows API для контролов не существует.

Также, приглашения для ввода какой-то информации в многострочных контролах Windows не поддерживаются.

Таким образом, возникает дилемма – а как? Хочется использовать стандартные компоненты, но при этом иметь расширенные возможности ввода текстовой информации.

Небольшое отступление


С некоторых, достаточно отдаленных, пор, я не пишу компоненты и не использую сторонние. В условиях вечного дедлайна намного выгодней, быстрее и экономичней все писать самому. То, что будет создано в real-time. Т.е. использовать богатые возможности дизайнера Delphi, но подменять классы «на лету» в real-time. Как это все выглядит, надеюсь описать подробнее чуть позже. Что это значит в текущем конкретном случае, опишу сейчас.

Что требуется


По сути, от меня требуется TMemo, в котором есть вертикальное выравнивание, скажем, свойство Layout, свойство TextHint — «приглашение» ввести какой-нибудь текст. Также, требуется сделать отступы сверху-снизу-слева-справа для ввода и отображения текста, чтоб он не «прилипал» к граням контрола.

Теория


Необходим TMemo с дополнительными возможностями. Очевидно, придется писать наследника от TMemo. Не от TCustomMemo, и уж тем более не от TCustomEdit. Нам нужен именно TMemo, потому что мы не собираемся писать библиотеку компонентов, а хотим сделать проект быстро и в срок.
Вертикальное выравнивание нам недоступно. Ну что ж, зато мы можем установить для контролов прямоугольник ввода текста. Это осуществляется следующим образом.

В нашем случае, это будет выглядеть так:

Perform(EM_SETRECT, 0, LPARAM(@ARect))  

Где ARect –искомый прямоугольник для ввода текста. Очевидно, его верхняя грань должна зависеть от значения свойства Layout. Также, этот прямоугольник может определить и границы отступа от краев для ввода текста.

Далее, немного поковыряв исходники, находим виртуальный метод:

procedure PaintWindow(DC: HDC); virtual;

Он вызывается в любом случае, что для DoubleBuffered, что без него. Его вызов будет осуществлен при наличии csCustomPaint в ControlState компонента, после всех значимых отрисовок компонента. Его мы будем использовать для отрисовки TextHint.

Практика


Не буду останавливаться на некоторых, думаю, не особо интересных деталях реализации.

Для начала, у нас появляются следующие дополнительные свойства:

    
//-- выравнивание по вертикали ----------------------------------------
property Layout : TTextLayout read FLayout write SetLayout default tlTop;
//-- отступы от краев контрола, описание в исходниках ниже----------
property Margin : TxMargin read FMargin write SetMargin;
//-- серое приглашение ввести что-нибудь в пустой элемент ----------
property TextHint : string read FTextHint write SetTextHint;


И основные моменты.

1. Объявление класса безусловно таково:


type
  TxIPMemo = class (TMemo)

2. В конструкторе пишем строку:

Constructor TxIPMemo.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  //-- для того, чтобы метод PaintWindow был вызван ---------------
  ControlState := ControlState + [csCustomPaint];
…
end;

3. Назначение прямоугольник ввода:

function TxIPMemo.SetRect (ARect : TRect) : boolean;
begin
  result := Perform(EM_SETRECT, 0, LPARAM(@ARect))>0;   
end;

4. Расчет прямоугольника ввода:


function TxIPMemo.CalcRect : TRect;
var s : string;
    h : Integer;
    rct : TRect;
begin
  rct := Rect(0,0,ClientWidth,ClientHeight);
  //-- вначале определяем смещения от краев контрола ----------------  
  rct.Top := rct.Top + FMargin.Top;
  rct.Left := rct.Left + FMargin.Left;
  rct.Right := rct.Right - FMargin.Right;
  rct.Bottom := rct.Bottom - FMargin.Bottom;  
  //-- если выравнивание по верху - ничего не высчитваем, выходим ---          
  result := rct;
  if Layout = tlTop then exit;
  //-- битмап создается в конструкторе ------------------------------
  FBitmap.Canvas.Font.Assign(Font);
  s := Lines.Text;
  //-- если строка пуста и нет фокуса берем значение хинта для расчетов
  if (s = '') and (not Focused) then s := TextHint;
  //-- вычисляем выосту текста --------------------------------------  
  h := CalcHeight(FBitmap.Canvas.Handle, WidthRect(rct)-2, s,
                  TrueWordWrap);
  //-- находим смещение сверху для прямоугольника ввода -------------
  case FLayout of
    tlCenter : H := rct.Top + (HeightRect(rct) - H) div 2;
    tlBottom : H := rct.Bottom - H;    
  end;
  //-- небольша проверка на валидность ------------------------------
  if (H > rct.Top) then 
    rct.Top := H;
  result := rct;
end;

5. Что такое TrueWordWrap в вызове функции CalcHeight выше. Это метод, которые возвращает истинное значение переноса строк для TMemo, которое зависит на самом деле от ряда параметров:


function TxIPMemo.TrueWordWrap : boolean;
begin
  result := not ((Alignment = taLeftJustify) and 
                      (ScrollBars in [ssHorizontal, ssBoth])) 
            and (WordWrap or (Alignment <> taLeftJustify));
end;

6. Где происходит вызов перерасчета и назначения прямоугольника ввода:

    
    procedure DoEnter; override;
    procedure DoExit; override;    
    procedure Change; override;
    procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT;
    procedure CMRecreateWnd(var Message: TMessage); message CM_RECREATEWND;    

7. Назначение свойства TextHint чрезвычайно просто, но с учетом того, если кому-то вдруг захочется регистрировать компонент:


procedure TxIPMemo.SetTextHint (Value : string);
begin
  if FTextHint = Value then exit;
  FTextHint := Value;
  if not (csLoading in ComponentState) then
    Change;
end;

8. Рисуем TextHint:


procedure TxIPMemo.PaintWindow(DC: HDC); 
var rct : TRect; 
    str : string;
    cnv : TCanvas;
begin
  inherited PaintWindow(DC);
  if Focused then exit;
  str := Lines.Text;
  if str <> '' then exit;

  str := FTextHint;
  if str = '' then exit;
  
  rct := CalcRect;
  InflateRect (rct, -2,-2);
  cnv := TCanvas.Create;
  cnv.Handle := DC;
  cnv.Font.Assign(Font);
  cnv.Font.Color := clBtnShadow;
  DrawTextEx(cnv,rct,str,tlTop,Alignment,TrueWordWrap,false);
  cnv.Free;
end;

9. Чтобы облегчить «подмену» стандартного TMemo на наш, есть следующий метод. Он забирает все основные события и свойства у переданного указателя на TCustomMemo. При выставленном флаге AWithFree, уничтожает экземпляр старого и становится на его место. Т.е., если в коде все завязано на «старый» TCustomMemo, ничего страшного не произойдет. Все будет работать с новым экземпляром, как со старым, за исключением тех моментов, когда будут использованы свойства, про которые вы и так в курсе, и обращаться к ним все равно придется как к TxIPMemo:


function TxIPMemo.SetMemo (AMemo : PMemoControl; AWithFree : boolean = true) : boolean;
var s : string;
begin
  result := AMemo <> nil;
  if not result then exit;

  s := Amemo^.Name;
  BoundsRect := AMemo^.BoundsRect;
  Parent := AMemo^.Parent;
  Align := Amemo^.Align;
  Alignment := TxIPMemo(Amemo^).Alignment;

{$IFDEF VER_XE}
  OnMouseEnter := TxIPMemo(Amemo^).OnMouseEnter;
  OnMouseLeave := TxIPMemo(Amemo^).OnMouseLeave;
{$ENDIF}

  BorderStyle := TxIPMemo(Amemo^).BorderStyle;

  Font.Assign(TxIPMemo(Amemo^).Font);
  Color := TxIPMemo(Amemo^).Color;
  Visible := Amemo^.Visible;
  TabOrder := TxIPMemo(Amemo^).TabOrder;
  ScrollBars := TxIPMemo(Amemo^).ScrollBars;
  WantTabs  := TxIPMemo(Amemo^).WantTabs;
  WantReturns := TxIPMemo(Amemo^).WantReturns;
  WordWrap := TxIPMemo(Amemo^).WordWrap;
  
  OnKeyPress := TxIPMemo(Amemo^).OnKeyPress;
  OnKeyDown := TxIPMemo(Amemo^).OnKeyDown;
  OnKeyUp := TxIPMemo(Amemo^).OnKeyUp;
  OnChange := TxIPMemo(Amemo^).OnChange;
  OnClick := TxIPMemo(Amemo^).OnClick;
  OnMouseDown := TxIPMemo(Amemo^).OnMouseDown;
  OnMouseMove := TxIPMemo(Amemo^).OnMouseMove;
  OnMouseUp := TxIPMemo(Amemo^).OnMouseUp;
  OnEnter := TxIPMemo(Amemo^).OnEnter;
  OnExit := TxIPMemo(Amemo^).OnExit;  

  if AWithFree then begin
    Amemo^.Free;
    Name := s;
    AMemo^ := self;
  end; 
end;

Как использовать


Предположим, что уже есть компонент TMemo на форме, которое Вы либо используете в динамике, подобно как выше-вкратце-описанные редакторы, либо статический компонент, созданный в дизайне. Это все не важно.

1. Объявляем где-то следующим образом:

    FMemo : TxIPMemo;

2. В событии OnCreate формы, либо в её конструкторе, пишем следующее:

  
  FMemo := TxIPMemo.Create (self);
//-- назначение дополнительных свойств ------------------
  FMemo.TextHint := 'Введите сюда что-нибудь ...';
  FMemo.Layout := tlCenter;

За уничтожение экземпляра класса не волнуемся – он будет гарантированно уничтожен в деструкторе.

3. Возможно, в том же обработчике FormCreate пишем:

FMemo.SetMemo (@Memo1);

Тем самым забирая свойства и события у Memo1, и уничтожая его, становясь на его место.

4. Собственно, и все. Назначаете необходимые свойства нашему компоненту. И пользуем TMemo с возможностями вертикального выравнивания, отступов (которые могут быть и отрицательными), приглашения для пользователя при пустом Text.

image
Окно демо-приложения

Эпилог


В исходниках, ссылка на которые ниже, все используемые в тексте вспомогательные функции представлены.

Версия компилятора определяется {$I} подключаемым файлом pro_param.inc.

Т.к., в силу специфики работы, придерживаюсь концепции один модуль – разные версии, представленные исходники компилируются в Delphi 7, Delphi XE 7 и Delphi 10.1 Berlin. По той простой причине, что Delphi 7 у меня куплен, а Delphi 10.1 Berlin – бесплатная лицензия для коммерческих продуктов. А заказчик в последнее время хочет быть абсолютно «белым». Поэтому не использую никаких платных библиотек.

Надеюсь, материал поможет в ситуациях разной степени тяжести.

Скачать:

xIPMemo
Demo D7, XE 7
Поделиться публикацией
Ой, у вас баннер убежал!

Ну. И что?
Реклама
Комментарии 12
    +1

    А всё-таки, почему не написать свой компонент? Ведь вы уже все сделали, осталось только собрать в пакет и инсталлировать.

      0
      Я постараюсь подробно ответить в ближайшее время в статье. Там будет много спорного материала, но это все равно опыт, который мне помогает.
      0
      Довольно интересный подход с подменой компонента) В принципе, никаких чудес, но я даже не задумывался, что «так можно»)
        0
        Еще и не так можно. Все расскажу, дайте время. На самом деле все просто, если смотреть под иным углом зрения.
          0
          Как-то я имел дело с оперднем, в котором в зависимости от бизнес-логики у объектов в рантайме подменялась таблица виртуальных методов (VMT). Легким движением руки элементарные проводки становились выданными кредитами, лицевые счета — договорами и т.д. Глючило оно безбожно, пока не переписал на нормальное присвоение.

          Я к тому, что иной угол зрения имеет право на жизнь, но не стоит увлекаться. В вашем примере вы имеете полный контроль над формой, а если форма чужая, то указатель на оригинальный TMemo мог быть где-то сохранен и использован позднее, а сам объект вы уже уничтожили.
        0
        Не понял — в чем смысл использовать TMemo, а потом через одно место его подменять? Почему сразу не использовать ваш дочерний класс?
          0
          Есть более простой и менее опасный (в плане возможности наделать ошибок) способ «подмены». Хотя это уже совсем не подмена.

          type
            TMemo = class(StdCtrls.TMemo)
              ...
            end;
          


          Единственное требование — такой класс должен быть объявлен перед объявлением класса формы. По идее, будет работать, если объявить в отдельном модуле, но в uses этот модуль должен быть указан обязательно после StdCtrls.

          В результате в design-time ничего не меняется — там остается стандартный TMemo, а в run-time имеем доступ ко всем новым «фичам» нового класса.

          Повторюсь — подмены тут никакой нет, компонент создается сразу с нужной функциональностью. Не надо создавать экземпляр нового класса, не надо ничего копировать. Отпадает необходимость писать метод TxIPMemo.SetMemo.
            0
            В результате в design-time ничего не меняется — там остается стандартный TMemo, а в run-time имеем доступ ко всем новым «фичам» нового класса.

            Зачем?
            Почему просто не сделать свой компонент и размещать на форме его?
              0
              Вы абсолютно правы. Это красивое и элегантное решение, чтобы подменить в run-time все компоненты, созданные в дизайне, на свои. Только не всегда нужно заменять абсолютно все.

              SetMemo имеет два параметра: указатель на TCustomMemo и AWithFree – уничтожать ли. Т.е. передать можно любого наследника TCustomMemo, не обязательно TMemo, компонент возьмет все необходимые ему свойства. И можно не уничтожать «донора», пусть живет как есть.
                0

                Вот, кстати, на кой чёрт там указатель?
                var параметры придумали миллиард лет назад. Ещё в Borland Pascal были.

                  0
                  Можно попробовать сделать такую запись:
                  function F1 (var m : TCustomMemo) : boolean;

                  Далее в коде вызвать хотя бы даже с «родным» наследником Memo1: TMemo
                  F1 (Memo1);

                  Компилятор будет не доволен.
                    0
                    Точно, вы правы.
                    Тогда можно сделать такой финт ушами:

                    {$apptype console}
                    program Test;
                    
                    uses
                      System.SysUtils;
                    
                    type
                      TBase = class(TObject)
                      end;
                    
                      TFoo = class(TBase)
                      end;
                    
                      TBar = class(TBase)
                      end;
                    
                      TXyz = class(TObject)
                      end;
                    
                      TUtility = class(TObject)
                      public
                        class procedure SurpriseMe<T: TBase>(var AValue: T);
                      end;
                    
                    class procedure TUtility.SurpriseMe<T>(var AValue: T);
                    begin
                      FreeAndNil(AValue);
                      AValue := T(TBar.Create());
                    end;
                    
                    var
                      ObjFoo: TBase;
                      ObjXyz: TXyz;
                    begin
                      
                      ObjFoo := TFoo.Create();
                      
                      try 
                        writeln('Before:'#9, ObjFoo.ClassName);
                        TUtility.SurpriseMe(ObjFoo);
                        writeln('After:'#9, ObjFoo.ClassName);
                      finally
                        FreeAndNil(ObjFoo);
                      end;
                      
                      // Will fail to compile at SurpriseMe() call.
                      {
                      ObjXyz := TXyz.Create();
                      
                      try 
                        writeln('Before:'#9, ObjXyz.ClassName);
                        TUtility.SurpriseMe(ObjXyz);
                        writeln('After:'#9, ObjXyz.ClassName);
                      finally
                        FreeAndNil(ObjXyz);
                      end;
                      }
                    end.
                    

                    Как минимум в Delphi XE8 должно уже работать.

                    Тут, как оказалось, ещё и проверка типов переменной ломается.

            Только полноправные пользователи могут оставлять комментарии. Войдите, пожалуйста.

            Самое читаемое