Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 2 июля!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Динамическое добавление пунктов меню 2

Автор: Neil J. Rubenking

Вот пример программы, создающей структуру меню большой вложенности двумя различными способами. Она даст вам пищу для размышлений. Форма содержит компонент TMainMenu1 и, первоначально, одно подменю с именем SubMenu1.


 unit Istopmnu;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
   Controls, Forms, Dialogs, StdCtrls, Menus;
 
 type
   TForm1 = class(TForm)
     MainMenu1: TMainMenu;
     SubMenu1: TMenuItem;
     procedure AClick(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.AClick(Sender: TObject);
 var
   TM: TMenuItem;
   Lev: Word;
 begin
   MessageBeep(0);
   TM := Sender as TMenuItem;
   if TM.Count > 0 then
     Caption := 'подменю'
   else
     Caption := 'элемет меню';
   Caption := Caption + ' с именем "' + TM.Name + '"';
   Lev := 0;
   while (TM.Parent <> nil) and (TM.Parent is TMenuItem) do
   begin
     TM := TM.Parent;
     Inc(Lev);
   end;
   case Lev of
     1: Caption := 'Верхний уровень ' + Caption;
     2: Caption := '2-й уровень ' + Caption;
     3: Caption := '3-й уровень ' + Caption;
   else
     Caption := Format('%d-й уровень %s', [Lev, Caption]);
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   TM: TMenuItem;
   N: Integer;
 begin
   TM := SubMenu1;
   TM.Add(NewItem('&Элемент', 0, False, True, AClick, 0, 'MenuItem2'));
   for N := 2 to 5 do
   begin
     TM.Add(TMenuItem.Create(nil));
     TM := TM.Items[TM.Count - 1];
     TM.Caption := '&Меню';
     TM.Name := 'SubMenu' + IntToStr(N);
     TM.OnClick := AClick;
     TM.Add(NewItem('&Элемент', 0, False, True, AClick, 0,
       'MenuItem' + IntToStr(N + 1)));
   end;
   MainMenu1.Items.Add(NewSubMenu('Меню&2', 0, 'SM1',
     [NewItem('&Элемент', 0, False, True, AClick, 0, 'MI2'),
     NewSubMenu('&Меню', 0, 'SM2',
       [NewItem('&Элемент', 0, False, True, AClick, 0, 'MI3'),
       NewSubMenu('&Меню', 0, 'SM3',
         [NewItem('&Элемент', 0, False, True, AClick, 0, 'MI4'),
         NewSubMenu('&Меню', 0, 'SM4',
           [NewItem('&Элемент', 0, False, True, AClick, 0, 'MI5'),
           NewSubMenu('&Меню', 0, 'SM5',
             [NewItem('&Элемент', 0, False, True, AClick, 0, 'MI6')
             ])
           ])
         ])
       ])
     ]));
   TM := MainMenu1.Items[1];
   while TRUE do
   begin
     TM.OnClick := AClick;
     if TM.Count < 2 then
       Break;
     TM := TM.Items[1];
   end;
 end;
 
 end.
 




Динамическое добавление пунктов меню 3

Вы можете использовать готовые функции, определенные в модуле Menus. Определения в Delphi 2:


 function NewMenu(Owner: TComponent; const AName: string;
 Items: array of TMenuItem): TMainMenu;
 
 function NewPopupMenu(Owner: TComponent; const AName: string;
 Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of
 TMenuitem): TPopupMenu;
 
 function NewSubMenu(const ACaption: string; hCtx: Word; const AName:
 string; Items: array of TMenuItem): TMenuItem;
 
 function NewItem(const ACaption: string; AShortCut: TShortCut;
 AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word;
 const AName: string): TMenuItem;
 
 function NewLine: TMenuItem;
 
 

Это превращает вышепоставленную задачу в сущий пустяк.




Динамическая и статическая загрузка DLL

DLL возможно загружать двумя способами:

  1. статически
  2. динамически

Давайте создадим простую библиотеку DLL:


 {Project file name: c:\example\exdouble\exdouble.dpr}
 
 library ExDouble;
 // my simple dll
 
 function calc_double(r: real): real; stdcall;
 begin
   result := r * 2;
 end;
 
 exports
   calc_double index 1;
 
 end;
 

Теперь посмотрим, как её можно загружать:

Статическая загрузка DLL

При таком способе загрузки достаточно поместить файл DLL в директорию приложения или в директорию Windows, или в Windows\System, Windows\Command. Однако, если система не найдёт этого файла в этих директория, то высветится сообщение об ошибке (DLL не найдена, или что-то в этом духе).


 unit untMain;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 function calc_double(r: real): real; stdcall; external 'ExDouble.dll';
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   // в окошке сообщения будет цифра 21
   ShowMessage(FloatToStr(calc_double(10.5)));
 end;
 
 end.
 

Динамическая загрузка DLL

При динамической загрузке требуется написать немного больше кода.

А вот как это выглядит:


 unit untMain;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 type
   Tcalc_double = function ( r: real ): real;
 
   TForm1 = class(TForm)
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   hndDLLHandle: THandle;
   calc_double: Tcalc_double;
 begin
   try
     // загружаем dll динамически
     hndDLLHandle := loadLibrary ( 'ExDouble.dll' );
 
     if hndDLLHandle <> 0 then
     begin
 
       // получаем адрес функции
       @calc_double := getProcAddress ( hndDLLHandle, 'calc_double' );
 
       // если адрес функции найден
       if addr ( calc_double ) <> nil then
       begin
         // показываем результат ( 21...)
         showMessage ( floatToStr ( calc_double ( 10.5 ) ) );
       end
       else
         // DLL не найдена ("handleable")
         showMessage ( 'Function not exists...' );
 
     end
     else
       // DLL не найдена ("handleable")
       showMessage ( 'DLL not found...' );
 
   finally
     // liberar
     freeLibrary ( hndDLLHandle );
   end;
 end;
 
 end.
 




Динамические и виртуальные методы

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


 type
   t = class
     function a : integer; {статический}
     function b : integer; virtual;
     function c : integer; dynamic;
     property i : integer read a; { ok }
     property j : integer read b; { ok }
     property k : integer read c;
     { ОШИБКА: type mismatch (несовпадение типа) }
   end;
 




Динамические массивы


 const
   MaxBooleans = (High(Cardinal) - $F) div sizeof(boolean);
 
 type
   TBoolArray = array[1..MaxBooleans] of boolean;
   PBoolArray = ^TBoolArray;
 
 var
   B: PBoolArray;
   N: integer;
 
 begin
   N := 63579;
   {= получение памяти под динамический массив.. =}
 
   GetMem(B, N * sizeof(boolean));
   {= работа с массивом... =}
 
   B^[3477] := FALSE;
   {= возвращение памяти в кучу =}
 {$IFDEF VER80}
 
   FreeMem(B, N * sizeof(boolean));
 {$ELSE}
 
   FreeMem(B);
 {$ENDIF}
 end.
 




Динамические массивы 2

В. Возможно создавать динамически-изменяющиеся массивы в Delphi?

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

Прежде, чем вы сможете пользоваться массивом, вам необходимо распределить для него память. Используя AllocMem, вы можете точно управлять выделяемым размером памяти. Для того, чтобы определить необходимое количество байт, которые вы должны распределить, просто умножьте размер массива на размер отдельного элемента массива. Имейте в виду, что самый большой блок, который вы сможете распределить в любой момент в 16-битной среде равен 64Kб. Самый большой блок, который вы можете в любой момент распределить в 32-битной среде равен 4Гб. Для определения максимального числа элементов, которые вы можете иметь в вашем конкретном массиве (в 16-битной среде), разделите 65,520 на размер отдельного элемента. Например: 65520 div SizeOf(LongInt)

Пример объявления типа массива и указателя:


 type
   ElementType = LongInt;
 
 const
   MaxArraySize = (65520 div SizeOf(ElementType));
   (* в 16-битной среде *)
 
 type
   MyArrayType = array[1..MaxArraySize] of ElementType;
 
 var
   P: ^MyArrayType;
 
 const
   ArraySizeIWant: Integer = 1500;
 

Затем, для распределения памяти под массив, вы могли бы использоваться следующую процедуру:


 procedure AllocateArray;
 begin
   if ArraySizeIWant <= MaxArraySize then
     P := AllocMem(ArraySizeIWant * SizeOf(LongInt));
 end;
 

Не забывайте о том, что величина ArraySizeIWant должна быть меньше или равна MaxArraySize.

Вот процедура, которая с помощью цикла устанавливает величину каждого члена:


 procedure AssignValues;
 var
   I: Integer;
 begin
   for I := 1 to ArraySizeIWant do
     P^[I] := I;
 end;
 

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

Помните также о том, что после использования массива всю распределенную память необходимо освободить. Вот пример того, как избавиться от этого массива:


 procedure DeallocateArray;
 begin
   P := AllocMem(ArraySizeIWant * SizeOf(LongInt));
 end;
 

Ниже приведен пример динамического массива:


 unit Unit1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
   Controls, Forms, Dialogs, StdCtrls;
 
 type
   ElementType = Integer;
 
 const
   MaxArraySize = (65520 div SizeOf(ElementType));
   { в 16-битной среде }
 
 type
   { Создаем тип массива. Убедитесь в том, что вы установили
   максимальный диапазон, который вам, вероятно, может понадобиться. }
   TDynamicArray = array[1..MaxArraySize] of ElementType;
   TForm1 = class(TForm)
     Button1: TButton;
     procedure FormCreate(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
   { Создаем переменную типа указатель на ваш тип массива. }
   P: ^TDynamicArray;
 
 const
   { Это типизированные константы. В действительности они
   являются статическими переменными, инициализирующимися
   во время выполнения указанными в исходном коде значениями.
   Это означает, что вы можете использовать типизированные
   константы точно также, как и любые другие переменные.
   Удобство заключается в автоматически инициализируемой величине. }
   DynamicArraySizeNeeded: Integer = 10;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   { Распределяем память для нашего массива. Будь внимательны
   и распределяйте размер, в точности необходимый для размещения нового массива.
   Если вы попытаетесь записать элемент, выходящий за допустимый диапазон,
   компилятор не ругнется, но объект исключения вам обеспечен. }
   DynamicArraySizeNeeded := 500;
   P := AllocMem(DynamicArraySizeNeeded * SizeOf(Integer));
   { Как присвоить значение пятому элементу массива. }
   P^[5] := 68;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   { Вывод данных. }
   Button1.Caption := IntToStr(P^[5]);
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   { Освобождаем распределенную для массива память. }
   FreeMem(P, DynamicArraySizeNeeded * SizeOf(Integer));
 end;
 
 end.
 




Динамические массивы 3

Автор: Robert Wittig

Вот "демо-модуль", демонстрирующий три различных способа (далеко не все) создания динамических массивов. Все три способа для распределения достаточного количества памяти из кучи используют GetMem, tList используют для добавления элементов в список массива и используют tMemoryStream для того, чтобы распределить достаточно памяти из кучи и иметь к ней доступ, используя поток. Старый добрый GetMem вполне подходит для такой задачи при условии, что массив не слишком велик (<64K).

PS. Я не стал ловить в коде исключения (с помощью блоков Try...Finally}, которые могли бы мне помочь выявить ошибки, связанные с распределением памяти. В реальной системе вы должны быть уверены в своем грациозном владении низкоуровневыми операциями с памятью.


 {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
 { Форма, демонстрирующая различные методы создания массива с         }
 { динамически изменяемым размером. Разместите на форме четыре кнопки,}
 { компоненты ListBox и SpinEdit и создайте, как показано ниже,       }
 { обработчики событий, возникающие при нажатии на кнопки. Button1,   }
 { Button2 и Button3 демонстрируют вышеуказанных метода. Button4      }
 { очищает ListBox для следующего примера.                            }
 {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
 unit Dynarry1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, Spin;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     Button3: TButton;
     SpinEdit1: TSpinEdit;
     ListBox1: TListBox;
     Button4: TButton;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
     procedure Button3Click(Sender: TObject);
     procedure Button4Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 type
   pSomeType = ^SomeType;
   SomeType = Integer;
 
 procedure TForm1.Button1Click(Sender: TObject);
 type
   pDynArray = ^tDynArray;
   tDynArray = array[1..1000] of SomeType;
 var
   DynArray: pDynArray;
   I: Integer;
 begin
   { Распределяем память }
   GetMem(DynArray, SizeOf(SomeType) * SpinEdit1.Value);
   { Пишем данные в массив }
   for I := 1 to SpinEdit1.Value do
     DynArray^[I] := I;
   { Читаем данные из массива }
   for I := SpinEdit1.Value downto 1 do
     ListBox1.Items.Add('Элемент ' + IntToStr(DynArray^[I]));
   { Освобождаем память }
   FreeMem(DynArray, SizeOf(SomeType) * SpinEdit1.Value);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   List: tList;
   Item: pSomeType;
   I: Integer;
 begin
   { Создаем список }
   List := tList.Create;
   { Пишем данные для списка }
   for I := 1 to SpinEdit1.Value do
   begin
     { Распределяем уникальный экземпляр данных }
     New(Item);
     Item^ := I;
     List.Add(Item);
   end;
   { Читаем данные из списка - базовый индекс списка 0, поэтому вычитаем из I единицу }
   for I := SpinEdit1.Value downto 1 do
     ListBox1.Items.Add('Элемент ' +
       IntToStr(pSomeType(List.Items[I - 1])^));
   { Освобождаем лист }
   for I := 1 to SpinEdit1.Value do
     Dispose(List.Items[I - 1]);
   List.Free;
 end;
 
 procedure TForm1.Button3Click(Sender: TObject);
 var
   Stream: tMemoryStream;
   Item: SomeType;
   I: Integer;
 begin
   { Распределяем память потока }
   Stream := tMemoryStream.Create;
   Stream.SetSize(SpinEdit1.Value);
   { Пишем данные в поток }
   for I := 1 to SpinEdit1.Value do
     { Stream.Write автоматически отслеживает позицию записи,
     поэтому при записи данных за ней следить не нужно }
     Stream.Write(I, SizeOf(SomeType));
   { Читаем данные из потока }
   for I := SpinEdit1.Value downto 1 do
   begin
     Stream.Seek((I - 1) * SizeOf(SomeType), 0);
     Stream.Read(Item, SizeOf(SomeType));
     ListBox1.Items.Add('Элемент ' + IntToStr(Item));
   end;
   { Освобождаем поток }
   Stream.Free;
 end;
 
 procedure TForm1.Button4Click(Sender: TObject);
 begin
   ListBox1.Items.Clear;
 end;
 
 end.
 




Динамические массивы 4

Автор: Виталий

Я хочу написать об использовании динамических массивов. Для того чтобы с ними работать можно использовать два вида объявлния в типах


 type
   DAr = array of real;
 var
   A: DAr;
 

или сразу


 var A:array of real;
 

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


 SetLength(A,7)
 

Так мы создали массив состоящий из 7 элементов начиная с 0. Важно! Первый элемент в динамическом массиве всегда нулевой. Для определения верхний границы используем функцию Hihg


 I:=High(A);
 

I - верхняя граница. Для определения длины Length(A), для определения нижней границы Low(A). При нулевой длине массива High, возращает -1. Пример:


 var
   a,b: array of integer;
 begin
   SetLength(a,2);
   SetLength(b,2);
   a[0]:=2;
   b[0]:=3;
   a:=b;
   b[0]:=4;
 end;
 

После этих манипуляций а[0] равно 4. Дело в том при присвоении a:=b не происходит копирование т.к. а, b, это всего лишь указатели на область памяти. Для копирования необходимо использовать функцию Copy.

Я надеюсь что это кому-нибудь поможет в работе.

Всего наилучшего. Виталий

P.S. Не советую изменять длину массивов в DLL, у меня при этом возникала ошибка Acess violation побороть ее мне так и не удалось.




Динамические массивы 5

Автор: Igor Nikolaev aKa The Sprite

Иногда разработчик, работая с массивами, не знает какого размера массив ему нужен. Тогда Вам пригодится использование динамических массивов.


 var
   intArray : array of integer;
 

При таком объявлении размер массива не указывается. Что бы использовать его дальше необходимо определить его размер (обратите внимание, что размер динамического массива можно устанавливать в программе):


 begin
   intArray:=(New(IntArray,100); //Размер массива? 100
 end;
 




Решение для динамически создаваемых компонентов

Предупреждение:

Если вы просто хотите во время выполнения приложения создавать компоненты необходимого вам типа, ознакомьтесь с файлом delphi\doc\VB2Delph.wri и следуйте его рекомендациям, лучшего способа изучения этой темы пока не существует. Данный совет повествует об использовании в Delphi RTTI.

Во-первых, в вашем приложении необходимо зарегистрировать все классы, экземпляры которых вы собираетесь в каком-то месте кода создавать. Сделать это можно с помощью функций RegisterClass(), RegisterClasses() и RegisterClassAlias().

Пример:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   RegisterClasses([TButton, TEdit, TMemo, TLabel]);
 end;
 

Это может навести вас на мысль об ограничениях, но Delphi строгий язык. Если вы хотите истинно динамическое создание объектов в слаботипизированной среде позднего связывания, используйте динамический язык типа Smalltalk. У меня есть подозрение, что Delphi использует этот механизм регистрации для регистрации всех компонентов в DCL при его запуске, позволяя этим самым создавать любой компонент во время разработки.

Создание компонентов. Используйте функцию FindClass() для получения ссылки на класс компонента, который вы хотите создать, и вызывайте его метод Create. Легко, не правда ли? В примере у меня имеется приведение типа SomeComponent к TControl, после чего я уже могу установить свойство parent (я могу делать это, поскольку я знаю, что все зарегистрированные мною классы являются потомками TControl). Для того, чтобы визуальный компонент появился на форме, вам необходимо установить свойство parent.

Пример:


 procedure TForm1.CreateClick(Sender: TObject);
 begin
   SomeComponent:= TComponentClass(FindClass(ClassName.Text)).Create(Self);
   (SomeComponent as TControl).Parent := Self;
 end;
 

Теперь, когда вы имеете созданный компонент, как установить его свойства без использования самого большого блока case во вселенной? Очень просто: для получения информации о свойстве из структуры run-time type information (RTTI) используется функция GetPropInfo(), после чего для установления значений используется набор функций SetXXXXProp(). (Примечание: эти функции не задокументированы в файлах помощи Delphi. OO-программисты, как я понимаю, пользуются примерами из чужого кода и не изобретают свой велосипед.) У каждой функции SetXXXXProp() имеется функция-сателлит GetXXXXProp(), позволяющая узнать значения свойств объекта.

Пример:


 procedure TForm1.SetPropertyClick(Sender: TObject);
 var
   PropType: PTypeInfo;
   PropInfo: PPropInfo;
 begin
   PropInfo := GetPropInfo(SomeComponent.ClassInfo, PropertyName.Text);
   PropType := PropInfo^.PropType;
   case PropType^.Kind of
     tkInteger:
       SetOrdProp(SomeComponent, PropInfo,
         StrToInt(PropertyValue.Text));
     tkChar:
       SetOrdProp(SomeComponent, PropInfo, Ord(PropertyValue.Text[1]));
     tkEnumeration:
       SetOrdProp(SomeComponent, PropInfo, GetEnumValue(PropType,
         PropertyValue.Text));
     tkFloat:
       SetFloatProp(SomeComponent, PropInfo,
         StrToFloat(PropertyValue.Text));
     tkString:
       SetStrProp(SomeComponent, PropInfo, PropertyValue.Text);
   end;
 end;
 

Вы также можете установить значения свойств Set, Class и Method, но это будет немного сложнее. Немного позже я объясню как это можно сделать.

Это все. Вы проведете время с большой пользой, изучая исходный код VCL, и удивляясь, когда вы все там увидите собственными глазами.

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




Динамическое создание формы

Автор: Steve Schafer

Я хочу следующее:

  • мой компонент должен "динамически" создавать форму.
  • я не хочу включать имя модуля создаваемой формы в список используемых модулей моей текущей формы!!!

Ок, но модуль, содержащий форму, должен включаться в ваш EXE-файл, после чего вы должны вызвать RegisterClass. Наилучшее место для размещения вызова - секция инициализации модуля, определяющего форму:


 unit MyUnit;
 
 interface
 
 type
 TMyForm = class(TForm)
 
 ...
 
 implementation
 
 ...
 
 initialization
 RegisterClass(TMyForm);
 end.
 

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


 var
 SomeForm: TForm;
 FormClass: TFormClass;
 ...
 FormClass := TFormClass(FindClass('TMyForm'));
 SomeForm := FormClass.Create(Application);
 ...
 




Динамическое распределение памяти

Дай бог памати...буквально метра 128.


 uses WinCRT;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   MyArray: array[0..30] of char;
   b: ^char;
   i: integer;
 begin
   StrCopy(MyArray, 'Delphi World - это круто!!!');
   b := @MyArray;
   for i := StrLen(MyArray) downto 0 do
   begin
     write(b^);
     inc(b, sizeof(char));
   end;
 end;
 




Динамическое распределение памяти 2

- Что делает программист после запоя наутро?
- Тестирует память.

Как мне уменьшить количество занимаемой мной памяти в сегменте данных? (или как мне распределять память динамически?)

Скажем, ваша структура данных выглядит похожей на эту:


 type
   TMyStructure = record
     Name: String[40];
     Data: array[0..4095] of Integer;
 end;
 

Она слишком большая для глобального распределения, так что вместо объявления глобальной переменной,


 var
   MyData: TMyStructure;
 

объявляете указательный тип,


 type
   PMyStructure = ^TMyStructure;
 

и переменную этого типа,


 var
   MyDataPtr: PMyStructure;
 

Такой указатель занимает всего лишь четыре байта сегмента данных.

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


 New(MyDataPtr);
 

и получить к ней доступ через глобальные данные любым удобным для вас способом. Единственное отличие от традиционного способа заключается в необходимости использования символа "^" для обозначения указателя на данные:


 MyDataPtr^.Name := 'Советы по Delphi';
 MyDataPtr^.Data[0] := 12345;
 

И, наконец, после использования памяти, освободите ее:


 Dispose(MyDataPtr);
 




Динамическое OLE

Чем компьютер лучше женщины:
1. Компьютер не скажет: "ты мне не нравишься, я люблю другого".
2. Кожух с компьютера снимается без сопротивления.
3. Изображение на компьютере легко поменять.
4. Звук на колонках легко выключить.
5. У компьютера не бывает месячных.
6. Компьютер не потащит тебя знакомится со своими родителями.
7. Память на компьютере можно увеличить.
8. У девушки не бывает режима турбо.
9. Вирусы компьютера пользователю не передаются.
10. Компьютер можно собрать из тех частей, которые тебе нравятся.
11. Компьютер можно отформатировать.
12. У компьютера не болит голова.
13. Компьютер можно иметь в присутствии других.
14. Компьютер можно иметь везде.
15. К компьютеру можно подключить дополнительные периферийные устройства.
16. Компьютер не залетит.
17. Компьютер потерпит любые извращения.
18. Компьютер не ревнует, когда вы имеете другой компьютер.
19. На компьютер можно поставить пароль.
20. Девушку нельзя перезагрузить и начать всё сначала.
21. Сетевой сервер может одновременно обслуживать уйму народа.
22. На компьютере можно играть с друзьями.
23. Компьютер не заставит тебя на нем женится.
24. Компьютер не обидится, если ты назовешь его другим именем.
25. На компьютере можно отлаживать чужие программы.
26. У компьютера не бывает тещи.
27. Компьютер всегда запомнит, что ему скажешь.
28. Компьютер никогда не опаздывает.
29. Компьютер не боится мышей.
30. Компьютер не требует постоянно спонсировать его.
31. С глюками компьютера легко справится.
32. Компьютер грузится быстрее.
33. Компьютер не волнует, когда ты кончишь.
34. Компьютер мыслит логически.
35. Компьютер не потеет.

Некоторое время тому назад вы задавали вопрос по поводу динамического OLE без создания диалогового окна для просмотра файла. Я таки добился этого и вот код...


 uses...BOleDefs...
 
 procedure TPreview.previewOLEFile(fileName: string);
 var
 
   Info: ^BOleInitInfo;
   cString: array[0..80] of char;
 begin
 
   Screen.Cursor := crHourGlass;
   try
     GetMem(Info, sizeof(BoleInitInfo));
 
     Info^.How := BOLE_EMBED;
     Info^.Where := BOLE_FILE;
     Info^.pContainer := nil;
     Info^.hIcon := 0;
     Info^.Storage := nil;
 
     StrPCopy(cString, fileName);
     Info^.Path := cString;
 
     oleDocument.PInitInfo := Info;
     ReleaseOLEInitInfo(Info); { данная функция освобождает (getmem) память ! }
     oleDocument.Visible := True;
 
   finally
     Screen.Cursor := crDefault;
 
   end;
 end;
 




Динамические PageControl и TabSheet


 var
   T: TTabSheet;
   P: TPageControl;
 begin
   // Создаем PageControl
   // При создании получаем ссылку на PageControl, чтобы в дальнейшем на него ссылаться.
   P := TPageControl.Create(application);
   with P do
   begin
     Parent := Form1; // устанавливаем его как элемент управления формы.
     Top := 30;
     Left := 30;
     Width := 200;
     Height := 150;
   end; // with TPageControl
 
   // Создаем 3 страницы
   T := TTabSheet.Create(P);
   with T do
   begin
     Visible := True;
       // Это необходимо, или форма не будет корректно перерисовываться
     Caption := 'Страница 1';
     PageControl := P; // Назначаем Tab в Page Control
   end; // with
 
   T := TTabSheet.Create(P);
   with T do
   begin
     Visible := True;
       // Это необходимо, или форма не будет корректно перерисовываться
     Caption := 'Страница 2';
     PageControl := P; // Назначаем Tab в Page Control
   end; // with
 
   T := TTabSheet.Create(P);
   with T do
   begin
     Visible := True;
       // Это необходимо, или форма не будет корректно перерисовываться
     Caption := 'Страница 3';
     PageControl := P; // Назначаем Tab в Page Control
   end; // with
 
   // Создаем 3 кнопки, 1 на страницу
   with tbutton.create(application) do
   begin
     Parent := P.Pages[0]; // "Указываем" кнопке родительскую страницу
     Caption := 'Привет, страница 1';
     Left := 0;
     Top := 0;
   end; // with
 
   with tbutton.create(application) do
   begin
     Parent := P.Pages[1]; // "Указываем" кнопке родительскую страницу
     Caption := 'Привет, страница 2';
     Left := 50;
     Top := 50;
   end; // with
 
   with tbutton.create(application) do
   begin
     Parent := P.Pages[2]; // "Указываем" кнопке родительскую страницу
     Caption := 'Привет, страница 3';
     Left := 100;
     Top := 90;
   end; // with
 
   // Это должно быть сделано, или Tab первоначально не синхронизируется
   // с правильной страницей. Только в случае, если у вас более чем одна страница.
   P.ActivePage := P.Pages[1];
   P.ActivePage := P.Pages[0]; // Реально показываемая страница
 end;
 




Динамические PageControl и TabSheet 2

В данном документе показана технология динамического добавления страниц компонента PageControl (объектов TTabSheet) к элементу управления Windows 95/NT PageControl (объект TPageControl). Оба этих объекта объявлены в модуле ComCtrls. Поэтому убедитесь в том, что ComCtrls указан в списке используемых модулей.

Как динамически создать PageControl

Прежде, чем мы приступим к динамическому созданию страниц, давайте динамически создадим PageControl (если он еще не на форме). Это делается посредством вызова конструктора TPageControl Create с параметром owner, равным Self. Конструктор Create возвращает объектную ссылку на вновь созданный объект PageControl и назначает его переменной 'PageControl'. Вторым шагом будет установка свойства PageControl Parent в Self. Свойство Parent определяет где должен быть отображен новый PageControl; в нашем случае это будет сама форма. Вот кусок кода, демонстрирующий вышесказанное:


 var
 
 PageControl : TPageControl;
 
 PageControl := TPageControl.Create(Self);
 PageControl.Parent := Self;
 

Примечание: При разрушении формы разрушаются также PageControl и ее закладки, поскольку они принадлежат форме.

Как динамически создавать закладки

Существует два основных способа добавления новых страниц к PageControl. Сначала вы должны динамически создать TTabSheet следующим образом:


 var
 TabSheet : TTabSheet;
 TabSheet := TTabSheet.Create(Self);
 

Затем ему необходимо присвоить заголовок следующей командой:


 TabSheet.Caption := 'Закладка 1';
 

И, наконец, самая важное действие заключается в том, что новой странице необходимо сообщить, какому объекту PageControl она принадлежит. Это делается с помощью присваивания свойством TTabSheet PageControl переменной-ссылки TPageControl, типа той, которую мы создали выше (PageControl). Вот кусок кода, демонстрирующий вышесказанное:


 TabSheet.PageControl := PageControl;
 

Как динамически добавлять к страницам элементы управления

Ключевым моментом при создании и размещении элемента управления на странице TabSheet является назначение свойства Parent на переменную-ссылку класса TTabSheet. Вот пример:


 var
 
 Button : TButton;
 
 Button := TButton.Create(Self);
 Button.Caption := 'Кнопка 1';
 Button.Parent := TabSheet;
 

Более подробно об объектах TPageControl и TTabSheet вы можете узнать в онлайн-документации, или посмотреть код файла ComCtrls.pas, расположенного в вашем каталоге ..\Delphi 2.0\SOURCE\VCL.

Полный код примера


 // Код использует форму с единственной на ней кнопкой.
 
 unit DynamicTabSheetsUnit;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, Buttons;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
     procedure TestMethod(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 uses ComCtrls;
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
 
   PageControl: TPageControl;
   TabSheet: TTabSheet;
 begin
 
   // Создаем PageControl
   PageControl := TPageControl.Create(Self);
   PageControl.Parent := Self;
 
   // Создаем первую страницу и связываем ее с PageControl
   TabSheet := TTabSheet.Create(Self);
   TabSheet.Caption := 'Закладка 1';
   TabSheet.PageControl := PageControl;
 
   // Создаем первую страницу
 
   with TButton.Create(Self) do
   begin
     Caption := 'Кнопка 1';
     OnClick := TestMethod; // Назначаем обработчик события
     Parent := TabSheet;
   end;
 
   // Создаем вторую страницу и связываем ее с PageControl
 
   TabSheet := TTabSheet.Create(Self);
   TabSheet.Caption := ' Закладка 2';
   TabSheet.PageControl := PageControl;
 end;
 
 procedure TForm1.TestMethod(Sender: TObject);
 begin
 
   ShowMessage('Привет');
 end;
 
 end.
 




Как удобнее работать с динамически формируемыми запросами

Автор: Nomadic

В процессе работы с БД иногда необходимо выполнить какие-то мелкие запросы. Держать для этого где-то временную Query меня лично ломает, посему ловите творение (под Delphi) - модуль для создания временных TQuery и работы с ними.

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


 var
   S: string;
 ...
 
 S := FastLookUp(format('select A.F1 from A,B where A.F4=B.F4 and
   B.F9=%d', [1]));
 
 with GiveMeResultSet('select*from A where F1="777"') do
   try
     ....
   finally
     Free; {не забудьте!}
   end;
 .....
 
   if not ExecuteSQL('delete from A') then
     ShowMessage('Something Wrong');
 .....
 

Сам модуль идёт ниже


 {
 Temporary Queries Creatin' and handlin'
 
 (c) 1997-98 by Volok Alexander (D1/D2)
 
 creation date: 30.10.1997
 last update : 17.06.1998
 }
 unit TmpQuery;
 
 interface
 
 uses
   DBTables;
 
 const
   InternalDBname = 'MAIN'; {Изменять по вкусу - TDataBase.DataBaseName}
 
 type
   TSQLScript = {$IFDEF WIN32}string{$ELSE}PChar{$ENDIF};
 
   {Создаст куери с текстом запроса, но не откроет его}
 function CreateTempQuery(SQLscript: TSQLscript): TQuery;
 
 {Создаст куери и откроет запрос - не забудьте прибить}
 function GiveMeResultSET(SQLscript: TSQLscript): TQuery;
 
 {Проверит непустоту выборки, заданной ...}
 function CheckExistence(SQLscript: TSQLscript): boolean;
 
 {Вытащит аж одно значение(лукап) из выборки, заданной ...}
 function FastLookUP(SQLscript: TSQLscript): string;
 
 {Выполнит запрос и сообщит результат}
 function ExecuteSQL(SQLscript: TSQLscript): boolean;
 
 implementation
 
 uses
   Forms;
 
 function CreateTempQuery(SQLscript: TSQLscript): TQuery;
 begin
   Result := TQuery.Create(Application);
   with Result do
   begin
     DatabaseName := InternalDBname;
 {$IFDEF WIN32}
     SQL.Text := SQLscript;
 {$ELSE}
     SQL.SetText(SQLscript);
 {$ENDIF}
   end;
 end;
 
 function ExecuteSQL(SQLscript: TSQLscript): boolean;
 begin
   with CreateTempQuery(SQLscript) do
   begin
     try
       ExecSQL;
       Result := True;
     except
       Result := False;
     end;
     Free;
   end;
 end;
 
 function CheckExistence(SQLscript: TSQLscript): boolean;
 begin
   with GiveMeResultSET(SQLscript) do
   begin
     Result := not EOF;
     Free;
   end;
 end;
 
 function GiveMeResultSET(SQLscript: TSQLscript): TQuery;
 begin
   Result := CreateTempQuery(SQLscript);
   with Result do
   try
     Open;
   except
     Free;
     Result := nil;
   end;
 end;
 
 function FastLookUP(SQLscript: TSQLscript): string;
 begin
   with GiveMeResultSET(SQLscript) do
   begin
     try
       Result := Fields[0].AsString;
     except
       Result := '';
     end;
     Free;
   end;
 end;
 
 end.
 




Динамическое использование DLL

Автор: Dr. Bob

Y3K. На пляже мама с ребенком.
- Мам, а откуда берется песок?
- Из микросхем. Их сердцевина состоит из кремния. Его собирают, перемалывают и сжигают, и получают песок.

...возможно ли заставить Delphi осуществлять только линковку ссылок на необходимые приложению DLL-функции с помощью директив компилятора или чего-то подобного? Я могу с ними динамически связаться с помощью GetProcAddress или функций линковки, но я был бы счастлив если была бы альтернатива попроще. (стилистика авторская - В.О.)

Нет, даже в вашем случае вы должны использовать динамическое связывание...

Часто кажется, что проще написать в модуле явное импортирование функций, чем использовать их динамическое связывание. Тем не менее, основное преимущество динамически загружаемых DLL в том, что ваше приложение может быть загружено и быть работоспособным и в случае отсутствия DLL, при условии, что приложение может к этому "приспособиться". Например, если если вы реализовали в своей DLL трехмерное представление вашего объекта, но DLL не была найдена (при попытке загрузить ее динамически), то приложение также будет работать, но объекты будут представлены в обычном, двумерном виде. Если DLL, о которой идет речь, будет связана статически, Windows откажется выполнять приложение (с претензией, что ваша 3D.DLL не была обнаружена), чему пользователь будет "неслыханно рад". Другое преимущество явного импорта в модуле в том, что приложение будет загружаться быстрее, поскольку динамически подгружаемые DLL будут загружены впоследствии, когда они действительно понадобятся.

Проследим, что получается, если вы используете в модуле явный импорт DLL или в вашем коде вы объявляете функцию DLL с внешним 'DLLNAME'. В этом случае компоновщик установит ссылки на DLL-функции в таблице импортируемых имен скомпонованного EXE-файла и загрузчик Windows автоматически загрузит DLL (во время выполнения главного блока) вместе с файлом EXE:


 procedure Foo(X: Integer); external 'BAR' index 1;
 

Если в течение связывания (также называемое статической линковкой) Windows не сможет найти DLL, вы получите предупреждение - чаще всего File Error MessageBox (как раз то, в котором не указан ненайденный файл - ну очень "полезная" штуковина!). Поэтому вы должны быть абсолютно уверенными в том, что DLL будет доступна все то время, когда вы захотите ей воспользоваться, т.е. всегда.

Динамически связанная DLL, использующая модуль явного импорта, пользуется методами VB, каковые вы также можете использовать, но делая это "вручную". С помощью LoadLibrary по мере необходимости вы загружаете DLL, получаете указатели на экспортируемые функции, которые вы предполагаете использовать с GetProcAddress и освобождаете DLL с помощью FreeLibrary, когда она вам больше не нужна:


 var
   Hbar: Thandle;
   Foo: procedure(X: Integer);
 begin
   Hbar := LoadLibrary('BAR.DLL');
   if Hbar >= 32 then { успешно }
   begin
     Foo := GetProcAddress(HBar, 'FOO');
     ...
     Foo(1);
     ...
     FreeLibrary(HBar);
   end
   else
     MessageDlg('Ошибка: не могу найти BAR.DLL', mtError, [mbOk], 0)
 end.
 




Удаление и добавление элементов в динамический массив

Автор: http://sunsb.dax.ru

Крутая штука динамический массив. Очень быстрая и здоровая реализация. Единственное, чего на мой взгляд не хватает, это механизма удаления элемента из середины массива и соответственно вставки в середину. Насколько я понял ( и проверил ), в памяти массив хранится по-разному в зависимости от типа его элементов. Скажм если в массиве строки(!! не shortString ) - хранятся указатели на них, а если прямоугольники (TRect) - то непосредственно сами прямоугольники.

Ниже привожу подпрограммы удаления и добавления элемента.


 procedure delElem( var A:TRectArray; Index:integer );
 var Last : integer;
 begin
    Last:= high( A );
    if Index <  Last then move( A[Index+1], A[ Index ],
        (Last-Index) * sizeof( A[Index] )  );
    setLength( A, Last );
 end;
 
 procedure addElem( var A: TRectArray; Index: integer;
                                        ANew: TRect );
 var Len : integer;
 begin
    Len:= Length( A );
    if Index > = Len then Index := Len+1;
    setLength( A, Len+1);
    move( A[Index], A[ Index+1 ],
          (Len-Index) * sizeof( A[Index] ));
    A[Index] := ANew;
 end;
 

Подпрограмма delElem полностью универсальна, а в addElem Вам нужно поменять тип добовляемого елемента (ANew) на требуемый.




Простое использование TParser

Автор: Mike Scott

...можно ли с помощью TParser "вытащить" из строки целочисленные значения, разделенные между собой пробелом, например, из строки '345 998 223 546 777' получить пять чисел?

Как этот пример? Он парсирует текст из поле редактирования с именем Edit1 и помещает полученные числа с список с именем Listbox1:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   Stream: TStream;
   s: string;
 begin
   Stream := TMemoryStream.Create;
   try
     { получаем текст области редактирования и помещаем его в поток }
     s := Edit1.Text;
     Stream.WriteBuffer(s[1], length(s));
     { сбрасываем стартовую позицию потока и создаем парсер }
     Stream.Position := 0;
     with TParser.Create(Stream) do
     try
       { "добываем" числа и добавляем их в список }
       while Token <> toEOF do
       begin
         CheckToken(toInteger); { возбуждаем исключение, если не toInteger }
         Listbox1.Items.Add(IntToStr(TokenInt));
         NextToken;
       end;
     finally
       Free;
     end;
   finally
     Stream.Free;
   end;
 end;
 

Как вы можете видеть, бОльшая часть кода тривиальна: работа с потоком, его создание и освобождение, и парсер, естественно, с обработкой ошибок<g>. CheckToken проверяет, является ли текущий признак ожидаемым, и, если нет, генерирует исключительную ситуацию. В нашем случае мы ищем целые (toInteger), и читаем их из TParser.TokenInt. Просто!




Как сэкономить память в программах

Что общего между морской свинкой и женщиной-программистом?
То, что морская свинка - она и не свинка, и не морская.

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

Но сначала обратимся к основам типов данных, используемых в Delphi, и детально рассмотрим - сколько байт памяти занимает каждый тип данных:

1 байт
boolean, char and byte
2 байт
smallInt, word, wordbool
4 байт
string, pointers, longint, integer

Теперь давайте посмотрим на объявление класса в нашем исходном коде:


 TMyClass = class
   private
     field1: char;
     field2: longint;
     field3: boolean;
     field4: string;
     field5: byte;
     field6: integer;
   public
     procedure proc1;
 end;
 

теперь просуммируем байты, которы занимает каждый тип данных. По идее должно получиться 15 байт, но на самом деле это не так. Реальный размер, занимаемый данным экземпляром класса будет составлять 24 байта, т. е. 4 байта на каждое поле. Почему ? Потому что поумолчанию в Delphi, по правилам оптимизации, каждое поле располагается от предыдущего со сдвигом на 4 байта: field1 занимает 1 байт, поидее поле field2 должно следовать сразу же за field1, но по правилам оптимизации, остаются 3 байта не содержащие никакой информации, а следовательно напрасно потерянные. А если бы field2 был бы длиной в 1 байт или 2 байта, то он был бы помещён сразу же за полем field1, потому что это не нарушает правил оптимизации.

Какой же напрашивается вывод ? А если изменить порядок объявления переменных в классе ? Я просто сгруппировал переменные по их размеру (байтовому): вместе все однобайтовые, соответственно вместе все двухбайтовые и т.д.

Вот так стал выглядеть наш класс:


 TMyClass = class
   private
     field1: char;
     field3: boolean;
     field5: byte;
     field2: longint;
     field4: string;
     field6: integer;
   public
     procedure proc1;
 end;
 

С такой организацией классы, его длина стала 16 байт (сэкономили 8 байт на каждом экземпляре данного класса). Конечно же это не большая экономия памяти, но в тех случая, когда класс инициализируется многократно либо класс довольно велик, то такая экономия довольно ощутима.




Обработка исключений EDBEngineError

Error 109: Error 108.

Информация, описывающая условия возникновения ошибки BDE, может быть получена приложением с помощью исключения EDBEngineError. Перехват и обработка в приложениях исключений EDBEngineError осуществляется с помощью конструкции try..except. При наступлении исключения EDBEngineError должен быть создан объект EDBEngineError, различные поля в котором могут быть использованы программистом для определения источника ошибки и принятия решения по исправлению ситуации. Для данного типа исключения может генерироваться более чем одно сообщение об ошибке. Для получения нужной информации необходимо "проиграть" все сообщения.

Вот поля, наиболее соответствующие нашему контексту:

  • ErrorCount: тип Integer; указывает количество ошибок в свойстве Errors; отсчет начинается с нуля.
  • Errors: тип TDBError; набор записей типа структуры, содержащей информацию о каждой специфической сгенерированной ошибке; каждая запись доступна через номер индекса, имеющего тип Integer.
  • Errors.ErrorCode: тип DBIResult; указывает код ошибки BDE для ошибки в текущей записи Errors.
  • Errors.Category: тип Byte; категория ошибки, ссылается на поле ErrorCode.
  • Errors.SubCode: тип Byte; субкод значения ErrorCode.
  • Errors.NativeError: тип LongInt; код удаленной ошибки, возвращаемой сервером; если ноль, то ошибка не является ошибкой сервера; в этом поле возвращается код запроса SQL.
  • Errors.Message: тип TMessageStr; если ошибка является ошибкой сервера, то сообщение сервера содержится в текущей записи Errors; если это не ошибка сервера, то это сообщение об ошибке BDE.
В случае наличия конструкции try..except, объект EDBEngineError создается непосредственно в секции except. После создания объекта исключения все его области становятся доступными, ссылка на объект может передаваться в другую процедуру для детального исследования ошибок. Метод передачи объекта EDBEngineError в специализированную процедуру для приложения предпочтительнее, поскольку делает код приложения более модульным и уменьшает общий объем кода, необходимого для синтаксического анализа объекта и получения информации о возникшей ошибке. В качестве альтернативы можно предложить идею создания специализированного компонента, предусматривающего описанную функциональность; такое решение позволяет распространять созданный в основе компонента код среди нескольких приложений. Приведенный ниже пример демонстрирует создание объекта DBEngineError, передачу его процедуре и синтаксический разбор объекта для получения информации об ошибке.

В конструкции try..except для создания экземпляра DBEngineError необходим синтаксис, показаный ниже:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: Integer;
 begin
   if Edit1.Text > ' ' then
   begin
     Table1.FieldByName('Number').AsInteger := StrToInt(Edit1.Text);
     try
       Table1.Post;
     except
       on E: EDBEngineError do
         ShowError(E);
     end;
   end;
 end;
 

В данной процедуре сделана попытка изменить значение поля таблицы и вызвать метод Post соответствующего компонента TTable. Ошибка при попытке отправить измененные данные перехватывается в секции try..except. В случае возникновения EDBEngineError, выполнение передается в секцию except, где происходит создание объекта EDBEngineError (E) и передача его процедуре ShowError. Обратите внимание на то, что в этой секции во внимание берутся только исключения EDBEngineError. В реальной программе код должен содержать проверку на другие типы исключений.

Процедура ShowError в качестве параметра получает ссылку на объект EDBEngineError и "опрашивает" его на предмет наличия информации об ошибках. В приведенном ниже примере информация об ошибках отображается в компоненте TMemo. В реальной жизни отображение ошибок может и не понадобится, но информация о них является логикой работы приложения, расширяющая его функциональность так, чтобы оно могло правильно реагировать на них. Первым шагом необходимо вычислить количество реально произошедших ошибок. Эта величина хранится в свойстве ErrorCounnt. Данное свойство имеет тип Integer и может использоваться для создания цикла, в теле которого можно по очереди получить информацию о каждой ошибке, содержащейся в объекте. В теле цикла поочередно ErrorCount-раз перебираются все содержащиеся в объекте ошибки (как вы помните, каждая ошибка представляет собой запись-элемент свойства Errors), "достается" о них вся информация и помещается в компонент TMemo.


 procedure TForm1.ShowError(AExc: EDBEngineError);
 var
   i: Integer;
 begin
   Memo1.Lines.Clear;
   Memo1.Lines.Add('Количество ошибок: ' + IntToStr(AExc.ErrorCount));
   Memo1.Lines.Add('');
   {Перебираем все записи Errors}
   for i := 0 to AExc.ErrorCount - 1 do
   begin
     Memo1.Lines.Add('Сообщение: ' + AExc.Errors[i].Message);
     Memo1.Lines.Add(' Категория: ' +
       IntToStr(AExc.Errors[i].Category));
     Memo1.Lines.Add(' Код ошибки: ' +
       IntToStr(AExc.Errors[i].ErrorCode));
     Memo1.Lines.Add(' Субкод: ' +
       IntTooStr(AExc.Errors[i].SubCode));
     Memo1.Lines.Add(' Реальная ошибка: ' +
       IntToStr(AExc.Errors[i].NativeError));
     Memo1.Lines.Add('');
   end;
 end;
 




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

Не стОит давать деньги программисту (особенно WINDOWS-программисту), т.к. если ему удастся на них что-нибудь купить , то он вернет Вам 0 (ноль) как результат успешно выполненного действия.


 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;
       {Устанавливаем необходимые свойства TEdit}
       SetSomeOtherPropertiesOfTEdit;
       Left := 100;
       Top := K * 10;
       {Что-то делаем при перемещении мыши}
       OnMouseMove := WhatToDoWhenMouseIsMoved;
     end;
     {Делаем все что хотим с полученным массивом Edit-компонентов}
     DoWhateverYouWantToDoWithTheseEdits;
   finally
     for K := 0 to 99 do
       EditArray[K].Free;
   end;
 end;
 




Матрица на основе TEdit

Автор: Mike Orriss

Для продвижения своих многоплатформных решений, одна из компьютерных компаний решила создать свой формат HELP-файлов на базе ".RTF" (rich text format). Новый формат было решено назвать ".RTFM"

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

Допустим, если они имеют имена с Edit1 по Edit 9, то можно попробовать сделать так:


 var
   eds: array[1..3,1..3] of TEdit;
   ix: integer;
   ed: TEdit;
 begin
   for ix := 0 to 8 do
   begin
     ed := FindComponent('Edit'+IntToStr(ix+1)) as TEdit;
     if ed <> nil then
       eds[ix div 3 + 1,ix mod 3 + 1] := ed;
   end;
 end;
 

Затем, допустим, вам захотелось скопировать текст из строки 1 в строку 2:


 for ix := 1 to 3 do
   eds[2,ix].Text := eds[1,ix].Text;
 




Числовая маска компонента Edit

Я здесь лежал, и здесь мои друзья
С таким похмельем долго жить нельзя
Средь глючных вИндов в пьяной тишине,
Какой-то юзер подпевает мне...

Я предлагаю обработать событие OnKeyPress следующим образом:


 procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
 begin
   if    NOT (Key in ('0'..'9', '.', #8, #13)) // разрешенные клавиши
     OR (    (Key = '.')                  // пользователь нажал '.'
     AND (POS ('.', Edit1.Text) > 0)) // десятичная точка уже имеется
     then
     begin
       Key := #0;
       MessageBeep (MB_OK);
   end;
 end;
 

В коде проверяется, была ли нажатая клавиша цифрой, клавишей [Tab] или [Enter]. Все остальное запрещено (код клавиши не принимается, и устанавливается в ноль) и подается сигнал через компьютерную пищалку.

Если вы не хотите связываться с десятичной дробью, уберите строчку с ключевым словом OR и символ '.' из первого IF-условия. Если вы хотите проверять, что пользователь ввел между LowLimit и HighLimit, воспользуйтесь следующим кодом:


 procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
 begin
   if    NOT (Key in ('0'..'9', #8, #13))
     OR (StrToInt (Edit1.Text + Key) < LowLimit)
     OR (StrToInt (Edit1.Text + Key) > HighLimit)
     then
     begin
       Key := #0;
       MessageBeep (MB_OK);
   end;
 end;
 




Как заставить TEdit не пикать при нажатии недопустимых клавиш

Перехватите событие KeyPress и установите key = #0 для недопустимых клавиш.


 procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
 begin
   if ((UpCase(Key) < 'A') or (UpCase(Key) > 'Z')) then
     Key := #0;
 end;
 




Элемент управления Edit, реагирующий на событие OnTimer

Как-то раз встала такая проблема: если пользователь какое-то время ничего не вводит в элемент управления Edit, то предупредить его об этом.


 unit EditOnTime;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, ExtCtrls, StdCtrls;
 
 type
   TEditOnTime = class(TEdit)
   private
     FInterval: integer;
     FTimer: TTimer;
     FOnTimer: TNotifyEvent;
     procedure SetInterval(Interval: integer);
     procedure Timer(Sender: TObject);
   protected
     procedure KeyPress(var Key: char); override;
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
   published
     property Interval: integer read FInterval write SetInterval default 750;
     property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
 end;
 
 procedure register;
 
 implementation
 
 //******************* RegisterComponent
 // Здесь мы регистрируем компонент в IDE
 procedure register;
 begin
   RegisterComponents('MPS', [TEditOnTime]);
 end;
 
 //******************* TEditOnTime.SetInterval
 // устанавливаем интервал таймера
 procedure TEditOnTime.SetInterval(Interval: integer);
 begin
   FInterval := Interval;
   if Assigned(FTimer) then
     FTimer.Interval := FInterval;
 end;
 
 //******************* TEditOnTime.Create
 constructor TEditOnTime.Create(AOwner: TComponent);
 begin
   FInterval := 750;
   inherited Create(AOwner);
   if not (csDesigning in ComponentState) then
     try
       FTimer := TTimer.Create(self);
       FTimer.Enabled := false;
       FTimer.Interval := FInterval;
       FTimer.OnTimer := Timer;
     except
       FreeAndNil(FTimer);
     end;
 end;
 
 //******************* TEditOnTime.Destroy
 destructor TEditOnTime.Destroy;
 begin
   if Assigned(FTimer) then
     FreeAndNil(FTimer);
   inherited Destroy;
 end;
 
 //******************* TEditOnTime.OnTimer
 procedure TEditOnTime.Timer(Sender: TObject);
 begin
   FTimer.Enabled := false;
   if Assigned(FOnTimer) then
     FOnTimer(self);
 end;
 
 //******************* TEditOnTime.KeyPress
 procedure TEditOnTime.KeyPress(var Key: char);
 begin
   FTimer.Enabled := false;
   inherited KeyPress(Key);
   FTimer.Enabled := (Text <> '') and Assigned(FTimer)
     and Assigned(FOnTimer);
 end;
 
 end.
 




Правое выравнивание текста в компоненте Edit

Утро. Квартира сисопа. Ночная подружка подходит к компу, смотрит в логи и говорит:
- Да, и cps у тебя тоже маленький...


 TEdit1  = class(TEdit)
   public
     procedure CreateParams(var Params: TCreateParams); Override;
 end;
 
 procedure TEdit1.CreateParams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
   Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT;
 end;
 




Edit с возможностью автоматического выбора

Автор: Константин Хрипков

EDIT твою мать!
FORMAT тебя за ногу!

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

...я тоже пишу в Delphi и могу поделиться своим опытом. В дополнение к этому письму, чтобы не быть голословным, прилагаю маленький компонент THintEdit, порожденный от TCustomEdit, который представляет собой с виду обычный TEdit элемент с возможностью автоматического выбора стринговых значений из скрытого списка (так, как это реализовано в Netscape Navigator'е). Описание особенно не нужно, так как выполнено все достаточно элементарно: значения для выбора заносятся в свойство HintList, тип свойства TStrings. При нажатии клавиш вверх/вниз выбираются значения, соответствующие набранным начальным символам.


 unit HintEdit;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   THintEdit = class(TCustomEdit)
   private
     { Private declarations }
     FHintList: TStrings;
     Searching,
       CanSearch: boolean;
     CurSPos: integer;
   protected
     { Protected declarations }
     procedure Change; override;
     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
     property HintList: TStrings read FHintList write FHintList;
     destructor Destroy; override;
   published
     { Published declarations }
     property Anchors;
     property AutoSelect;
     property AutoSize;
     property BiDiMode;
     property BorderStyle;
     property CharCase;
     property Color;
     property Constraints;
     property Ctl3D;
     property DragCursor;
     property DragKind;
     property DragMode;
     property Enabled;
     property Font;
     property HideSelection;
     property ImeMode;
     property ImeName;
     property MaxLength;
     property OEMConvert;
     property ParentBiDiMode;
     property ParentColor;
     property ParentCtl3D;
     property ParentFont;
     property ParentShowHint;
     property PasswordChar;
     property PopupMenu;
     property ReadOnly;
     property ShowHint;
     property TabOrder;
     property TabStop;
     property Text;
     property Visible;
     property OnChange;
     property OnClick;
     property OnDblClick;
     property OnDragDrop;
     property OnDragOver;
     property OnEndDock;
     property OnEndDrag;
     property OnEnter;
     property OnExit;
     property OnKeyDown;
     property OnKeyPress;
     property OnKeyUp;
     property OnMouseDown;
     property OnMouseMove;
     property OnMouseUp;
     property OnStartDock;
     property OnStartDrag;
   end;
 
 procedure Register;
 
 implementation
 
 {$R *.DCR}
 
 procedure Register;
 begin
   RegisterComponents('Netscape', [THintEdit]);
 end;
 
 constructor THintEdit.Create;
 begin
   inherited;
   FHintList := TStringList.Create;
   Searching := false;
   CanSearch := true;
   CurSPos := -1;
 end;
 
 procedure THintEdit.Change;
 var
   i, l: integer;
 begin
   if Searching then
     Exit;
   if not CanSearch then
     Exit;
   if Text = '' then
     exit;
   l := Length(Text);
   for i := 0 to FHintList.Count - 1 do
     if Copy(FHintList[i], 1, l) = Text then
     begin
       Searching := true;
       CurSPos := i;
       Text := FHintList[i];
       Searching := false;
       SelStart := Length(Text);
       SelLength := -(Length(Text) - l);
       break;
     end;
   inherited;
 end;
 
 procedure THintEdit.KeyDown;
 var
   l: integer;
 begin
   if Chr(Key) in ['A'..'z', 'А'..'Я', 'а'..'я'] then
     CanSearch := true
   else
     CanSearch := false;
   case Key of
     VK_DOWN:
       begin
         if (CurSPos < HintList.Count - 1) and (SelLength > 0) then
           if Copy(FHintList[CurSPos + 1], 1, SelStart) = Copy(Text, 1, SelStart)
             then
           begin
             l := SelStart;
             Inc(CurSPos);
             Text := FHintList[CurSPos];
             SelStart := Length(Text);
             SelLength := -(Length(Text) - l);
           end;
         Key := VK_RETURN;
       end;
     VK_UP:
       begin
         if (CurSPos > 0) and (SelLength > 0) then
           if Copy(FHintList[CurSPos - 1], 1, SelStart) = Copy(Text, 1, SelStart)
             then
           begin
             l := SelStart;
             Dec(CurSPos);
             Text := FHintList[CurSPos];
             SelStart := Length(Text);
             SelLength := -(Length(Text) - l);
           end;
         Key := VK_RETURN;
       end;
     VK_RETURN:
       begin
         SelStart := 0;
         SelLength := Length(Text);
       end;
   end;
   inherited;
 end;
 
 destructor THintEdit.Destroy;
 begin
   FHintList.Free;
   inherited;
 end;
 




Эллипсовидное окно

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

Сначала в частных объявлениях (после слова private) объявляем процедуру:


 private
 procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
 

Затем в разделе implementation описываем её так:


 implementation
 {$R *.DFM}
 
 procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
 begin
   inherited;
   if M.Result = htClient then
     M.Result := htCaption;
 end;
 

Далее самое главное. По созданию окна (событие OnCreate) пишем следующий код:


 procedure TForm1.FormCreate(Sender: TObject);
 var
   hsWindowRegion: Integer;
 begin
   hsWindowRegion := CreateEllipticRgn(50, 50, 350, 200);
   SetWindowRgn(Handle, hsWindowRegion, true);
 end;
 




Как отправить письмо и указать тему, текст сообщения


Мужик работает на участке около своего дома. Из соседнего дома выходит его соседка-блондинка, открывает свой почтовый ящик, заглядывает туда, захлопывает и убегает обратно в дом. Немного погодя, соседка выбегает снова, заглядывает в почтовый ящик и снова убегает обратно. Когда все повторяется в третий раз, мужик не выдерживает:
- В чем дело? Что-нибудь случилось?
- Это точно, что что-то случилось. Мой дурацкий компьютер все время сообщает: "Уou've got mail"

Для отправки письма с помощью зарегистрированого клиента используется функция Windows - ShellExecute, где в качестве аргумента передается строка протокола Mailto. Для этого сделайте следующее:

  1. В разделе uses подключите ShellAPI
  2. В обработчике OnClick метки или клавиши введите следующий код.

     ShellExecute(Handle, 'open', 'mailto:lalala@lala.ru?par1=value1&par1=value1&...',
     nil, nil, SW_SHOWNORMAL);
     

Третий параметр функции ShellExecute() - это строка в соответствии с протоколом mailto и правилами оформления URL:

mailto:
тип протокола (может быть http: в этом случае оставшая URL и параметры запроса).
lalala@lala.ru
адрес получателя, можно включать несколько адресов, разделяя из символом ";"
?
разделитель параметров от адреса
par1=value1
имя параметра и его значение
&
разделитель параметров

Протокол Mailto имеет следующую форму.


 MAILTO:Recipients&Parameters
 

  • Поле Recipients может быть пустым, одиночным адресом и состоять из нескольких адресов, разделенных символом ";"
  • Поле Parameters дополнительно и если оно есть то должно быть отделено символом "&". Параметры должны появляться в форме пары name/value. Следующий список описывает возможные параметры:



  •  PARAMETER DESCRIPTION
     

    CC=
    Carbon copy (дополнительные получатели)
    BCC=
    Blind carbon copy (дополнительные получатели, адреса которых не показываются остальным получателям)
    SUBJECT=
    Subject text (тема)
    BODY=
    Body text (текст)

Все данные указываемые в параметрах должны быть так называемые Internet safe characters. Используййте %0d для символа перевод строки (LF), %20 для пробела и так далее.

Пример:


 mailto:email1;email2&cc=email3?subject=Это%20тема&
 body=это%20текст%20письма%0dЭто%20другая%20строка
 




Вложенные свойства

Автор: Mike Scott (Mobius Ltd)

- Почему программисты весят больше чем другие люди?
- Потому, что в каждом килограмме у них 1024 грамма!

Для регистрации контейнерного класса в процедуре Register вы должны вызвать RegisterPropertyEditor. Приблизительно так:


 RegisterPropertyEditor( TypeInfo( TYourContainedClass ),
   TYourContainer, 'YourContainedPropery', TClassProperty ) ;
 

Все это задокументировано в справке помощи по созданию компонентов. Первым всегда идет параметр TypeInfo() с контейнерным классом, затем сам контейнерный класс, затем имя контейнерного свойства, затем TClassProperty, который регистрирует расширение свойства класса.

А где взять реальный примерчик?

Посмотрите как это делаю я. Сохраните приведенный модуль с именем CONTAIN.PAS и добавите его к вашей палитре.


 unit Contain;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, ExtCtrls;
 
 type
   TContainer = class(TComponent)
   private
     FImage: TImage;
   public
     constructor Create(AOwner: TComponent); override;
   published
     property Image: TImage read FImage write FImage;
   end;
 
 procedure Register;
 
 implementation
 
 uses DsgnIntf;
 
 constructor TContainer.Create(AOwner: TComponent);
 
 begin
   inherited Create(AOwner);
   FImage := TImage.Create(Self);
 end;
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TContainer]);
   RegisterPropertyEditor(TypeInfo(TImage),
     TContainer,
     'Image',
     TClassProperty);
 end;
 
 end.
 




Как создать неактивное изображение из обычного (рельеф)



 procedure TForm1.aaa(bmpFrom, bmpTo: Tbitmap);
 var
   TmpImage, Monobmp: TBitmap;
   IRect: TRect;
 begin
   MonoBmp := TBitmap.Create;
   TmpImage:=Tbitmap.Create;
   TmpImage.Width := bmpFrom.Width;
   TmpImage.Height := bmpFrom.Height;
   IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height);
   TmpImage.Canvas.Brush.Color := clBtnFace;
   try
     with MonoBmp do
     begin
       Assign(bmpFrom);
       Canvas.Brush.Color := clBlack;
       if Monochrome then
       begin
         Canvas.Font.Color := clWhite;
         Monochrome := False;
         Canvas.Brush.Color := clWhite;
       end;
       Monochrome := True;
     end;
     with TmpImage.Canvas do
     begin
       Brush.Color := clBtnFace;
       FillRect(IRect);
       Brush.Color := clBlack;
       Font.Color := clWhite;
       CopyMode := MergePaint;
       Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);
       CopyMode := SrcAnd;
       Draw(IRect.Left, IRect.Top, MonoBmp);
       Brush.Color := clBtnShadow;
       Font.Color := clBlack;
       CopyMode := SrcPaint;
       Draw(IRect.Left, IRect.Top, MonoBmp);
       CopyMode := SrcCopy;
       bmpTo.assign(TmpImage);
       TmpImage.free;
     end;
   finally
     MonoBmp.Free;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   aaa(image1.picture.bitmap, image2.picture.bitmap);
   Image2.invalidate;
 end;
 




Очистка таблицы (с проверкой)

TTable имеет метод EmptyTable.

Пример:


 try
   with Table1 do
   begin
     Close;
     Exclusive := true;
     Open;
     EmptyTable;
     Close;
   end;
 except
   on E: EDBEngineError do
     ShowMessage(E.Message);
 end;
 




Как позволить или запретить выдачу звукового сигнала в динамик (Beep)

С помощью функции Beep можно выводить звуковой сигнал. напишите это слово по событию OnTimer для компонента TTimer и вы услышите звуковые сигналы. Теперь вы сможете запрещать или разрешать подобные Beep'ы.


 uses shellapi;
 
 //выключить
 systemparametersinfo(spi_setbeep, 0, nil, 0);
 //включить
 systemparametersinfo(spi_setbeep, 1, nil, 0);
 




Зашифровать и расшифровать строку


 unit uEncrypt;
 
 interface
 
 function Decrypt(const S: AnsiString; Key: Word): AnsiString;
 function Encrypt(const S: AnsiString; Key: Word): AnsiString;
 
 implementation
 
 const
   C1 = 52845;
   C2 = 22719;
 
 function Decode(const S: AnsiString): AnsiString;
 const
   Map: array[Char] of Byte = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, 0, 63, 52, 53,
     54, 55, 56, 57, 58, 59, 60, 61, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2,
     3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
     20, 21, 22, 23, 24, 25, 0, 0, 0, 0, 0, 0, 26, 27, 28, 29, 30,
     31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
     46, 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     0);
 var
   I: LongInt;
 begin
   case Length(S) of
     2:
       begin
         I := Map[S[1]] + (Map[S[2]] shl 6);
         SetLength(Result, 1);
         Move(I, Result[1], Length(Result))
       end;
     3:
       begin
         I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12);
         SetLength(Result, 2);
         Move(I, Result[1], Length(Result))
       end;
     4:
       begin
         I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12) +
           (Map[S[4]] shl 18);
         SetLength(Result, 3);
         Move(I, Result[1], Length(Result))
       end
   end
 end;
 
 function PreProcess(const S: AnsiString): AnsiString;
 var
   SS: AnsiString;
 begin
   SS := S;
   Result := '';
   while SS <> '' do
   begin
     Result := Result + Decode(Copy(SS, 1, 4));
     Delete(SS, 1, 4)
   end
 end;
 
 function InternalDecrypt(const S: AnsiString; Key: Word): AnsiString;
 var
   I: Word;
   Seed: Word;
 begin
   Result := S;
   Seed := Key;
   for I := 1 to Length(Result) do
   begin
     Result[I] := Char(Byte(Result[I]) xor (Seed shr 8));
     Seed := (Byte(S[I]) + Seed) * Word(C1) + Word(C2)
   end
 end;
 
 function Decrypt(const S: AnsiString; Key: Word): AnsiString;
 begin
   Result := InternalDecrypt(PreProcess(S), Key)
 end;
 
 function Encode(const S: AnsiString): AnsiString;
 const
   Map: array[0..63] of Char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +
     'abcdefghijklmnopqrstuvwxyz0123456789+/';
 var
   I: LongInt;
 begin
   I := 0;
   Move(S[1], I, Length(S));
   case Length(S) of
     1:
       Result := Map[I mod 64] + Map[(I shr 6) mod 64];
     2:
       Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
         Map[(I shr 12) mod 64];
     3:
       Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
         Map[(I shr 12) mod 64] + Map[(I shr 18) mod 64]
   end
 end;
 
 function PostProcess(const S: AnsiString): AnsiString;
 var
   SS: AnsiString;
 begin
   SS := S;
   Result := '';
   while SS <> '' do
   begin
     Result := Result + Encode(Copy(SS, 1, 3));
     Delete(SS, 1, 3)
   end
 end;
 
 function InternalEncrypt(const S: AnsiString; Key: Word): AnsiString;
 var
   I: Word;
   Seed: Word;
 begin
   Result := S;
   Seed := Key;
   for I := 1 to Length(Result) do
   begin
     Result[I] := Char(Byte(Result[I]) xor (Seed shr 8));
     Seed := (Byte(Result[I]) + Seed) * Word(C1) + Word(C2)
   end
 end;
 
 function Encrypt(const S: AnsiString; Key: Word): AnsiString;
 begin
   Result := PostProcess(InternalEncrypt(S, Key))
 end;
 
 end.
 
 {**************************************************************}
 // Example: 
 {**************************************************************}
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
  my_key = 33189;
 var
   sEncrypted, sDecrypted :AnsiString;
 begin
   // Encrypt a string 
   sEncrypted := Encrypt('this is a sample text
     to encrypt...abcd 123 {}[]?=)=(',my_key);
   // Show encrypted string 
   ShowMessage(sEncrypted);
   // Decrypt the string 
   sDecrypted := Decrypt(sEncrypted,my_key);
    // Show decrypted string 
   ShowMessage(sDecrypted);
 end;
 




Шифрование текста

Метод основан на сложении текста и пароля: "мой текст" + "пароль" = ('м'+'п')('о'+'а')... То есть каждый символ получают путем сложения соответствующих символов текста и пароля. Под "сложением символов" я подразумеваю сложение номеров этих символов. Обычно пароль длиннее текста, поэтому его размножают: "парольпар".

Чтобы расшифровать текст, нужно проделать обратную операцию, то есть из текста вычесть пароль.

При нажатии на Button1 эта программа шифрует текст из Memo1 при помощи пароля из Edit1. Результат сохраняется в строку s. Для наглядности зашифрованный текст также помещается в Memo1. При нажатии на Button2 текст из s расшифровывается. Если Вы нажмете Button1 два раза подряд, получится зашифрованный зашифрованный текст. Вернуть начальный текст можно будет двумя нажатиями на Button2. Но, поскольку в результате шифрования в строке могут появится


 var
   s: string;
 
 procedure Code(var text: string; password: string;
   decode: boolean);
 var
   i, PasswordLength: integer;
   sign: shortint;
 begin
   PasswordLength := length(password);
   if PasswordLength = 0 then Exit;
   if decode
     then sign := -1
     else sign := 1;
   for i := 1 to Length(text) do
     text[i] := chr(ord(text[i]) + sign *
       ord(password[i mod PasswordLength + 1]));
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   s := Memo1.Text;
   code(s, Edit1.Text, false);
   Memo1.Text := s;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   code(s, Edit1.Text, true);
   Memo1.Text := s;
 end;
 




Шифрование текста 2


 {$I-,R-}
 
 Unit Crypter;
 
 interface
 Uses Objects;
 
 procedure EnCrypt(var Pntr: Array of Char; ArrLen: Word; password: string);
 { - Закpиптовать блок }
 procedure DeCrypt(var Pntr: Array of Char; ArrLen: Word; password: string);
 { - Раскиптовать блок }
 
 procedure EnCryptStream(var st: tStream; Password: String);
 { - Закpиптовать поток }
 procedure DeCryptStream(var st: tStream; Password: String);
 { - Раскиптовать поток }
 
 implementation
 
 procedure EnCrypt(var Pntr: Array of Char; ArrLen:Word; password: string);
 var
   len,pcounter: byte;
   x:Word;
 begin
   len := length(password) div 2;
   pcounter := 1;
   for x:=0 to ArrLen-1 do begin
     Pntr[x] := chr(ord(password[pcounter]) + ord(Pntr[x]) + len);
     inc(pcounter);
     if pcounter > length(password) then pcounter := 1;
   end;
 end;
 
 procedure DeCrypt(var Pntr: Array of Char; ArrLen:Word; password: string);
 var
   len,pcounter: byte;
   x:Word;
 begin
   len := length(password) div 2;
   pcounter := 1;
   for x:=0 to ArrLen-1 do begin
     Pntr[x] := chr(ord(Pntr[x]) - ord(password[pcounter]) - len);
     inc(pcounter);
     if pcounter > length(password) then pcounter := 1;
   end;
 end;
 
 type
  pBuffer = ^tBuffer;
  tBuffer = Array[1..$FFFF] of Char;
 
 procedure EnCryptStream(var st: tStream; Password: String);
  var
   buf: pBuffer;
   StSize, StPos, p: Longint;
  begin
   if (@st=nil) or (Password='') then exit;
   New(buf);
   StPos:=st.GetPos;
   StSize:=st.GetSize;
   st.Reset;
   st.Seek(0);
   repeat
    p:=st.GetPos;
    if SizeOf(Buf^)> St.GetSize-St.GetPosthen st.Read(buf^,St.GetSize-St.GetPos)
 else st.Read(buf^,SizeOf(Buf^));
    EnCrypt(buf^,SizeOf(buf^),password);
    st.Reset;
    st.Seek(p);
    st.Write(buf^,SizeOf(Buf^));
   until (St.GetSize=St.GetPos);
   st.Seek(StSize);
   st.Truncate;
   st.Seek(StPos);
   Dispose(buf);
  end;
 
 procedure DeCryptStream(var st: tStream; Password: String);
  var
   buf: pBuffer;
   StSize, StPos, p: Longint;
  begin
   if (@st=nil) or (Password='') then exit;
   New(buf);
   StPos:=st.GetPos;
   StSize:=st.GetSize;
   st.Reset;
   st.Seek(0);
   repeat
    p:=st.GetPos;
    if SizeOf(Buf^)> St.GetSize-St.GetPosthen st.Read(buf^,St.GetSize-St.GetPos)
 else st.Read(buf^,SizeOf(Buf^));
    DeCrypt(buf^,SizeOf(buf^),password);
    st.Reset;
    st.Seek(p);
    st.Write(buf^,SizeOf(Buf^));
   until (St.GetSize=St.GetPos);
   st.Seek(StSize);
   st.Truncate;
   st.Seek(StPos);
   Dispose(buf);
  end;
 
 end.
 




Увеличить процессорное время, выделяемое программе


Фирма Intel после выпуска процессоров Pentium 1, Pentium 2, Pentium 3, Pentium 4 выпустила новые процессоры Pentium жив и Pentium возвращается.

Следующий пример изменяет приоритет приложения. Изменение приоритета следует использовать с осторожностью - т.к. присвоение слишком высокого приоритета может привести к медленной работе остальных программ и системы в целом ;-)


 procedure TForm1.Button1Click(Sender: TObject);
 var
   ProcessID : DWORD;
   ProcessHandle : THandle;
   ThreadHandle : THandle;
 begin
   ProcessID := GetCurrentProcessID;
   ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION,
   false, ProcessID);
   SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
   ThreadHandle := GetCurrentThread;
   SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
 end;
 




Как осуществить ввод текста в компоненте Label

Все, конечно, слышали выражение "программа партии". А что было бы, если бы политические партии действительно писали программы?
Программа КПРФ
Последние версии документированы как совместимые с другими программами, но на самом деле после инсталляции стремятся их уничтожить. Интерфейс текстовый, белые буквы на красном фоне. Ядро написано более ста лет назад, с тех пор не только не исправлены старые глюки, но и добавлены многие новые. Считает, что все файлы должны быть одинакового размера. Периодически объявляет какое-нибудь расширение вредным и удаляет файлы с этим расширением по всему диску. Запросы на подтверждение имеют единственный вариант ответа: "Даешь!" Пытается выделять под свои задачи ресурсы, не заботясь об их физическом наличии, и в случае неудачи блокирует вывод сообщений об ошибках. При запросе диагностики выводит заранее сформированный файл, сообщающий, что все хорошо. Hе принимает электронную почту извне и прибивает задачи, пытающиеся ее отправить. Hе совместима с современной техникой. Hе может быть деинсталлирована легальными средствами.
Программа ЛДПР
Имеет яркий, аляповатый интерфейс и неотключаемые звуковые эффекты повышенной громкости. Может быть инсталлирована хоть на ХТ, однако заявляет о чрезвычайно высоких требованиях к системным ресурсам и на любой машине стремится захватить их как можно больше. В сообщениях активно использует нецензурную лексику, в особенности если пользователь - женщина. Постоянно грозится взломать сервер Пентагона и устроить mail-bombing президенту США, но физически не содержит модулей, способных на что-то подобное. Выводит множество предупреждений и сообщений об ошибках, в том числе самых невероятных, но никогда не виснет, не падает и не выгружается из памяти, даже если пользователь очень захочет. При выводе диагностики начинает торговаться с пользователем, обещая вывести хорошие результаты, если ей выделят больше ресурсов. Запрашивает высокую цену за инсталляцию и вдвое большую - за деинсталляцию.
Программа "Яблока"
Имеет красивый, стильный, но не всем понятный интерфейс. Отказывается работать с другими программами. Содержит мощный диагностический модуль, всегда готова дать пользователю подробный совет в любой ситуации, но на предложение выполнить конкретную операцию неизменно выдает сообщение с аргументированным объяснением, почему данная операция выполнена быть не может. Работает только на компьютерах фирмы Apple.
Программа HДР
Hекогда была главным системным модулем и по-прежнему пытается выполнять эту функцию. Имеет непонятный интерфейс и нечитабельную документацию. Сообщения об ошибках приписывает предыдущим и последующим версиям, а также внешним процессам. Пытается решить проблему нехватки ресурсов, постоянно прося пользователя вставить новую дискету и обещая впоследствии отдать две. Когда задача запрашивает память, сообщает, что память успешно выделена, но на самом деле выделяет ее не раньше чем через полгода, отобрав у других задач. В конечном итоге наглухо вешает машину.

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

Первый шаг, это кнопка, которая может отображать вводимый текст:


 type
   TInputButton = class(TButton)
   private
     procedure WmChar (var Msg: TWMChar); message wm_Char;
 end;
 
 procedure TInputButton.WmChar (var Msg: TWMChar);
 var
   Temp: string;
 begin
   if Char (Msg.CharCode) = #8 then
   begin
     Temp := Caption;
     Delete (Temp, Length (Temp), 1);
     Caption := Temp;
   end
   else
     Caption := Caption + Char (Msg.CharCode);
 end;
 

С меткой (label) дела обстоят немного сложнее, так как прийдётся создать некоторые ухищрения, чтобы обойти её внутреннюю структуру. Впринципе, проблему можно решить созданием других скрытых компонент (кстати, тот же edit box). Итак, посмотрим на объявление класса:


 type
   TInputLabel = class (TLabel)
   private
     MyEdit: TEdit;
     procedure WMLButtonDown (var Msg: TMessage); message wm_LButtonDown;
   protected
     procedure EditChange (Sender: TObject);
     procedure EditExit (Sender: TObject);
   public
     constructor Create (AOwner: TComponent); override;
 end;
 

Когда метка (label) создана, то она в свою очередь создаёт edit box и устанавливает несколько обработчиков событий для него. Фактически, если пользователь кликает по метке, то фокус перемещается на (невидимый) edit box, и мы используем его события для обновления метки. Обратите внимание на ту часть кода, которая подражает фокусу для метки (рисует прямоугольничек), основанная на API функции DrawFocusRect:


 constructor TInputLabel.Create (AOwner: TComponent);
 begin
   inherited Create (AOwner);
 
   MyEdit := TEdit.Create (AOwner);
   MyEdit.Parent := AOwner as TForm;
   MyEdit.Width := 0;
   MyEdit.Height := 0;
   MyEdit.TabStop := False;
   MyEdit.OnChange := EditChange;
   MyEdit.OnExit := EditExit;
 end;
 
 procedure TInputLabel.WMLButtonDown (var Msg: TMessage);
 begin
   MyEdit.SetFocus;
   MyEdit.Text := Caption;
   (Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
 end;
 
 procedure TInputLabel.EditChange (Sender: TObject);
 begin
   Caption := MyEdit.Text;
   Invalidate;
   Update;
   (Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
 end;
 
 procedure TInputLabel.EditExit (Sender: TObject);
 begin
   (Owner as TForm).Invalidate;
 end;
 




Использование Enter как Tab в TDBGrid

Заядлый компьютерщик заходит в банк снять денег. Кассирша ему:
- Сколько?
- Мне плиз 1024 рубля!

Приведу код, позволяющий использовать нажатие клавиши Enter как клавиши Tab пока управление находится в табличной сетке.

Данный код включает обработку клавиши Enter для всего приложения, включая поля и пр.. Код для работы с компонентом DBGrid заключен в блок ELSE. Приведенный код не имитирует поведение клавиши Tab, связанное с переходом на следующую запись когда курсор достигает последней колонки табличной сетки, в нашем случае он перемещается на первую колонку.


 procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
 { Это обработчик события OnKeyPress для ФОРМЫ! }
 { Вы должны также установить свойство формы KeyPreview в True }
 begin
   if Key = #13 then { если это клавиша Enter }
     if not (ActiveControl is TDBGrid) then
     begin { если не на TDBGrid }
       Key := #0; { гасим клавишу Enter }
       Perform(WM_NEXTDLGCTL, 0, 0);
         { перемещаемя на следующий элемент управления }
     end
     else if (ActiveControl is TDBGrid) then { если это TDBGrid }
       with TDBGrid(ActiveControl) do
         if selectedindex < (fieldcount - 1) then { увеличиваем поле }
           selectedindex := selectedindex + 1
         else
           selectedindex := 0;
 end;
 




Как подменить нажатия ENTER на нажатия TAB


Программист в церкви молится:
- Во имя отца и сына и святого духа. Enter.

Существует множество методов решения этой проблемы, но самый быстрый способ, это перехват нажатия клавиш, перед тем как их получит форма:

В секции формы PRIVATE добавьте:


 procedure CMDialogKey(var Msg: TWMKey); message CM_DIALOGKEY;
 

В секции IMPLEMENTATION добавьте:


 procedure TForm1.CMDialogKey(var Msg: TWMKey);
 begin
   if not (ActiveControl is TButton) then
     if Msg.Charcode = 13 then
       Msg.Charcode := 9;
   inherited;
 end;
 

Тем самым мы исключаем срабатывания нашей подмены, если фокус находится на кнопке.

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




Как подменить нажатия ENTER на нажатия TAB 2

Тонет программист. И во все горло орет:
- F1, F1, F1, тьфу ты, помогите, помогите, помогите!!!

Как-то бухгалтер, который пользовался моей программой, заявил, что ему не удобно перескакивать пустые поля в форме кнопкой Tab, и что намного удобнее это делать обычным Enter-ом. Предлагаю посмотреть, как я решил эту проблемму.


 procedure Tform1.FormKeyDown(Sender: TObject;
 var Key: Word; Shift: TShiftState);
 var
   ACtrl: TWinControl;
 begin
   if key = 13 then
   begin
     ACtrl := ActiveControl;
     if ACtrl is TCustomMemo then
       exit;
     repeat
       ACtrl:= FindNextControl(ACtrl,true,true,false);
     until
       (ACtrl is TCustomEdit) or
       (ACtrl is TCustomComboBox) or
       (ACtrl is TCustomListBox) or
       (ACtrl is TCustomCheckBox) or
       (ACtrl is TRadioButton);
     ACtrl.SetFocus ;
   end;
 end;
 

Не забудьте установить свойство формы KeyPreview в true.

Как Вы можете видеть; этот код использует функцию FindNextControl, которая ищет следующий свободный контрол.

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




Как подменить нажатия ENTER на нажатия TAB 3


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Form1.KeyPreview := true;
 end;
 
 procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
   Shift: TShiftState);
 var
   c: TControl;
 begin
   if Key <> 13 then
     Exit;
   repeat
     c := Form1.FindNextControl(Form1.ActiveControl, true, true, true);
     (c as TWinControl).SetFocus;
   until
     c is TEdit;
 end;
 




Как подменить нажатия ENTER на нажатия TAB 4

Компьютерный интим - клавиатуру тискают, мышку лапают, а коврик гладят.


 procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
 begin
   if Key = Chr(VK_RETURN) then
   begin
     Perform(WM_NEXTDLGCTL,0,0);
     key:= #0;
   end;
 end;
 




Как подменить нажатия ENTER на нажатия TAB 5

Разговаривают два программера:
- Представляешь, был вчера на презентации, а там... И коньячок, и вискарек, и водочка! Через полчаса - уже никакой, а на столах - не убавляется, обидно просто. Ну, я не растерялся, пошел в сортир, поблевал хорошенько - и продолжил!
- Вот и мне CTRL+ALT+DEL всегда помогает.


 procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
 begin
  if Key = #13 then
  begin
    SelectNext(Sender as TWinControl, True, True);
    Key := #0;
  end;
 end;
 




Получить список шрифтов и их размеров для текущего принтера

Следующий пример помещает в компонент TMemo список шрифтов и их размеров для текущего принтера.


 uses Printers;
 
 function EnumFontFamilyProc(var lf: TLogFont;
   var tm: TNewTextMetric;
   FontType: integer;
   var Memo: TMemo): integer
 {$IFDEF WIN32} stdcall;
 {$ELSE}; export;
 {$ENDIF}
 begin
   Memo.Lines.Add(StrPas(@lf.lfFaceName) +
     #32 + IntToStr(lf.lfHeight));
   result := 1;
 end;
 
 function EnumFontFamiliesProc(var lf: TLogFont;
   var tm: TNewTextMetric;
   FontType: integer;
   var Memo: TMemo): integer
 {$IFDEF WIN32} stdcall;
 {$ELSE}; export;
 {$ENDIF}
 begin
   if FontType = TRUETYPE_FONTTYPE then
   begin
     Memo.Lines.Add(StrPas(@lf.lfFaceName) + #32 + 'All Sizes');
   end
   else
     EnumFontFamilies(Printer.Handle,
       @lf.lfFaceName,
       @EnumFontFamilyProc,
       LongInt(@Memo));
   result := 1;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   tm: TTextMetric;
   i: integer;
 begin
   if PrintDialog1.Execute then
   begin
     EnumFontFamilies(Printer.Handle,
       nil,
       @EnumFontFamiliesProc,
       LongInt(@Memo1));
   end;
 end;
 




Пример EnumWindows

Автор: Paul Powers (Borland)

  1. Создайте форму и разместите на ней два компонента ListBox.
  2. Скопируйте код, показанный ниже.
  3. Запустите SysEdit.
  4. Запустите форму Delphi. Первый ListBox должен содержать список всех запущенных приложений. Дважды щелкните на SysEdit и нижний ListBox покажет дочернее MDI-окно программы SysEdit.

 unit Wintask1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     ListBox1: TListBox;
     ListBox2: TListBox;
     procedure FormCreate(Sender: TObject);
     procedure ListBox1DblClick(Sender: TObject);
   private
     function enumListOfTasks(hWindow: hWnd): Bool; export;
     function enumListOfChildTasks(hWindow: hWnd): Bool; export;
   end;
 
   THoldhWnd = class(TObject)
   private
   public
     hWindow: hWnd;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   enumWindows(@TForm1.EnumListOfTasks, Longint(Self));
   if (ListBox1.Items.Count > 0) then
     ListBox1.ItemIndex := 0;
 end;
 
 function TForm1.enumListOfTasks(hWindow: hWnd): Bool;
 var
   HoldString: PChar;
   WindowStyle: Longint;
   IsAChild: Word;
   HoldhWnd: THoldhWnd;
 
 begin
   GetMem(HoldString, 256);
 
   HoldhWnd := THoldhWnd.Create;
   HoldhWnd.hWindow := hWindow;
 
   WindowStyle := GetWindowLong(hWindow, GWL_STYLE);
   WindowStyle := WindowStyle and Longint(WS_VISIBLE);
   IsAChild := GetWindowWord(hWindow, GWW_HWNDPARENT);
 
   {Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items }
   if (GetWindowText(hWindow, HoldString, 255) > 0) and
     (WindowStyle > 0) and (IsAChild = Word(nil)) then
     ListBox1.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd))
   else if (GetClassName(hWindow, HoldString, 255) > 0) and
     (WindowStyle > 0) and (IsAChild = Word(nil)) then
     ListBox1.Items.AddObject(Concat('<', StrPas(HoldString), '>'),
       TObject(HoldhWnd));
 
   FreeMem(HoldString, 256);
   HoldhWnd := nil;
   Result := TRUE;
 end;
 
 function TForm1.enumListOfChildTasks(hWindow: hWnd): Bool;
 var
   HoldString: PChar;
   WindowStyle: Longint;
   IsAChild: Word;
   HoldhWnd: THoldhWnd;
 
 begin
   GetMem(HoldString, 256);
 
   HoldhWnd := THoldhWnd.Create;
   HoldhWnd.hWindow := hWindow;
 
   WindowStyle := GetWindowLong(hWindow, GWL_STYLE);
   WindowStyle := WindowStyle and Longint(WS_VISIBLE);
   IsAChild := GetWindowWord(hWindow, GWW_HWNDPARENT);
 
   {Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items }
   if (GetWindowText(hWindow, HoldString, 255) > 0) and
     (WindowStyle > 0) and (IsAChild <> Word(nil)) then
     ListBox2.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd))
   else if (GetClassName(hWindow, HoldString, 255) > 0) and
     (WindowStyle > 0) and (IsAChild = Word(nil)) then
     ListBox2.Items.AddObject(Concat('<', StrPas(HoldString), '>'),
       TObject(HoldhWnd));
 
   FreeMem(HoldString, 256);
   HoldhWnd := nil;
   Result := TRUE;
 end;
 
 procedure TForm1.ListBox1DblClick(Sender: TObject);
 begin
   enumChildWindows(THoldhWnd(ListBox1.Items.Objects[ListBox1.ItemIndex]).hWindow,
     @TForm1.enumListOfChildTasks, Longint(Self));
 
   ListBox2.RePaint;
 end;
 
 end.
 




Использование перечислимых констант

Автор: Dan Miser(Med Data Systems, Inc.)

В Инспекторе Объектов я пытаюсь получить раскрывающийся список для моего перечислимого типа...

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


 type
   TBaudRateProperty = class(TStringProperty)
   public
     function GetAttributes: TPropertyAttributes; override;
     procedure GetValues(Proc: TGetStrProc); override;
     function GetValue: string; override;
     procedure SetValue(const Value: string); override;
   end;
 
   ...
 
 type
 
   TBaudRate = (br110, br300, br600, br1200, br2400, br4800, br9600, br14400,
     br19200, br38400, br56000, br128000, br256000);
 const
   BaudList: array[TBaudRate] of string[7] =
   ('110', '300', '600', '1200', '2400', '4800', '9600', '14400', '19200',
     '38400', '56000', '128000', '256000');
 
 {TBaudRateProperty}
 
 function TBaudRateProperty.GetAttributes: TPropertyAttributes;
 begin
   Result := [paValueList];
 end;
 
 procedure TBaudRateProperty.GetValues(Proc: TGetStrProc);
 var
   i: TBaudRate;
 begin
   for i := Low(TBaudRate) to High(TBaudRate) do
     Proc(BaudList[i]);
 end;
 
 function TBaudRateProperty.GetValue: string;
 begin
   Result := BaudList[TBaudRate(GetOrdValue)];
 end;
 
 procedure TBaudRateProperty.SetValue(const Value: string);
 var
   i: TBaudRate;
 begin
   for i := Low(TBaudRate) to High(TBaudRate) do
     if BaudList[i] = Value then
     begin
       SetOrdValue(integer(i));
       EXIT;
     end;
   inherited SetValue(Value);
 end;
 




Получить текст элемента перечисляемого типа


 // For example, if you have some enum type
 // Als Beispiel, wenn dieser Aufzahlungstyp vorhanden ist
 
 {....}
 
 type
   TYourEnumType = (One, Two, Three, Four, Five, Six, Seven, Eight, Nine, Ten);
 
 {....}
 
 {
  And you want in run-time to get a string with same value for each of
  them (for example, fill the Listbox items with enum values), then you
  can use the next procedure:
 }
 
 uses TypInfo;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: Integer;
 begin
   for i := Ord(Low(TYourEnumType)) to Ord(High(TYourEnumType)) do
     ListBox1.Items.Add(GetEnumName(TypeInfo(TYourEnumType), i));
 end;
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS