Принцип создания плагинов в Delphi

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


function PluginType : PChar;  

функция, определяющая назначение плугина.


function PluginName : PChar;  

функция, которая возвращает название плугина. Это название будет отоброжаться в меню.


function PluginExec(AObject: ТТип): boolean;  

главный обработчик, выполняет определённые действия и возвращает TRUE;

и ещё, я делал res файл с небольшим битмапом и компилировал его вместе с плугином, который отображался в меню соответствующего плугина. Откомпилировать res фaйл можно так:

создайте файл с расширением *.rc
напишите в нём : bitmap RCDATA LOADONCALL 1.bmp где bitmap - это идентификатор ресурса RCDATA LOADONCALL - тип и параметр 1.bmp - имя локального файла для кампиляций
откомпилируйте этот файл программой brcc32.exe, лежащей в папке ...\Delphi5\BIN\ .
Загрузка плагина

Перейдём к теоретической части.

Раз плугин это dll значит её можно подгрузить следующими способами:

Прищипыванием её к программе!

function PluginType : PChar; external 'myplg.dll';  
// в таком случае dll должна обязательно лежать возле exe и мы не можем передать  
// туда конкретное имя! не делать же все плугины одного имени! это нам не подходит.  
// Программа просто не загрузится без этого файла! Выдаст сообщение об ошибке.  
// Этот способ может подойти для поддержки обновления вашей программы!  

Динамический
это означает, что мы грузим её так, как нам надо! Вот пример:


var  
  // объявляем процедурный тип функции из плугина  
  PluginType: function: PChar;  
  //объявляем переменную типа хендл в которую мы занесём хендл плугина  
  PlugHandle: THandle;  
  
procedure Button1Click(Sender: TObject);  
begin  
  //грузим плугин  
  PlugHandle := LoadLibrary('MYplg.DLL');  
  //Получилось или нет?  
  if PlugHandle <> 0 then  
  begin  
    // ищем функцию в dll  
    @PluginType := GetProcAddress(plugHandle,'Plugintype');  
    if @PluginType <> nil then  
      //вызываем функцию  
      ShowMessage(PluginType);  
  end;  
  //освобождаем библиотеку  
  FreeLibrary(LibHandle);  
end;  

Вот этот способ больше подходит для построения плугинов!

Функции:


//как вы поняли загружает dll и возвращает её хендл  
function LoadLibrary(lpLibFileName : Pchar):THandle;  
// пытается найти обработчик в переданной ей хендле dll,  
// при успешном выполнении возвращает указатель обработчика.  
function GetProcAddress(Module: THandle; ProcName: PChar): TFarProc   
//освобождает память, занитую dll  
function FreeLibrary(LibModule: THandle);  

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

Вот полноценный пример реализации простой программы для поддержки плугинов...

Исходный текст модуля программы:


unit Unit1;  
  
interface  
  
uses  
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,  
  Dialogs, Menus, Grids, DBGrids;  
  
type  
  TForm1 = class(TForm)  
    MainMenu1: TMainMenu;  
    //меню, которое будет содержать ссылки на плугины  
    N1231: TMenuItem;  
    procedure FormCreate(Sender: TObject);  
  private  
    { Private declarations }  
    //лист, в котором мы будем держать имена файлов плугинов  
    PlugList : TStringList;  
    //Процедура загрузки плугина  
    procedure LoadPlug(fileName : string);  
    //Процедура инициализации и выполнения плугина  
    procedure PlugClick(sender : TObject);  
  public  
    { Public declarations }  
end;  
  
var  
Form1: TForm1;  
  
implementation  
{$R *.DFM}  

Процедура загрузки плугина. Здесь мы загружаем, вносим имя dll в список и создаём для него пункт меню; загружаем из dll картинку для пункта меню


procedure TForm1.LoadPlug(fileName: string);  
var  
  //Объявление функции, которая будет возвращать имя плугина  
  PlugName : function : PChar;  
  //Новый пункт меню  
  item : TMenuItem;  
  //Хендл dll  
  handle : THandle;  
  //Объект, с помощью которого мы загрузим картинку из dll  
  res :TResourceStream;  
begin  
  item := TMenuItem.create(mainMenu1); //Создаём новый пункт меню  
  handle := LoadLibrary(Pchar(FileName)); //загружаем dll  
  if handle <> 0 then //Если удачно, то идём дальше...  
  begin  
    @PlugName := GetProcAddress(handle,'PluginName'); //грузим процедуру  
    if @PlugName <> nil then  
      item.caption := PlugName  
      //Если всё прошло, идём дальше...  
    else  
    begin  
      ShowMessage('dll not identifi '); //Иначе, выдаём сообщение об ошибке  
      Exit; //Обрываем процедуру  
    end;  
    PlugList.Add(FileName); //Добавляем название dll  
    res:= TResourceStream.Create(handle,'bitmap',rt_rcdata); //Загружаем ресурс из dll  
    res.saveToFile('temp.bmp'); res.free; //Сохраняем в файл  
    item.Bitmap.LoadFromFile('Temp.bmp'); //Загружаем в пункт меню  
    FreeLibrary(handle); //Уничтожаем dll  
    item.onClick:=PlugClick; //Даём ссылку на обработчик  
    Mainmenu1.items[0].add(item); //Добавляем пункт меню  
  end;  
end;  

Процедура выполнения плугина. Здесь мы загружаем, узнаём тип и выполняем


procedure TForm1.PlugClick(sender: TObject);  
var  
  //Объявление функции, которая будет выполнять плугин  
  PlugExec : function(AObject : TObject): boolean;  
  //Объявление функции, которая будет возвращать тип плугина  
  PlugType : function: PChar;  
  //Имя dll  
  FileName : string;  
  //Хендл dll  
  handle : Thandle;  
begin  
  with (sender as TmenuItem) do  
    filename:= plugList.Strings[MenuIndex];  
  //Получаем имя dll  
  handle := LoadLibrary(Pchar(FileName)); //Загружаем dll  
  //Если всё в порядке, то идём дальше  
  if handle <> 0 then  
  begin  
    //Загружаем функции  
    @plugExec := GetProcAddress(handle,'PluginExec');  
    @plugType := GetProcAddress(handle,'PluginType');  
    //А теперь, в зависимости от типа, передаём нужный ей параметр...  
    if PlugType = 'FORM' then  
      PlugExec(Form1)  
    else  
    //Если плугин для формы, то передаём форму  
    if PlugType = 'CANVAS' then  
      PlugExec(Canvas)  
    else  
    //Если плугин для канвы, то передаём канву  
    if PlugType = 'MENU' then  
      PlugExec(MainMenu1)  
    else  
    //Если плугин для меню, то передаём меню  
    if PlugType = 'BRUSH' then  
      PlugExec(Canvas.brush)  
    else  
    //Если плугин для заливки, то передаём заливку  
    if PlugType = 'NIL' then  
      PlugExec(nil);  
    //Если плугину ни чего не нужно, то ни чего не передаём  
  end;  
  FreeLibrary(handle); //Уничтожаем dll  
end;  
  
procedure TForm1.FormCreate(Sender: TObject);  
var  
  SearchRec : TSearchRec; //Запись для поиска  
begin  
  plugList:=TStringList.create; //Создаём запись для имён dll'ок  
  //ищем первый файл  
  if FindFirst('*.dll',faAnyFile, SearchRec) = 0 then  
  begin  
    LoadPlug(SearchRec.name); //Загружаем первый найденный файл  
    while FindNext(SearchRec) = 0 do  
      LoadPlug(SearchRec.name);  
    //Загружаем последующий  
    FindClose(SearchRec); //Закрываем поиск  
  end;  
  //Левые параметры  
  canvas.Font.pitch := fpFixed;  
  canvas.Font.Size := 20;  
  canvas.Font.Style:= [fsBold];  
end;  
  
end.  

Здесь написан простой исходный текст dll, то есть нашего плугина. Он обязательно возвращает название, тип и выполняет свои задачи


library plug;  
  
uses  
  SysUtils, graphics, Classes, windows;  
  
{$R bmp.RES}  
  
function PluginType : Pchar;  
begin  
  //Мы указали реакцию на этот тип  
  Plugintype := 'CANVAS';  
end;  
  
function PluginName:Pchar;  
begin  
  //Вот оно, название плугина. Эта строчка будет в менюшке  
  PluginName := 'Canvas painter';  
end;  

Функция выполнения плугина! Здесь мы рисуем на переданной канве анимационную строку.


function PluginExec(Canvas:TCanvas):Boolean;  
var  
  X : integer;  
  I : integer;  
  Z : byte;  
  S : string;  
  color : integer;  
  proz : integer;  
begin  
  color := 10;  
  proz :=0;  
  S:= 'hello всем это из плугина ля -- ля';  
  for Z:=0 to 200 do  
  begin  
    proz:=proz+2;  
    X:= 0;  
    for I:=1 to length(S) do  
    begin  
      X:=X + 20;  
      Canvas.TextOut(X,50,S[i]);  
      color := color+X*2+Random(Color);  
      canvas.Font.Color := color+X*2;  
      canvas.font.color := 10;  
      canvas.TextOut(10,100,'execute of '+inttostr(proz div 4) + '%');  
      canvas.Font.Color := color+X*2;  
      sleep(2);  
    end;  
  end;  
  PluginExec:=True;  
end;  
  
exports  
  PluginType, PluginName, PluginExec;  
  
end.  

Пару советов:

Не оставляйте у своих плугинов расширение *.dll, это не катит. А вот сделайте, например *.plu . Просто в исходном тексте плугина напишите {$E plu} Ну и в исходном тексте программы ищите не Dll, а уже plu.
Когда вы сдаёте программу, напишите к ней уже готовых несколько плугинов, что бы юзеру было интересно искать новые.
Сделайте поддержку обновления через интернет. То есть программа заходит на ваш сервер, узнаёт, есть ли новые плугины или нет, если есть - то она их загружает. Этим вы увеличите спрос своей программы и конечно трафик своего сайта!

Добавлено: 07 Августа 2018 08:27:23 Добавил: Андрей Ковальчук

Сохранение и загрузка данных в объекты на примере коллекций

Если в Вашей программе используются классы для описания объектов некоторой предметной области, то данные, их инициализирующие, можно хранить и в базе данных. Но можно выбрать гораздо более продуктивный подход, который доступен в Delphi/C++ Builder. Среда разработки Delphi/C++ Builder хранит ресурсы всех форм в двоичных или текстовых файлах и эта возможность доступна и для разрабатываемых с ее помощью программ. В данном случае, для оценки удобств такого подхода лучше всего рассмотреть конкретный пример.

Необходимо реализовать хранение информации о некоей службе рассылки и ее подписчиках. Будем хранить данные о почтовом сервере и список подписчиков. Каждая запись о подписчике хранит его личные данные и адрес, а также список тем(или каталогов), на которые он подписан. Как большие поклонники Гради Буча (Grady Booch), а также будучи заинтересованы в удобной организации кода, мы организуем информацию о подписчиках в виде объектов. В Delphi для данной задачи идеально подходит класс TCollection, реализующий всю необходимую функциональность для работы со списками типизированных объектов. Для этого мы наследуемся от TCollection, называя новый класс TMailList - список рассылки, а также создаем наследника от TCollectionItem - TMailClient - адресат рассылки. Последний будет содержать все необходимые данные о подписчике, а также реализовывать необходимые функции для работы с ним.

Саму коллекцию с подписчиками нам нужно будет поместить в некий базовый класс, который мы и будем сохранять и загружать. На роль такового подходит класс TMailer - почтовый клиент.
Начнем с TMailClient.


type   
  TMailClient = class(TCollectionItem)   
  private   
    FName: string;   
    FAddress: string;   
    FEnabled: boolean;   
    FFolders: TStringList;   
  public   
    Files: TStringList;  // список файлов к рассылке. заполняется в run-time. Сохранению не подлежит    
    constructor Create(Collection: TCollection); override;   
    destructor Destroy; override;   
    procedure PickFiles;   
  published   
    property Name: string read FName write FName;  // имя адресата   
    property Address: string read FAddress write FAddress; // почтовый адрес   
    property Enabled: boolean read FEnabled write FEnabled default true;  
    property Folders: TStringList read FFolders write FFolders; // список папок (тем) подписки   
  end;  

Класс содержит сведения о имени клиента, его адресе, его статусе(Enabled), а также список каталогов, на которые он подписан. Процедура PickFiles составляет список файлов к отправке и сохраняет его в свойстве Files
Класс TMailList, хранящий объекты класса TMailClient, приведен ниже.


TMailList = class(TCollection)   
public   
  function GetMailClient(Index: Integer): TMailClient;   
  procedure SetMailClient(Index: Integer; Value: TMailClient);   
public   
  function  Add: TMailClient;   
  property Items[Index: Integer]: TMailClient read GetMailClient  write SetMailClient; default;   
end;  

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

То есть в нашем примере он выполняет только роль носителя данных о подписчиках и их подписке. Класс TComponent, от которого он наследуется можно сохранить в файл, в то время как TCollection самостоятельно не сохранится. Только если она агрегирована в TComponent. Именно это у нас и реализовано.


TMailer = class(TComponent)   
private   
  FMailList: TMailList;   
public   
  constructor Create(AOwner: TComponent); override;   
  destructor Destroy; override;   
published   
  property MailList: TMailList read FMailList write FMailList; // коллекция - список рассылки.   
  // здесь можно поместить, к примеру, данные о соединении с почтовым сервером    
end;  

Повторюсь. В данном случае мы наследуемся от класса TComponent, для того, чтобы была возможности записи данных объекта в файл. Свойство MailList содержит уже объект класса TMailList.
Реализация всех приведенных классов приведена ниже.


constructor TMailClient.Create(Collection: TCollection);   
begin   
  inherited;   
  Folders := TStringList.Create;   
  Files := TStringList.Create;   
  FEnabled := true;   
end;   
   
destructor TMailClient.Destroy;   
begin   
  Folders.Free;   
  Files.Free;   
  inherited;   
end;   
  
// здесь во всех каталогах Folders ищем файлы для рассылки и помещаем их в Files.   
procedure TMailClient.PickFiles;   
var i: integer;  
begin   
    for i:=0 to Folders.Count-1 do CreateFileList(Files, Folders[i]);   
end;   
  
// Стандартный код при наследовании от класса коллекции: переопределяем тип    
function TMailList.GetMailClient(Index: Integer): TMailClient;   
begin   
  Result := TMailClient(inherited Items[Index]);   
end;   
   
// Стандартный код при наследовании от класса коллекции    
procedure TMailList.SetMailClient(Index: Integer; Value: TMailClient);   
begin   
  Items[Index].Assign(Value);   
end;   
  
 // Стандартный код при наследовании от класса коллекции: переопределяем тип    
function TMailList.Add: TMailClient;   
begin   
  Result := TMailClient(inherited Add);   
end;   
  
// создаем коллекцию адресатов рассылки TMailList   
constructor TMailer.Create(AOwner: TComponent);   
begin   
  inherited Create(AOwner);   
  MailList := TMailList.Create(TMailClient);   
end;   
   
destructor TMailer.Destroy;   
begin   
  MailList.Free;   
  inherited;   
end;   
//---------------------  

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


procedure CreateFileList(sl: TStringList; const FilePath: string);   
var   
  sr: TSearchRec;   
  procedure ProcessFile;   
  begin   
    if (sr.Name = '.')or(sr.Name = '..') then exit;   
    if sr.Attr <> faDirectory then   
      sl.Add(FilePath + '\' + sr.Name);   
    if sr.Attr = faDirectory then   
    begin   
      CreateFileList(sl, FilePath + '\' + sr.Name);   
    end;   
  end;   
begin   
  if not DirectoryExists(FilePath) then exit;   
  if FindFirst(FilePath + '\' + '*.*', faAnyFile , sr) = 0 then ProcessFile;   
  while FindNext(sr) = 0 do ProcessFile;   
  FindClose(sr);   
end;  

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


var   
  Mailer: TMailer; // это наш объект для хранения данных о почтовой рассылки  
    
// Процедура загрузки данных в объект. Может быть процедурой OnCreate() главной формы.  
procedure TfMain.FormCreate(Sender: TObject);  
var   
  sDataFile, sTmp: string;   
  i, j: integer;  
begin   
   
  Mailer := TMailer.Create(self);   
   
 // будем считать, что данные были сохранены в файл users.dat в каталоге программы  
  sDataFile := ExtractFilePath(ParamStr(0)) + 'users.dat';   
   
  //...загрузка данных из файла   
  if FileExists(sDataFile) then  
    LoadComponentFromTextFile(Mailer, sDataFile);   
   { здесь данные из файла загружены }  
  
  //...перебор подписчиков   
  for i:=0 to Mailer.MailList.Count-1 do   
  begin   
  
    sTmp := Mailer.MailList[i].Name;  //...обращение к имени   
    sTmp := Mailer.MailList[i].Address; //...обращение к адресу   
    //... sTmp - фиктивная переменная. Поменяйте ее на свои.    
      
    Mailer.MailList[i].PickFiles;  //... поиск файлов для отправки очередному подписчику.   
   
   //...перебор найденных файлов к отправке   
    for j:=0 to Mailer.MailList[i].Files.Count-1 do   
    begin   
      sTmp := Mailer.MailList[i].Files[j];   
    end;  
      
  end;  
end;  

После загрузки данных мы можем работать с данными в нашей коллекции подписчиков. Добавлять и удалять их ( Mailer.MailList.Add; Mailer.MailList.Delete(Index); ). При завершении работы программы необходимо сохранить уже новые данные в тот же файл.


// Процедура сохранения данных из объекта в файл. Может быть процедурой OnDestroy() главной формы.  
procedure TfMain.OnDestroy;  
begin  
  //...сохранение данных в файл users.dat  
  SaveComponentToTextFile(Mailer, ExtractFilePath(ParamStr(0)) + 'users.dat');   
end;  

Хранение данных в файле позволяет оказаться от использования БД, если объем данных не слишком велик и нет необходимости в совместном доступе к данным.
Самое главное - мы организуем все данные в виде набора удобных для работы классов и не тратим время на их сохранение и инициализацию из БД.
Приведенный пример лишь иллюстрирует этот подход. Для его реализации могут подойти и 2 таблицы в БД. Однако приведенный подход удобен при условии, что данные имеют сложную иерархию. К примеру, вложенные коллекции разных типов гораздо сложнее разложить в базе данных, для их извлечения потребуется SQL. Решайте сами, судя по своей конкретной задаче.

Далее приведен код функций для сохранения/чтения компонента.


//...процедура загружает(инициализирует) компонент из текстового файла с ресурсом   
procedure LoadComponentFromTextFile(Component: TComponent; const FileName: string);   
var   
  ms: TMemoryStream;   
  fs: TFileStream;   
begin   
  fs := TFileStream.Create(FileName, fmOpenRead);   
  ms := TMemoryStream.Create;   
  try   
    ObjectTextToBinary(fs, ms);   
    ms.position := 0;   
    ms.ReadComponent(Component);   
  finally   
    ms.Free;   
    fs.free;   
  end;   
end;   
   
//...процедура сохраняет компонент в текстовый файл   
procedure SaveComponentToTextFile(Component: TComponent; const FileName: string);   
var   
  ms: TMemoryStream;   
  fs: TFileStream;   
begin   
  fs := TFileStream.Create(FileName, fmCreate or fmOpenWrite);   
  ms := TMemoryStream.Create;   
  try   
    ms.WriteComponent(Component);   
    ms.position := 0;   
    ObjectBinaryToText(ms, fs);   
  finally   
    ms.Free;   
    fs.free;   
  end;   
end;  

Добавлено: 07 Августа 2018 08:25:36 Добавил: Андрей Ковальчук

Чудеса TStringList. Почему надо использовать объекты TStringList везде

Object Pascal в сочетании с ассемблером в современной его форме Delphi 5/6/7 предоставляет неограниченные возможности для полета мысли программиста, и этой статьей мы откроем серию, в которой последовательно будем это демонстрировать.

Начнем мы с простого, крайне полезного, но мало известного, по крайней мере, для начинающих, стандартного класса Дельфи TStringList. Сейчас мы посмотрим, как красиво решаются типичные задачи при помощи этого класса.

Для начала в двух словах, какие такие замечательные свойства есть у объектов данного класса. TStringList - это класс, предназначенный для хранения списка строк и списка объектов с текстовым представлением (прямо как в 1С - это СписокЗначений). Кроме того, этот список может быть отсортирован по алфавиту или при помощи сравнительной функции, написанной программистом. Кроме того, этот список может быть интерпретирован как список значений (Name=string). Кроме того, этот список может быть сохранен в файл или поток, преобразован в непрерывную строку или строку, разделенную запятыми. Физически получаемая строка или поток представляет собой обычный текст, в котором строки разделены символами CR/LF (стандартный Windows Text File), или запятыми (CommaText, Excel). Ну и само собой, есть возможность загружать список строк из файла, потока, строки и строки, разделенной запятыми. Следует особо отметить замечательное свойство упаковки в строку, разделенную запятыми: при обратной распаковке строки всегда восстанавливаются в их исходном виде. Это означает, что допустима многократная вложенность строк, разделенных запятыми, дающая огромный выигрыш при упаковке/распаковке многомерных структурных данных в текстовый формат, что мы и продемонстрируем во второй задаче.

Итак, для начала рассмотрим список строк как список объектов с текстовым представлением, т. к. именно в данном ключе следует использовать список строк в реальных приложениях. Что из себя представляет объект с текстовым представлением? Это может быть, например, список товаров, имеющих помимо наименования еще и дополнительные параметры типа единицы измерения, количества в упаковке и цены. Итак, имеем предопределение типов:


type   
  TEdIzm=class  
    public  
      Name:string;  
      Weight:double;  
    end;  
  TTovar=class  
    public  
      Name:string; //наименование  
      EdIzm:TEdIzm; //ед. изм.  
      CountUp:integer; //кол-во в упаковке  
      PriceOut:currency; //цена продажная  
    end;  
var  
  TovarList:TStringList;  

Набор объектов TTovar - это классический справочник однородных товаров, например, хлебобулочных изделий. Поле Weight в классе TEdIzm требуется для перевода одних единиц в другие. Вернемся к нашим булкам. Допустим, поставщик "Карякинский Хлебозавод" предоставил нам текстовый файл, в котором находится информация о его новой продукции и отпускных ценах в формате текстового файла:


*Начало файла*  
Товар1=[наименование товара]  
ЕдИзм1=[наименование ед.изм.]  
Вес1=[вес единицы измерения]  
КолУп1=[количество в упаковке]  
Цена1=[цена поставщика]  
--  
Товар2=[наименование товара]  
ЕдИзм2=[наименование ед.изм.]  
Вес2=[вес единицы измерения]  
КолУп2=[количество в упаковке]  
Цена2=[цена поставщика]  
--  
*Конец файла*  

Всего в файле содержится, например, 2000 наименований. Наша задача - загрузить данные этого файла в список строк ListBox1:TListBox (лежащий на форме) в отсортированном виде так, чтобы была возможность по двойному щелчку просмотреть параметры каждого товара (для этого к каждой строке будет прикреплен объект типа TTovar).

Если решать эту задачу в лоб (как чтение построчно и разбор текстового файла), а так же напрямую добавлять в ListBox, то это обернется неэффективной работой компьютера, его подтормаживанием (на слабых машинах), и вообще, для дальнейших внесений изменений в программный код это решение не является лучшим. Гораздо эффективнее сделать "финт ушами", а именно, создать TStringList, загрузить в него исходный файл, создать второй TStringList, загрузить в него товары, отсортировать их, и в конце концов, присвоить свойству ListBox.Items:


function LoadTovary(filename:string):TStrings;   
var str:TStringList;  
    tovar:TTovar;  
    edizm:TEdIzm;  
    I:integer;  
begin  
  //загружаем файл с данными  
  str:=TStringList.Create;  
  str.LoadFromFile(filename);  
  //посчитаем, сколько будет товаров  
  result:=TStringList.Create; // TStrings являедся предком TStringList, поэтому данное присвоение корректно  
  result.Capacity:=str.count div 6;  
  for I:=0 to result.capacity do  
  begin  
    tovar:=TTovar.Create;  
    edizm:=TEdIzm.Create;  
    tovar.Name:=str.Values['Товар'+inttostr(i)];  
    edizm.Name:=str.Values['ЕдИзм'+inttostr(i)];  
    edizm.Weight:=strtofloat(str.Values['Вес'+inttostr(i)]);  
    tovar.CountUp:=strtoint(str.Values['КолУп'+inttostr(i)]);  
    tovar.PriceOut:=strtoint(str.Values['Цена'+inttostr(i)]);  
    tovar.EdIzm:=edizm;  
    result.AddObject(tovar.Name,tovar);  
  end;  
  result.Sort;  
end;  
  
...  
ListBox1.Items:=LoadTovary('fromhlzd.txt');  
...  

Заметим, что если написать функцию типа TStringListSortCompare, то можно будет сортировать не только по текстовому представлению, но и по любым другим признакам, например, цене:


function StringListComparePrice(List: TStringList; Index1, Index2: Integer): Integer;  
begin  
  Result := TTovar(List.Objects[Index1]).PriceOut-TTovar(List.Objects[Index2]).PriceOut;  
end;  
  
...  
result.CustomSort(StringListComparePrice);  
...  

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


procedure TForm1.ListBox1DblClick(Sender: TObject);  
begin  
  showmessage('Цена поставщика '+  
floattostr(TTovar(TListBox(sender).Items.Objects[TListBox(sender).ItemIndex]).PriceOut)  
  );  
end;  

Кстати, не забываем освобождать системные ресурсы объектов перед удалением строк методами ListBox1.Items.Delete()/Clear() или str.Delete()/Clear() (str:TStringList), если это требуется, а так же при закрытии приложения:


procedure TForm1.FormDestroy(Sender: TObject);  
var i:integer;  
begin  
  for i:=0 to ListBox1.Items.Count-1 do  
  with TTovar(ListBox1.Items.Objects[i]) do  
  begin  
    EdIzm.Free;  
    Free;  
  end;  
end;  

Теперь немного усложним задачу. Пусть у нас есть не один файл, а десять - от десяти разных поставщиков. Нам надо в общей сложности загрузить 20000 наименований и затем отсортировать их. Если мы будем именно так и делать, то сортировка такого большого списка объектов займет значительное время, это и составляет задачу. Однако такая задача решается очень просто - достаточно после создания объекта TStringList сразу присвоить его свойству Sorted значение true. После этого вставка новых строк будет осуществляться с помощью быстрого алгоритма, однако потеряется возможность сортировать по параметрам прикрепленных объектов, т.к. в случае Sorted=true сортировка производится автоматически только по текстовому представлению (см. исходники TStringList). При Sorted=true, обработка дубликатов определяется свойством Duplicates. Можно пропускать, разрешать и запрещать дубликаты объектов с одинаковым текстовым представлением. При этом, если дубликаты пропускаются или запрещены, необходимо следить за освобождением ресурсов объектов, не добавленных в список. По умолчанию, свойство Duplicates равно dupIgnore, что означает, что дубликаты пропускаются, поэтому по умолчанию надо следить за освобождением ресурсов.

Стоит отметить, что при сохранении или загрузке списка строк, прикрепленные к строкам объекты не сохраняются и не восстанавливаются в стандартном TStringList, однако можно очень красиво решить эту проблему - написать потомка TStringList с переопределенными процедурами GetTextStr и SetTextStr, в которых придумать и реализовать собственный формат хранения объектов и их текстового представления в виде непрерывного текста.

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

Предположим, что нам надо запустить некую программу obrab.exe с параметром командной строки, в которой необходимо передать выбранный товар из сформированного выше списка. Напишем упаковщик и распаковщик данных. С TStringList эта задача программируется за две секунды:

Упаковщик


procedure runobrab;  
var strtov,stred:TStringList;  
begin  
  strtov:=TStringList.Create;  
  with TTovar(ListBox1.Items.Objects[ListBox1.ItemIndex]) do  
  begin  
    stred:=TStringList.Create;  
    stred.Values['ЕдИзм']:=EdIzm.Name;  
    stred.Values['Вес']:=floattostr(EdIzm.Weight);  
    strtov.Values['Товар']:=Name;  
    strtov.Values['ЕдИзм']:=stred.CommaText;  
    strtov.values['КолУп']:=inttostr(CountUp);  
    strtov.values['Цена']:=floattostr(PriceOut);  
  end;  
  winexec('obrab.exe '+strtov.CommaText,SW_SHOWNORMAL);  
  strtov.Free;  
  stred.Free;  
end;  

Распаковщик


function getparam:TTovar;  
var strtov,stred:TStringList;  
begin  
  strtov:=TStringList.Create;  
  stred:=TStringList.Create;  
  strtov.CommaText:=paramstr(1);  
  stred.CommaText:=strtov.Values['ЕдИзм'];  
  result:=TTovar.Create;  
  with result do  
  begin  
    EdIzm:=TEdIzm.Create;  
    EdIzm.Name:=stred.Values['ЕдИзм'];  
    EdIzm.Weight:=strtofloat(stred.Values['Вес']);  
    Name:=strtov.Values['Товар'];  
    CountUp:=strtoint(strtov.values['КолУп']);  
    PriceOut:=strtofloat(strtov.values['Цена']);  
  end;  
  stred.Free;  
  strtov.Free;  
end;  

Продолжение следует…

Автор: Цованян Роман

Добавлено: 07 Августа 2018 08:24:30 Добавил: Андрей Ковальчук

Шаблоны в Object Pascal

Наверное каждый Delphi программист хоть раз общался с программистом C++ и объяснял насколько Delphi мощнее и удобнее. Но в некоторый момент, программист C++ заявляет примерно следующее "OK, но Delphi использует Pascal, а значит не поддерживает множественное наследование и шаблоны, поэтому он не так хорош как C++."

Насчёт множественного наследования можно легко заявить, что Delphi имеет интерфейсы, которые прекрасно справляются со своей задачей, но вот насчёт шаблонов Вам прийдётся согласится, так как Object Pascal не поддерживает их.

Давайте посмотрим на эту проблему по-внимательней Шаблоны позволяют делать универсальные контейнеры такие как списки, стеки, очереди, и т.д. Если Вы хотите осуществить что-то подобное в Delphi, то у Вас есть два пути:

Использовать контейнер TList, который содержит указатели. В этом случае Вам прийдётся всё время делать явное приведение типов. Сделать подкласс контейнера TCollection или TObjectList, и убрать все методы, зависящие от типов каждый раз, когда Вы захотите использовать новый тип данных. Третий вариант, это сделать модуль с универсальным классом контейнера, и каждый раз, когда нужно использовать новый тип данных, нам прийдётся в редакторе искать и вносить исправления. Было бы здорово, если всю эту работу за Вас делал компилятор.... вот этим мы сейчас и займёмся!

Например, возьмём классы TCollection и TCollectionItem. Когда Вы объявляете нового потомка TCollectionItem , то так же Вы наследуете новый класс от TOwnedCollection и переопределяете большинство методов, чтобы их можно было вызывать с новыми типами.

Давайте посмотрим, как создать универсальную коллекцию шаблонов класса:

Шаг 1: Создайте новый текстовый файл (не юнитовский) с именем TemplateCollectionInterface.pas:


_COLLECTION_ = class (TOwnedCollection)  
protected  
 function  GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;  
 procedure SetItem (const aIndex : Integer;  
                    const aValue : _COLLECTION_ITEM_);  
public  
 constructor Create (const aOwner : TComponent);  
  
 function Add                                 : _COLLECTION_ITEM_;  
 function FindItemID (const aID    : Integer) : _COLLECTION_ITEM_;  
 function Insert     (const aIndex : Integer) : _COLLECTION_ITEM_;  
 property Items      [const aIndex : Integer] : _COLLECTION_ITEM_ read GetItem write SetItem;  
end;  

Обратите внимание, что нет никаких uses или interface clauses, только универсальное объявление типа, в котором _COLLECTION_ это имя универсальной коллекции класса, а _COLLECTION_ITEM_ это имя методов, содержащихся в нашем шаблоне.

Шаг 2: Создайте второй текстовый файл и сохраните его как TemplateCollectionImplementation.pas:


constructor _COLLECTION_.Create (const aOwner : TComponent);  
begin  
 inherited Create (aOwner, _COLLECTION_ITEM_);  
end;  
  
function _COLLECTION_.Add : _COLLECTION_ITEM_;  
begin  
 Result := _COLLECTION_ITEM_ (inherited Add);  
end;  
  
function _COLLECTION_.FindItemID (const aID : Integer) : _COLLECTION_ITEM_;  
begin  
 Result := _COLLECTION_ITEM_ (inherited FindItemID (aID));  
end;  
  
function _COLLECTION_.GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;  
begin  
 Result := _COLLECTION_ITEM_ (inherited GetItem (aIndex));  
end;  
  
function _COLLECTION_.Insert (const aIndex : Integer) : _COLLECTION_ITEM_;  
begin  
 Result := _COLLECTION_ITEM_ (inherited Insert (aIndex));  
end;  
  
procedure _COLLECTION_.SetItem (const aIndex : Integer;  
                                const aValue : _COLLECTION_ITEM_);  
begin  
 inherited SetItem (aIndex, aValue);  
end;   

Снова нет никаких uses или interface clauses , а только код универсального типа.

Шаг 3: Создайте новый unit-файл с именем MyCollectionUnit.pas:


unit MyCollectionUnit;  
  
interface  
  
uses Classes;  
  
type TMyCollectionItem = class (TCollectionItem)  
     private  
      FMyStringData  : String;  
      FMyIntegerData : Integer;  
     public  
      procedure Assign (aSource : TPersistent); override;  
     published  
      property MyStringData  : String  read FMyStringData  write FMyStringData;  
      property MyIntegerData : Integer read FMyIntegerData write FMyIntegerData;  
     end;  
  
     // !!! Указываем универсальному классу на реальный тип  
       
     _COLLECTION_ITEM_ = TMyCollectionItem;   
       
     // !!! директива добавления интерфейса универсального класса  
  
     {$INCLUDE TemplateCollectionInterface}   
  
     // !!! переименовываем универсальный класс  
  
     TMyCollection = _COLLECTION_;            
  
implementation  
  
uses SysUtils;  
  
// !!! препроцессорная директива добавления универсального класса  
  
{$INCLUDE TemplateCollectionImplementation}   
  
procedure TMyCollectionItem.Assign (aSource : TPersistent);  
begin  
 if aSource is TMyCollectionItem then  
 begin  
  FMyStringData  := TMyCollectionItem(aSource).FMyStringData;  
  FMyIntegerData := TMyCollectionItem(aSource).FMyIntegerData;  
 end  
 else inherited;  
end;  
  
end.  

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

Второй пример Давайте создадим универсальный класс для динамических массивов.

Шаг 1: Создайте текстовый файл с именем TemplateVectorInterface.pas:


_VECTOR_INTERFACE_ = nterface  
 function  GetLength : Integer;  
 procedure SetLength (const aLength : Integer);  
  
 function  GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;  
 procedure SetItems (const aIndex : Integer;  
                     const aValue : _VECTOR_DATA_TYPE_);  
  
 function  GetFirst : _VECTOR_DATA_TYPE_;  
 procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);  
  
 function  GetLast  : _VECTOR_DATA_TYPE_;  
 procedure SetLast  (const aValue : _VECTOR_DATA_TYPE_);  
  
 function  High  : Integer;  
 function  Low   : Integer;  
  
 function  Clear                              : _VECTOR_INTERFACE_;  
 function  Extend   (const aDelta : Word = 1) : _VECTOR_INTERFACE_;  
 function  Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;   
  
 property  Length                         : Integer             read GetLength write SetLength;  
 property  Items [const aIndex : Integer] : _VECTOR_DATA_TYPE_  read GetItems  write SetItems; default;  
 property  First                          : _VECTOR_DATA_TYPE_  read GetFirst  write SetFirst;  
 property  Last                           : _VECTOR_DATA_TYPE_  read GetLast   write SetLast;  
end;  
  
_VECTOR_CLASS_ = class (TInterfacedObject, _VECTOR_INTERFACE_)  
private  
 FArray : array of _VECTOR_DATA_TYPE_;  
protected  
 function  GetLength : Integer;  
 procedure SetLength (const aLength : Integer);  
  
 function  GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;  
 procedure SetItems (const aIndex : Integer;  
                     const aValue : _VECTOR_DATA_TYPE_);  
  
 function  GetFirst : _VECTOR_DATA_TYPE_;  
 procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);  
  
 function  GetLast  : _VECTOR_DATA_TYPE_;  
 procedure SetLast  (const aValue : _VECTOR_DATA_TYPE_);  
public  
 function  High  : Integer;  
 function  Low   : Integer;  
  
 function  Clear                              : _VECTOR_INTERFACE_;  
 function  Extend   (const aDelta : Word = 1) : _VECTOR_INTERFACE_;  
 function  Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;   
  
 constructor Create (const aLength : Integer);  
end;  

Шаг 2: Создайте текстовый файл и сохраните его как TemplateVectorImplementation.pas:


constructor _VECTOR_CLASS_.Create (const aLength : Integer);  
begin  
 inherited Create;  
  
 SetLength (aLength);  
end;  
  
function _VECTOR_CLASS_.GetLength : Integer;  
begin  
 Result := System.Length (FArray);  
end;  
  
procedure _VECTOR_CLASS_.SetLength (const aLength : Integer);  
begin  
 System.SetLength (FArray, aLength);  
end;  
  
function _VECTOR_CLASS_.GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;  
begin  
 Result := FArray [aIndex];  
end;  
  
procedure _VECTOR_CLASS_.SetItems (const aIndex : Integer;  
                                   const aValue : _VECTOR_DATA_TYPE_);  
begin  
 FArray [aIndex] := aValue;  
end;  
  
function _VECTOR_CLASS_.High : Integer;  
begin  
 Result := System.High (FArray);  
end;  
  
function _VECTOR_CLASS_.Low : Integer;  
begin  
 Result := System.Low (FArray);  
end;  
  
function _VECTOR_CLASS_.GetFirst : _VECTOR_DATA_TYPE_;  
begin  
 Result := FArray [System.Low (FArray)];  
end;  
  
procedure _VECTOR_CLASS_.SetFirst (const aValue : _VECTOR_DATA_TYPE_);  
begin  
 FArray [System.Low (FArray)] := aValue;  
end;  
  
function _VECTOR_CLASS_.GetLast : _VECTOR_DATA_TYPE_;  
begin  
 Result := FArray [System.High (FArray)];  
end;  
  
procedure _VECTOR_CLASS_.SetLast (const aValue : _VECTOR_DATA_TYPE_);  
begin  
 FArray [System.High (FArray)] := aValue;  
end;  
  
function _VECTOR_CLASS_.Clear : _VECTOR_INTERFACE_;  
begin  
 FArray := Nil;  
  
 Result := Self;  
end;  
  
function _VECTOR_CLASS_.Extend (const aDelta : Word) : _VECTOR_INTERFACE_;  
begin  
 System.SetLength (FArray, System.Length (FArray) + aDelta);  
  
 Result := Self;  
end;  
  
function _VECTOR_CLASS_.Contract (const aDelta : Word) : _VECTOR_INTERFACE_;  
begin  
 System.SetLength (FArray, System.Length (FArray) - aDelta);  
  
 Result := Self;  
end;  

Шаг 3: Создайте unit файл с именем FloatVectorUnit.pas:

unit FloatVectorUnit;  
  
interface  
  
uses Classes;                           // !!! Модуль "Classes" содержит объявление класса TInterfacedObject  
  
type _VECTOR_DATA_TYPE_ = Double;       // !!! тип данных для класса массива Double  
  
     {$INCLUDE TemplateVectorInterface}  
  
     IFloatVector = _VECTOR_INTERFACE_; // !!! give the interface a meanigful name  
     TFloatVector = _VECTOR_CLASS_;     // !!! give the class a meanigful name  
  
function CreateFloatVector (const aLength : Integer = 0) : IFloatVector; // !!! дополнительная функция   
  
implementation  
  
{$INCLUDE TemplateVectorImplementation}  
  
function CreateFloatVector (const aLength : Integer = 0) : IFloatVector;       
begin  
 Result := TFloatVector.Create (aLength);  
end;  
  
end.   

Естевственно, можно дополнить универсальный класс дополнительными функциями. Всё зависит от Вашей фантазии!

Использование шаблонов Вот пример использования нового векторного интерфейса:


procedure TestFloatVector;  
 var aFloatVector : IFloatVector;  
     aIndex       : Integer;  
begin  
 aFloatVector := CreateFloatVector;  
  
 aFloatVector.Extend.Last := 1;  
 aFloatVector.Extend.Last := 2;  
  
 for aIndex := aFloatVector.Low to aFloatVector.High do  
 begin  
  WriteLn (FloatToStr (aFloatVector [aIndex]));  
 end;  
end.   

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

Добавлено: 07 Августа 2018 08:22:42 Добавил: Андрей Ковальчук

Регистрация в реестре

Несомненно, регистр (он же реестр) Windows — очень полезная вещь. Ведь в нем можно хранить так много информации — от количества программ вашей фирмы, ранее установленных на данном PC, и информации об их регистрации до разнообразных настроек окошек этих самых программ. Но для того чтобы все это там хранить, необходимо уметь работать с реестром, причем работать корректно, без ошибок.В данной статье будут разобраны основные функции работы с регистром в Delphi (легко портируемые при необходимости на С/С++), а также рассмотрены примеры пользовательских функций для более общих действий с регистром (тоже легко переносимые на С/С++). Итак, приступим…

Рассмотрим на примере. Допустим, вы написали очень (или не слишком) навороченную софтину и теперь хотите, чтобы богатенькие юзеры ею не просто так пользовались, а за денежку. То бишь, скачал юзер вашу софтинку с официального сайта вашей же фирмы Глюкософт, запустил, а она ему: «Заплати-ка ты, дружок, сначала $99.99 фирме Глюкософт, если хочешь получить все мои возможности, получи там у них код на такой-то номер, а потом и пользуйся!» Для этого вам необходимо при первом запуске сгенерировать два значения — «Программа не зарегистрирована» и уникальный номер — и где-то их сохранить. Уникальный номер нужен затем, чтобы предотвратить попытки доморощенных хакеров продавать за $9 универсальный код к вашей софтинке.

Первое и самое главное, что вам понадобится, это какая-либо переменная типа HKey. Этот тип описан в модуле windows.pas (как и все функции, описанные ниже) и представляет собой тип дескриптора ключа регистра (кто не знает, дескриптор — это типа указателя, только круче :-)).

Затем при помощи функции RegOpenKey или RegOpenKeyEx открыть необходимый нам ключ регистра. Если при этом возникнет ошибка, значит, на 99% можно утверждать, что софтина запускается впервые, или что ваши записи в регистре были удалены.

Синтаксис у нее такой:


Function RegOpenKey(BaseKey:HKey; SubKey:PChar; dwReserved:dword; samDesired:RegSAM; var ResKey:PHKey):dword;  

Где:

BaseKey — дескриптор ранее открытого ключа или одна из мнемонических констант — HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE или HKEY_USERS, обозначающих соответствующие базовые разделы регистра. Рекомендуется использовать только первые два: HKEY_CLASSES_ROOT — информация об обрабатываемых расширениях, и HKEY_CURRENT_USER — информация о текущем пользователе;

SubKey — имя ключа, который вы хотите создать. При этом оно может содержать \ для спуска на один уровень вниз, но не должно начинаться или заканчиваться на этот самый \;

dwReserved — припасено для будущих версий, должно быть 0;

samDesired — флаг или комбинация флагов, отвечающих за способ открытия ключа; возможны следующие значения: KEY_READ — просто чтение, KEY_SET_VALUE — установить значение переменной в ключе, KEY_WRITE — перезаписать ключ полностью, при этом все старые значения будут уничтожены;

ResKey — дескриптор-приемник ключа.

В случае успешного выполнения функция возвращает значение ERROR_SUCCESS или NO_ERROR, в случае ошибки возвращается код ошибки.

