• BitBtn
  • Смена иконки BitBtn во время работы приложения
  • DBGrid
  • Использование опции MultiSelect в DBGRID
  • Edit
  • Массив Edit-компонентов
  • Label
  • 3D-рамка для текстовых компонентов
  • ScrollBox
  • Синхронизация двух компонентов Scrollbox
  • Splitter
  • Конструирование Splitter
  • StatusBar
  • Обработчик события OwnerDraw в компоненте StatusBar
  • StringGrid
  • Установка атрибутов –=Только для чтения=– у столбцов компонента StringGrid
  • Помещение изображения в ячейку StringGrid
  • Сохранение и чтение Tstringgrid
  • TabbedNotebook
  • Добавление элементов управления в TTabbedNotebook и TNotebook
  • Недоступная закладка в компоненте Tabbednotebook
  • Table
  • Создание компонента TTable без формы
  • TreeView
  • Ускорение работы TreeView
  • Разное
  • Создание компонента во время работы приложения
  • Получение индекса компонента в списке родителя
  • Массив компонентов…
  • Дублирование компонентов и их потомков во время выполнения приложения
  • Компоненты

    BitBtn

    Смена иконки BitBtn во время работы приложения

    Иконка компонента является инкапсулированным объектом, требующим для хранения изображения некоторый участок памяти. Следовательно, при замене иконки, память, связанная с первоначальной иконкой, должна возвратиться в кучу, а для новой иконки требуется новое распределение памяти. По правилам Delphi, этим должен заниматься метод "Assign". Ниже приведен код всей процедуры замены иконки.

    implementation

    {$R *.DFM}


    var n: integer;  // При инициализации программы данное значение будет равным нулю

    procedure TForm1.Button1Click(Sender: TObject);

    var Image: TBitmap;

    begin // Изменение иконки в bitbtn1

     Image:= TBitmap.Create;

     if n < ImageList1.Count then ImageList1.GetBitmap(n, Image); {end if}

     BitBtn1.Glyph.Assign(Image)   // Примечание: Для изменения свойств объекта используется метод Assign

     inc(n,2); // В данный момент кнопка содержит две иконки!

     if n > ImageList1.Count then n:= 0; {end if}

     Image.Free;

    end;


    procedure TForm1.Button2Click(Sender: TObject);

    begin // добавляем новую иконку кнопки в список imagelist1

     if OpenDialog1.Execute then ImageList1.FileLoad(rtBitMap,OpenDialog1.FileName,clBtnFace);

     label1.Caption:=  'Количество иконок = ' + IntToStr(ImageList1.Count);

    end;

    DBGrid

    Использование опции MultiSelect в DBGRID

    Есть пример в Delphi Technical Information… Его можно посмотреть по адресу http://loki.borland.com/winbin/bds.exe?getdoc+2976+Delphi

    {*

     Данный пример позволяет производить множественный выбор записей

     в табличной сетке и отображать второе поле

     набора данных.

     Метод DisableControls применяется для того, чтобы

     DBGrid не обновлялся во время изменения набора данных.

     Последняя позиция набора данных сохраняется как

     TBookmark.

     Метод IndexOf вызывается для проверки

     существования закладки.

     Решение использовать метод IndexOf, а не метод

     Refresh должно определяться

     спецификой приложения.

    *}

    procedure TForm1.SelectClick(Sender: TObject);

    var

     x: word;

     TempBookmark: TBookMark;

    begin

     DBGrid1.Datasource.Dataset.DisableControls;

     with DBgrid1.SelectedRows do if Count  <> 0 then begin

      TempBookmark:= DBGrid1.Datasource.Dataset.GetBookmark;

      for x:= 0 to Count - 1 do begin

       if  IndexOf(Items[x]) > –1 then begin

        DBGrid1.Datasource.Dataset.Bookmark:= Items[x];

        showmessage(DBGrid1.Datasource.Dataset.Fields[1].AsString);

       end;

      end;

     end;

     DBGrid1.Datasource.Dataset.GotoBookmark(TempBookmark);

     DBGrid1.Datasource.Dataset.FreeBookmark(TempBookmark);

     DBGrid1.Datasource.Dataset.EnableControls;

    end;


    Edit

    Массив Edit-компонентов

    Procedure DoSomethingWithEditControls;

    Var K: Integer;

     EditArray: Array[0..99] of Tedit;

    begin

     Try

      For  K:= 0 to 99 do begin

       EditArray[K]:= TEdit.Create(Self);

       EditArray[K].Parent:= Self;

       SetSomeOtherPropertiesOfTEdit; {Устанавливаем необходимые свойства TEdit}

       Left:= 100; Top:= K*10;

       OnMouseMove:= WhatToDoWhenMouseIsMoved; {Что-то делаем при перемещении мыши}

      end;

      DoWhateverYouWantToDoWithTheseEdits; {Делаем все что хотим с полученным массивом Edit-компонентов}

     Finally

     For K:= 0to 99do EditArray[K].Free;

    end;

    Примечание: узнать доступные свойства компонента можно непосредственно в инспекторе объектов и (или) в текстовом режиме вашей формы (щелкните на форме правой кнопкой мыши и выберите пункт View as Text)

    Label

    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.

    ScrollBox

    Синхронизация двух компонентов Scrollbox

    Решить задачу помогут обработчики событий OnScroll (в данном примере два компонента ScrollBox (ScrollBar1 и ScrollBar2) расположены на форме TMainForm):

    procedure TMainForm.ScrollBar1Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);

    begin

     ScrollBar2.Position:= ScrollPos;

    end;

    procedure TMainForm.ScrollBar1Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);

    begin

     ScrollBar1.Position:= ScrollPos;

    end;

    Splitter

    Конструирование Splitter

    У меня есть форма с расположенными на ней компонентами TreeView и Memo. Значение свойства align обоих компонентов позволяет им занимать всю форму. Я хотел бы расположить между ними движок типа Splitter, пропорционально меняющий их размеры (один шире, другой меньше и наоборот), но к сожалению я обладаю лишь дистрибутивом Delphi2 (Splitter вошел в палитру только в Delphi3). Какой компонент мог бы сымитировать поведение Splitter и как это реализовать?

    Предположим, Ваш TreeView расположен в левой, а Memo в правой части формы. Вам нужно сделать следующее:

    • Установите свойство Align компонента TreeView на alLeft.

    • Вырежьте (Ctrl-X) компонент TMemo из вашей формы.

    • Добавьте компонент Panel и присвойте его свойству Align значение alClient.

    • Внутри панели разместите другой компонент Panel.

    • Установите его ширину, равной 8 пикселам, свойству Align присвойте значение alLeft.

    • Скопируйте вырезанный компонент TMemo в панель Panel1 и присвойте свойству Align значение alClient.

    Panel2 – движок: теперь вам необходимо добавить процедуры, приведенные ниже. Ваш код будет выглядеть приблизительно так:

    type TForm1 = class(tform)

     TreeView1: TTreeview;

     Panel1: TPanel;

     Panel2: TPanel;

     Memo1: TMemo;

     procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

     procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

     procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

    private

     Resizing: Boolean;

    public

     …

    end;

    procedure TForm1.Panel2MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

    begin

     Resizing:=true;

    end;

    procedure TForm1.Panel2MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

    begin

     Resizing:= false;

    end;

    procedure TForm1.Panel2MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

    begin

     if Resizing then begin

      TreeView1.Width:=TreeView1.Width+X;

      // Предохранение от странных ошибок перерисовки при изменении размеров:

      Panel1.Invalidate;

     end;

    end;

    Код может быть модифицирован для получения горизонтального движка – идея, надеюсь, понятна…

    StatusBar

    Обработчик события OwnerDraw в компоненте StatusBar

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

    procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect);

    begin

     with statusbar1.Canvas do begin

      Brush.Color:= clRed;

      FillRect(Rect);

      TextOut(Rect.Left, Rect.Top, 'Панель '+IntToStr(Panel.Index));

     end;

    end;

    StringGrid

    Установка атрибутов –=Только для чтения=– у столбцов компонента StringGrid

    Манипулирование вышеуказанным атрибутом возможно в обработчике события OnSelectCell:

    if Col mod 2 = 0 then grd.Options:= grd.Options + [goEditing]

    else grd.Options:= grd.Options – [goEditing];

    Помещение изображения в ячейку StringGrid

    Возможно ли поместить изображение в одну из ячеек компонента StringGrid?

    Такое позволяет обработчик события OnDrawCell. Приводим скелет кода, демонстрирующий принцип вывода изображения в ячейке компонента:

    with StringGrid1.Canvas do begin

     {…}

     Draw(Rect.Left, Rect.Top, Image1.Picture.Graphic);

     {…}

    end;

    Достичь цели позволяют методы Draw() и StretchDraw() объекта TCanvas. В приведенном примере переменная Image1 класса TImage содержит заранее загруженное изображение.

    Сохранение и чтение Tstringgrid

    Как мне сохранить целый Stringgrid со всеми ячейками в файле?

    Procedure SaveGrid;

    var f:textfile;

     x,y: integer;

    begin

     assignfile(f,'Filename');

     rewrite(f);

     writeln(f,stringgrid.colcount);

     writeln(f,stringgrid.rowcount);

     For x:= 0 to stringgrid.colcount-1 do For y:= 0 to stringgrid.rowcount-1 do writeln(F, stringgrid.cells[x,y]);

     closefile(f);

    end;


    Procedure LoadGrid;

     var f:textfile;

     temp,x,y:integer;

     tempstr:string;

    begin

     assignfile(f,'Filename');

     reset(f);

     readln(f,temp);

     stringgrid.colcount:= temp;

     readln(f,temp);

     stringgrid.rowcount:= temp;

     For x:=0 to stringgrid.colcount-1 do For y:=0 to stringgrid.rowcount-1 do begin

      readln(F, tempstr);

      stringgrid.cells[x,y]:= tempstr;

     end;

     closefile(f);

    end;

    TabbedNotebook

    Добавление элементов управления в TTabbedNotebook и TNotebook

    Я несколько раз видел в конференциях вопросы типа "как мне добавить элементы управления в TTabbedNotebook или TNotebook во время выполнения программы?". Теперь, когда у меня выдалось несколько свободных минут, я попытаюсь осветить этот вопрос как можно подробнее:

    TTabbedNotebook

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

    Добавление элементов управление во время выполнения приложения также очень просто. Тем не менее, в прилагаемой документации по Delphi вы не найдете рецептов типа Что-и-Как. Видимо для того, чтобы окончательно запутать начинающих программистов, фирма-изготовитель даже не удосужилась включить исходный код TTabbedNotebook в VCL-библиотеку. Таким образом, TTabbedNotebook остается для некоторых тайной за семью печатями. К счастью, я имею некоторый опыт, коим и хочу поделиться.

    Первым шагом к раскрытию тайны послужит просмотр файла \DELPHI\DOC\TABNOTBK.INT, интерфейсной секции модуля TABNOTBK.PAS, в котором определен класс TTabbedNotebook. Беглый просмотр позволяет обнаружить класс TTabPage, описанный как хранилище элементов управления отдельной страницы TTabbedNotebook.

    Вторым шагом в исследовании TTabbedNotebook может стать факт наличия свойством Pages типа TStrings. В связи с этим отметим, что Delphi-классы TStrings и TStringList соорганизуются с двумя свойствами: Strings и Objects. Другими словами, для каждой строки в TStrings есть указатель на соответствующий Objects. Во многих случаях этот дополнительный указатель игнорируется, нам же он очень пригодится.

    После небольшого эксперимента выясняем, что свойство Objects указывает на нашу копию TTabPage и ссылается на имя страницы в свойстве Strings. Блестяще! Всегда полезно знать что ищешь. Теперь посмотрим что мы можем сделать:

    { Данная процедура добавляет кнопку в случайной позиции на }

    { текущей странице данного TTabbedNotebook.                }

    procedure AddButton(tabNotebook : TTabbedNotebook);

    var

     tabpage: TTabPage;

     button: TButton;

    begin

     with tabNotebook do tabpage:= TTabPage(Pages.Objects[PageIndex]);

     button:= TButton.Create(tabpage);

     try

      with button do begin

       Parent:= tabpage;

       Left:= Random(tabpage.ClientWidth – Width);

       Top:= Random(tabpage.ClientHeight – Height);

      end;

     except

      button.Free;

     end;

    end;

    TNotebook

    Операция по заполнению элементами управления компонента TNotebook почти такая же, как и в TTabbedNotebook – разница лишь в типе класса – TPage вместо TTabPage. Тем не менее, если вы заглянете в DELPHI\DOC\EXTCTRLS.INT, декларацию класса TPage вы там не найдете. По неизвестной причине Borland не включил определение TPage и в DOC-файлы, поставляемые с Delphi. Декларация TPage в EXTCTRLS.PAS (можно найти в библиотеке VCL-исходников), правда, расположена в интерфейсной части модуля. Мы восполним пропущенную информацию о классе TPage:

    TPage = class(TCustomControl)

    private

     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;

    protected

     procedure ReadState(Reader: TReader); override;

     procedure Paint; override;

    public

     constructor Create(AOwner: TComponent); override;

    published

     property Caption;

     property Height stored False;

     property TabOrder stored False;

     property Visible stored False;

     property Width stored False;

    end;

    Теперь, по аналогии с вышеприведенной процедурой, попробуем добавить кнопку на TNotebook. Все, что мы должны сделать – заменить "TTabbedNotebook" на "TNotebook" и "TTabPage" на "TPage". Вот что должно получиться:

    { Данная процедура добавляет кнопку в случайной позиции на }

    { текущей странице данного TNotebook.                      }

    procedure AddButton(Notebook1: TNotebook);

    var

     page: TPage;

     button: TButton;

    begin

     with Notebook1 do page:= TPage(Pages.Objects[PageIndex]);

     button:= TButton.Create(page);

     try

      with button do begin

       Parent:= page;

       Left:= Random(page.ClientWidth – Width);

       Top:= Random(page.ClientHeight – Height);

      end;

     except

      button.Free;

     end;

    end;

    Остальное не менее просто!

    Недоступная закладка в компоненте Tabbednotebook

    Есть ли возможность в компоненте Tabbednotebook сделать какую-либо страницу недоступной? То есть не позволять пользователю щелкать на ней и видеть ее содержимое?

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

    with TabbedNotebook do Pages.Delete(PageIndex);

    и снова включить ее (при необходимости), перегрузив форму.

    Блокировка (а не удаление) немного мудренее, поскольку необходима организация цикла в процедуре создания формы, присваивающая имена закладкам компонента TabbedNotebook. Например так:

    J:= 0;

    with TabbedNotebook do for I:= 0 to ComponentCount - 1 do if Components[I].ClassName = 'TTabButton' then begin

     Components[I].Name:= ValidIdentifier(TTabbedNotebook(Components[I].Owner).Pages[J]) + 'Tab';

     Inc(J);

    end;

    где ValidIdentifier ValidIdentifier – функция, которая возвращает правильный Pascal-идентификатор, производный от строки 'Tab':

    function ValidIdentifier(theString: str63): str63;

    {--------------------------------------------------------}

    { Конвертирует строку в правильный Pascal-идентификатор, }

    { удаляя все неправильные символы и добавляя символ '_', }

    { если первый символ – цифра                             }

    {--------------------------------------------------------}

    var

     I, Len: Integer;

    begin

     Len:= Length(theString);

     for I:= Len downto 1 do if not (theString[I] in LettersUnderscoreAndDigits) then Delete(theString, I, 1);

     if not (theString[1] in LettersAndUnderscore) then theString:= '_' + theString;

     ValidIdentifier:= theString;

    end; {ValidIdentifier}

    Затем мы можем сделать закладку компонента TabbedNotebook недоступной:

    with TabbedNotebook  do begin

     TabIdent:= ValidIdentifier(Pages[PageIndex]) + 'Tab';

     TControl(FindComponent(TabIdent)).Enabled:= False;

     { Переключаемся на первую доступную страницу: }

     for I:= 0 to Pages.Count – 1 do begin

      TabIdent:= ValidIdentifier(Pages[I]) + 'Tab';

      if TControl(FindComponent(TabIdent)).Enabled then begin

       PageIndex:= I;

       Exit;

      end;

     end; {for}

    end; {with TabbedNotebook}

    следующий код восстанавливает доступность страницы:

    with TabbedNotebook do for I:= 0 to Pages.Count - 1 do begin

     TabIdent:= ValidIdentifier(Pages[I]) + 'Tab';

     if not TControl(FindComponent(TabIdent)).Enabled:= True;

    end; {for}

    Table

    Создание компонента TTable без формы

    Решение 1

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

    FSession:= TSession.Create(nil);

    FDatabase:= TDatabase.Create(nil);

    FSession.SessionName:= 'DBSession'

    FDatabase.Connected:= False;

    FDatabase.AliasName:= Database;

    FDatabase.DatabaseName:= USER_DATABASE;

    FDatabase.SessionName:= FSession.SessionName;

    FUserTBL:= TTable.Create(nil);

    FUserTBL.DatabaseName:= FDatabase.DatabaseName;

    FUserTBL.SessionName:= FSession.SessionName;

    FUserTBL.TableName:= USERTBL;

    FUserTBL.IndexName:= USERSpIndex;

    FUserSource:= TDataSource.Create(nil);

    FUserSource.DataSet:= FUserTBL;

    Решение 2

    Я привожу некоторый код, касающийся описываемой проблемы: он работал, когда я использовал его в большом приложении. Я не знаю специфического метода создания компонента TTable вне родителей, поэтому я пошел путем создания своего класса от TTable во время инициализации модуля. Удобство такого подхода объясняется наличием под рукой всегда готового к работе экземпляра класса, стоит всего-лишь добавить модуль к вашему приложению. Конечно, новый класс не должен иметь одиноко выглядящую процедуру со странной технологией фильтрации данных :=))), да и не помешала бы публикация нескольких событий, но этот пример призван все-го лишь продемонстрировать иной подход к решаемой задаче.

    unit Unit2;


    interface


    uses db, DBTables, dialogs;


    type fake = class(Ttable)

     procedure fakeFilterRecord(DataSet: TDataSet; var Accept: Boolean);

    end;


    var

     MyTable: fake;


    implementation


    procedure fake.fakeFilterRecord(DataSet: TDataSet; var Accept: Boolean);

    begin

     showmessage('Здравствуй, Вася');

    end;


    Initialization

     MyTable:= fake.create(nil);

     With Mytable do begin

      DataBaseName:= 'dbdemos';

      TableName:= 'biolife';

      OnFilterRecord:= MyTable.fakeFilterRecord;

      Filtered:= true;

      active:= true;

     end;

     {проверка получением неких данных…}

     showmessage(MyTable.fields[1].asstring);


    Finalization

     {Важно!  MyTable не имеет родителя, – уничтожаем объект сами, иначе память не высвобождается…}

     MyTable.free;

    end.

    TreeView

    Ускорение работы TreeView

    Представляем вашему вниманию немного переработанный компонент TreeView, работающий быстрее своего собрата из стандартной поставки Delphi. Кроме того, была добавлена возможность вывода текста узлов и пунктов в жирном начертании (были использованы методы TreeView, хотя, по идее, необходимы были свойства TreeNode. Мне показалось, что это будет удобнее).

    Для сравнения:

    TreeView:

    128 сек. для загрузки 1000 элементов (без сортировки)*

    270 сек. для сохранения 1000 элементов (4.5 минуты!!!)

    HETreeView:

    1.5 сек. для загрузки 1000 элементов – ускорение около 850%!!! (2.3 секунды без сортировки = stText)*

    0.7 сек. для сохранения 1000 элементов – ускорение около 3850%!!!

    Примечание:

    • Все операции выполнялись на медленной машине 486SX 33 Mгц, 20 Mб RAM.

    • Если TreeView пуст, загрузка происходит за 1.5 секунды, плюс 1.5 секунды на стирание 1000 элементов (общее время загрузки составило 3 секунды). В этих условиях стандартный компонент TTreeView показал общее время 129.5 секунд. Очистка компонента осуществлялась вызовом функции SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)).

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

    unit HETreeView;

    {$R-}

    // Описание: Реактивный TreeView

    (*

    TREEVIEW:

     128 сек. для загрузки 1000 элементов (без сортировки)*

     270 сек. для сохранения 1000 элементов (4.5 минуты!!!)

    HETREEVIEW:

     1.5 сек. для загрузки 1000 элементов – ускорение около 850%!!! (2.3 секунды без сортировки = stText)*

     0.7 сек. для сохранения 1000 элементов – ускорение около 3850%!!!

    NOTES:

     – Все операции выполнялись на медленной машине 486SX 33 Mгц, 20 Mб RAM.

     – * Если TTreeView пуст, загрузка происходит за 1.5 секунды,

     плюс 1.5 секунды на стирание 1000 элементов (общее время загрузки составило 3 секунды).

     В этих условиях стандартный компонент TreeView показал общее время 129.5 секунд.

     Очистка компонента осуществлялась вызовом функции

     SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)).

    *)

    interface


    uses SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, CommCtrl, tree2vw;


    type THETreeView = class(TTreeView)

    private

    FSortType: TSortType;

     procedure SetSortType(Value: TSortType);

    protected

     function GetItemText(ANode: TTreeNode): string;

    public

     constructor Create(AOwner: TComponent); override;

     function AlphaSort: Boolean;

     function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;

     procedure LoadFromFile(const AFileName: string);

     procedure SaveToFile(const AFileName: string);

     procedure GetItemList(AList: TStrings);

     procedure SetItemList(AList: TStrings);

     //Жирное начертание шрифта 'Bold' должно быть свойством TTreeNode, но...

     function IsItemBold(ANode: TTreeNode): Boolean;

     procedure SetItemBold(ANode: TTreeNode; Value: Boolean);

    published

     property SortType: TSortType read FSortType write SetSortType default stNone;

    end;


    procedure Register;


    implementation


    function DefaultTreeViewSort(Node1, Node2: TTreeNode; lParam: Integer): Integer; stdcall;

    begin

     {with Node1 do

      if Assigned(TreeView.OnCompare) then

      TreeView.OnCompare(Node1.TreeView, Node1, Node2, lParam, Result)

     else}

     Result:= lstrcmp(PChar(Node1.Text), PChar(Node2.Text));

    end;


    constructor THETreeView.Create(AOwner: TComponent);

    begin

     inherited Create(AOwner);

     FSortType:= stNone;

    end;


    procedure THETreeView.SetItemBold(ANode: TTreeNode; Value: Boolean);

    var

     Item: TTVItem; Template: Integer;

    begin

     if ANode = nil then Exit;

     if Value then Template:= -1 else Template:= 0;

     with Item do begin

      mask:= TVIF_STATE;

      hItem:= ANode.ItemId;

      stateMask:= TVIS_BOLD;

      state:= stateMask and template;

     end;

     TreeView_SetItem(Handle, Item);

    end;


    function THETreeView.IsItemBold(ANode: TTreeNode): Boolean;

    var

     Item: TTVItem;

    begin

     Result:= False;

     if ANode = nil then Exit;

     with Item do begin

      mask:= TVIF_STATE;

      hItem:= ANode.ItemId;

      if TreeView_GetItem(Handle, Item) then Result:= (state and TVIS_BOLD) <> 0;

     end;

    end;


    procedure THETreeView.SetSortType(Value: TSortType);

    begin

     if SortType <> Value then begin

    FSortType:= Value;

      if ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or (SortType in [stText, stBoth]) then AlphaSort;

     end;

    end;


    procedure THETreeView.LoadFromFile(const AFileName: string);

    var

     AList: TStringList;

    begin

     AList:= TStringList.Create;

     Items.BeginUpdate;

     try

      AList.LoadFromFile(AFileName);

      SetItemList(AList);

     finally

      Items.EndUpdate;

      AList.Free;

     end;

    end;


    procedure THETreeView.SaveToFile(const AFileName: string);

    var

     AList: TStringList;

    begin

     AList:= TStringList.Create;

     try

      GetItemList(AList);

      AList.SaveToFile(AFileName);

     finally

      AList.Free;

     end;

    end;


    procedure THETreeView.SetItemList(AList: TStrings);

    var

     ALevel, AOldLevel, i, Cnt: Integer;

     S: string;

     ANewStr: string;

     AParentNode: TTreeNode;

     TmpSort: TSortType;


     function GetBufStart(Buffer: PChar; var ALevel: Integer): PChar;

     begin

      ALevel:= 0;

      while Buffer^ in [' ', #9] do begin

       Inc(Buffer);

       Inc(ALevel);

      end;

      Result:= Buffer;

     end;


    begin

     //Удаление всех элементов – в обычной ситуации подошло бы Items.Clear, но уж очень медленно

     SendMessage(handle, TVM_DELETEITEM, 0, Longint(TVI_ROOT));

     AOldLevel:= 0;

     AParentNode:= nil;

     //Снятие флага сортировки

     TmpSort:= SortType;

     SortType:= stNone;

     try

      for Cnt := 0 to AList.Count-1 do begin

       S:= AList[Cnt];

       if (length(s) = 1) and (s[1] = chr($1a)) then break;

       ANewStr:= GetBufStart(PChar(S), ALevel);

       if (ALevel > AOldLevel) or (AParentNode = nil) then begin

        if ALevel - AOldLevel > 1 then raise Exception.Create('Неверный уровень TreeNode');

       end else begin

        for i:= AOldLevel downto ALevel do begin

         AParentNode:= AParentNode.Parent;

         if (AParentNode = nil) and (i - ALevel > 0) then raise Exception.Create('Неверный уровень TreeNode');

        end;

       end;

       AParentNode:= Items.AddChild(AParentNode, ANewStr);

       AOldLevel:= ALevel;

      end;

     finally

      //Возвращаем исходный флаг сортировки…

      SortType:= TmpSort;

     end;

    end;


    procedure THETreeView.GetItemList(AList: TStrings);

    var

     i, Cnt: integer;

     ANode: TTreeNode;

    begin

     AList.Clear;

     Cnt:= Items.Count -1;

     ANode:= Items.GetFirstNode;

     for i:= 0 to Cnt do begin

      AList.Add(GetItemText(ANode));

      ANode:= ANode.GetNext;

     end;

    end;


    function THETreeView.GetItemText(ANode: TTreeNode): string;

    begin

     Result:= StringOfChar(' ', ANode.Level) + ANode.Text;

    end;


    function THETreeView.AlphaSort: Boolean;

    var

     I: Integer;

    begin

     if HandleAllocated then begin

      Result:= CustomSort(nil, 0);

     end else Result:= False;

    end;


    function eView.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;

    var

     SortCB: TTVSortCB;

     I: Integer;

     Node: TTreeNode;

    begin

     Result:= False;

     if HandleAllocated then begin

      with SortCB do begin

       if not Assigned(SortProc) then lpfnCompare:= @DefaultTreeViewSort

       else lpfnCompare:= SortProc;

       hParent:= TVI_ROOT;

       lParam:= Data;

       Result:= TreeView_SortChildrenCB(Handle, SortCB, 0);

      end;

      if Items.Count > 0 then begin

       Node:= Items.GetFirstNode;

       while Node <> nil do begin

        if Node.HasChildren then Node.CustomSort(SortProc, Data);

        Node:= Node.GetNext;

       end;

      end;

     end;

    end;


    //Регистрация компонента

    procedure Register;

    begin

     RegisterComponents('Win95', [THETreeView]);

    end;


    end.

    Разное

    Создание компонента во время работы приложения

    Var

     MyButton: TButton;


    MyButton:= TButton.Create(MyForm);   //  MyForm теперь "обладает" MyButton

    with MyButton do BEGIN

     Parent:= MyForm;    //  Выбираем родителей. MyForm "усыновляет" MyButton

     height:= 32;

     width:= 128;

     caption:= 'Я здесь!';

     left := (MyForm.ClientWidth – width) div 2;

     top := (MyForm.ClientHeight – height) div 2;

    END;

    Inprise также рассказывала об этом в выпусках TechInfo.

    Поищите

    ti2938.asc Creating Dynamic Components at Runtime

    на публичном WWW или FTP сайте компании Inprise.

    Получение индекса компонента в списке родителя

    Мне необходимо найти индекс компонента в родительском списке дочерних элементов управления. Я попытался модифицировать prjexp.dll, но без успеха. У кого-нибудь есть идеи?

    Есть такая функция. Ищет родителя заданного компонента, перебирает список и возвращает индекс искомого компонента. Функция прошла многочисленные тесты и вполне работоспособна.

    { функция, возвращающая индекс искомого компонента в

      списке родителя; возвращает –1 при отсутствии компонента }

    function IndexInParent(vControl: TControl): integer;

    var

     ParentControl: TWinControl;

    begin

     {делаем "слепок" родителя через базовый класс на предмет доступности }

     ParentControl:= TForm(vControl.Parent);

     if (ParentControl <> nil) then begin

      for Result:= 0 to ParentControl.ControlCount - 1 do begin

       if (ParentControl.Controls[Result] = vControl) then exit;

      end;

     end;

     { если мы уж попали в это место, то либо не найден компонент, либо компонент не имел родителя }

     Result:= –1;

    end;

    Массив компонентов…

    Возможно ли создание массива компонентов? Для показа статуса я использую набор LED-компонентов и хотел бы иметь к ним доступ, используя массив.

    Прежде всего необходимо объявить массив:

    LED: array[1..10] of TLed;      (10 элементов компонентного типа TLed)

    При необходимости динамического создания LED-компонентов организуйте цикл, пример которого мы приводим ниже:

    for counter:= 1 to 10 do begin

     LED[counter]:= TLED.Create;

     LED[counter].top:= …

     LED[counter].Left:= …

     LED[counter].Parent:= Mainform;   {что-то типа этого}

    end;

    Если компоненты уже присутствуют на форме (в режиме проектирования), сделайте их элементами массива, например так:

    leds:= 0;

    for counter:= 0 to Form.Componentcount  do begin

     if (components[counter] is TLED) then begin

     inc(leds);

     LED[leds]:= TLED(components[counter]);

     end

    end;

    Тем не менее у нас получился массив со случайным расположением LED-компонентов. Я предлагаю назначить свойству Tag каждого LED-компонента порядковый номер его расположения в массиве, а затем заполнить массив, используя это свойство:

    for counter := 0 to Form.Componentcount do begin

     if (components[counter] is TLED) then begin

      LED[Component[counter].tag]:= TLED(components[counter]);

     end

    end;

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

    Дублирование компонентов и их потомков во время выполнения приложения

    Приведенный ниже код содержит функцию DuplicateComponents, позволяющую проводить клонирование любых компонентов и их потомков во время выполнения приложения. Действия ее напоминают операцию копирования/вставки (copy/paste) во время разработки приложения. Новые компоненты при создании получают тех же родителей, владельцев (в случае применения контейнеров) и имена (естественно, несколько отличающихся), что и оригиналы. В данной функции есть вероятность багов, но я пока их не обнаружил. Ошибки и недочеты могут возникнуть из-за редко применяемых специфических методов, которые, вместе с тем, могут помочь программистам, столкнувшимися с аналогичными проблемами.

    Данная функция может оказаться весьма полезной в случае наличия нескольких одинаковых областей на форме с необходимостью синхронизации изменений в течение некоторого промежутка времени. Процедура создания дубликата проста до безобразия: разместите на TPanel или на другом родительском компоненте необходимые элементы управления и сделайте: "newpanel := DuplicateComponents(designedpanel)".

    uses SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, IniFiles, TypInfo, Debug;


    type TUniqueReader = Class(TReader)

     LastRead: TComponent;

     procedure ComponentRead(Component: TComponent);

     procedure SetNameUnique(Reader: TReader; Component: TComponent; var Name: string);

    end;


    implementation


    procedure TUniqueReader.ComponentRead(Component: TComponent);

    begin

     LastRead:= Component;

    end;


    procedure TUniqueReader.SetNameUnique(  // Задаем уникальное имя считываемому компоненту, например, "Panel2", если "Panel1" уже существует

     Reader: TReader; Component: TComponent;              // Считываемый компонент

     var Name: string                    // Имя компонента для дальнейшей модификации

    );

    var

     i: Integer;

     tempname: string;

    begin

     i:= 0;

     tempname:= Name;

     while Component.Owner.FindComponent(Name) <> nil do begin

      Inc(i);

      Name:= Format('%s%d', [tempname, i]);

     end;

    end;


    function DuplicateComponents(

     AComponent: TComponent  // исходный компонент

    ): TComponent;              // возвращаемся к созданию нового компонента

     procedure RegisterComponentClasses(AComponent: TComponent);

     var i : integer;

     begin

      RegisterClass(TPersistentClass(AComponent.ClassType));

      if AComponent is TWinControl then

       if TWinControl(AComponent).ControlCount > 0 then

        for i:= 0 to (TWinControl(AComponent).ControlCount-1) do RegisterComponentClasses(TWinControl(AComponent).Controls[i]);

     end;


    var

     Stream: TMemoryStream;

     UniqueReader: TUniqueReader;

     Writer: TWriter;

    begin

     result:= nil;

     UniqueReader:= nil;

     Writer:= nil;

     try

      Stream:= TMemoryStream.Create;

      RegisterComponentClasses(AComponent);

      try

       Write:= TWriter.Create(Stream, 4096);

       Writer.Root:= AComponent.Owner;

       Writer.WriteSignature;

       Writer.WriteComponent(AComponent);

       Writer.WriteListEnd;

      finally

       Writer.Free;

      end;

      Stream.Position:= 0;

      try

       UniqueReader:= TUniqueReader.Create(Stream, 4096);     // создаем поток, перемещающий данные о компоненте в конструктор

       UniqueReader.OnSetName:= UniqueReader.SetNameUnique;

       UniqueReader.LastRead:= nil;

       if AComponent is TWinControl then UniqueReader.ReadComponents( // считываем компоненты и суб-компоненты

        TWinControl(AComponent).Owner, TWinControl(AComponent).Parent, UniqueReader.ComponentRead

       )

       else UniqueReader.ReadComponents( // читаем компоненты

        AComponent.Owner, nil, UniqueReader.ComponentRead

       );

       result:= UniqueReader.LastRead;

      finally

       UniqueReader.Free;

      end;

     finally

      Stream.Free;

     end;

    end;









     


    Главная | В избранное | Наш E-MAIL | Добавить материал | Нашёл ошибку | Наверх