Ведущий раздела KOL и MCK: Анатолий aka XVeL
Автор: Жаров Дмитрий aka Gandalf
WEB-сайт: http://kol.mastak.ru

Полную версию библиотеки KOL и MCK можно скачать здесь

Создание визуального KOL компонента: Сфера вид сбоку

На самом деле создание визуальных компонентов под KOL и MCK не сильно отличается от создания не визуальных, но некоторые различия все же есть, они следует из разницы между визуальными и не визуальными компонентами вообще:
1. Наследование
2. Создание (New)
3. Сообщения (Events)
Пойдем по порядку. Наследоваться можно от TObj как и мы делали для не визуальных компонентов, а можно от TControl второй способ рекомендован Кладовым. И в данной главе мы рассмотрим именно его.
Вообще наследование от TControl имеет один недостаток, который поначалу пугает - нельзя вводить свои переменные в новый тип, вы скажите, что без этого создать компонент нельзя, но не беспокойтесь этот дефект довольно легко обходится.
Именно из-за этого дефекта появилась идея наследоваться от TObj, но как показала практика его нечего, боятся, это даже не дефект это особенность. Так же выяснилось, что наследование TObj добавляет массу проблем, при создании MCK компонента, не говоря уже о KOL. Да и при доведении до полной работоспособности код становится очень громоздким (в 3-5 и более раз, что отражается на размере откомпилированного файла), плохо адаптируемым к новым версиям KOL .Все же идея изначально была неплоха и в данной статье она рассматривается.
С наследованием решили, теперь создание, опять же чтобы не водить по воздуху руками возьмем в качестве примера много страдальным TrackBar.

unit KOLMHTrackBar;

interface

uses
  windows, messages, KOL;

type
  PMHTrackBar =^TMHTrackBar;
  TKOLMHTrackBar = PMHTrackBar;
  TMHTrackBar = object(TControl)
    private
      function GetOnScroll: TOnScroll;
      procedure SetOnScroll(const Value: TOnScroll);
      function GetFrequency: DWord;
      procedure SetFrequency(const Value: DWord);
      procedure SetOrientation(const Value: TTrackBarOrientation);
      function GetOrientation: TTrackBarOrientation;
    public
      procedure Recreate;
      procedure ClearSel;
      property Orientation: TTrackBarOrientation read GetOrientation write SetOrientation;
      property Frequency: DWord read GetFrequency write SetFrequency;
      property Position: DWord index 2 read GetVal write SetVal;
      property OnScroll: TOnScroll read GetOnScroll write SetOnScroll;
    end;

const
  TRACKBAR_CLASS = 'msctls_trackbar32';
  TBS_AUTOTICKS = $0001;
  TBS_VERT = $0002;
  TBS_HORZ = $0000;
  TBS_TOP = $0004;
  TBS_BOTTOM = $0000;
  TBS_LEFT = $0004;
  TBS_RIGHT = $0000;
  TBS_BOTH = $0008;
  TBS_NOTICKS = $0010;
  TBS_ENABLESELRANGE = $0020;
  TBS_FIXEDLENGTH = $0040;
  TBS_NOTHUMB = $0080;
  TBS_TOOLTIPS = $0100;

  TBM_GETPOS = WM_USER; 
  TBM_GETRANGEMIN = WM_USER + 1; 
  TBM_GETRANGEMAX = WM_USER + 2; 
  TBM_GETTIC = WM_USER + 3;
  TBM_SETTIC = WM_USER + 4;
  TBM_SETPOS = WM_USER + 5; 
  TBM_SETRANGE = WM_USER + 6; 
  TBM_SETRANGEMIN = WM_USER + 7; 
  TBM_SETRANGEMAX = WM_USER + 8; 
  TBM_CLEARTICS = WM_USER + 9;
  TBM_SETSEL = WM_USER + 10; 
  TBM_SETSELSTART = WM_USER + 11; 
  TBM_SETSELEND = WM_USER + 12; 
  TBM_GETPTICS = WM_USER + 14;
  TBM_GETTICPOS = WM_USER + 15;
  TBM_GETNUMTICS = WM_USER + 16;
  TBM_GETSELSTART = WM_USER + 17; 
  TBM_GETSELEND = WM_USER + 18; 
  TBM_CLEARSEL = WM_USER + 19; 
  TBM_SETTICFREQ = WM_USER + 20; 
  TBM_SETPAGESIZE = WM_USER + 21; 
  TBM_GETPAGESIZE = WM_USER + 22; 
  TBM_SETLINESIZE = WM_USER + 23; 
  TBM_GETLINESIZE = WM_USER + 24; 
  TBM_GETTHUMBRECT = WM_USER + 25; 
  TBM_GETCHANNELRECT = WM_USER + 26; 
  TBM_SETTHUMBLENGTH = WM_USER + 27; 
  TBM_GETTHUMBLENGTH = WM_USER + 28;
  TBM_SETTOOLTIPS = WM_USER + 29;
  TBM_GETTOOLTIPS = WM_USER + 30; 
  TBM_SETTIPSIDE = WM_USER + 31;

  TBTS_TOP = 0;
  TBTS_LEFT = 1;
  TBTS_BOTTOM = 2;
  TBTS_RIGHT = 3;

  TBM_SETBUDDY = WM_USER + 32;
  TBM_GETBUDDY = WM_USER + 33;
  TBM_SETUNICODEFORMAT = CCM_SETUNICODEFORMAT;
  TBM_GETUNICODEFORMAT = CCM_GETUNICODEFORMAT;

  TB_LINEUP = 0;
  TB_LINEDOWN = 1;
  TB_PAGEUP = 2;
  TB_PAGEDOWN = 3;
  TB_THUMBPOSITION = 4;
  TB_THUMBTRACK = 5;
  TB_TOP = 6;
  TB_BOTTOM = 7;
  TB_ENDTRACK = 8;

  TBCD_TICS = $0001;
  TBCD_THUMB = $0002;
  TBCD_CHANNEL = $0003;

  Visible2Style: array [Boolean] of DWord = ($0, WS_VISIBLE);
  Orientation2Style: array [TTrackBarOrientation] of DWord = (TBS_HORZ, TBS_VERT);
  function NewMHTrackBar(AParent: PControl; Visible: Boolean; Orientation: TTrackBarOrientation; 
                         OnScroll: TOnScroll): PMHTrackBar;

implementation

type
  PTrackbarData = ^TTrackbarData;
  TTrackbarData = packed record
    FOnScroll: TOnScroll;
    FOrientation: TTrackBarOrientation;
    FFrequency: DWord;
end;

function WndProcTrackbarParent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var
  D: PTrackbarData;
  Trackbar: PMHTrackbar;
begin
  Result := FALSE;
  if (Msg.message = WM_HSCROLL) or (Msg.message = WM_VSCROLL) then
    if (Msg.lParam <> 0) then
    begin
      Trackbar := Pointer( GetProp( Msg.lParam, ID_SELF ) );
      if Trackbar <> nil then
      begin
        D := Trackbar.CustomData;
        if Assigned( D.FOnScroll ) then
          D.FOnScroll( Trackbar, Msg.wParam );
        end;
      end;
    end;

function NewMHTrackBar(AParent: PControl; Visible: Boolean; Orientation: TTrackBarOrientation;
                       OnScroll: TOnScroll): PMHTrackBar;
var
  D: PTrackbarData;
begin
  DoInitCommonControls( ICC_BAR_CLASSES );
  Result := PMHTrackbar(_NewCommonControl(AParent, TRACKBAR_CLASS, WS_CHILD or
            Visible2Style[Visible] or TBS_FIXEDLENGTH or TBS_ENABLESELRANGE or
            Orientation2Style[Orientation], False, 0));
  GetMem(D, Sizeof(D^));
  Result.CustomData := D;
  D.FOnScroll := OnScroll;
  AParent.AttachProc(WndProcTrackbarParent);