Пусть мы установили, что запуск произведен впервые (открытие ключа вернуло ошибку). Значит, теперь нужно создать соответствующий вашей программе ключ. Сделать это можно при помощи функции RegCreateKeyEx.

Синтаксис у нее следующий:


Function RegCreateKeyEx(BaseKey:HKey; SubKey:PChar; dwReserved:dword; pClass:PChar; dwOptions:dword; samDesired:RegSAM; SecAttr:lpSecurity_Attributes; var ResKey:PHKey; Disposition:lpdword):dword;
Большинство параметров аналогичны RegOpenKeyEx:

samDesired — может быть также KEY_ALL_ACCESS — полный доступ с предварительным созданием; KEY_CREATE_SUB_KEY — создание вложенного ключа; pClass — совершенно бесполезный параметр, поэтому лучше ставить значение nil; dwOptions — определяет тип создаваемого ключа; может быть REG_OPTION_NON_VOLATILE (постоянный ключ, используется по умолчанию; при этом информация, записанная в ключ, сохраняется и доступна после перезагрузки) или REG_OPTION_VOLATILE (временный ключ; в Win95/98 вообще игнорируется, во всех WinNT информация записывается во временную память и теряется при перезагрузке); SecAttr — в Win95/98 вообще игнорируется, во всех WinNT отвечает за параметры политики безопасности. Лучше ставить значение nil;

Disposition — еще один совершенно ненужный параметр; лучше использовать адрес любой переменной типа integer или word со значением 0.

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


Function RegSetValueEx(BaseKey:HKey; ValueName:PChar; dwReserved, dwType:dword; pData:pointer; DataSize:dword):dword;  

Где:

ValueName — имя переменной, значение которой устанавливается (если ее нет, то она будет создана);
dwType — идентификатор типа переменной: REG_BINARY — все виды двоичных типов переменных (напремер, boolean); REG_DWORD — переменная типа dword; REG_SZ — строковая переменная; REG_EXPAND_SZ — строка с мнемоническими обозначениями переменных среды (например, %PATH%\GluckoSoft); REG_NONE — неопределенный или сложный тип (например, какая-нибудь структура);
pData — указатель на записываемые данные;
DataSize — размер записываемых данных.

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


Function RegCloseKey(WhatKey:HKey):dword. 

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


…  
const {нам понадобятся некоторые константы}  
SKey = ‘Software\GluckoSoft\Someware’; {ключ для данной программы}  
SID = ‘ProductID’; {имя переменной, хранящей уникальный номер программы}  
SRg = ‘Registered’;{имя переменной, хранящей сведения о регистрации}  
…  
function Prepare:dword;  
var  
Res:dword;  
Key:HKey;  
Rgst:boolean;  
ID:dword;  
Dummy:integer;  
begin  
Prepare:=ERROR_SUCCESS;  
Dummy:=0;  
Rgst:=false;  
ID:=Random(10000);  
Res:=RegOpenKeyEx(HKEY_CURRENT_USER, SKey, 0, KEY_READ, Key);  
if (Res<>ERROR_SUCCESS)  
then  
begin  
Res:=RegCreateKey(HKEY_CURRENT_USER, SKey, 0, nil, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, nil, Key, @Dummy);  
if (Res<>ERROR_SUCCESS)  
then  
begin  
Prepare:=Res;  
Exit;  
end  
else  
begin  
Res:=RegSetValueEx(Key,SRg,0,REG_BINARY,@Rgst,SizeOf(Rgst));  
if (Res<>ERROR_SUCCESS)  
then  
begin  
Prepare:=Res;  
Exit;  
end;  
Res:=RegSetValueEx(Key,SID,0,REG_DWORD,@ID,SizeOf(ID));  
if (Res<>ERROR_SUCCESS)  
then  
begin  
Prepare:=Res;  
Exit;  
end;  
RegCloseKey(Key);  
end;  
end  
else RegCloseKey(Key);  
end;  
…  

Значит, данные вы сохранили, окошко с сообщением юзеру выдали (наверняка сами это сможете сделать), тот зарегистрировался и получил код. Теперь необходимо код этот проверить на соответствие уникальному номеру и при соответствии отметить, что софтинка ваша зарегистрирована. Для этого вам понадобится уже знакомая функция RegOpenKeyEx с типом доступа KEY_READ и функция чтения RegQueryValueEx:


Function RegQueryValueEx(BaseKey:HKey; ValueName:PChar; pdwReserved,pdwType:lpdword; pData:pointer; pDataSize:lpdword):dword;  

Почти все параметры вам уже знакомы.

pdwReserved — зарезервировано, nil;
pdwType — указатель на приемник идентификатора типа указанной переменной; заполняется по выполнении функции;
pData — указатель на структуру-приемник данных;
pDataSize — указатель (!) на размер приемника данных.

С их помощью вы считываете значение уникального номера, проверяете его на соответствие введенному коду и, при удовлетворительном результате, функцией RegSetValueEx изменяете значение переменной Registered на true.

Реализовать это можно примерно так:


…  
function Register(Code:dword):dword;  
var  
Key:HKey;  
Res,D1,D2,ID:dword;  
Rgst:boolean;  
begin  
Register:=ERROR_SUCCESS;  
Res:=RegOpenKeyEx(HKEY_CURRENT_USER, SKey, 0, KEY_READ, Key);  
if (Res<>ERROR_SUCCESS)  
then  
begin  
Register:=Res;  
Exit;  
end  
else  
begin  
D2:=SizeOf(ID);  
Res:=RegQueryValue(Key, SID, nil, @D1, @ID, @D2);  
if (Res<>ERROR_SUCCESS)  
then  
begin  
Register:=Res;  
Exit;  
end;  
{проверяем соответствие кода уникальному номеру например так: уникальный номер равен коду, нацело деленному на два}  
if ((Code div 2)<>ID) {при несоответствии…}  
then  
begin  
Register:=666; {…возвращаем ошибку…}  
Exit; {…и выходим!}  
end;  
RegCloseKey(Key);  
Res:=RegOpenKeyEx(HKEY_CURRENT_USER, SKey, 0, KEY_SET_VALUE, Key);  
if (Res<>ERROR_SUCCESS)  
then  
begin  
Register:=Res;  
Exit;  
end;  
Rgst:=true;  
Res:=RegSetValueEx(Key, SRg, 0, REG_BINARY, @Rgst, SizeOf(Rgst));  
if (Res<>ERROR_SUCCESS)  
then  
begin  
Register:=Res;  
Exit;  
end;  
RegCloseKey(Key);  
end;  
end;  
…  

Осталось совсем чуть-чуть. Предположим, что юзер вашей несомненно великолепной софтиной попользовался, но по какой-то причине решил ее удалить (мало ли, может, лучше нашел… причем, тоже вашу :-)). Удалять при этом придется порядком всякой всячины, и конечно же, вы для этого создали специальную процедуру/программу. Нужно обязательно не забыть удалить еще и записи в реестре (желательно, только от своей программы :-)). В этом вам поможет функция RegDeleteKey: Function RegDeleteKey(BaseKey:HKey; SubKey:PChar):dword.

Тут все понятно. Выглядеть это будет приблизительно вот так:


…  
procedure UnInstall;  
…  
begin  
…  
RegDeleteKey(HKEY_CURRENT_USER, SKey);  
…  
end;  
…  

Нужно заметить, что при этом удаляется только подключ HKEY_CURRENT_USER\Software\GluckoSoft\Someware, а ключ HKEY_CURRENT_USER\Software\GluckoSoft остается. Чтобы избежать удаления информации других программ в этом ключе и, с другой стороны, захламления регистра пустыми ключами, можно, например, непосредственно в ключ HKEY_CURRENT_USER\Software\GluckoSoft добавить переменную, которая будет увеличиваться на 1 при установке новых программ вашей фирмы и уменьшаться на 1 при их удалении. Когда она станет равна нулю, смело производите удаление ключа. Заодно получится счетчик «рейтинга» вашей фирмы.

P.S. Вообще-то существует еще модуль registry.pas с описанием типа TRegistry, вроде бы призванного облегчить вам жизнь, но на практике гораздо удобнее и эффективнее использовать описанные выше функции. К тому же подключение этого модуля увеличивает размер ехе-файла.

Автор: Дмитрий НАЗАРАТИЙ

Добавлено: 07 Августа 2018 08:20:56 Добавил: Андрей Ковальчук

Работа с TDBGrid

Что можно поместить в DBGrid

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

Как изменить цвет строки в TDBGrid
Предположим, нам требуется изменить атрибуты текста и фона строки в компоненте TDBGrid, если значение какого-либо поля удовлетворяет заранее заданному условию. Для этой цели принято использовать обработчик события OnDrawColumnCell этого компонента. Отметим, что возможности, предоставляемые при его использовании, весьма разнообразны.

Рассмотрим простейшее приложение с TDBGrid, содержащее один компонент TTable, один компонент TDataSource и один компонент TDBGrid: Установим значения их свойств в соответствии с приведенной ниже таблицей:

Компонент Свойство Значение
Table1 DatabaseName BCDEMOS (или DBDEMOS)
TableName events.db
Active true
DataSource1 DataSet Table1
DBGrid1 DataSource DataSource1
Обычно для перерисовки изображения в ячейках используется метод OnDrawColumnCell.

Его параметр Rect - структура, описывающая занимаемый ячейкой прямоугольник, параметр Column - колонка DBGrid, в которой следует изменить способ рисования изображения. Для вывода текста используется метод TextOut свойства Canvas компонента TDBGrid.

Предположим, нам нужно изменить цвет текста и фона строки в зависимости от значения какого-либо поля (например, VenueNo). Создадим обработчик события OnDrawColumnCell компонента DBGrid1. В случае C++Builder он имеет вид:


void __fastcall TForm1::DBGrid1DrawColumnCell(TObject *Sender,  
      const TRect &Rect, int DataCol, TColumn *Column,  
      TGridDrawState State)  
{  
if (Table1->FieldByName("VenueNo")->Value==1)  
{  
DBGrid1->Canvas->Brush->Color=clGreen;  
DBGrid1->Canvas->Font->Color=clWhite;  
DBGrid1->Canvas->FillRect(Rect);  
DBGrid1->Canvas->TextOut(Rect.Left+2,Rect.Top+2,Column->Field->Text);  
}  
}  

В случае Delphi соответствующий код имеет вид:


procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;  
  DataCol: Integer; Column: TColumn; State: TGridDrawState);  
begin  
if (Table1.FieldByName('VenueNo').Value=1) then begin  
with  DBGrid1.Canvas do begin  
Brush.Color:=clGreen;  
Font.Color:=clWhite;  
FillRect(Rect);  
TextOut(Rect.Left+2,Rect.Top+2,Column.Field.Text);  
end;  
end;  
end;  

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

При выводе выделенных строк все данные в ячейках оказались выровненными по левому краю. Если мы хотим более корректно отобразить выравнивание текста в колонке, следует слегка модифицировать наш код, учтя значение свойства Alignment текущей (то есть рисуемой в данный момент) колонки:


void __fastcall TForm1::DBGrid1DrawColumnCell(TObject *Sender,  
      const TRect &Rect, int DataCol, TColumn *Column,  
      TGridDrawState State)  
{  
if (Table1->FieldByName("VenueNo")->Value==1)  
{  
DBGrid1->Canvas->Brush->Color=clGreen;  
DBGrid1->Canvas->Font->Color=clWhite;  
DBGrid1->Canvas->FillRect(Rect);  
if (Column->Alignment==taRightJustify)  
{  
DBGrid1->Canvas->TextOut(Rect.Right-2-  
  DBGrid1->Canvas->TextWidth(Column->Field->Text),  
  Rect.Top+2,Column->Field->Text);  
}  
else  
{  
DBGrid1->Canvas->TextOut(Rect.Left+2,Rect.Top+2,Column->Field->Text);  
}  
}  
}  

Соответствующий код для Delphi имеет вид:


procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;  
  DataCol: Integer; Column: TColumn; State: TGridDrawState);  
begin  
if (Table1.FieldByName('VenueNo').Value=1) then begin  
with  DBGrid1.Canvas do begin  
Brush.Color:=clGreen;  
Font.Color:=clWhite;  
FillRect(Rect);  
if (Column.Alignment=taRightJustify) then  
 TextOut(Rect.Right-2-  TextWidth(Column.Field.Text),  
  Rect.Top+2,Column.Field.Text)  
else  
 TextOut(Rect.Left+2,Rect.Top+2,Column.Field.Text);  
end;  
end;  
end;  

В этом случае выравнивание текста в колонках совпадает с выравниванием столбцов.

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

Если необходимо отобразить нестандартным образом не всю строку, а только некоторые ячейки, следует проанализировать имя поля, отображаемого в данной колонке, как в приведенном ниже обработчике событий. Пример для C++Builder выглядит так:


void __fastcall TForm1::DBGrid1DrawColumnCell(TObject *Sender,  
      const TRect &Rect, int DataCol, TColumn *Column,  
      TGridDrawState State)  
{  
if ((Table1->FieldByName("VenueNo")->Value==1) &  
(Column->FieldName=="VenueNo") )  
{  
DBGrid1->Canvas->Brush->Color=clGreen;  
DBGrid1->Canvas->Font->Color=clWhite;  
DBGrid1->Canvas->FillRect(Rect);  
DBGrid1->Canvas->TextOut(Rect.Right-2-  
  DBGrid1->Canvas->TextWidth(Column->Field->Text),  
  Rect.Top+2,Column->Field->Text);  
}  
}  

Соответствующий код для Delphi имеет вид:


procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;  
  DataCol: Integer; Column: TColumn; State: TGridDrawState);  
begin  
if (Table1.FieldByName('VenueNo').Value=1) and  
(Column.FieldName='VenueNo')  then begin  
with  DBGrid1.Canvas do begin  
Brush.Color:=clGreen;  
Font.Color:=clWhite;  
FillRect(Rect);  
TextOut(Rect.Right-2-  TextWidth(Column.Field.Text),  
  Rect.Top+2,Column.Field.Text)  
end;  
end;  
end;  

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

Как заменить данные в столбце компонента TDBGrid
Нередко в колонке DBGrid нужно вывести не реальное значение, хранящееся в поле соответствующей таблицы, а другие данные, соответствующие имеющимся (например, символьную строку вместо ее числового кода). В этом случае также используется метод TextOut свойства Canvas компонента TDBGrid:


void __fastcall TForm1::DBGrid1DrawColumnCell(TObject *Sender,  
      const TRect &Rect, int DataCol, TColumn *Column,  
      TGridDrawState State)  
{  
if  
(Column->FieldName=="VenueNo")  
{  
DBGrid1->Canvas->Brush->Color=clWhite;  
DBGrid1->Canvas->FillRect(Rect);  
if (Table1->FieldByName("VenueNo")->Value==1)  
{  
DBGrid1->Canvas->Font->Color=clRed;  
DBGrid1->Canvas->TextOut(Rect.Right-2-  
  DBGrid1->Canvas->TextWidth("our venue"),  
  Rect.Top+2,"our venue");  
}  
else  
{  
DBGrid1->Canvas->TextOut(Rect.Right-2-  
  DBGrid1->Canvas->TextWidth("other venue"),  
  Rect.Top+2,"other venue");  
}  
}  
}  

Соответствующий код для Delphi имеет вид:


procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;  
  DataCol: Integer; Column: TColumn; State: TGridDrawState);  
begin  
if  (Column.FieldName='VenueNo')  then begin  
with  DBGrid1.Canvas do begin  
Brush.Color:=clWhite;  
FillRect(Rect);  
if (Table1.FieldByName('VenueNo').Value=1) then begin  
Font.Color:=clRed;  
TextOut(Rect.Right-2-  
  DBGrid1.Canvas.TextWidth('our venue'),  
  Rect.Top+2,'our venue');  
end else begin  
 TextOut(Rect.Right-2-  
  DBGrid1.Canvas.TextWidth('other venue'),  
  Rect.Top+2,'other venue');  
end;  
end;  
end;  
end;  

Еще один пример - использование значков из шрифтов Windings или Webdings в качестве подставляемой строки.


void __fastcall TForm1::DBGrid1DrawColumnCell(TObject *Sender,  
      const TRect &Rect, int DataCol, TColumn *Column,  
      TGridDrawState State)  
{  
if  
(Column->FieldName=="VenueNo")  
{  
DBGrid1->Canvas->Brush->Color=clWhite;  
DBGrid1->Canvas->FillRect(Rect);  
DBGrid1->Canvas->Font->Name="Wingdings";  
DBGrid1->Canvas->Font->Size=-14;  
if (Table1->FieldByName("VenueNo")->Value==1)  
{  
DBGrid1->Canvas->Font->Color=clRed;  
DBGrid1->Canvas->TextOut(Rect.Right-2-  
  DBGrid1->Canvas->TextWidth("J"),  
  Rect.Top+1,"J");  
}  
else  
{  
DBGrid1->Canvas->Font->Color=clBlack;  
DBGrid1->Canvas->TextOut(Rect.Right-2-  
  DBGrid1->Canvas->TextWidth("F"),  
  Rect.Top+1,"F")    ;  
}  
}  
}  

Соответствующий код для Delphi имеет вид:


procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;  
  DataCol: Integer; Column: TColumn; State: TGridDrawState);  
begin  
if  (Column.FieldName='VenueNo')  then begin  
with  DBGrid1.Canvas do begin  
Brush.Color:=clWhite;  
FillRect(Rect);  
Font.Name:='Wingdings';  
Font.Size:=-14;  
if (Table1.FieldByName('VenueNo').Value=1) then begin  
Font.Color:=clRed;  
TextOut(Rect.Right-2-  
  DBGrid1.Canvas.TextWidth('J'),  
  Rect.Top+1,'J');  
end else begin  
 Font.Color:=clBlack;  
 TextOut(Rect.Right-2- DBGrid1.Canvas.TextWidth('F'),  
  Rect.Top+1,'F');  
end;  
end;  
end;  
end;  

Как поместить графическое изображение в TDBGrid
Использование свойства Canvas компонента TDBGrid в методе OnDrawColumnCell позволяет не только выводить в ячейке текст методом TextOut, но и размещать в ячейках графические изображения. В этом случае используется метод Draw свойства Canvas.

Модифицируем наш пример, добавив на форму компонент TImageList и поместив в него несколько изображений.

Модифицируем код нашего приложения:


void __fastcall TForm1::DBGrid1DrawColumnCell(TObject *Sender,  
      const TRect &Rect, int DataCol, TColumn *Column,  
      TGridDrawState State)  
{  
 Graphics::TBitmap *Im1;  
 Im1= new   Graphics::TBitmap;  
if  
(Column->FieldName=="VenueNo")  
{  
DBGrid1->Canvas->Brush->Color=clWhite;  
DBGrid1->Canvas->FillRect(Rect);  
if (Table1->FieldByName("VenueNo")->Value==1)  
{  
ImageList1->GetBitmap(0,Im1);  
}  
else  
{  
ImageList1->GetBitmap(2,Im1);  
}  
DBGrid1->Canvas->Draw((Rect.Left+Rect.Right-Im1->Width)/2,Rect.Top,Im1);  
}  
}  

Соответствующий код для Delphi имеет вид:


procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;  
  DataCol: Integer; Column: TColumn; State: TGridDrawState);  
var Im1: TBitmap;  
begin  
Im1:=TBitmap.Create;  
if  (Column.FieldName='VenueNo' ) then begin  
with  DBGrid1.Canvas do begin  
Brush.Color:=clWhite;  
FillRect(Rect);  
if (Table1.FieldByName('VenueNo').Value=1)  
then begin  
ImageList1.GetBitmap(0,Im1);  
end else begin  
ImageList1.GetBitmap(2,Im1);  
end;  
Draw(round((Rect.Left+Rect.Right-Im1.Width)/2),Rect.Top,Im1);  
end;  
end;  
end;  

Теперь в TDBGrid в колонке VenueNo находятся графические изображения.

Добавлено: 07 Августа 2018 08:18:46 Добавил: Андрей Ковальчук

Создание Анимации в Delphi

В этом примере показано, как, объеденив классы Delphi 5 с функциями Win32 GDI, можно добиться анимации упрощенного избражения эльфа.

Исходные тексты можно взять здесь.


unit MainFrm;  
interface  
uses  
SysUtils, WinTypes, WinProcs, Messages, Classes,  
Graphics, Controls, Forms, Dialogs, Menus, Stdctrls;  
{$R SPRITES.RES } {Привязка растровых изображений к 
исполняемому файлу.}  
type  
TSprite = class  
private  
FWidth: integer;  
FHeight: integer;  
FLeft: integer;  
FTop: integer;  
FAndImage, FOrImage: TBitMap;  
public  
property Top: Integer read FTop write FTop;  
property Left: Integer read FLeft write FLeft;  
property Width: Integer read FWidth write FWidth;  
property Height: Integer read FHeight write FHeight;  
constructor Create;  
destructor Destroy; override;  
end;  
  
TMainForm = class(TForm)  
procedure FormCreate(Sender: TObject);  
procedure FormPaint(Sender: TObject);  
procedure FormDestroy(Sender: TObject);  
private  
BackGnd1, BackGnd2: TBitMap;  
Sprite: TSprite;  
GoLeft, GoRight,GoUp,GoDown: boolean;  
procedure MyIdleEvent(Sender: TObject;  
var Done: Boolean);  
procedure DrawSprite;  
end;  
  
const  
BackGround = 'BACK2.BMP';  
var  
  
MainForm: TMainForm;  
  
implementation  
  
{$R *.DFM}  
constructor TSprite.Create;  
begin  
inherited Create;  
{ Создание растров для хранения изображений эльфа, 
которые будут использованы при выполнении операции 
AND/OR (И/ИЛИ) для содания анимации }  
FAndImage := TBitMap.Create;  
FAndImage.LoadFromResourceName(hInstance, 'AND');  
  
FOrImage := TBitMap.Create;  
FOrImage.LoadFromResourceName(hInstance, 'OR');  
  
Left := 0;  
Top := 0;  
Height := FAndImage.Height;  
Width := FAndImage.Width;  
end;  
  
