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

Иконка компонента является инкапсулированным объектом, требующим для хранения изображения некоторый участок памяти. Следовательно, при замене иконки, память, связанная с первоначальной иконкой, должна возвратиться в кучу, а для новой иконки требуется новое распределение памяти. По правилам 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;

Есть пример в 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;

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)

Один из примеров создания текстового компонента с трехмерной декоративной контурной рамкой (для создания компонента потребовалось около получаса. Он демонстрирует только принцип получения рамки. Я не стал колдовать над свойствами типа 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.

Решить задачу помогут обработчики событий 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;

У меня есть форма с расположенными на ней компонентами 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;

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

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

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;

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

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

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

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

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

with StringGrid1.Canvas do begin

 {…}

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

 {…}

end;

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

Как мне сохранить целый 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;

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

Добавление элементов управления в 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 почти такая же, как и в 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 сделать какую-либо страницу недоступной? То есть не позволять пользователю щелкать на ней и видеть ее содержимое?

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

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}

Действительно, любой компонент можно создать и без (вне) формы или любого другого дочернего компонента. Для этого я использую параметр 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;

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