end;

procedure TMHTrackBar.Recreate;
begin
end;

function TMHTrackBar.GetFrequency: DWord;
var
  D: PTrackbarData;
begin
  D := CustomData;
  Result := D.FFrequency;
end;

procedure TMHTrackBar.SetFrequency(const Value: DWord);
var
  D: PTrackbarData;
begin
  D := CustomData;
  D.FFrequency := Value;
  Perform(TBM_SETTICFREQ, Value, 1);
end;

function TMHTrackBar.GetOrientation: TTrackBarOrientation;
begin
  Result := PTrackbarData(CustomData)^.FOrientation;
end;

procedure TMHTrackBar.SetOrientation(const Value: TTrackBarOrientation);
begin
  PTrackbarData(CustomData)^.FOrientation := Value;
  Recreate;
end;

function TMHTrackbar.GetOnScroll: TOnScroll;
var
  D: PTrackbarData;
begin
  D := CustomData;
  Result := D.FOnScroll;
end;

procedure TMHTrackbar.SetOnScroll(const Value: TOnScroll);
var
  D: PTrackbarData;
begin
  D := CustomData;
  D.FOnScroll := Value;
end;

procedure TMHTrackbar.ClearSel;
begin
  Perform(TBM_CLEARSEL, 1, 0);
end;

function TMHTrackbar.GetPosition: DWord;
begin
  Result := Perform(TBM_GETPOS, 0, 0);
end;

procedure TMHTrackbar.SetPosition(const Value: DWord);
begin
  Perform(TBM_SETPOS, 1, Value);
end;
end.

Исходный код приведен не полностью, поскольку он довольно велик, из него были извлечены фрагменты, не содержащие информацию обучающего характера, если вы все же хотите увидеть весь код, вы можете найти их в Интернете или написать мне.
Посмотрим, что у нас есть - создание:

function NewMHTrackBar(AParent: PControl; Visible: Boolean; Orientation: TTrackBarOrientation;
                       OnScroll: TOnScroll): PMHTrackBar;
var
  D: PTrackbarData;
begin
  DoInitCommonControls( ICC_BAR_CLASSES );
  Result := PMHTrackbar(_NewCommonControl(AParent, TRACKBAR_CLASS, WS_CHILD
            or Visible2Style[Visible] or TBS_FIXEDLENGTH or TBS_ENABLESELRANGE or
            Orientation2Style[Orientation], False, 0));
  GetMem(D, Sizeof(D^));
  Result.CustomData := D;
  D.FOnScroll := OnScroll;
  AParent.AttachProc(WndProcTrackbarParent);
end;

Начнем с переедаемых параметров - Parent, Visible, Orientation, OnScroll - думаю назначение ясно без комментариев, но достойны ли они идти в качестве постоянных "спутников жизни"? Без Родителя компонент не создать! Видимость можно указать на этапе создания - поэтому выносить ее отдельно не хочется. Ориентацию вообще можно установить только во время создания и поменять нельзя! Событие желательно прикреплять как можно раньше, ну что думаю, возражений нет. Строка:

DoInitCommonControls( ICC_BAR_CLASSES );

нужна для инициализации "стандартных компонентов" (CommonControls - понятие API).
Особенность этой строки заключается в том, что ее необходимо вызывать только один раз, для любого числа TrackBar'ов. И поэтому появляться в New она собственно недолжна, лучше ее поместить в конце модуля.

begin
  DoInitCommonControls( ICC_BAR_CLASSES );
end.

Тогда если TrackBar(ы) создается(ются) эта строка вызывается, если же нет, то KOL и MCK удалит сам модуль из uses и вызываться она не будет - оптимизация. Хотя есть еще мысль поручить вызов функции MCK части компонента (где-нибудь в SetupFirst) вроде того:

procedure TKOLMHTrackBar.SetupFirst(SL: TStringList; const AName, AParent, Prefix: string);
 …
begin
  SL.Add(' DoInitCommonControls( ICC_BAR_CLASSES );');
  …

Преимущества пока не совсем очевидны, но если договорится, веем оформлять подобные (с точки зрения количества вызовов) функции таким образом (в MCK части компонента) и перед добавлением данной строки осуществлять проверку на ее наличие,
то можно облегчить код, а значит и размер программы (заметим, что это отразится и на быстродействии, в положительную сторону) - правда не очень (насчет выгоды не хочу вводить вас в заблуждение - она невелика, мелочь, а приятно).
Ладно, далее:

Result := PMHTrackbar(_NewCommonControl(AParent, TRACKBAR_CLASS, WS_CHILD    
          or Visible2Style[Visible] or TBS_FIXEDLENGTH or TBS_ENABLESELRANGE or
          Orientation2Style[Orientation], False, 0));

Просто создание. _NewCommonControl призвана создавать "стандартные компоненты", если хотите обычных вам подойдет _NewControl. Список параметров прост - думаю, разберетесь сами. PMHTrackbar(…) - преобразование типов необходимо, _NewCom… возвращает PControl, а нам нужен PMHTrackBar.
А вот, например на Orientation2Style[Orientation] прошу обратить внимание! Некоторые для преобразования типов используют функции - но данная методика через массив, осуществляется проще, работает быстрее, занимает меньше места - советую применять.
Далее очень интересный момент, помните, я говорил, нельзя вводить новые переменные, а вот и решение:

GetMem(D, Sizeof(D^));
Result.CustomData := D;
D.FOnScroll := OnScroll;

Выделяем память, и передаем указатель на данные стандартному свойству CustomData. Тип PTrackbarData мы определили, и добавили все необходимое нам для счастья переменные. Об освобождении памяти можно забыть, Кладов заботливо сделал это за нас, и она (память) будет заботливо освобождена при уничтожении компонента. Не забудем присвоить уже полученное значение (OnScroll). А теперь тоже интересный и важный момент - создание события (event) - OnScroll:

AParent.AttachProc(WndProcTrackbarParent);

И все! Этой строкой, мы только прицепляем (именно прицепляем - добавляем, но не заменяем) обработчик нашему родителю. Именно к родителю, это не специфика KOL и MCK и не моя прихоть особенность API. Но все не так просто, сначала нам пришлось написать функцию:

function WndProcTrackbarParent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
var
  D: PTrackbarData;
  Trackbar: PMHTrackbar;
begin
  Result := FALSE;
  if (Msg.message = WM_HSCROLL) or (Msg.message = WM_VSCROLL) then
    if (Msg.lParam <> 0) then
    begin
      Trackbar := Pointer( GetProp( Msg.lParam, ID_SELF ) );
      if Trackbar <> nil then
      begin
        D := Trackbar.CustomData;
        if Assigned( D.FOnScroll ) then
           D.FOnScroll( Trackbar, Msg.wParam );
      end;
    end;
end;

Не вдаваясь в API (это тема не нашей статьи) - она смотрит, что за событие (нам нужен WM_XXSCROLL), и для кого пришло (Handle) и если есть обработчик (OnScroll) пользователя - он выполняется, все. Может возникнуть справедливый вопрос - чем мне не нравится стандартный обработчик OnScroll (он ведь уже есть) - отвечаю нечем, это просто пример.
Теперь займемся свойствами. Установка позиции, API позволяет, получит нынешние состояние при помощи функции и установить необходимое, поэтому мы не используем CustomData. Вызов Perform аналогичен SendMessage(Handle,…), т.е. посылает сообщение себе.

function TMHTrackbar.GetPosition: DWord;
begin
  Result := Perform(TBM_GETPOS, 0, 0);
end;

procedure TMHTrackbar.SetPosition(const Value: DWord);
begin
  Perform(TBM_SETPOS, 1, Value);
end;