destructor TSprite.Destroy;  
begin  
FAndImage.Free;  
FOrImage.Free;  
inherited Destroy;  
end;  
  
  
procedure TMainForm.FormCreate(Sender: TObject);  
begin  
// Создание исходного фонового изображения  
BackGnd1 := TBitMap.Create;  
with BackGnd1 do  
begin  
LoadFromResourceName(hInstance, 'BACK');  
Parent := nil;  
SetBounds(0, 0, Width, Height);  
end;  
  
// Создание копии фонового изображения  
BackGnd2 := TBitMap.Create;  
BackGnd2.Assign(BackGnd1);  
  
// Создание изображения эльфа  
Sprite := TSprite.Create;  
  
// Инициализация переменных направления  
GoRight := true;  
GoDown := true;  
GoLeft := false;  
GoUp := false;  
  
{ Установка события приложения OnIdle равным значению 
MyIdleEvent, с которого начнется движение эльфа }  
Application.OnIdle := MyIdleEvent;  
// Установка высоты и ширины области клиента формы  
ClientWidth := BackGnd1.Width;  
ClientHeight := BackGnd1.Height;  
end;  
  
procedure TMainForm.FormDestroy(Sender: TObject);  
begin  
// Освобождение всех объектов, созданных в конструкторе  
формы FormCreate()  
BackGnd1.Free;  
BackGnd2.Free;  
Sprite.Free;  
end;  
  
procedure TMainForm.MyIdleEvent(Sender: TObject;  
var Done: Boolean);  
begin  
DrawSprite;  
{ Разрешение вызова события OnIdle даже при отсутствии 
сообщений в очереди сообщений приложения }  
Done := False;  
end;  
  
procedure TMainForm.DrawSprite;  
var  
OldBounds: TRect;  
begin  
  
// Сохранение границ эльфа в объекте OldBounds  
with OldBounds do  
begin  
Left := Sprite.Left;  
Top := Sprite.Top;  
Right := Sprite.Width;  
Bottom := Sprite.Height;  
end;  
  
{ Теперь изменяем границы эльфа, чтобы он двигался в одном 
направлении, или изменяем направление при 
соприкосновении с границами формы }  
with Sprite do  
begin  
if GoLeft then  
if Left > 0 then  
Left := Left - 1  
else begin  
GoLeft := false;  
GoRight := true;  
end;  
  
if GoDown then  
if (Top + Height) < self.ClientHeight then  
Top := Top + 1  
else begin  
GoDown := false;  
GoUp := true;  
end;  
  
if GoUp then  
if Top > 0 then  
Top := Top - 1  
else begin  
GoUp := false;  
GoDown := true;  
end;  
  
if GoRight then  
if (Left + Width) < self.ClientWidth then  
Left := Left + 1  
else begin  
GoRight := false;  
GoLeft := true;  
end;  
end;  
{ Стираем исходное изображение эльфа на фоне BackGnd2 
путем копирования прямоугольника из фона BackGnd1 }  
with OldBounds do  
BitBlt(BackGnd2.Canvas.Handle, Left, Top, Right, Bottom,  
BackGnd1.Canvas.Handle, Left, Top, SrcCopy);  
{ Теперь рисуем эльфа на "внеэкранном" растре, тем самым 
избавлясь от мерцания }  
with Sprite do  
begin  
{ Создадим черное пятно с силуэтом эльфа с помощью 
операции логического И, выполненной над растрами 
FAndImage и BackGnd2 }  
BitBlt(BackGnd2.Canvas.Handle, Left, Top, Width, Height,  
FAndImage.Canvas.Handle, 0, 0, SrcAnd);  
// Выполним заливку черного пятна исходными цветами эльфа  
BitBlt(BackGnd2.Canvas.Handle, Left, Top, Width, Height,  
FOrImage.Canvas.Handle, 0, 0, SrcPaint);  
end;  
{ Копируем эльфа в его новой позиции на канву формы. 
При этом используется прямоугольник, который немного 
больше, чем нужно для фигуры эльфа. Тем самым мы 
добиваемся эффективного стирания эльфа путем его 
перезаписи, после чего рисуем нового эльфа в новой 
позиции с помощью доного вызова функции BitBlt }  
with OldBounds do  
BitBlt(Canvas.Handle, Left-2, Top-2, Right+2, Bottom+2,  
BackGnd2.Canvas.Handle, Left-2, Top-2, SrcCopy);  
end;  
procedure TMainForm.FormPaint(Sender: TObject);  
begin  
// Рисуем фоновой изображение при закрашивании формы  
BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight,  
BackGnd1.Canvas.Handle, 0, 0, SrcCopy);  
end;  
  
end.  

Как это работает. Анимационный проект состоит из фонового изображения и нарисованного на нем эльфа в виде летающего блюдца, которое перемещается в пределах области клиента фона. Фон представлен растровым изображением разбросанных по небу звезд (рис 1).

Эльф составлен из двух растров размером 64x32. О них речь пойдет ниже, а пока рассмотрим, что происходит в программе. В приведенном модуле определяется класс TSprite, который содержит поля, предназначенные для хранения позиций эльфа на изображении фона, и два объекта типа TBitmap для хранения растровых изображений эльфа. Конструктор TSprite.Create создает оба экземпляра класса TBitmap и загружает их реальными растрами. Оба растровых изображения эльфа и фоновый растр содержатся в файле ресурсов, который привязывается к проекту путем включения в основной модуль следующей инструкции: { $R SPRITES.RES }.

После загрузки растра устанавливаются границы изображения эльфа. Деструктор TSprite.Destroy освобождает оба экземпляра растра. Главная форма содержит два объекта типа TBitmap, объект TSprite и индикаторы напрвлений, задающие линию движения эльфа. Кроме того, в главной форме определены два метода: MyIdleEvent(), служащий обработчиком событий Application.OnIdle, и DrawSprite(), предназначенный для рисования изображения эльфа.

Обработчик событий FormCreate() создает оба экземпляра класса TBitmap и загружает каждый одним и тем же растровым изображением (зачем - разберемся чуть ниже). Затем создается экземпляр класса TSprite, устанавливаются значения индикаторов направлений и обработчику событий Application.OnIdle назначается метод MyIdleEvent(). Наконец, обработчик событий формы FormCreate() изменяет размеры формы в соответствии с размерами фонового изображения.

Метод FormPaint() выполняет рисование на канве фона BackGnd1.

Метод FormDestroy() освобождает экземпляры классов TBitmap и TSprite.

Метод MyIdleEvent() вызывает метод DrawSprite(), который перемещает и рисует эльфа на существующем фоне.

Метод MyIdleEvent() вызывается, когда приложение находится в состоянии ожидания, т.е. когда пользователь не выполняет никаких действий, на которые приложению следовало бы отреагировать.

Метод DrawSprite() изменяет расположение эльфа на изображении фона. Для этого требуется выполнить немало инструкций - ведь сначала нужно стереть старое изображение эльфа, а затем нарисовать его на новом месте, сохраняя цвет фона вокруг реального изображения эльфа. Кроме того, метод DrawSprite() должен выполнить эти действия без мерцания. Для достижения поставленных целей процесс рисования выполняется на "внеэкранном" растре BackGnd2. Растры BackGnd2 и BackGnd1 являются точными копиями фонового изображения, однако BackGnd1 никогда не модифицируется (поэтому его можно назвать чистой копией фона). По завершении рисования модифицированная область растра BackGnd2 копируется на канву формы. Это позволяет за одно обращение к функции BitBlt() выполнить как стирание на канве формы, так и рисование эльфа в новой позиции. Какие же опреции выполняются с растром BackGnd2?

Во-первых, из BackGnd1 в BackGnd2 копируется прямоугольный участок, превышающий по размерам область, занимаемую самим эльфом. Тем самым гарантируется стирание изображения эльфа с растра BackGnd2. После этого растр FAndImage копируется в BackGnd2 на его новой позиции с помощью поразрядной опреции AND (логическое И). Это приводит к созданию черного пятна с силуэтом эльфа, но с сохранением цветов в области растра BackGnd2, окружающей черный силуэт. Растр FAndImage показан на (рис 2).

На рис 2 эльф представлен черными пикселами, а изображение вокруг эльфа состоит из белых пикселей. Черный цвет имеет значение, равное 0, а белый - 1. В табл. 1 и 2 приведены результаты выполнения опреции AND с белым и черным цветами.

Табл. 1 "Опреция AND с черным цветом"Фон Значение Цвет

BackGnd2 1001 Некоторый цвет
FAndImage 0000 Черный
Результат 1001 Черный
Табл. 2 "Операция AND с белым цветом"Фон Значение Цвет

BackGnd2 1001 Некоторый цвет
FAndImage 1111 Белый
Результат 1001 Некоторый цвет
Эти таблицы показывают, как выполнение операции логического И приводит к зачернению области, занимаемой эльфом на растре BackGnd2. В табл. 1 столбец "Значение" представляет цвет пискселя. Если пиксель на растре BackGnd2 содержит некоторый произвольный цвет, то объединение этого цвета с черным при использовании оператора AND заставит этот пиксель полностью почернеть. Аналогичная операция, выполненная над тем же цветом и абсолютно белым "коллегой" никак не отразится наисходном цвете, как видно в табл. 2. А поскольку цвет фона, на котором находится эльф в растре FAndImage, был белым, то пиксели на растре BackGnd2 копируются без изменения своих цветов. После копирования растра FAndImage в объект BackGnd2 растр FOrImage должен быть скопирован в то же самое место растра BackGnd2, чтобы заполнить черное пятно, созданное объединением растра FAndImage с реальными цветами эльфа. Растр FOrImage таже имеет прямоугольник, окружающий реальное изображение эльфа. И вновь мы сталкиваемся с задачей получения цветов эльфа для растра BackGnd2 и одновременным сохранением цветов этого растра в области, окружающей эльфа. Это достигается объединением растров FOrImage и BackGnd2 с использованием оператора OR (лигическое ИЛИ).

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

Табл. 3 "Операция OR с черным цветом"Фон Значение Цвет

BackGnd2 1001 Некоторый цвет
FOrImage 0000 Черный
Результат 1001 Некоторый цвет
Напомним, что все рисование выполняется на "внеэкранном" растре. По завершении рисования достаточно только одного обращения к функции BitBlt(), чтобы стереть и скопировать изображение эльфа. В описанном способе создания анимации нет ничего необычного. Вы можете сами расширить функциональные возможности класса, связанные с переме.

Добавлено: 07 Августа 2018 08:16:36 Добавил: Андрей Ковальчук

Создание собственных компонентов

Тебе предстоит познакомится с технологией создания собственных компонентов. Я расскажу, как можно создать компонент Delphi (не путай с компонентами ActiveX). В качестве примера я выбрал достаточно простой, но напичканый математикой пример - часы. Наши часы смогут работать как аналоговые и числовые. По этим часам будет Москва сверятся :).

Компоненты - это самая удобная вещь. С самого появления языков программирования, все программеры стремятся добится многократности использования кода. Для этого мы перешли к процедурному программирования, затем к объектному и сейчас нам предлагают перейти к компонентному программированию. То, что предлагает нам MS - использовать компоненты ActiveX я назову настоящей лажей. Эти компоненты требую гемороя для регистрации их на машине клиента, слежка за версиями и многое другое. Borland предложила свои компоненты. По умолчанию они встраиваются прямо в запускной файл и не требуют никакой регистрации и великолепно работают.

Я думаю, что я достаточно расхвалил компоненты Delphi, пора бы и написать один для примерчика.

Для создания нового компонента выбери меню Component-> New Component.

Давай расмотрим каждое окошечко в отдельности:

Ancestor type - Тип предка. Это имя объекта, от которого мы порадим наш объект. Это даст нашему объекту все возможности его предка, плюс мы добавим свои. Для часиков нам понадобится TGraphicControl.
Class Name - Имя нашего будущего компонента. Я его назвал TGraphicClock.
Palette Page - Имя палитры компонентов, куда будет помещён наш компонент после инсталляции. Я оставил значение по умолчанию "Samples". Но ты можешь поместить его даже на закладку "Standart".
Unit file name - имя и путь к модулю, где будет располагатся исходный код компонента. Хотябы посмотри под каким именем сохранят твой компонент и где.
Search path - Сюда можно даже не заглядывать.
Жмём "ОК" (именно "ОК", а не Install) и получаем созданный Дульфой код:


unit GraphicClock;  
  
interface  
  
uses  
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;  
  
type  
  TGraphicClock = class(TGraphicControl)  
  private  
    { Private declarations }  
  protected  
    { Protected declarations }  
  public  
    { Public declarations }  
  published  
    { Published declarations }  
  end;  
  
procedure Register;  
  
implementation  
  
procedure Register;  
begin  
  RegisterComponents('Samples', [TGraphicClock]);  
end;  
  
end.  

В принципе простейший компонент готов и его можно инсталировать в Дельфу. Но этот компонент ничего не умеет и он пока является полным аналогом своего предка TGraphicControl. Чтобы он стал отличатся, сейчас мы добавим ему разные свойства.

Начнём написание нашего компонента с конструктора и деструктора. конструктор - это простая процедура, которая автоматически вызывается при создании компонента. Деструктор - тоже процедура, только она автоматически вызывается при уничтожении компонента. В конструкторе мы проинициализируем все наши переменные, а в деструкторе уничтожим.

Итак, напиши в разделе public:


constructor Create(AOwner: TComponent); override;  

Теперь нажми сочетание клавишь CTRL+SHIFT+C. Дельфи сам создаст заготовку для конструктора:


constructor TGraphicClock.Create(AOwner: TComponent);  
begin  
  inherited;  
end;  

Поправим её до вот такого вида:


constructor TCDClock.Create(AOwner: TComponent);  
begin  
//Вызываем конструктор предка  
 inherited Create(AOwner);  
  
//Устанавливаем значения ширины и высоты по умолчанию  
 Width := 50;  
 Height := 50;  
  
//Устанавливаем переменную ShowSecondArrow в true.  
//Она будет у нас отвечать за показ секундной стрелки  
 ShowSecondArrow := true;  
  
//Инициализируем остальные переменные  
 PrevTime := 0;  
 CHourDiff := 0;  
 CMinDiff := 0;  
  
//Инициализируем растры TBitmap, в которых будут хранится  
//фон и сам рисунок часов.  
 FBGBitmap:= TBitmap.Create;  
 FFont:=TFont.Create;;  
  
 FBitmap:= TBitmap.Create;  
 FBitmap.Width := Width;  
 FBitmap.Height := Height;  
  
 //Выставляем формат времени  
 DateFormat:='tt';  
  
 //Запускаем таймер  
 Ticker := TTimer.Create( Self);  
 //Интервал работы таймера - одна секунда  
 Ticker.Interval := 1000;  
 //По событию OnTimer будет вызыватсья процедура TickerCall  
 Ticker.OnTimer := TickerCall;  
 //Включаем таймер  
 Ticker.Enabled := true;  
  
//Устанавливаем цвета поумолчанию  
 FFaceColor := clBtnFace;  
 FHourArrowColor := clActiveCaption;  
 FMinArrowColor := clActiveCaption;  
 FSecArrowColor := clActiveCaption;  
end;  

Ключевое слово inherited вызывает конструктор предка (в нашем случае TGraphicClock). В остальном, я надеюсь, что с конструктором всё ясно.

Теперь создадим деструктор. Для этого также опишем его в разделе public:


public  
  { Public declarations }  
  constructor Create(AOwner: TComponent); override;  
  destructor Destroy; override;  

Кстати, ключевое слово override; после имени этих процедур говорит о том, что мы хотим переписать уже существующую у предка функцию с таким именем. Теперь жмём Ctrl+Shift+C и получаем заготовку для деструктора и поправляем её до вида :


destructor TGraphicClock.Destroy;  
begin  
 Ticker.Free;  
 FBitmap.Free;  
 FBGBitmap.Free;  
 inherited Destroy;  
end;  

Заметь, что в конструкторе я вызывал предка в самом начале inherited, а в деструкторе в самом конце. В конструкторе сначала нужно, чтобы проинициализировался предок (он проинициализирует необходимые ссылки), а потом можно инициализировать свои вещи. Если в деструкторе мы сначала вызовем предка, то последующая работа с компонентом уже будет невозможна, потому что предок уничтожит все ссылки, поэтому я ставлю этот вызов в конце.

Теперь опишем все необходимые нам переменные в разделе private:


private  
  //Для часов обязательно понадобится таймер  
  Ticker: TTimer;  
  
  //Картинки часов и фона       
  FBitmap, FBGBitmap: TBitmap;  
  
  /События  
  FOnSecond, FOnMinute, FOnHour: TNotifyEvent;  
  
  //Центральная точка  
  CenterPoint: TPoint;  
  //Радиус  
  Radius: integer;  
  
  //Остальные параметры, которые мы рассмотрим в процессе.  
  LapStepW: integer;  
  PrevTime: TDateTime;  
  ShowSecondArrow: boolean;  
  FHourArrowColor,FMinArrowColor, FSecArrowColor: TColor;  
  FFaceColor: TColor;  
  CHourDiff, CMinDiff: integer;  
  FClockStyle:TClockStyle;  
  FDateFormat: String;  
  FFont: TFont;  

Теперь в разделе private опицем процедуру TickerCall. Мы её уже использовали в конструкторе. Она у нас вызывается по событию от таймера:


protected  
  { Protected declarations }  
  procedure TickerCall(Sender: TObject);  

Жмём CTRL+SHIAT+C и модифицируем созданную функцию:


procedure TCDClock.TickerCall(Sender: TObject);  
var  
 H,M,S,Hp,Mp,Sp: word;  
begin  
 //Если компонент создан в дезайнере, то выход  
 if csDesigning in ComponentState then exit;  
 //Иначе это уже запущеная программа  
  
 //Получить время  
 DecodeCTime( Time, H, M, S);  
 //Получить предыдущее время.  
 DecodeCTime( PrevTime, Hp, Mp, Sp);  
  
 //Сгенерировать событие OnSecond  
 if Assigned( FOnSecond) then FOnSecond(Self);  
 //Сгенерировать событие  OnMinute  
 if Assigned( FOnMinute) AND (Mp < M) then FOnMinute(Self);  
 //Сгенерировать событие  OnHour  
 if Assigned( FOnHour) AND (Hp < H) then FOnHour(Self);  
  
 //Сохранить текущее время в PrevTime  
 PrevTime := Time;  
  
 if ( NOT ShowSecondArrow) AND (Sp <= S) then exit;  
  
 //Прорисовать часы.  
 DrawArrows;  
end;  

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

У нас уже объявлено три события:


FOnSecond, FOnMinute, FOnHour: TNotifyEvent;  

Все они появятся на закладке Events в окне Object Inspector, когда ты поставишь компонент на форму. Чтобы приложения могло поймать эти события, мы объявили переменные типа TNotifyEvent и генерируем эти события (с помощью конструкции типа FOnSecond(Self) для события OnSecond), когда изменилась секунда, изменилась минута или изменился час.

Помимо этого, в разделе published мыдолжны описать свойство OnSecond:


property OnSecond: TNotifyEvent read FOnSecond write FOnSecond;  
property OnMinute: TNotifyEvent read FOnMinute write FOnMinute;  
property OnHour: TNotifyEvent read FOnHour write FOnHour;  

Теперь наш компонент сможет генерировать события.

С событиями вроде всё ясно (если нет, то посмотри на исходник в конце статьи). Теперь переходим к свойствам. В разделе published мы можем создавать свойства, которые будут отображатся в Object Inspector при выделении наших часиков. Все свойства, которые есть у предка нужно просто описать


published  
  property Align;  
  property Enabled;  
  property ParentShowHint;  
  property ShowHint;  
  property Visible;  

Слово property говорит о том, что мы описываем свойство. Для них не нужны процедуры или функции, потому что эти свойства уже есть у предка. Нам надо только описать их и всё. Я описал только маленькую часть из доступных у TGraphicControl функций. Ты можешь добавить любые из доступных. Чтобы узнать, какие функции можно добавлять, открой помощь (меню Help->Delphi Help) и найди там объект TGraphicControl. Щёлкни по нему дважды и в появившейся справке выбери пункт Properties (вверху окна) (рис 2). Появится окно с перечнем всех свойств. Ты можешь добавить любое из них. Например, чтобы добавить свойство Action нужно написать в разделе published:


published  
  property Action;  

Чтобы добавить своё свойство, нужно немного попатеть. Например. Добавим возможность, чтобы пользователь мог менять картинку фона. Для этого описываем в разделе published свойство BGBitmap:


//свойство Имя     :Тип     читать из FBGBitmap записывать с помощью SetBGBitmap  
  property BGBitmap:TBitmap read FBGBitmap      write SetBGBitmap;  

Коментарий поможет тебе разобраться в написанном здесь. Итак, мы объявили свойство BGBitmap типа ТBitmap. Для чтения используется простая переменная FBGBitmap (можно использовать и функцию, но нет смысла, потому что можно прямо читать из переменной), для записи используется процедура SetBGBitmap. Процедура выглядит так:


procedure TCDClock.SetBGBitmap(Value: TBitmap);  
begin  
 FBGBitmap.Assign(Value);  
 invalidate;  
end;  

Теперь ты можешь изменять фон простой операцией GraphicClock1.BGBitmap:=bitmap.

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


//свойство Имя       :Тип         Это нам известно                 Значение по умолчанию  
  property ClockStyle:TClockStyle read FClockStyle write SetStyleStyle default scAnalog;  

Мы объявляем свойство ClockStyle типа TClockStyle. Тип TClockStyle мы должны описать в самом начале, до описания нашего объекта TGraphicClock:


type  
  TClockStyle = (scAnalog, scDigital);  
  
  TGraphicClock = class(TGraphicControl)  
  private  
    Ticker: TTimer;  
Строка TClockStyle = (scAnalog, scDigital) - объявляет список переменных, которые и будут выпадать по выбору свойства.

Всё остально происходит так же, за исключением нового слова default Которое устанавливает значение по умолчанию - scAnalog.

Вот и всё, что я хотел тебе рассказать.

Чтобы установить компонент в системе нужно щёлкнуть меню Component->Install Component. Перед тобой появится окно.

В строке Unit file name нужно указать полный путь к файлу. Для облегчения выбора используй кнопку Browse

