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… Его можно посмотреть по адресу
{*
Данный пример позволяет производить множественный выбор записей
в табличной сетке и отображать второе поле
набора данных.
Метод 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;