А вот если API вернуть нынешнее состояние параметра не в состоянии, его предется сохранять в CustomData:

function TMHTrackBar.GetOrientation: TTrackBarOrientation;
begin
  Result := PTrackbarData(CustomData)^.FOrientation;
end;

procedure TMHTrackBar.SetOrientation(const Value: TTrackBarOrientation);
begin
  PTrackbarData(CustomData)^.FOrientation := Value;
  Recreate;
end;

function TMHTrackbar.GetOnScroll: TOnScroll;
var
  D: PTrackbarData;
begin
  D := CustomData;
  Result := D.FOnScroll;
end;

procedure TMHTrackbar.SetOnScroll(const Value: TOnScroll);
var
  D: PTrackbarData;
begin
  D := CustomData;
  D.FOnScroll := Value;
end;

Тут показаны методики доступа к CustomData -правда, просто - причем два способа, причем с точки зрения откомпилированного кода он тождественны, выбирайте на вкус, я люблю первый.
Вы наверняка заметили в функции SetOrientation вызов Recreate, но сама функция пустая. Как я уже говорил, есть свойства, который в режиме работы поменять можно только пересоздав компонент (Ориентация - например, один из них). Кладов предлагает два выхода:
1. Создать в режиме разработки несколько компонентов с необходимыми наборами свойств, а потом переключать их при помощи Visible (т.е. ненужные скрывать, нужные показывать).
2. В режиме работы, старый уничтожать, а новый создавать с необходимым набором свойств (только в обратном порядки, сначала создать, а потом разрушить - чтобы избежать пропадания компонента и было, откуда копировать свойства).
Первый метод громоздок, с точки зрения разработки, да и если у вас много свойств - и вы все хотите менять, то количество компонентов, которое вам понадобиться может быть очень солидным. Второй громоздкий в плане исполнения руками - рутинен. Я предлагаю, чтобы не нагружать разработчика, большим и не нужным кодом, создать один раз Recreate (в KOL модуле) и вызывать его. С точки зрения потерь в эффективности - они небольшие, и появляется исключительно в специфических случаях, а так методики равнозначные. В любом случае имеющаяся сейчас у меня методика воссоздания меня не сильно устраивает. Есть идея войти глубже в KOL, и создать такие методы для TObj и TComponent (а может где и еще). Если у кого есть идеи, пишите - дискуссия открыта.
Собственно вот мы и разобрали весь код. Есть еще функция ClearSel, но она банальна и в себе ничего нового не несет. Теперь вы умеете создавать визуальные компоненты, для KOL. Вооружаемся MSDN и в бой!
Я хочу сказать, пока глава не окончилась еще пару слов об оптимизации. Человеку свойственна оптимизация, она идет от стремления к совершенству, но это не тема статьи. Есть два типа оптимизации: абсолютная - когда в результате растет и быстродействие и падает объем программы, относительное - когда улучшается что одно, а другое ухудшается (скорость - размер, размер - скорость).Для людей характерен первый вариант (абсолютная), чуть реже они оптимизирует в угоду скорости (это факт). Я хочу рассмотреть оптимизацию в пользу объема. И поступим мы так, возьмем наш TrackBar и посмотрим на следующие свойства:

property Min: DWord…;
property Max: DWord …;
property Position: DWord …;
property SelStart: DWord …;
property SelEnd: DWord …;
property PageSize: DWord …;
property LineSize: DWord …;
property ThumbLength:DWord…;

Как мы обычно делаем? SetMax/GetMax, SetMin/GetMin и пошло. А если подумать, они все одного типа. Теперь посмотрим на код функций и процедур Set/Get:

function TMHTrackbar.GetPosition: DWord;
begin
  Result := Perform(TBM_GETPOS, 0, 0);
end;

procedure TMHTrackbar.SetPosition(const Value: DWord);
begin
  Perform(TBM_SETPOS, 1, Value);
end;

или вот:

function TMHTrackbar.GetMax: DWord;
begin
  Result := Perform(TBM_GETRANGEMIN, 0, 0);
end;
procedure TMHTrackbar.SetMin(const Value: DWord);
begin
  Perform(TBM_SETRANGEMIN, 1, Value);
end;

Можно обобщить как:

property Min: DWord index 0 read GetVal write SetVal;
property Max: DWord index 1 read GetVal write SetVal;
property Orientation: TTrackBarOrientation read GetOrientation write SetOrientation;
property Position: DWord index 2 read GetVal write SetVal;
property SelStart: DWord index 3 read GetVal write SetVal;
property SelEnd: DWord index 4 read GetVal write SetVal;
property PageSize: DWord index 5 read GetVal write SetVal;
property LineSize: DWord index 6 read GetVal write SetVal;
property ThumbLength: DWord index 7 read GetVal write SetVal;

function TMHTrackbar.GetVal(const Index: Integer): DWord;

  type RVal = packed record
    Com: DWord;
    Par1: Byte;
    Par2: Byte;
  end;

const
  Val: array [0..7] of RVal = 
       (
       (Com: TBM_GETRANGEMIN; Par1: 0; Par2: 0),
       (Com: TBM_GETRANGEMAX; Par1: 0; Par2: 0),
       (Com: TBM_GETPOS; Par1: 0; Par2: 0),
       (Com: TBM_GETSELSTART; Par1: 0; Par2: 0),
       (Com: TBM_GETSELEND; Par1: 0; Par2: 0),
       (Com: TBM_GETPAGESIZE; Par1: 0; Par2: 0),
       (Com: TBM_GETLINESIZE; Par1: 0; Par2: 0),
       (Com: TBM_GETTHUMBLENGTH; Par1: 0; Par2: 0)
       );
begin
  with Val[Index] do
    Result := Perform(Com, Par1, Par2);
end;

procedure TMHTrackbar.SetVal(const Index: Integer; const Value: DWord);
  
  type RVal = packed record     Com: DWord;
    Use1: Byte;
    Use2: Byte;
    Par1: Byte;
    Par2: Byte;
  end;

const
  Val: array [0..7] of RVal = 
       (
       (Com: TBM_SETRANGEMIN; Use1: 0; Use2: 1; Par1: 1; Par2: 0),
       (Com: TBM_SETRANGEMAX; Use1: 0; Use2: 1; Par1: 1; Par2: 0),
       (Com: TBM_SETPOS; Use1: 0; Use2: 1; Par1: 1; Par2: 0),
       (Com: TBM_SETSELSTART; Use1: 0; Use2: 1; Par1: 1; Par2: 0),
       (Com:TBM_SETSELEND; Use1:0; Use2:1; Par1:1; Par2: 0),
       (Com: TBM_SETPAGESIZE; Use1: 0; Use2: 1; Par1: 1; Par2: 0),
       (Com: TBM_SETLINESIZE; Use1: 0; Use2: 1; Par1: 1; Par2: 0),
       (Com: TBM_SETTHUMBLENGTH; Use1: 1; Use2: 0; Par1: 0; Par2: 0)
       );
begin
with Val[Index] do
  Perform(Com, Value*Use1 + Par1, Value*Use2 + Par2);
end;

Как вам, вместо 14 методов 2? Статистику слегка портит THUMBLENGTH, но его можно выкинуть и упростить методы. Можно еще под Com выделять байт и сделать так:

…
(Com: TBM_SETRANGEMIN - WM_USER; Use1: 0; Use2: 1; Par1: 1; Par2: 0),
…
Perform(Com + WM_USER, Value*Use1 + Par1, Value*Use2 + Par2);

Еще экономия. Вы можете сказать, что теперь код стал медленнее, это так, но не сильно - это раз, а во-вторых в деле графического интерфейса - это не самый критичный код (самый критичный отрисовка - а ей руководит ОС). Мда… маленькая вставочка - недаром я хотел ее в отдельную главу оформить.