справа. Перед тобой появится запрос на компиляцию пакета. Соглашайся.

В этом окне ты можешь откомпелировать пакет с помощью кнопки Compile и установить в Delphi с помощью Install .

Вот и всё. Наслаждайся новым компонентом в твоей палитре.

На сегодня хватит. Статья и так получилась достаточно большая. Увидимся в следующий раз.

Напоследок у меня есть небольшая просьба. Пиши мне, о чём бы ты хотел прочитать на моих страницах. Некоторые разделы я неуспеваю писать, а некоторые я просто уже не знаю, о чём тебе рассказать. Ты просто пиши мне, а там разберёмся.

Добавлено: 07 Августа 2018 08:15:23 Добавил: Андрей Ковальчук

Создание хранителя экрана (ScreenSaver)

Главное о чем стоит упомянуть это, что ваш хранитель экрана будет работать в фоновом режиме и он не должен мешать работе других запущенных программ. Поэтому сам хранитель должен быть как можно меньшего объема. Для уменьшения объема файла в описанной ниже программе не используется визуальные компоненты Delphi, включение хотя бы одного из них приведет к увеличению размера файла свыше 200кб, а так, описанная ниже программа, имеет размер всего 20Кб!

Технически, хранитель экрана является нормальным EXE файлом (с расширением .SCR), который управляется через командные параметры строки. Например, если пользователь хочет изменить параметры вашего хранителя, Windows выполняет его с параметром "-c" в командной строке. Поэтому начать создание вашего хранителя экрана следует с создания примерно следующей функции:


procedure RunScreenSaver;  
var S : String;  
begin  
  S := ParamStr(1);  
  if (Length(S) > 1) then begin  
    Delete(S,1,1); { delete first char - usally "/" or "-" }  
    S[1] := UpCase(S[1]);  
  end;  
  LoadSettings; { load settings from registry }  
  if (S = 'C') then RunSettings  
  else If (S = 'P') then RunPreview  
  else If (S = 'A') then RunSetPassword  
  else RunFullScreen;  
end;  

Поскольку нам нужно создавать небольшое окно предварительного просмотра и полноэкранное окно, их лучше объединить используя единственный класс окна. Следуя правилам хорошего тона, нам также нужно использовать многочисленные нити. Дело в том, что, во-первых, хранитель не должен переставать работать даже если что-то "тяжелое" случилось, и во-вторых, нам не нужно использовать таймер.

Процедура для запуска хранителя на полном экране приблизительно такова:


procedure RunFullScreen;  
var  
  R : TRect;  
  Msg : TMsg;  
  Dummy : Integer;  
  Foreground : hWnd;  
begin  
  IsPreview := False; MoveCounter := 3;   
  Foreground := GetForegroundWindow;  
  while (ShowCursor(False) > 0) do ;  
  GetWindowRect(GetDesktopWindow,R);  
  CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,0);  
  CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);  
  SystemParametersInfo(spi_ScreenSaverRunning,1,@Dummy,0);  
  while GetMessage(Msg,0,0,0) do  
    begin  
    TranslateMessage(Msg);  
    DispatchMessage(Msg);  
  end;  
  SystemParametersInfo(spi_ScreenSaverRunning,0,@Dummy,0);  
  ShowCursor(True);  
  SetForegroundWindow(Foreground);  
end;  

Во-первых, мы проинициализировали некоторые глобальные переменные (описанные далее), затем прячем курсор мыши и создаем окно хранителя экрана. Имейте в виду, что важно уведомлять Windows, что это - хранителя экрана через SystemParametersInfo (это выводит из строя Ctrl-Alt-Del чтобы нельзя было вернуться в Windows не введя пароль). Создание окна хранителя:


function CreateScreenSaverWindow(Width,Height : Integer; ParentWindow : hWnd) : hWnd;  
var WC : TWndClass;  
begin  
  with WC do  
    begin  
    Style := cs_ParentDC;  
    lpfnWndProc := @PreviewWndProc;  
    cbClsExtra := 0; cbWndExtra := 0; hIcon := 0; hCursor := 0;  
    hbrBackground := 0; lpszMenuName := nil;   
    lpszClassName := 'MyDelphiScreenSaverClass';  
    hInstance := System.hInstance;  
  end;  
  RegisterClass(WC);  
  if (ParentWindow 0) then  
    Result := CreateWindow('MyDelphiScreenSaverClass','MySaver'ws_Child Or ws_Visible or  
ws_Disabled,0,0,Width,Height,ParentWindow,0,hInstance,nil)  
  else  
    begin  
    Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',ws_Visible or ws_Popup,0,0,Width,Height,  
0,0,hInstance,nil);SetWindowPos(Result,hwnd_TopMost,0,0,0,0,swp_NoMove or swp_NoSize or swp_NoRedraw);  
  end;  
  PreviewWindow := Result;  
end;  

Теперь окна созданы используя вызовы API. Я удалил проверку ошибки, но обычно все проходит хорошо, особенно в этом типе приложения.

Теперь Вы можете погадать, как мы получим handle родительского окна предварительного просмотра? В действительности, это совсем просто: Windows просто передает handle в командной строке, когда это нужно. Таким образом:


procedure RunPreview;  
var  
  R : TRect;  
  PreviewWindow : hWnd;  
  Msg : TMsg;  
  Dummy : Integer;  
begin  
  IsPreview := True;  
  PreviewWindow := StrToInt(ParamStr(2));  
  GetWindowRect(PreviewWindow,R);  
  CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,PreviewWindow);  
  CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);  
  while GetMessage(Msg,0,0,0) do  
    begin  
    TranslateMessage(Msg);  
        DispatchMessage(Msg);  
  end;  
end;  

Как Вы видите, window handle является вторым параметром (после "-p").

Чтобы "выполнять" хранителя экрана - нам нужна нить. Это создается с вышеуказанным CreateThread. Процедура нити выглядит примерно так:


function PreviewThreadProc(Data : Integer) : Integer; StdCall;  
var R : TRect;  
begin  
  Result := 0; Randomize;  
  GetWindowRect(PreviewWindow,R);  
  MaxX := R.Right-R.Left; MaxY := R.Bottom-R.Top;  
  ShowWindow(PreviewWindow,sw_Show); UpdateWindow(PreviewWindow);  
  repeat  
    InvalidateRect(PreviewWindow,nil,False);  
    Sleep(30);  
  until QuitSaver;  
  PostMessage(PreviewWindow,wm_Destroy,0,0);  
end;  

Нить просто заставляет обновляться изображения в нашем окне, спит на некоторое время, и обновляет изображения снова. А Windows будет посылать сообщение WM_PAINT на наше окно (не в нить!). Для того, чтобы оперировать этим сообщением, нам нужна процедура:


function PreviewWndProc(Window : hWnd; Msg,WParam,LParam : Integer): Integer; StdCall;  
begin  
  Result := 0;  
  case Msg of  
    wm_NCCreate : Result := 1;  
    wm_Destroy : PostQuitMessage(0);  
    wm_Paint : DrawSingleBox; { paint something }  
    wm_KeyDown : QuitSaver := AskPassword;  
    wm_LButtonDown, wm_MButtonDown, wm_RButtonDown, wm_MouseMove :   
    begin  
      if (Not IsPreview) then  
            begin  
        Dec(MoveCounter);  
        if (MoveCounter <= 0) then QuitSaver := AskPassword;  
      end;  
    end;  
  else  
      Result := DefWindowProc(Window,Msg,WParam,LParam);  
  end;  
end;  

Если мышь перемещается, кнопка нажата, мы спрашиваем у пользователя пароль:


function AskPassword : Boolean;  
var  
  Key : hKey;  
  D1,D2 : Integer; { two dummies }  
  Value : Integer;  
  Lib : THandle;  
  F : TVSSPFunc;  
begin  
  Result := True;  
  if (RegOpenKeyEx(hKey_Current_User,'Control Panel\Desktop',0,Key_Read,Key) = Error_Success) then  
  begin  
    D2 := SizeOf(Value);  
    if (RegQueryValueEx(Key,'ScreenSaveUsePassword',nil,@D1,@Value,@D2) = Error_Success) then  
    begin  
      if (Value 0) then  
            begin  
        Lib := LoadLibrary('PASSWORD.CPL');  
        if (Lib > 32) then  
                begin  
          @F := GetProcAddress(Lib,'VerifyScreenSavePwd');  
          ShowCursor(True);  
          if (@F nil) then Result := F(PreviewWindow);  
          ShowCursor(False);  
          MoveCounter := 3; { reset again if password was wrong }  
          FreeLibrary(Lib);  
        end;  
      end;  
    end;  
  RegCloseKey(Key);  
  end;  
End;  

Это также демонстрирует использование Registry на уровне API. Также имейте в виду как мы динамически загружаем функции пароля, используюя LoadLibrary. Запомните тип функции? TVSSFunc ОПРЕДЕЛЕН как:


type  
  TVSSPFunc = Function(Parent : hWnd) : Bool; StdCall;  

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


procedure RunSettings;  
var Result : Integer;  
begin  
  Result := DialogBox(hInstance,'SaverSettingsDlg',0,@SettingsDlgProc);  
  if (Result = idOK) then SaveSettings;  
end;  

Трудная часть -это создать диалоговый сценарий (запомните: мы не используем здесь Delphi-формы!). Я сделал это, используя 16-битовую Resource Workshop (остался еще от Turbo Pascal для Windows). Я сохранил файл как сценарий (текст), и скомпилированный это с BRCC32:


SaverSettingsDlg DIALOG 70, 130, 166, 75  
STYLE WS_POPUP | WS_DLGFRAME | WS_SYSMENU  
CAPTION "Settings for Boxes"  
FONT 8, "MS Sans Serif"  
BEGIN  
DEFPUSHBUTTON "OK", 5, 115, 6, 46, 16  
PUSHBUTTON "Cancel", 6, 115, 28, 46, 16  
CTEXT "Box &Color:", 3, 2, 30, 39, 9  
COMBOBOX 4, 4, 40, 104, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS  
CTEXT "Box &Type:", 1, 4, 3, 36, 9  
COMBOBOX 2, 5, 12, 103, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS  
LTEXT "Boxes Screen Saver for Win32 Copyright (c) 1996 Jani  
Jдrvinen.", 7, 4, 57, 103, 16,  
WS_CHILD | WS_VISIBLE | WS_GROUP  
END  

Почти также легко сделать диалоговое меню:


function SettingsDlgProc(Window : hWnd; Msg,WParam,LParam : Integer): Integer; stdcall;  
var S : String;  
begin  
  Result := 0;  
  case Msg of  
    wm_InitDialog :  
        begin  
      { initialize the dialog box }  
      Result := 0;  
    end;  
    wm_Command :  
        begin  
      if (LoWord(WParam) = 5) then EndDialog(Window,idOK)  
      else if (LoWord(WParam) = 6) then EndDialog(Window,idCancel);  
    end;  
    wm_Close : DestroyWindow(Window);  
    wm_Destroy : PostQuitMessage(0);  
  else  
      Result := 0;  
  end;  

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


procedure SaveSettings;  
var  
  Key : hKey;  
  Dummy : Integer;  
begin  
  if  
(RegCreateKeyEx(hKey_Current_User,'Software\SilverStream\SSBoxes',0,nil,  
  
Reg_Option_Non_Volatile,Key_All_Access,nil,Key,@Dummy)  
= Error_Success) then  
    begin  
    RegSetValueEx(Key,'RoundedRectangles',0,Reg_Binary,@RoundedRectangles,SizeOf(Boolean));  
    RegSetValueEx(Key,'SolidColors',0,Reg_Binary, @SolidColors,SizeOf(Boolean));  
    RegCloseKey(Key);  
  end;  
end;  

Загружаем параметры так:


procedure LoadSettings;  
var  
  Key : hKey;  
  D1,D2 : Integer; { two dummies }  
  Value : Boolean;  
begin  
  if (RegOpenKeyEx(hKey_Current_User,'Software\SilverStream\SSBoxes',0,Key_Read,Key) = Error_Success) then  
    begin  
    D2 := SizeOf(Value);  
    if (RegQueryValueEx(Key,'RoundedRectangles',nil,@D1,@Value, @D2) = Error_Success) then  
      RoundedRectangles := Value;  
    if (RegQueryValueEx(Key,'SolidColors',nil,@D1,@Value,@D2) = Error_Success) then  
      SolidColors := Value;  
    RegCloseKey(Key);  
  end;  
end;  

Легко? Нам также нужно позволить пользователю, установить пароль. Я честно не знаю почему это оставлено разработчику приложений! Тем не менее:


procedure RunSetPassword;  
var  
  Lib : THandle;  
  F : TPCPAFunc;  
begin  
  Lib := LoadLibrary('MPR.DLL');  
  if (Lib > 32) then  
    begin  
    @F := GetProcAddress(Lib,'PwdChangePasswordA');  
    if (@F nil) then F('SCRSAVE',StrToInt(ParamStr(2)),0,0);  
    FreeLibrary(Lib);  
  end;  
end;  

Мы динамически загружаем (недокументированную) библиотеку MPR.DLL, которая имеет функцию, чтобы установить пароль хранителя экрана, так что нам не нужно беспокоиться об этом. TPCPAFund определён как:


type  
  TPCPAFunc = Function(A : PChar; Parent : hWnd; B,C : Integer) : Integer; StdCall;  

Не спрашивайте меня что за параметры B и C ! :-)

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


procedure DrawSingleBox;  
var  
  PaintDC : hDC;  
  Info : TPaintStruct;  
  OldBrush : hBrush;  
  X,Y : Integer;  
  Color : LongInt;  
begin  
  PaintDC := BeginPaint(PreviewWindow,Info);  
  X := Random(MaxX); Y := Random(MaxY);  
  if SolidColors then  
    Color := GetNearestColor(PaintDC,RGB(Random(255),Random(255),Random(255)))  
  else  
      Color := RGB(Random(255),Random(255),Random(255));  
  OldBrush := SelectObject(PaintDC,CreateSolidBrush(Color));  
  if RoundedRectangles then  
    RoundRect(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y),20,20)  
  else  
      Rectangle(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y));  
  DeleteObject(SelectObject(PaintDC,OldBrush));  
  EndPaint(PreviewWindow,Info);  
end;  

И последнее — глобальные переменные:


var  
  IsPreview : Boolean;  
  MoveCounter : Integer;  
  QuitSaver : Boolean;  
  PreviewWindow : hWnd;  
  MaxX,MaxY : Integer;  
  RoundedRectangles : Boolean;  
  SolidColors : Boolean;  

Затем исходная программа проекта (.dpr). Красива, а!?


program MySaverIsGreat;  
   
uses Windows, messages, Utility; { defines all routines }  
   
{$R SETTINGS.RES}  
   
begin  
  RunScreenSaver;   
end.  

Ох, чуть не забыл! Если, Вы используете SysUtils в вашем проекте (например фуекцию StrToInt) вы получите EXE-файл больше чем обещанный в 20K :-) Если Вы хотите все же иметь 20K, надо как-то обойтись без SysUtils, например самому написать собственную StrToInt процедуру.

Если все же очень трудно обойтись без использования Delphi-форм, то можно поступить как в случае с вводом пароля: форму изменения параметров хранителя сохранить в виде DLL и динамически ее загружать при необходимости. Т.о. будет маленький и шустрый файл самого хранителя экрана и довеска DLL для конфигурирования и прочего (там объем и скорость уже не критичны).

Добавлено: 07 Августа 2018 08:13:19 Добавил: Андрей Ковальчук

Способы сохранения и загрузки параметров программного обеспечения

В этой статье речь пойдет о способах сохранения и загрузки параметров программного обеспечения. Из своего личного опыта я могу твердо сказать, что это не так просто, как кажется многим. Как Вы уже успели заметить, крупные программные продукты используют для хранения своих параметров исключительно системный реестр. Напротив, разработчики программного обеспечения, относящие его к Freeware, предпочитают конфигурационные файлы с расширением “INI” (далее “ini-файлы”). Почему же дело обстоит именно так? Мы рассмотрим два этих способа более подробно, а так же поговорим о внедрении определенных средств защиты ini-файлов.

Системный реестр – один из самых надежных, но отнюдь не самый безопасный способов хранения параметров. Данные в нем располагаются в виде иерархической структуры, что облегчает поиск нужного раздела, но тем самым увеличивает риск удаления данных. Угрозой потери данных, находящихся в реестре, кроме неосторожных действий самих пользователей, могут являться сбои в операционной системе Microsoft Windows. Но это уже другая история.

Для работы с системным реестром в Borland Delphi предусмотрен модуль Registry, который содержит класс TRegistry.


Uses Registry;  
…  
…  
Var  
  R: TRegistry;  
Begin  
  R := Tregistry.Create;  
  …  
  …  
  …  
  R.Free;  
End;  

Рассмотрим принципы сохранения и загрузки данных, используя системный реестр, на небольшом примере, который будет содержать две процедуры GetCaption и SaveCaption.


procedure GetCaption;  
var  
  R: TRegistry;  
begin  
  R := TRegistry.Create;  
  R.RootKey := HKEY_LOCAL_MACHINE;  
  { 
    Открытие ключа. Параметр True означает, 
    что при отсутствии ключа он автоматически создается 
  }  
  R.OpenKey('Software\Test', True)  
  {Записываем параметр}  
  R.WriteString('FormCaption', Form1.Caption);  
  {Закрываем ключ}  
  R.CloseKey;  
  R.Free;  
end;  
  
procedure SaveCaption;  
var  
  R: TRegistry;  
begin  
  R := TRegistry.Create;  
  R.RootKey := HKEY_LOCAL_MACHINE;  
  R.OpenKey('Software\Test', True)  
  { 
    Устанавливаем заголовок формы, используя 
    ранее сохраненную строчку 
  }  
  Form1.Caption := R.ReadString('FormCaption');  
  R.CloseKey;  
  R.Free;  
end;  

Процедура SaveCaption сохраняет заголовок формы, а процедура GetCaption загружает из реестра ранее сохраненную строку, и устанавливает ее в качестве заголовка.

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

Стоит сказать еще о двух процедурах модуля Registry: GetKeyNames и GetValueNames. Они позволяют сканировать реестр, как обычные каталоги. При открытии ключа вы указываете начальный путь поиска, а далее процедура GetKeyNames создает список типа TStrings и записывает в него имена всех найденных ключей, а процедура GetValueNames составляет список из имен параметров, находящихся в заданном ключе.

До появления 32-х разрядных операционных систем, для хранения параметров программы использовали исключительно конфигурационные файлы с расширением “INI” (далее ini-файлы). Но вскоре, ini-файлы были забыты, и на смену им пришел системный реестр. Но до сих пор встречаются программы, которые активно используют такой способ хранения параметров. В чем же его преимущества? Прежде всего в стабильности. В отличие от системного реестра, при сбоях в операционной системе с ini-файлом ничего не случается, если только он не находится в системном каталоге. Стоит помнить, что ini-файл должен находиться в одном каталоге с программой. Кроме стабильности, важным преимуществом ini-файлов является мобильность программного кода, в чем вы можете убедиться, посмотрев пример, приведенный ниже. Что же касается недостатков, то это простота удаления. Ini-файл – это обычный файл, который можно случайно удалить.

Для работы с ini-файлами в Borland Delphi предусмотрен модуль IniFiles.


Uses IniFiles;  
…  
…  
…  
Var  
  IniFile: TiniFile;  
Begin  
  IniFile := TiniFile.Create(‘имя файла’);  
  …  
  …  
  …  
  IniFile.Free;  
End;  

Принципы работы Ini-файлов и системного реестра схожи между собой. Изменим предыдущую программу, которая сохраняла и изменяла заголовок формы, используя системный реестр.


procedure SaveCaption;  
var  
  IniFile: TIniFile;  
begin  
  IniFile := TIniFile.Create(ExtractFilePath(Application.Exename) + 'Test.ini');  
  IniFile.WriteString('MainOptions', 'FormCaption', Form1.Caption);  
  IniFile.Free;  
end;  
  
procedure GetCaption;  
var  
  IniFile: TIniFile;  
begin  
  IniFile := TIniFile.Create(ExtractFilePath(Application.Exename) + 'Test.ini');  
  Form1.Caption := IniFile.ReadString('MainOptions', 'FormCaption', '');  
  IniFile.Free;  
end;  

Как видите, по сравнению с предыдущей программой, наблюдается уменьшение программного кода. Да и ошибок при работе с ini-файлами возникает так же намного меньше, чем с системным реестром.

А теперь, поговорим о средствах защиты. Операционная система предоставляет возможность закрытия доступа к определенным файлам. Но, к сожалению, закрытие доступа длится только во время работы программы. После того, как программа будет закрыта, доступ будет полностью открыт. Например, можно ограничить доступ к ini-файлу. Для реализации данной возможности, среди множества функций WinAPI существует функция OpenFile. Давайте попробуем написать программу, которая закрывала бы доступ к ini-файлу.


 var  
  Form1: TForm1;  
  hIniLockedFile: Cardinal;  
  OfStruct      : _OfStruct;  
implementation  
 {$R *.dfm}  
procedure SaveCaption;  
var  
  IniFile: TIniFile;  
begin  
  {Отключаем защиту файла}  
  CloseHandle(hIniLockedFile);  
  {Резервное время для оключения}  
  Sleep(1000);  
  IniFile := TIniFile.Create(ExtractFilePath(Application.Exename) + 'Test.ini');  
  IniFile.WriteString('MainOptions', 'FormCaption', Form1.Caption);  
  IniFile.Free;  
  {После сохранения, заново ставим защиту}  
  hIniLockedFile := OpenFile(PChar(ExtractFileDir(Application.Exename) + 'Test.ini'), OfStruct, OF_Share_Exclusive);  
end;  
  
procedure GetCaption;  
var  
  IniFile: TIniFile;  
begin  
  IniFile := TIniFile.Create(ExtractFilePath(Application.Exename) + 'Test.ini');  
  Form1.Caption := IniFile.ReadString('MainOptions', 'FormCaption', '');  
  IniFile.Free;  
  {Устанавливаем защиту}  
  hIniLockedFile := OpenFile(PChar(ExtractFileDir(Application.Exename) + 'Test.ini'), OfStruct, OF_Share_Exclusive);  
end;  

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

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

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

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

Я написал две простейшие процедуры кодирования и декодирования текста. На их примере мы и рассмотрим работу нашей программы.


 var  
  Form1: TForm1;  
  hIniLockedFile: Cardinal;  
  OfStruct      : _OfStruct;  
  
const  
  csCryptFirst = 20;  
  csCryptSecond = 230;  
  csCryptHeader = 'Crypted';  
  
type  
  ECryptError = class(Exception);  
  
implementation  
  
{$R *.dfm}  
  
function CryptString(Str:String):String;  
var  
  I    : Integer;  
  Clen : Integer;  
begin  
  clen := Length(csCryptHeader);  
  SetLength(Result, Length(Str)+clen);  
  Move(csCryptHeader[1], Result[1], clen);  
  For i := 1 to Length(Str) do  
   begin  
    if i mod 2 = 0 then  
     Result[i+clen] := Chr(Ord(Str[i]) xor csCryptFirst)  
    else  
     Result[i+clen] := Chr(Ord(Str[i]) xor csCryptSecond);  
   end;  
end;  
  
function UnCryptString(Str:String):String;  
var  
  I    : Integer;  
  Clen : Integer;  
begin  
  Clen := Length(csCryptHeader);  
  SetLength(Result, Length(Str)-Clen);  
  If Copy(Str, 1, clen) <> csCryptHeader then  
   raise ECryptError.Create('Файл поврежден!');  
  For i := 1 to Length(Str)-clen do  
   begin  
    if (i) mod 2 = 0 then  
     Result[i] := Chr(Ord(Str[i+clen]) xor csCryptFirst)  
    else  
     Result[i] := Chr(Ord(Str[i+clen]) xor csCryptSecond);  
   end;  
end;  
  
Procedure CryptIniFile;  
var  
  S: TStringList;  
  I: Integer;  
begin  
  S := TStringList.Create;  
  S.LoadFromFile(ExtractFileDir(Application.Exename) + 'Test.ini');  
  For I := 0 to S.Count - 1 do  
    S.Strings[I] := CryptString(S.Strings[I]);  
  S.SaveToFile(ExtractFileDir(Application.Exename) + 'Test.ini');  
end;  
  
Procedure DecryptIniFile;  
var  
  S: TStringList;  
  I: Integer;  
begin  
  if not FileExists(ExtractFileDir(Application.Exename) + 'Test.ini') then Exit;  
  S := TStringList.Create;  
  S.LoadFromFile(ExtractFileDir(Application.Exename) + 'Test.ini');  
  For I := 0 to S.Count - 1 do  
    S.Strings[I] := UnCryptString(S.Strings[I]);  
  S.SaveToFile(ExtractFileDir(Application.Exename) + 'Test.ini');  
end;  
  
procedure SaveCaption;  
var  
  IniFile: TIniFile;  
begin  
  {Отключаем защиту файла}  
  CloseHandle(hIniLockedFile);  
  {Резервное время для оключения}  
  Sleep(1000);  
  IniFile := TIniFile.Create(ExtractFilePath(Application.Exename) + 'Test.ini');  
  IniFile.WriteString('MainOptions', 'FormCaption', Form1.Caption);  
  IniFile.Free;  
  {После сохранения, заново ставим защиту}  
  hIniLockedFile := OpenFile(PChar(ExtractFileDir(Application.Exename) + 'Test.ini'), OfStruct, OF_Share_Exclusive);  
end;  
  
procedure GetCaption;  
var  
  IniFile: TIniFile;  
begin  
  {Расширофка конфигурационного файла}  
  DeCryptInIFile;  
  Sleep(1000);  
  IniFile := TIniFile.Create(ExtractFilePath(Application.Exename) + 'Test.ini');  
  Form1.Caption := IniFile.ReadString('MainOptions', 'FormCaption', '');  
  IniFile.Free;  
  {Устанавливаем защиту}  
  hIniLockedFile := OpenFile(PChar(ExtractFileDir(Application.Exename) + 'Test.ini'), OfStruct, OF_Share_Exclusive);  
end;  
  
procedure TForm1.FormCreate(Sender: TObject);  
begin  
  GetCaption;  
end;  
  
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);  
begin  
  SaveCaption;  
  CloseHandle(hIniLockedFile);  
  CryptInIFile;  
end;  


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

Следует сказать пару слов о самих алгоритмах кодирования и декодирования текста. В качестве признака того, что файл уже был закодирован, используется обыкновенная текстовая строка «Crypted», которой соответствует константа csCryptHeader. Она следует вначале каждой зашифрованной строчки. Перед шифрованием, определяется длина строки csCryptHeader, после чего увеличивается длина будущей строки, которая равна длине шифруемой строки и длине строки csCryptHeader. Далее, простым перебором, происходит замена каждого символа шифруемой строки. Это осуществляется с помощью функции Chr, которая по сгенерированному программой числу возвращает соответствующий символ. При замене символов, следует учитывать определенные параметры, которые определяет логическая операция. В нашем примере, в зависимости от того, делится ли порядковый номер строки на два без остатка, используются разные параметры, что усложняет последующую дешифровку текста.

При дешифровки текста определяется его реальная длина, что достигается вычитанием из длины дешифруемой строки длины строки csCryptHeader. Для того, что бы определить, поврежден файл или нет, программа ищет в закодированной строчке заголовок, в нашем примере это «Crypted», и если он отсутствует, то дешифровка прекращается и возникает ошибка. Если же все в порядке, далее идет расшифровка текста, алгоритм которой полностью противоположен алгоритму шифрования.

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

Автор: Корнейчук Михаил

Добавлено: 07 Августа 2018 08:02:33 Добавил: Андрей Ковальчук

Простейший AI на примере мини-игры (часть 1)

Большинство компьютерных игр содержат содержат искусственный интеллект. Если брать во внимание все серьёзные игры (Action, RPG и т.п.), то они полностью "захвачены искусственным разумом". Другое дело - мини-игры. К примеру, общеизвестный Сапёр прекрасно живёт и без интеллекта, думать ему во время игры вообще не нужно... Да что говорить и самой игре, если в некоторых ситуациях мыслительный процесс самого игрока ни к чему не приведёт - бывают ситуации, когда нужно просто щёлкнуть наугад - тут уже вероятность 50% - либо попал на мину, либо не попал... :-)

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

Сейчас мы попытаемся создать самый простой AI (Artificial Intelligence кстати) на примере небольшой игры.

Игра

Давайте создадим игру, которую можно назвать "Догонялки". Задача игрока очень проста: управляя своим героем, стараться не попасть в лапы соперника. Очень простая задумка, но тем не менее здесь будет AI, хотя и простейший. Пусть программа автоматически увеличивает уровень сложности по мере игры.

Проектируем интерфейс

Сделаем игру на основе стандартных компонент. Не будем применять никакой графики, ибо речь совсем не об этом. Итак, пусть наши "герои" будут простыми... квадратами. А почему бы и нет? Нет у нас времени на рисование персонажей - всё будет абстрактно. Размещаем на форме 2 компонента TShape (вкладка Additional палитры компонент). Один сделаем красным, а другой синим. Цвет заливки задаётся свойством Brush - Color. Пусть наш герой будет синим, а враг - красным. С персонажами определились. Что нам ещё нужно? Наверное, кнопка для запуска игры. Поместите на форму кнопку, лучше в левый верхний угол. Ну и ещё разместим где-нибудь 3 текстовые метки (TLabel) - одна будет показывать время игры, другая - уровень сложности, а в третьей будет появляться информация о результатах.

Время игры

Чтобы участники могли сравнить свои результаты, игра будет выдавать итоговое время. Для начала объявляем глобальную переменную, в которой будем хранить количество секунд, в течение которых длится игра. В раздел var модуля добавляем: Time: Integer = 0; Теперь нам нужен способ отсчитывать секунды. Для этого используем TTimer (вкладка System). Interval пусть останется стандартным (1000 мс = 1 сек), а вот сам таймер мы изначально выключим: Enabled = False. Назовём этот таймер не Timer1, а просто Timer. Теперь пишем его обработчик события OnTimer:


procedure TForm1.TimerTimer(Sender: TObject);  
begin  
  Inc(Time);  
  if Time < 60 then  
    TimeLabel.Caption:=IntToStr(Time)+' сек.'  
  else  
    TimeLabel.Caption:=IntToStr(Time div 60)+' мин. '+IntToStr(Time mod 60)+' сек.';  
end;   

Что же здесь происходит? Сначала мы прибавляем секунду к текущему времени. Затем в одну из текстовых меток, которая называется TimeLabel, выводим текущее время игры. Проверяем: если ещё не прошло одной минуты, то выводим просто секунды, а иначе выводим и минуты и секунды. Записать это можно немного по-другому, но не суть важно. Время почти готово, только в обработчик нажатия кнопки "Старт" нужно добавить включение игрового таймера: GameTimer.Enabled:=True; Вот теперь время точно готово.

Управление персонажем

Сделаем управление мышью для нашего "персонажа". Создаём обработчик на событие OnMouseMove формы, где устанвливаем фигурку в положение курсора:


procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);  
begin  
  Player.Left:=X-Round(Player.Width/2);  
  Player.Top:=Y-Round(Player.Height/2);  
end;  

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

Можно изменить курсор со стрелки на крестик - установить свойство Cursor в crCross для формы и для фигурки.

Ну вот, управление готово. Можно запустить программу и посмотреть, что получилось.

Интеллект

Для постоянной активности противника также будем использовать таймер. Назовём его GameTimer, зададим интервал в 0.1 с (Interval = 100) и выключим (Enabled = False). Назначение этого таймера в следующем: когда его событие будет активироваться, будет анализироваться положение врага и враг будет двигаться по направлению к игроку. Пусть Player - фигурка игрока, Enemy - фигурка противника. Для начала зададим шаг движения противника в виде количества точек, на которые будет смещаться фигурка. Объявляем глобальную переменную: Step: Byte = 10; Заодно заведём переменную и для текущего уровня сложности, который будет представлен цифрой: Level: Byte = 1;

Теперь разбираемся с интеллектом. Вот черновой вариант:


if Enemy.Left+Enemy.Width <= Player.Left then  
  Enemy.Left:=Enemy.Left+Step  
else if Enemy.Left >= Player.Left+Player.Width then  
  Enemy.Left:=Enemy.Left-Step  
else if Enemy.Top+Enemy.Height <= Player.Top then  
  Enemy.Top:=Enemy.Top+Step  
else if Enemy.Top >= Player.Top+Player.Height then  
  Enemy.Top:=Enemy.Top-Step  
else  

Игрок пойман
Здесь мы сравниваем позиции игрока и противника и соответствующим образом перемещаем фигурку противника. Для определения "наложения" одной фигурки на другую будем сравнивать не просто координаты левого верхнего угла (Left и Top), а также будем прибавлять к ним размеры самих фигурок, т.к. они достаточно большие.

Итак, по порядку:

- если противник расположен левее игрока, то сдвигаем противника вправо;
- если противник правее игрока, сдвигаем его влево;
- если противник выше игрока, то сдвигаем вниз;
- если противник ниже, то сдвигаем вверх.

Достаточно простой алгоритм, который будет работать. Добавим в обработчик кнопки "Старт" запуск таймера для движения противника: GameTimer.Interval:=100; и GameTimer.Enabled:=True; Также нужно указать что-либо для выполнения в том случае, если враг не сдвинулся с места, т.е. участник пойман и проиграл. Например, можно добавить сообщение: ShowMessage('Вы проиграли!'); Запускаем программу и смотрим. Работает? Работает. Однако движение противника слишком определено: сначала он движется по горизонтали до тех пор, пока не сравняется по вертикали с игроком, а затем догоняет его по вертикали. Да, не самый оптимальный и не самый короткий путь. Есть способы лучше.

Уровень сложности

Немного прервём разработку нашего интеллекта и запрограммируем изменение уровня сложности. Самое первое, что приходит в голову - ускорять движение противника в течение игры. Так и сделаем. Помещаем на форму ещё один таймер и называем его LevelTimer; выключаем его, а в качестве интервала задаём то время, через которое уровень должен изменяться. Например, зададим 10 секунд, т.е. изменим Interval на 10000. Кнопка старта игры должна включать и этот таймер: LevelTimer.Enabled:=True; В результате, обработчик нажатия кнопки получается примерно таким:


procedure TForm1.StartButtonClick(Sender: TObject);  
begin  
  Time:=0;  
  Level:=1;  
  GameTimer.Interval:=100;  
  GameTimer.Enabled:=True;  
  Timer.Enabled:=True;  
  LevelTimer.Enabled:=True;  
  StartButton.Enabled:=False;  
end;  

Ну и наконец, обработчик события OnTimer для LevelTimer:


procedure TForm1.LevelTimerTimer(Sender: TObject);  
begin  
  if GameTimer.Interval >= 15 then  
  begin  
    GameTimer.Interval:=GameTimer.Interval-10;  
    Inc(Level);  
    label1.Caption:='Уровень: '+IntToStr(Level);  
  end  
  else  
    Игра выиграна  
end;  

Принцип изменения уровня сложности: изменяем интервал таймера противника - с каждым новым уровнем сложности на 10 мс. Если дошли до маленького интервала, меньше 15 мс, то игру можно считать выигранной. Довольно простая система. Также можно изменять шаг перемещения фигурки противника, делая его больше, но тогда будет создаваться эффект, что фигурка просто перепрыгивает с одного места на другое, а не передвигается. Помимо этого следует отметить, что на компьютерах разной мощности такой способ может работать немного по-разному в плане скорости.

Кстати, чтобы обеспечить более-менее равные условия для всех, имеет смысл жёстко задать размеры формы, иначе владельцы больших мониторов получат огромное пространство для бегства :-) BorderStyle формы устанавливаем в bsSingle, а из множества BorderIcons исключаем biMaximize, чтобы форму нельзя было развернуть. Размеры формы лучше задать в ClientWidth и ClientHeight.

Запустите программу - теперь играть стало сложнее. Наш алгоритм при начальном интервале противника в 100 мс и последовательном понижении его на 10 мс даёт 10 уровней сложности. Дойдёте до конца? Думаю, да. С таким интеллектом далеко не уйти... Действительно, выбирается самый длинный путь, если не считать пути в обход (только этого нам не хватало! ;-) ).

Повышаем уровень интеллекта

Во-первых, неплохо бы слегка оптимизировать наш код - в нём содержится множество обращений к одним и тем же свойствам двух объектов. Лучше завести переменные, значения которых высчитать один раз и впоследствии использовать именно их. Работаем с событием OnTimer объекта GameTimer. Для начала заводим две локальные переменные: Var dx,dy: Integer; Это у нас будут соответственно расстояния между игроком и противником по горизонтали и по вертикали. Для удобства организуем вычисления так, что эти переменные будут принимать как положительные, так и отрицательные значения. Представим 4 координатные четверти плоскости и соответствующим образом расставим знаки наших переменных. Вот вычисление этих расстояний:


if Player.Left+Player.Width < Enemy.Left then  
  dx:=Player.Left+Player.Width-Enemy.Left  
else if Enemy.Left+Enemy.Width < Player.Left then  
  dx:=Player.Left-Enemy.Left-Enemy.Width  
else  
  dx:=0;  
  
if Player.Top+Player.Height < Enemy.Top then  
  dy:=Enemy.Top-Player.Top+Player.Height  
else if Enemy.Top+Enemy.Height < Player.Top then  
  dy:=Enemy.Top-Enemy.Height-Player.Top  
else  
  dy:=0;  
dx < 0
dy > 0

dx > 0
dy > 0

dx < 0
dy < 0

dx > 0
dy < 0


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


if (dx = 0) and (dy = 0) then  
begin  
  GameTimer.Enabled:=False;  
  Timer.Enabled:=False;  
  LevelTimer.Enabled:=False;  
  GameStatusLabel.Caption:='Вы проиграли!';  
  Exit;  
end;  

Ну а если игра всё ещё в процессе, то нужно догонять игрока. Вот тут-то мы и изменим наш алгоритм. Выберем путь короче: будем двигаться не только по горизонтали и вертикали, но и по диагонали. Отдадим приоритет горизонтальному направлению, т.е. сначала будем двигаться по горизонтали и только затем по вертикали и по диагонали. Причина - все экраны вытянуты горизонтально, а значит основной "пробег" будет именно по этому направлению. Итак, если по горизонтали дальше до цели, чем по вертикали, то сначала движемся по горизонтали, а когда расстояния сравняются, пойдём по диагонали под углом 45°. Вот и реализация:


if (Abs(dx) >= Abs(dy)) and (dx <> 0) then  
  if dx < 0 then  
    Enemy.Left:=Enemy.Left-Step  
  else if dx > 0 then  
    Enemy.Left:=Enemy.Left+Step  
else else if (dy <> 0) then  
  if dy < 0 then  
    Enemy.Top:=Enemy.Top+Step  
  else if dy > 0 then  
    Enemy.Top:=Enemy.Top-Step;  

И код короче, и движение эффективнее.

Заключение

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

Добавлено: 07 Августа 2018 07:55:06 Добавил: Андрей Ковальчук

Циклы - цикл с предусловием и цикл с постусловием

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

Задача
Определить количество натуральных чисел, рассматривая их в порядке возрастания, сумма кубов которых не превышает 50000. Т.е. мы должны последовательно суммировать кубы чисел 1, 2, 3, ..., и делать это до тех пор, пока сумма не достигнет 50000, а в результате должны узнать, сколько чисел было пройдено.

Понятно, что решить задачу лучше использованием цикла. Но будет ли решение с циклом FOR оптимальным? Конечно, можно задать диапазон пробегаемых значений от 1 до 50000 - количество чисел точно будет найдено (очевидно, это кол-во будет даже менее 50, ведь 50^3 >> 50000). Но в этом случае придётся ставить дополнительное условие на значение суммы и выполнение команды Break.

Есть способ проще!

Цикл WHILE - цикл с предусловием
Цикл WHILE (англ. "пока") - цикл, в котором условие находится перед телом цикла, а сам цикл выполняется до тех пор, пока условие не станет ложным.

Общий вид:


WHILE {условие} DO  
  {действия}  

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

Особенностью цикла с предусловием является то, что он может не выполниться ни разу - это произойдёт, если указанное условие изначально будет ложным. При этом, цикл может и стать "вечным" - если условие никогда не примет значения False. Именно поэтому следует следить за тем, чтобы всегда присутствовали условия для завершения работы цикла.

Решение задачи с помощью цикла WHILE

Вернёмся к нашей задаче. С помощью цикла с предусловием задача решается очень просто. Во-первых, нам потребуется переменная, в которой будет храниться текущее обрабатываемое число - это будут числа 1, 2, 3 и т.д. Во-вторых, ещё одна переменная потребуется для хранения суммы кубов чисел. Всё, этого достаточно. Теперь разберёмся, что писать в теле цикла. Там мы должны: а) увеличивать переменную-счётчик на единицу, чтобы последовательно проходить числа; б) увеличивать сумму на куб текущего числа. Условием цикла будет главное условие нашей задачи - достижение суммой 50000. Вот что получается:


procedure TForm1.Button1Click(Sender: TObject);  
var s,i: integer;  
begin  
  i:=0;  
  s:=0;  
  while s < 50000 do  
  begin  
    Inc(i);  
    Inc(s,i*i*i);  
  end;  
  Label1.Caption:=IntToStr(i-1)  
end;  

В данном случае процесс "повешен" на кнопку (Button1), а результат выводится в текстовую метку (Label1). Вы спросите, почему выводится i-1, а не само число i ? Всё просто. Ведь переменная-счётчик увеличивается после того, как проверяется условие цикла, а значит и результат получится на единицу больше. Удостовериться в этом можно, добавив в тело цикла вывод промежуточных результатов (в примере - в текстовое поле Memo1):


Memo1.Lines.Add(IntToStr(s)+' : '+IntToStr(i));  

Цикл REPEAT - цикл с постусловием
Завершает тройку циклов цикл с постусловием - REPEAT (англ. "повтор"). Примечательно, что этого цикла во многих языках программирования нет - есть только FOR и WHILE. Между тем, цикл с постусловием очень удобен.

Работает цикл точно так же, как и WHILE, но с одним лишь отличием, следующим из его названия - условие цикла располагается после тела цикла, а не до него.

Общий вид:


REPEAT  
  {действия}  
UNTIL {условие выхода из цикла};  

Есть несколько моментов, на которые стоит обратить внимание. Во-первых, в качестве условия задаётся уже условие выхода из цикла, в то время как в цикле WHILE задаётся условие продолжения цикла. Во-вторых, при наличии нескольких команд, которые помещаются в тело цикла, заключать их в блок BEGIN .. END не нужно - зарезервированные слова REPEAT .. UNTIL сами составляют аналогичный блок.

Цикл с постусловием, в отличие от цикла с предусловием, всегда выполняется хотя бы один раз! Но, как и цикл WHILE, при неверно написанном условии цикл станет "вечным".

Решение задачи с помощью цикла REPEAT

Решение нашей задачи практически не изменится - всё останется, только условие будет стоять в конце, а само условие изменится на противоположное:


procedure TForm1.Button2Click(Sender: TObject);  
var s,i: integer;  
begin  
  i:=0;  
  s:=0;  
  repeat  
    Inc(i);  
    Inc(s,i*i*i);  
  until s >= 50000;  
  Label1.Caption:=IntToStr(i-1);  
end;  

Команды Break и Continue
Команда Break, выполняющая досрочный выход из цикла, работает не только в цикле FOR, но и в циклах WHILE и REPEAT. Аналогично, команда Continue, немедленно запускающая следующую итерацию цикла, может использоваться в циклах WHILE и REPEAT.

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

Задание: при нажатии кнопки "Старт" программа начинает генерировать случайные комбинации из латинских букв (верхнего регистра) длиной 10 символов и все эти комбинации отображаются в текстовом поле TMemo. При нажатии кнопки "Стоп" генерация должна быть прекращена.

Каким образом решить поставленную задачу? Сначала сделаем акцент на механизме остановки. Понятно, что в данном случае нужно задать вечный цикл, да-да, самый настоящий, но каким образом предусмотреть его остановку? Очевидно, что выбор падает либо на WHILE, либо на REPEAT. Остановить цикл можно либо изменив значение логического выражения, заданного для цикла, либо вызвав команду Break. Вопрос стоит теперь в том, как при нажатии кнопки "Стоп" изменить условие цикла, описанного в обработчике кнопки "Старт". Ответ прост - использовать ту память, которая доступна обработчикам обеих кнопок. Итак, заведём глобальную переменную, которая будет видна во всей программе. Глобальные переменные описываются над словом implementation модуля, там, где идёт описание формы:


[DELPHI]var  
  Form1: TForm1;  
  Stop: Boolean = False;  

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

На форме разместим Memo1 (TMemo) и 2 кнопки: Button1 ("Старт"), Button2 ("Стоп"). У кнопки "Стоп" поставим Enabled = False, т.е. выключим её.

Сразу приведу обработчики обеих кнопок, после чего подробно разберём их работу:


procedure TForm1.Button1Click(Sender: TObject);  
var s: string; c: byte;  
begin  
  Button2.Enabled:=True;  
  Button1.Enabled:=False;  
  Stop:=False;  
  while not(Stop) do  
  begin  
    s:='';  
    for c := 1 to 10 do  
      s:=s+Chr(Random(Ord('Z')-Ord('A')+1)+Ord('A'));  
    Memo1.Lines.Add(s);  
    Application.ProcessMessages  
  end  
end;  
   
procedure TForm1.Button2Click(Sender: TObject);  
begin  
  Stop:=True;  
  Button2.Enabled:=False;  
  Button1.Enabled:=True;  
end;  

Начнём с кнопки "Стоп" (Button2). При её нажатии:
1) Значение переменной Stop устанавливается в True, т.е. мы подаём сигнал, что нужно остановиться;
2) Кнопку "Стоп" мы снова выключаем;
3) Кнопку "Старт" - наоборот, включаем.

Теперь кнопка "Старт" (Button1):
1) Кнопка "Стоп" включается, кнопка "Старт" выключается;
2) Переменной Stop присваивается значение False (если этого не сделать, то запустить процесс генерации второй раз будет невозможно);
3) Цикл с генерацией строки с условием на переменную Stop - цикл будет работать до тех пор, пока переменная Stop имеет значение False. Как только значение станет True, цикл сам завершит свою работу.

А теперь более подробно о том, что происходит в теле цикла. Начнём с генерации строки символов. Напомню, что строки можно складывать. Если сложить строку 'A' со строкой 'B', то получится строка 'AB'. Именно этот приём здесь и использован. Сначала мы делаем строку пустой, а затем последовательно добавляем в неё 10 произвольных символов. Как происходит добавление... Ну естественно с помощью цикла на 10 итераций. А вот выбор случайной из латинских букв не совсем прост и не для всех очевиден. Конечно, можно было заранее записать все буквы куда-либо (например, в массив, или в другую строковую переменную), а затем брать их оттуда. Но это не совсем хорошо, ведь можно сделать гораздо проще. В данном случае решающим фактором является то, что латинские буквы в кодовой таблице символов идут по порядку. Т.е. 'A' имеет некоторый код n, 'B' имеет код n+1 и т.д. - весь алфавит идёт последовательно, без разрывов. Убедиться в этом можно с помощью программы "Таблица символов", которая есть в Windows.

Вернёмся к нашей задаче. Мы должны выбрать случайную из букв 'A'..'Z'. Так как коды этих символов последовательны, то мы должны выбрать произвольное число от код_символа_A до код_символа_Z. Напомню, что для выбора случайного числа используется функция Random(n), возвращающая случайное число от 0 до n-1. Недостаток функции в том, что она берёт числа всё время от нуля, а код символа 'A' уж явно не 0. Но и здесь ничего сложного нет: сначала узнаём "ширину" диапазона кодов - из кода символа 'Z' вычитаем код символа 'A'. Не забываем прибавить 1, иначе буква 'Z' никогда не попадёт в строку, т.к. число берётся от 0 до n-1. Ну и дальше мы делаем сдвиг числа на код символа 'A'.
На буквах: от 'A' до 'Z' p позиций. Сама 'A' стоит в позиции n. Очевидно, 'Z' стоит в позиции p+n. Берём случайное число от 0 до p, а прибавив n получаем число из интервала от n до n+p. Простая арифметика, которая не для всех кажется простой.
Итак, код символа мы получили - осталось только добавить соответствующий символ в нашу строку. Функция Chr() возвращает символ с указанным кодом.

Для справки: очень часто, глядя на такой код, говорят, что он неоптимален - мол, коды символов будут постоянно рассчитываться (речь о функции Ord). Однако знающие люди никогда этого не скажут, ведь в Delphi есть маленькая хитрость: компилятор вычислит эти значения ещё на этапе компиляции и в программе они будут просто константами. Т.е. Ord('Z') и Ord('A') в программе не будут считаться никогда - там будут стоять вполне реальные числа, а значит никакого избытка вычислений идти не будет. Более того, даже вычитание будет произведено на этапе компиляции, ведь оба слагаемых являются константами. Мы пишем Ord('A') и Ord('Z') только из-за того, чтобы не лезть в кодовую таблицу, и не смотреть вручную коды этих символов. Кроме того, если вместо этого записать реальные коды, другой человек может испытать затрудение при чтении кода - он ведь не знает, откуда вы взяли эти числа и не помнит всю кодовую таблицу, чтобы определить, каким символам эти числа соответствуют.

Далее полученная строка s добавляется в Memo1 уже известным способом. А вот последняя строка в теле цикла - это маленькая хитрость. В одном из уроков об этой команде уже упоминалось. Дело в том, что при отсутствии этой команды программа просто зависнет с точки зрения пользовательского интерфейса - никаких изменений в Memo видно не будет, да и само окно перестанет реагировать на щелчки. На самом деле, конечно, программа будет работать, в памяти генерация строк будет идти полным ходом... Команда Application.ProcessMessages заставляет приложение обработать всю очередь задач, в том числе по отрисовке окна программы и элементов формы. Если при генерации каждой строки это будет происходить, программа будет выглядеть вполне живой - можно будет легко переместить окно по экрану и, что самое главное, нажать на заветную кнопку "Стоп". Ради эксперимента попробуйте убрать эту строку, и посмотреть, что получится.

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

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

Автор: Ерёмин А.А.

Добавлено: 07 Августа 2018 07:53:01 Добавил: Андрей Ковальчук

Прединсталляторы и психология

Прединсталляторы – малоизвестный класс программ, используемых в рекламных технологиях. Программы могут использоваться для создания большого количества показов рекламных баннеров или вебстраниц, формирования рекламного трафика, увеличения рентабельности вебсайтов с бесплатным программным обеспечением – freeware.

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

1. Прединсталляторы
Это программы, исполняемые до инсталляции программного обеспечения.

Архивы бесплатного программного обеспечения идут на различные ухищрения, чтобы получить компенсацию за расходы на поддержание вебсервера и сервиса. Т.к. программы распространяются бесплатно, то зарабатывать средства приходится за счет размещения рекламы спонсоров. Прединсталляторы – тот класс программ, которые могут существенно облегчить финансовые проблемы владельцев freeware архивов.

Обычно, скачанное пользователем бесплатное или демонстрационное программное обеспечение - файл, имеет имя, отличное от SETUP, INSTALL, RUN или START. Чаще всего сейчас в имени файла используется сокращенное название программы (например, http://pipa.send-sms.ru/get.php/pipa.exe). Это позволяет вместе с архивом программы представить пользователю дополнительный EXE файл с одним из таких названий (setup.exe например).

В подавляющем количестве случаев процесс инсталляции будет начат пользователем с запуска именно этого (setup.exe) файла. При этом в файл (setup.exe) могут быть включены следующие функции:

проверка версии операционной системы;
показ рекламной информации или подключение рекламного сервиса;
запуск инсталляции основной программы;
удаление прединсталлятора из памяти.
2. На чем программировать
Если посмотреть на статистику счетчиков http://extreme-dm.com на любом из вебсайтов, то можно увидеть примерно такое распределение версий ОС у посетителей:

Видно, что наибольший процент посетителей используют ОС Windows 2000 или Windows XP. Поэтому будем ориентироваться на структуру реестра именно этих OC.

В данном документе описан процесс разработки отдельных процедур программы для Интернет-рекламы.

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

В нашем примере программа-прединсталлятор будет состоять из прозрачной формы Form1 (Border Style = 0, Appearance = 0)

4. Подключение рекламного сервиса
Рекламный сервис может выполняться разными способами:

обязательным однократным или многократным посещением web страницы разработчика или спонсора;
размещением рекламного плаката в качестве wallpapers;
записью ссылки на web сайт спонсора или разработчика в Favorites;
каким-либо иным способом.
Внимание! В любом случае пользователь должен быть предупрежден об особенностях сервиса, включенного в программное обеспечение. Производить или не производить инсталляцию – выбор пользователя.

Рассмотрим вариант, когда программа-прединсталлятор устанавливает в качестве стартовой страницы для Internet Explorer страницу спонсора.

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

Листинг для записи в текстовый файл из программы на Delphi – в файле dlpp1.zip

Текст Java-скрипта (всего 3 строчки):

var WSHShell = WScript.CreateObject("WScript.Shell");
WSHShell.Popup("Стартовая страница");
WSHShell.RegWrite("HKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\Main\\Start Page", "http://www.privet.com");

Напишем Delphi-код для записи JS скрипта в файл set-page.js

Код:

procedure TForm1.FormActivate(Sender: TObject);  
begin  
AssignFile(f, 'c:\set-page.js');  
  
  Rewrite(f); // Создать и открыть файл  
  writeln(f, 'var WSHShell = WScript.CreateObject'+chr(40)+chr(34)+  
  'WScript.Shell'+chr(34)+chr(41)+chr(59)); // Записать СТРОКУ в файл  
  writeln(f, 'WSHShell.Popup'+chr(40)+chr(34)+'Стартовая страница'+  
  chr(34)+chr(41)+chr(59)); // Записать СТРОКУ в файл  
  writeln(f, 'WSHShell.RegWrite'+chr(40)+chr(34)+  
  'HKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\Main\\Start Page'+chr(34)+',   
  '+chr(34)+'http://www.privet.com'+chr(34)+chr(41)+chr(59)); // Записать СТРОКУ в файл  
  CloseFile(f); // Закрыть файл  
  
  ShellExecute(Handle, 'open', 'c:\set-page.js', nil, nil, SW_HIDE); // Выполнить команду. Запустить скрипт  
  
end;  

Здесь ‘ + chr(34) + ‘ – код для записи кавычек в файл Java-скрипта. Аналогично – для скобок и точки с запятой - '+chr(34)+chr(41)+chr(59)’. ASCII-коды можно посмотреть на http://www.lookuptables.com/

А для работы с ShellExecute необходимо добавить объявление (выделено красным):

uses   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ShellAPI;


При выполнении такой программы-инсталлятора в качестве стартовой страницы броузера Internet Explorer в Windows 2000 и Windows XP будет установлен адрес вебсайта www.privet.comПолный проект смотрите в файле dlpp2.zip

Здесь приведен самый простой вариант программы. В него надо добавить всего одну строку кода – запуск инсталляции основной программы. Это можно сделать просто включив в программу еще одну строку – например для инсталляции приведенной выше программы PIPA.EXE :


ShellExecute(Handle, 'open', ' pipa.exe', nil, nil, SW_HIDE);  

Кроме того, следует удалить с диска файл с Java-скриптом, как уже ненужный после начала инсталляции


ShellExecute(Handle, 'open', ' kill c:\set-page.js', nil, nil, SW_HIDE);  

Это самый простой образец программы-инсталлятора. Эффективность работы его можно значительно повысить, если произвести некоторые доработки – например, файлы конфигурации. Тогда программа-прединсталлятор станет более универсальной, подходящей для широкого использования. Можно разработать программу для создания, редактирования и кодирования файлов конфигурации прединсталлятора. Т.е. разработать новый коммерческий продукт.

Программа-инсталлятор имеет удивительную эффективность для создания трафика – с самых «банальных» web-сайтов с посещаемостью 300-600 человек в день скачивается 100-150 экземпляров программ минимум. Можете представить сколько посещений вебсайта спонсора может обеспечить прединсталлятор.

Эффективность программы-прединсталлятора можно повысить производя так же и запись в Favorites броузера.

Ничего сложного в этом нет. Каждая запись в Favorites («Избранное») – это специальный файл в особом каталоге на диске C:

5. Запись в Favorites
Для этого необходимо работать с реестром Windows. Команды для работы с реестром.


function ReadString(const Name: String): String;  

Возвращает строку значения параметра Name текущего ключа. При ошибке чтения генерируется исключение и возвращенное значение является ошибочным.

Пример:

uses Registry;  
.   
.  
.   
var  
Reg : TRegistry;   
begin  
Reg := TRegistry.Create;  
Reg.RootKey:=HKEY_LOCAL_MACHINE;  
Reg.OpenKey('\My Registry\',true);  
Edit1.Text:= Reg.ReadString('My');  
Reg.CloseKey;  
Reg.Destroy;  

Продемонстрируем функцию для чтения значения ключа реестра, в котором выше установили адрес стартовой страницы Internet Explorer (на форму Form1 нужно добавить кнопку Button1):


procedure TForm1.Button1Click(Sender: TObject);  
  
begin  
  
Reg := TRegistry.Create;  
Reg.RootKey:=HKEY_CURRENT_USER;  
Reg.OpenKey('\Software\Microsoft\Internet Explorer\Main\',true);  
Form1.Caption:= '' + Reg.ReadString('Start Page');  
Reg.CloseKey;  
Reg.Destroy;  
  
end;  

Для работы с реестром необходимо добавить объявление (выделено красным):

uses   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Registry, ShellAPI;


Полный Delphi-проект с этого этапа разработки смотрите в файле dlpp3.zip

Рассмотрим Delphi код для создания записи в Favorites («Избранное»)

Пример для записи в «Избранное» Internet Explorer (папка Favorites) можно посмотреть здесь http://delphiworld.narod.ru/base/webbrowser_add_to_fav.html.

Напишем более простой код. Добавим его в процедуру TForm1.Button1Click


procedure TForm1.Button1Click(Sender: TObject);  
begin  
Reg := TRegistry.Create;  
Reg.RootKey:=HKEY_CURRENT_USER;  
Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\',true);  
Form1.Caption:= '' + Reg.ReadString('Favorites') + '\' + 'Zagranica.url';  
ee:= Reg.ReadString('Favorites') + '\' + 'Hello.url';  
Reg.CloseKey;  
Reg.Destroy;  
  
Form1.Caption:= ee;  
  
//Создать новую запись в Favorites  
//C:\Documents and Settings\Administrator\Favorites  
  
AssignFile(f, ee);  
Rewrite(f); // Создать и открыть файл  
writeln(f, '[DEFAULT]');  
writeln(f, 'BASEURL= http://www.geocities.com/aboutsoft/');  
writeln(f, '[InternetShortcut]');  
writeln(f, 'URL= http://www.geocities.com/aboutsoft/');  
writeln(f, 'Modified=70037C581883C001A1');  
CloseFile(f); // Закрыть файл  
  
end;  

Полный Delphi проект программы смотрите в файле dlpp4.zip

В принципе, здесь создан еще один коммерчески ориентированный продукт. Представьте себе веб-сайт-каталог тематических ссылок. Например список ссылок на mp3 музыкальные сайты. Используя приведенный выше VB код, можно создать такой каталог тематических ссылок на компьютере, в Favorites. Создается вложенная папка, например, «MP3 ссылки». И в неё помещаются записи с ссылками на тщательно проверенные каталоги MP3 музыки. Программа для создания таких каталогов – вполне коммерческий продукт. Новый продукт. Эта ниша на рынке еще не занята. Кроме того, программа может быть немного усовершенствована и получать обновления списка вебсайтов с вебстраницы разработчика. Технически, это очень просто.

6. Wallpapers – рекламные обои
В предыдущем руководстве программиста показано, что обои (оформление рабочего стола) тоже могут использоваться в рекламных технологиях


procedure TForm1.Button1Click(Sender: TObject);  
 var  
   Picture: TPicture;  
   Desktop: TCanvas;  
   X, Y: Integer;  
 begin  
   // Objekte erstellen   
  // create objects   
  Picture := TPicture.Create;  
   Desktop := TCanvas.Create;  
  
   // Bild laden   
  // load bitmap   
  Picture.LoadFromFile('bitmap1.bmp');  
  
   // Geratekontex vom Desktop ermitteln   
  // get DC of desktop   
  Desktop.Handle := GetWindowDC(0);  
  
   // Position des Bildes   
  // position of bitmap   
  X := 100;  
   Y := 100;  
  
   // Bild zeichnen   
  // draw bitmap   
  Desktop.Draw(X, Y, Picture.Graphic);  
  
   // Geratekontex freigeben   
  ReleaseDC(0, Desktop.Handle);  
  
   // Objekte freigeben   
  // release objects   
  Picture.Free;  
   Desktop.Free;  
 end;  

Пример можно посмотреть здесь http://delphiworld.narod.ru/base/bmp_to_desktop.html

Обратите внимание, что графический файл для Desktop должен быть в формате .bmp

7. Об эффективности
Эффективность использования программ-прединсталляторов чрезвычайно высока. Свыше 70% программ инсталлируются сразу после скачивания и без всякого анализа состава программного пакета. В лучшем случае читается файл ReadMe.txt

Рекламную эффективность программ-прединсталлятров можно значительно увеличить используя специальный инсталлируемый на компьютер модуль для загрузки рекламы. В таком случае программа превращается в разновидность Adware и может вызвать у пользователей негативную реакцию.

Добавлено: 07 Августа 2018 07:51:04 Добавил: Андрей Ковальчук

Теория и практика использования RTTI

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

Информация о типах времени исполнения.(Runtime Type Information, RTTI) —это данные, генерируемые компилятором Delphi о большинстве объектов вашей программы. RTTI представляет собой возможность языка, обеспечивающее приложение информацией об объектах (его имя, размер экземпляра, указатели на класс-предок, имя класса и т. д.) и о простых типах во время работы программы. Сама среда разработки использует RTTI для доступа к значениям свойств компонент, сохраняемых и считываемых из dfm-файлов и для отображения их в Object Inspector,

Компилятор Delphi генерирует runtime информацию для простых типов, используемых в программе, автоматически. Для объектов, RTTI информация генерируется компилятором для свойств и методов, описанных в секции published в следующих случаях:

Объект унаследован от объекта, дня которого генерируется такая информация. В качестве примера можно назвать объект TPersistent.

Декларация класса обрамлена директивами компилятора {$M+} и {$M-}.

Необходимо отметить, что published свойства ограничены по типу данных. Они могут быть перечисляемым типом, строковым типом, классом, интерфейсом или событием (указатель на метод класса). Также могут использоваться множества (set), если верхний и нижний пределы их базового типа имеют порядковые значения между 0 и 31 (иначе говоря, множество должно помещаться в байте, слове или двойном слове). Также можно иметь published свойство любого из вещественных типов (за исключением Real48). Свойство-массив не может быть published. Все методы могут быть published, но класс не может иметь два или более перегруженных метода с одинаковыми именами. Члены класса могут быть published, только если они являются классом или интерфейсом.

Корневой базовый класс для всех VCL объектов и компонент, TObject, содержит ряд методов для работы с runtime информацией.

Наиболее часто используемые методы класса TObject для работы с RTTI

Метод Описание
ClassType Возвращает тип класса объекта. Вызывается неявно компилятором при определении типа объекта при использовании операторов is и as
ClassName Возвращает строку, содержащую название класса объекта. Например, для объекта типа TForm вызов этой функции вернет строку "TForm"
ClassInfo Возвращает указатель на runtime информацию объекта
InstanceSize Возвращает размер конкретного экземпляра объекта в байтах.
Object Pascal предоставляет в распоряжение программиста два оператора, работа которых основана на неявном для программиста использовании RTTI информации. Это операторы is и as. Оператор is предназначен для проверки соответствия экземпляра объекта заданному объектному типу. Так, выражение вида:


AObject is TSomeObjectType   

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


if Edit1 is TForm then   
  ShowMessage('Враки!');  

даже не будет пропущен компилятором, и он выдаст сообщение о не совместимости типов (разумеется, что Edit1 — это компонент типа TEdit):


Incompatible types: 'TForm' and 'TEdit'.   

Перейдем теперь к оператору as. Он введен в язык специально для приведения объектных типов. Посредством него можно рассматривать экземпляр объекта как принадлежащий к другому совместимому типу:


AObject as TSomeObjectType   

Использование оператора as отличается от обычного способа приведения типов


TSomeObjectType(AObject)   

наличием проверки на совместимость типов. Так при попытке приведения этого оператора с несовместимым типом он сгенерирует исключение EInvalidCast. Определенным недостатком операторов is и as является то, что присваиваемый фактически тип должен быть известен на этапе компиляции программы и поэтому на месте TSomeObjectType не может стоять переменная указателя на класс.

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


var  
  I: Integer;  
begin  
  for I := 0 to ComponentCount - 1 do  
    if Components[I] is TEdit then  
      (Components[I] as TEdit).Text := '';  
      { или так TEdit (Components[I]).Text := ''; }  
end;   

Хочу обратить ваше внимание, а то, что стандартное приведение типа в данном примере предпочтительнее, поскольку в операторе if мы уже установили что компонент является объектом нужного нам типа и дополнительная проверка соответствия типов, проводимая оператором as, нам уже не нужна.

Первые шаги в понимании RTTI мы уже сделали. Теперь переходим к подробностям. Все основополагающие определения типов, основные функции и процедуры для работы с runtime информацией находятся в модуле TypInfo. Этот модуль содержит две фундаментальные структуры для работы с RTTI — TTypeInfo и TTypeData (типы указателей на них — PTypeInfo и PTypeData соответственно). Суть работы с RTTI выглядит следующим образом. Получаем указатель на структуру типа TTypeInfo (для объектов указатель можно получить, вызвав метод, реализованный в TObject, ClassInfo, а для простых типов в модуле System существует функция TypeInfo). Затем, посредством имеющегося указателя и вызова функции GetTypeData получаем указатель на структуру типа TTypeData. Далее используя оба указателя и функции модуля TypInfo творим маленькие чудеса. Для пояснения написанного выше рассмотрим пример получения текстового вида значений перечисляемого типа. Пусть, например, это будет тип TBrushStyle. Этот тип описан в модуле Graphics следующим образом:


TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,   
  bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);   

Вот мы и попробуем получить конкретные значения этого типа в виде текстовых строк. Для этого создайте пустую форму. Поместите на нее компонент типа TListBox с именем ListBox1 и кнопку. Реализацию события OnClick кнопки замените следующим кодом:


var  
  ATypeInfo: PTypeInfo;  
  ATypeData: PTypeData;  
  I: Integer;  
  S: string;  
begin  
  ATypeInfo := TypeInfo(TBrushStyle);  
  ATypeData := GetTypeData(ATypeInfo);  
  for I := ATypeData.MinValue to ATypeData.MaxValue do  
  begin  
    S := GetEnumName(ATypeInfo, I);  
    ListBox1.Items.Add(S);  
  end;  
end;   

Ну вот, теперь, когда на вооружении у нас есть базовые знания о противнике, чье имя, на первый взгляд выглядит непонятно и пугающее — RTTI настало время большого примера. Мы приступаем к созданию объекта опций для хранения различных параметров, использующего в своей работе мощь RTTI на полную катушку. Чем же примечателен, будет наш будущий класс? А тем, что он реализует сохранение в ini-файл и считывание из него свои свойства секции published. Его потомки будут иметь способность сохранять свойства, объявленные в секции published, и считывать их, не имея для этого никакой собственной реализации. Надо лишь создать свойство, а все остальное сделает наш базовый класс. Сохранение свойств организуется при уничтожении объекта (т.е. при вызове деструктора класса), а считывание и инициализация происходит при вызове конструктора класса. Декларация нашего класса имеет следующий вид:


{$M+}  
TOptions = class(TObject)  
  protected  
    FIniFile: TIniFile;  
    function Section: string;  
    procedure SaveProps;  
    procedure ReadProps;  
  public  
    constructor Create(const FileName: string);  
    destructor Destroy; override;  
end;  
{$M-}   

Класс TOptions является производным от TObject и по этому, что бы компилятор генерировал runtime информацию его надо объявлять директивами {$M+/-}. Декларация класса весьма проста и вызвать затруднений в понимании не должна. Теперь переходим к реализации методов.


constructor TOptions.Create(const FileName: string);  
begin  
  FIniFile:=TIniFile.Create(FileName);  
  ReadProps;  
end;  
  
destructor TOptions.Destroy;  
begin  
  SaveProps;  
  FIniFile.Free;  
  inherited Destroy;  
end;  

Как видно реализация конструктора и деструктора тривиальна. В конструкторе мы создаем объект для работы с ini-файлом и организуем считывание свойств. В деструкторе мы в сохраняем значения свойств в файл и уничтожаем файловый объект. Всю нагрузку по реализации сохранения и считывания published-свойств несут методы SaveProps и ReadProps соответственно.


procedure TOptions.SaveProps;  
var  
  I, N: Integer;  
  TypeData: PTypeData;  
  List: PPropList;  
begin  
  TypeData:= GetTypeData(ClassInfo);  
  N:= TypeData.PropCount;  
  if N <= 0 then  
    Exit;  
  GetMem(List, SizeOf(PPropInfo)*N);  
  try  
    GetPropInfos(ClassInfo,List);  
    for I:= 0 to N - 1 do  
      case List[I].PropType^.Kind of  
        tkEnumeration, tkInteger:  
          FIniFile.WriteInteger(Section, List[I]^.name,GetOrdProp(Self,List[I]));  
        tkFloat:  
          FIniFile.WriteFloat(Section, List[I]^.name, GetFloatProp(Self, List[I]));  
        tkString, tkLString, tkWString:  
          FIniFile.WriteString(Section, List[I]^.name, GetStrProp(Self, List[I]));  
      end;  
  finally  
    FreeMem(List,SizeOf(PPropInfo)*N);  
  end;  
end;  
  
  
procedure TOptions.ReadProps;  
var  
  I, N: Integer;  
  TypeData: PTypeData;  
  List: PPropList;  
  AInt: Integer;  
  AFloat: Double;  
  AStr: string;  
begin  
  TypeData:= GetTypeData(ClassInfo);  
  N:= TypeData.PropCount;  
  if N <= 0 then  
    Exit;  
  GetMem(List, SizeOf(PPropInfo)*N);  
  try  
    GetPropInfos(ClassInfo, List);  
    for I:= 0 to N - 1 do  
      case List[I].PropType^.Kind of  
        tkEnumeration, tkInteger:  
        begin  
          AInt:= GetOrdProp(Self, List[I]);  
          AInt:= FIniFile.ReadInteger(Section, List[I]^.name, AInt);  
          SetOrdProp(Self, List[i], AInt);  
        end;  
        tkFloat:  
        begin  
          AFloat:=GetFloatProp(Self,List[i]);  
          AFloat:=FIniFile.ReadFloat(Section, List[I]^.name,AFloat);  
          SetFloatProp(Self,List[i],AFloat);  
        end;  
        tkString, tkLString, tkWString:  
        begin  
          AStr:= GetStrProp(Self,List[i]);  
          AStr:= FIniFile.ReadString(Section, List[I]^.name, AStr);  
          SetStrProp(Self,List[i], AStr);  
        end;  
      end;  
  finally  
    FreeMem(List,SizeOf(PPropInfo)*N);  
  end;  
end;  
  
function TOptions.Section: string;  
begin  
  Result := ClassName;  
end;   

Теперь, для проверки работоспособности, и отладки объекта опций создадим новое приложение и подключим к нему модуль, в котором описан и реализован объект TOptions. Ниже приведен программный код, иллюстрирующий создание наследника от класса TOptions и его использования в главной (и единственной) форме нашего тестового приложения интерфейсная часть выглядит так:


TMainOpt = class(TOptions)  
  private  
    FText: string;  
    FHeight: Integer;  
    FTop: Integer;  
    FWidth: Integer;  
    FLeft: Integer;  
    procedure SetText(const Value: string);  
    procedure SetHeight(Value: Integer);  
    procedure SetLeft(Value: Integer);  
    procedure SetTop(Value: Integer);  
    procedure SetWidth(Value: Integer);  
  published  
    property Text: string read FText write SetText;  
    property Left: Integer read FLeft write SetLeft;  
    property Top: Integer read FTop write SetTop;  
    property Width: Integer read FWidth write SetWidth;  
    property Height: Integer read FHeight write SetHeight;  
end;  
  
TForm1 = class(TForm)  
    Edit1: TEdit;  
    procedure Edit1Change(Sender: TObject);  
  private  
    FMainOpt: TMainOpt;  
  public  
    constructor Create(AOwner: TComponent); override;  
    destructor Destroy; override;  
end;  
А вот и реализация:


constructor TForm1.Create(AOwner: TComponent);  
var  
  S: string;  
begin  
  inherited Create(AOwner);  
  S := ChangeFileExt(Application.ExeName, '.ini');  
  FMainOpt := TMainOpt.Create(S);  
  Edit1.Text := FMainOpt.Text;  
  
  Left := FMainOpt.Left;  
  Top := FMainOpt.Top;  
  Width := FMainOpt.Width;  
  Height := FMainOpt.Height;  
end;  
  
destructor TForm1.Destroy;  
begin  
  FMainOpt.Left := Left;  
  FMainOpt.Top := Top;  
  FMainOpt.Width := Width;  
  FMainOpt.Height := Height;  
  FMainOpt.Free;  
  inherited Destroy;  
end;  
  
{ TMainOpt }  
  
procedure TMainOpt.SetText(const Value: string);  
begin  
  FText := Value;  
end;  
  
procedure TForm1.Edit1Change(Sender: TObject);  
begin  
  FMainOpt.Text := Edit1.Text;  
end;  
  
procedure TMainOpt.SetHeight(Value: Integer);  
begin  
  FHeight := Value;  
end;  
  
procedure TMainOpt.SetLeft(Value: Integer);  
begin  
  FLeft := Value;  
end;  
  
procedure TMainOpt.SetTop(Value: Integer);  
begin  
  FTop := Value;  
end;  
  
procedure TMainOpt.SetWidth(Value: Integer);  
begin  
  FWidth := Value;  
end;  

В заключение своей статьи хочу сказать, что RTTI является недокументированной возможностью Object Pascal и поэтому информации на эту тему в справочной системе и электронной документации весьма мало. Наиболее легкодоступный способ изучить более подробно эту фишку — просмотр и изучение исходного текста модуля TypInfo.

Добавлено: 07 Августа 2018 07:43:57 Добавил: Андрей Ковальчук

Секреты иконки в системном трее. Часть 1

Наверняка многие, кто начинает программировать на Delphi нередко задавались такими вопросами как:

А как можно поместить иконки приложения в системный трей Windows возле часов?
Как скрыть главную форму приложения при запуске и показывать ее по команде всплывающего меню иконки приложения в системной трее, и как затем скрыть ее обратно?
Знакомо да? Что ж, сам я тоже когда-то был начинающим программистом, и потратил уйму времени и нервов за изучение и поиска решений для всех вышеизложенных вопросов. И именно сейчас я готов изложить Вам все свои знания по части работы с иконкой приложения в системной трее.
Статью я решил разделить на две части. Что содержит каждая из них догадаться не трудно - вопросов, о решении которых я расскажу тоже две.
Итак, это часть 1: "Добавление иконки в системный трей".

В этой части мы научимся:

добавлять, изменять и удалять иконку.
отлавливать события мыши на иконке (наведение, клик, двойной клик и т.д.)
менять иконку во время работы приложения, а также текст всплывающей подсказки.
Начать статью я решил не с описания всевозможных компонентов для данной сферы программинга (которых полным полно в интернете), а с описания азов - WinAPI функций, предназначенных для работы с system tray. Хотя, "функции", как то больно громко получилось. На самом деле она всего одна:


function Shell_NotifyIcon ( dwMessage: Cardinal; lpData: PNotifyIconData ) : LongBool;  

(я привожу Вам упрощенное представление функции сделанное лично мной, т.к. если взять описание функции из WinAPI SDK - понять его будет намного труднее)
подробнее о параметрах:
dwMessage:

Параметр, а точнее команда, которая указывает этой функции что именно она должна делать. Может принимать следующие значения констант:
NIM_ADD - добавляет иконку в трей
NIM_DELETE - удаляет иконку из системного трея
NIM_MODIFY - меняет (обновляет) иконку в системном трее.
lpData:
Сей параметр есть запись, которая содержит всю информацию об добавляемой, удаляемой или изменяемой иконке. Данная запись имеет вид:

_NOTIFYICONDATAA = record
   cbSize: DWORD;
   Wnd: HWND;
   uID: UINT;
   uFlags: UINT;
   uCallbackMessage: UINT;
   hIcon: HICON;
   szTip: array [0..63] of AnsiChar;
end; 

(указатель PNotifyIconData является указателем именно на эту запись)

Давайте рассмотрим, какие именно данные содержит данная запись:
cbSize: Размер данной записи;
Wnd: Handle того окна, которое будет получать сообщения от иконки;
uID: Идентификатор иконки;
uFlags: Здесь содержатся константы, означающие, какие данные верны в записи:
NIF_ICON - hIcon содержит верную информацию.
NIF_MESSAGE - uCallbackMessage содержит верную информацию.
NIF_TIP -szTip содержит верную информацию.
(Подробнее об этом я расскажу ниже)
uCallbackMessage: Назначенный Вами идентификатор сообщения, которое будет получать приложение от иконки.
hIcon: Собственно Handle иконки (TIcon.Handle).
szTip: Текст всплывающей подсказки (не более 64 символов).
Мда, наверняка ничего не понятно, да? ..особенно новичкам. Ничего! Далее я приведу код небольшой программы, написанной лично мной. Весь код программы имеет очень богатые комментарии. С их помощью понять смысл каждого шага Вам будет нетрудно:)

Ниже привожу листинг файла main.pas (файл основной и единственной формы приложения):
Внимание!: в тексте программы прошу не путать два понятия: "иконка" - это то, что собственно находится в системно трее, и "иконка (изображение)" - это то, что содержит то само изображение иконочки.


unit main;  
  
interface  
  
uses  
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,  
  ShellApi, StdCtrls, ExtCtrls, Menus;  
  
type  
  TForm1 = class(TForm)  
    GroupBox1: TGroupBox;  
    TI_Event: TLabel;  
    GroupBox2: TGroupBox;  
    TI_DC: TLabel;  
    GroupBox3: TGroupBox;  
    Icon: TImage;  
    IconFile: TEdit;  
    Browse: TButton;  
    Exit: TButton;  
    About: TButton;  
    OpenDialog1: TOpenDialog;  
    GroupBox4: TGroupBox;  
    ToolTip: TEdit;  
    SetToolTip: TButton;  
    AboutGroupBox: TGroupBox;  
    Desk: TLabel;  
    Author: TLabel;  
    Label3: TLabel;  
    Label4: TLabel;  
    email: TLabel;  
    www: TLabel;  
    procedure FormCreate(Sender: TObject);  
    procedure FormClose(Sender: TObject; var Action: TCloseAction);  
    procedure BrowseClick(Sender: TObject);  
    procedure ExitClick(Sender: TObject);  
    procedure SetToolTipClick(Sender: TObject);  
    procedure wwwClick(Sender: TObject);  
    procedure emailClick(Sender: TObject);  
    procedure AboutClick(Sender: TObject);  
  private  
    { Private declarations }  
  public  
    { Public declarations }  
   procedure IconCallBackMessage( var Mess : TMessage ); message WM_USER + 100;  
   //Здесь мы объявлем процедуру, которая будет выполнятся каждый раз, когда  
   //на иконке будет происходит какое-либо событие (клик мышки и т.п.)  
  end;  
  
var  
  Form1: TForm1;  
  
implementation  
  
{$R *.DFM}  
  
procedure TForm1.FormCreate(Sender: TObject);  
var nid : TNotifyIconData;  
begin  
  //Добавляем иконку в трей при старте программы:  
  with nid do  //Указываем параметры иконки, для чего используем структуру  
               //TNotifyIconData.  
  begin  
    cbSize := SizeOf( TNotifyIconData ); //Размер все структуры  
    Wnd := Form1.Handle; //Здесь мы указывает Handle нашей главной формы  
                         //которая будет получать сообщения от иконки.  
    uID := 1;            //Идентификатор иконки  
    uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; //Обозначаем то, что в  
                                                  //параметры входят:  
                                                  //Иконка, сообщение и текст  
                                                  //подсказки (хинта).  
    uCallbackMessage := WM_USER + 100;            //Здесь мы указываем, какое  
                                                  //сообщение должна  высылать  
                                                  //иконочка нашей главной форме,  
                                                  //в тот момент, когда на ней  
                                                  //(иконке)  происходят  
                                                  //какие-либо события  
    hIcon := Application.Icon.Handle;             //Указываем на Handle  
                                                  //иконки (изображения)  
                                                  //(в данной случае берем  
                                                  //иконку основной формы  
                                                  //приложения. Ниже Вы увидите  
                                                  //как можно ее изменить)  
    StrPCopy(szTip, ToolTip.Text);                //Указываем текст всплывающей  
                                                  //посдказки, который берем из  
                                                  //компонента ToolTip,  
                                                  //расположенного на главной  
                                                  //форме.  
  end;  
  Shell_NotifyIcon( NIM_ADD, @nid );  
  //Собственно добавляем иконку в трей:)  
  //Обратите внимание, что здесь мы исползуем константу  
  //NIM_ADD (добавление иконки).  
  IconFile.Text:=Application.ExeName;  
  //Выводим на главной форме пусть к файлу, который содержит  
  //иконку (изображение):)  
  Icon.Picture.Icon:=Application.Icon;  
  //Теперь выводим на главной форме изображение  
  //иконки (изображения) в увеличенном виде  
end;  
  
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);  
var nid : TNotifyIconData;  
begin  
  with nid do  
  begin  
    cbSize := SizeOf( TNotifyIconData );  
    Wnd := Form1.Handle;  
    uID := 1;  
    uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;  
    uCallbackMessage := WM_USER + 100;  
    hIcon := Application.Icon.Handle;  
    StrPCopy(szTip, ToolTip.Text);  
  end;  
  Shell_NotifyIcon( NIM_DELETE, @nid );  
  //Удаляем иконку из трея. Параметры мы вводим для того,  
  //чтобы функция точно знала, какую именно иконку надо удалять.  
  //Обратите внимание, что здесь мы исползуем константу  
  //NIM_DELETE (удаление иконки).  
end;  
  
procedure TForm1.IconCallBackMessage( var Mess : TMessage );  
var Mouse: TMouse;  
begin  
  case Mess.lParam of  
    //Здесь Вы можете обрабатывать все события, происходящие на иконке:)  
    //На главнй форме я специально расположил две метки, в которых,  
    //при возникновении какого-либо события будет писаться что именно произошло:)  
    //Но, теперь во второй части во время некоторых событий будут происходит  
    //реальные процессы.  
    WM_LBUTTONDBLCLK  : TI_DC.Caption   := 'Двойной щелчок левой кнопкой'       ;  
    WM_LBUTTONDOWN    : TI_Event.Caption:= 'Нажатие левой кнопки мыши'          ;  
    WM_LBUTTONUP      : TI_Event.Caption:= 'Отжатие левой кнопки мыши'          ;  
    WM_MBUTTONDBLCLK  : TI_DC.Caption   := 'Двойной щелчок средней кнопкой мыши';  
    WM_MBUTTONDOWN    : TI_Event.Caption:= 'Нажатие средней кнопки мыши'        ;  
    WM_MBUTTONUP      : TI_Event.Caption:= 'Отжатие средней кнопки мыши'        ;  
    WM_MOUSEMOVE      : TI_Event.Caption:= 'Перемещение мыши'                   ;  
    WM_MOUSEWHEEL     : TI_Event.Caption:= 'Вращение колесика мыши'             ;  
    WM_RBUTTONDBLCLK  : TI_DC.Caption   := 'Двойной щелчок правой кнопкой'      ;  
    WM_RBUTTONDOWN    : TI_Event.Caption:= 'Нажатие правой кнопки мыши'         ;  
    WM_RBUTTONUP      : TI_Event.Caption:= 'Отжатие правой кнопки мыши'         ;  
  end;  
end;  
  
procedure TForm1.BrowseClick(Sender: TObject);  
var I   : TIcon;  
    nid : TNotifyIconData;  
begin  
  //Здесь мы меням иконку приложения, для чего используем диалоговое окно  
  //(для выбора файла, который содержит изображение иконки)  
  //Итак, все потизоньку:  
  if OpenDialog1.Execute then //Запуск диаголового окна  
  begin  
    I:=TIcon.Create; //Создаем объект I типа TIcon  
    I.LoadFromFile(OpenDialog1.Filename); //Теперь загружаем в него изображение  
                                          //из того файла, который был выбран в  
                                          //окне диалогового окна  
    //Далее делаем все тоже самое, что и раньше, создаем структуру типа  
    //TNotifyIconData куда заносим все параметры иконки:)  
    with nid do  
    begin  
      cbSize := SizeOf( TNotifyIconData );  
      Wnd := Form1.Handle;  
      uID := 1;  
      uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;  
      uCallbackMessage := WM_USER + 100;  
      hIcon := I.Handle;  
      StrPCopy(szTip, ToolTip.Text);  
    end;  
    Shell_NotifyIcon( NIM_MODIFY , @nid );  
    //А вот здесь мы заносим изменения в иконку, которая находится в системном  
    //трее обратите внимание, что здесь мы исползуем константу NIM_MODIFY  
    //(изменение иконки).  
    Icon.Picture.Icon:=I;  
    IconFile.Text:=OpenDialog1.FileName;  
    I.Free;  
  end;  
end;  
  
procedure TForm1.ExitClick(Sender: TObject);  
begin  
  //Закрываем приложение.   
  Close;  
end;  
  
procedure TForm1.SetToolTipClick(Sender: TObject);  
var nid : TNotifyIconData;  
begin  
  //Здесь мы назначаем всплывающую посказу:)  
  //Здесь все тоже самое, что и в предыдущей процедуре.  
  //Только иконка (изображение) берется из компонента Icon,  
  //который назодится на главной форме:)  
  //А текст всплывающей посказки берем из  
  //компонента ToolTip (который расположен на главной форме)  
  with nid do  
  begin  
      cbSize := SizeOf( TNotifyIconData );  
      Wnd := Form1.Handle;  
      uID := 1;  
      uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;  
      uCallbackMessage := WM_USER + 100;  
      hIcon := Icon.Picture.Icon.Handle;  
      StrPCopy(szTip, ToolTip.Text);  
  end;  
  Shell_NotifyIcon( NIM_MODIFY , @nid );  
  //.. и снова меням иконку:)  
end;  
  
//Далее идут процедуры, относящие работе сведений о программе  
//Тут нет ничего сложного :-)  
procedure TForm1.wwwClick(Sender: TObject);  
begin  
  ShellExecute(Application.Handle,'open','http://delphi.hostmos.ru',nil,nil,0);  
end;  
  
procedure TForm1.emailClick(Sender: TObject);  
begin  
  ShellExecute(Application.Handle,'open','mailto:srustik@rambler.ru',nil,nil,0);  
end;  
  
procedure TForm1.AboutClick(Sender: TObject);  
begin  
  if Form1.Width=250 then  
  begin  
    Form1.Width:=430;  
    About.Caption:='О Программе <<';  
  end  
  else begin  
    Form1.Width:=250;  
    About.Caption:='О Программе >>';  
  end;  
  AboutGroupBox.Visible:=not AboutGroupBox.Visible;  
end;  
  
end.  
end.  

Вот в принципе и все:) Надеюсь данная часть помогла Вам понять азы работы с системным треем:)

Автор: Рустик

Добавлено: 07 Августа 2018 07:42:27 Добавил: Андрей Ковальчук