Полезные функции работы со строками

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

Перейдем от слов к делу, надо уже скорее знакомить Вас с этими функциями! Первая, которую я предложу Вам проверяет есть ли подстрока в строке, и если есть - возвращает true, иначе - false.

Функция эта выглядит так:


function MatchStrings(source, pattern: String): Boolean;  
var  
  
pSource: Array [0..255] of Char;  
pPattern: Array [0..255] of Char;  
  
  
function MatchPattern(element, pattern: PChar): Boolean;  
  
  
function IsPatternWild(pattern: PChar): Boolean;  
var  
t: Integer;  
begin  
Result := StrScan(pattern,'*') <> nil;  
if not Result then Result := StrScan(pattern,'?') <> nil;  
end;  
  
  
begin  
if 0 = StrComp(pattern,'*') then  
Result := True  
else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then  
Result := False  
else if element^ = Chr(0) then  
Result := True  
else begin  
case pattern^ of  
'*': if MatchPattern(element,@pattern[1]) then  
Result := True  
else  
Result := MatchPattern(@element[1],pattern);  
'?': Result := MatchPattern(@element[1],@pattern[1]);  
else  
if element^ = pattern^ then  
Result := MatchPattern(@element[1],@pattern[1])  
else  
Result := False;  
end;  
end;  
end;  
  
begin  
  
StrPCopy(pSource,source);  
StrPCopy(pPattern,pattern);  
Result := MatchPattern(pSource,pPattern);  
end;  

Использовать ее нужно примерно так:


MatchStrings('Михаил' , '*' + 'Михаил автор данной статьи' + '*');  

Вызов этой функции в данном примере возвратит true, так как строка 'Михаил' содержится в строке 'Михаил автор этой статьи'. Символы '*' нужны для корректности работы функции. Разберем небольшой пример, будем вводить текст в поле Edit1, и искать его в Memo1, по нажатию на командной кнопке Button1. Итак, разместим перечисленные компоненты на форме. Скопируйте описание функции и поместите его после


implementation  
  
{$R *.DFM}  
А обработчик нажатия на командную кнопку может иметь такой вид:


procedure TForm1.Button1Click(Sender: TObject);  
var i:integer;  
n_sov:integer;//число совпадений  
begin  
n_sov:=0;  
for i:= 0 to memo1.Lines.Count-1 do  
begin  
if matchstrings(memo1.lines[i],'*'+edit1.text+'*') = true then  
inc(n_sov) else;  
end;  
showmessage(inttostr(n_sov));  
end;  
На всякий случай :) приведу полный код примера:


unit Unit1;  
  
interface  
  
uses  
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,  
StdCtrls;  
  
type  
TForm1 = class(TForm)  
Memo1: TMemo;  
Edit1: TEdit;  
Button1: TButton;  
procedure Button1Click(Sender: TObject);  
private  
{ Private declarations }  
public  
{ Public declarations }  
end;  
  
var  
Form1: TForm1;  
  
implementation  
  
{$R *.DFM}  
  
function MatchStrings(source, pattern: String): Boolean;  
var  
  
pSource: Array [0..255] of Char;  
pPattern: Array [0..255] of Char;  
  
  
function MatchPattern(element, pattern: PChar): Boolean;  
  
  
function IsPatternWild(pattern: PChar): Boolean;  
var  
t: Integer;  
begin  
Result := StrScan(pattern,'*') <> nil;  
if not Result then Result := StrScan(pattern,'?') <> nil;  
end;  
  
  
begin  
if 0 = StrComp(pattern,'*') then  
Result := True  
else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then  
Result := False  
else if element^ = Chr(0) then  
Result := True  
else begin  
case pattern^ of  
'*': if MatchPattern(element,@pattern[1]) then  
Result := True  
else  
Result := MatchPattern(@element[1],pattern);  
'?': Result := MatchPattern(@element[1],@pattern[1]);  
else  
if element^ = pattern^ then  
Result := MatchPattern(@element[1],@pattern[1])  
else  
Result := False;  
end;  
end;  
end;  
begin  
  
StrPCopy(pSource,source);  
StrPCopy(pPattern,pattern);  
Result := MatchPattern(pSource,pPattern);  
end;  
  
procedure TForm1.Button1Click(Sender: TObject);  
var i:integer;  
n_sov:integer;//число совпадений  
begin  
n_sov:=0;  
for i:= 0 to memo1.Lines.Count-1 do  
begin  
if matchstrings(memo1.lines[i],'*'+edit1.text+'*') = true then  
inc(n_sov) else;  
end;  
showmessage(inttostr(n_sov));  
end;  
  
end.  

Если вдруг кто-то не знает, то функция inc(x:ordinal); увеличивает число на единицу (а функция Dec - уменьшает). Таким образом мы просто проходим в цикле все строки Memo1 и ищем совпадения. К сожалению эта функция умеет только указывать если подстрока в строке, но неплохо было бы ее доработать, чтобы она возвращала позицию символа, с которого начинается совпадение. Если у вас есть идеи, то пожалуйста пишите!

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


function ReplaceSub(str, sub1, sub2: String): String;  
var  
aPos: Integer;  
rslt: String;  
begin  
aPos := Pos(sub1, str);  
rslt := '';  
while (aPos <> 0) do begin  
rslt := rslt + Copy(str, 1, aPos - 1) + sub2;  
Delete(str, 1, aPos + Length(sub1) - 1);  
aPos := Pos(sub1, str);  
end;  
Result := rslt + str;  
end;  

Эта функция заменяет Sub1 на Sub2 в строке Str и возвращает измененную строку.

Сразу усовершенствуем наш пример, дабы разобраться с использованием этой функции. Добавьте на форму еще одно текстовое поле Edit2. В Edit1 будем вводить слово, которое надо заменить, а в поле Edit2 слово, на которое надо заменить.

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


procedure TForm1.Button1Click(Sender: TObject);  
var i:integer;  
n_sov:integer;  
begin  
n_sov:=0;  
for i:= 0 to memo1.Lines.Count-1 do  
begin  
if matchstrings(memo1.lines[i],'*' +edit1.text+ '*') = true  
    then begin  
    Memo1.lines[i]:=ReplaceSub(memo1.lines[i],edit1.text,edit2.text);  
    inc(n_sov);  
    end;  
end;  
showmessage(inttostr(n_sov));  
end;  

Ну и опять, на всякий случай, приведу полный код примера:


unit Unit1;  
  
interface  
  
uses  
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,  
StdCtrls;  
  
type  
TForm1 = class(TForm)  
Memo1: TMemo;  
Edit1: TEdit;  
Button1: TButton;  
Edit2: TEdit;  
procedure Button1Click(Sender: TObject);  
private  
{ Private declarations }  
public  
{ Public declarations }  
end;  
  
var  
Form1: TForm1;  
  
implementation  
  
{$R *.DFM}  
  
function MatchStrings(source, pattern: String): Boolean;  
var  
  
pSource: Array [0..255] of Char;  
pPattern: Array [0..255] of Char;  
  
  
function MatchPattern(element, pattern: PChar): Boolean;  
  
  
function IsPatternWild(pattern: PChar): Boolean;  
var  
t: Integer;  
begin  
Result := StrScan(pattern,'*') <> nil;  
if not Result then Result := StrScan(pattern,'?') <> nil;  
end;  
  
  
begin  
if 0 = StrComp(pattern,'*') then  
Result := True  
else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then  
Result := False  
else if element^ = Chr(0) then  
Result := True  
else begin  
case pattern^ of  
'*': if MatchPattern(element,@pattern[1]) then  
Result := True  
else  
Result := MatchPattern(@element[1],pattern);  
'?': Result := MatchPattern(@element[1],@pattern[1]);  
else  
if element^ = pattern^ then  
Result := MatchPattern(@element[1],@pattern[1])  
else  
Result := False;  
end;  
end;  
end;  
begin  
  
StrPCopy(pSource,source);  
StrPCopy(pPattern,pattern);  
Result := MatchPattern(pSource,pPattern);  
end;  
  
function ReplaceSub(str, sub1, sub2: String): String;  
var  
aPos: Integer;  
rslt: String;  
begin  
aPos := Pos(sub1, str);  
rslt := '';  
while (aPos <> 0) do begin  
rslt := rslt + Copy(str, 1, aPos - 1) + sub2;  
Delete(str, 1, aPos + Length(sub1) - 1);  
aPos := Pos(sub1, str);  
end;  
Result := rslt + str;  
end;  
  
  
procedure TForm1.Button1Click(Sender: TObject);  
var i:integer;  
n_sov:integer;  
begin  
n_sov:=0;  
for i:= 0 to memo1.Lines.Count-1 do  
begin  
if matchstrings(memo1.lines[i],'*' +edit1.text+ '*') = true  
then begin  
Memo1.lines[i]:=ReplaceSub(memo1.lines[i],edit1.text,edit2.text);  
inc(n_sov);  
end;  
end;  
showmessage(inttostr(n_sov));  
end;  
  
end.  

На этом пока все. Надеюсь сумело помочь Вам в Ваших начинаниях

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

Поиск файлов на винчестере

Хотя я и не очень хороший "Делфер", но я очень люблю программировать в Delphi, делать маленькие полезные программки для себя и своего компьютера. Недавно я узнал как производить поиск файлов на компьютере, причем поиск файлов производится не в отдельном каталоге, а на всем винчестере и в процессе поиска возможно следить за поиском. Процедуре поиска я нашел очень широкое применение, например, у меня на компьютере имеется папка с исходниками по Delphi и в этой папки очень много лишних файлов, которые занимают место на винчестере и при помощи процедуры поиска я удаляю ненужные файлы (*.cfg; *.~dfm; *.~pas и др.).

Начнем с описания процедуры FindResursive( Const path: String; Const mask: String) где переменная Path - каталог в котором будет производится поиск ('c:\'), а Mask - название файла или его часть ('*.exe' или '*.*' или 'project.dpr').

В самой процедуре будем использовать только одну (не считая вложенные функции)переменную, которая будет носить полное название найденного файла. А найденные файлы будем записывать в ListBox. Данную процедуру будем вызывать при нажатии кнопки. Процедура FindRecursive выглядит следующим образом:


Procedure FindRecursive( Const path: String; Const mask: String);  
  Var  
    fullpath: String;  
  Function Recurse( Var path: String; Const mask: String ): Boolean;  
    Var  
      SRec: TSearchRec;  
      retval: Integer;  
      oldlen: Integer;  
    Begin  
      Recurse := True;  
      oldlen := Length( path );  
      retval := FindFirst( path+mask, faAnyFile, SRec );  
      While retval = 0 Do Begin  
        If (SRec.Attr and (faDirectory or faVolumeID)) = 0 Then  
        form1.ListBox1.items.Add(path+srec.name);  
        retval := FindNext( SRec );  
      End;  
      FindClose( SRec );  
      If not Result Then Exit;  
      retval := FindFirst( path+'*.*', faDirectory, SRec );  
      While retval = 0 Do Begin  
        If (SRec.Attr and faDirectory) <> 0 Then  
          If (SRec.Name <> '.') and (SRec.Name <> '..') Then Begin  
            path := path + SRec.Name + '\';  
            If not Recurse( path, mask ) Then Begin  
              Result := False;  
              Break;  
            End;  
            Delete( path, oldlen+1, 255 );  
          End;  
        retval := FindNext( SRec );  
      End;  
      FindClose( SRec );  
    End; { Recurse }  
  Begin  
    If path = '' Then  
      GetDir(0, fullpath)  
    Else  
      fullpath := path;  
    If fullpath[Length(fullpath)] <> '\' Then  
      fullpath := fullpath + '\';  
    If mask = '' Then  
      Recurse( fullpath, '*.*' )  
    Else  
      Recurse( fullpath, mask );  
  End;  

В целом же программа выглядит так:


unit Unit1;  
  
interface  
  
uses  
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
  Dialogs, StdCtrls;  
  
type  
  TForm1 = class(TForm)  
    ListBox1: TListBox;  
    Button1: TButton;  
    procedure Button1Click(Sender: TObject);  
  private  
    { Private declarations }  
  public  
    { Public declarations }  
  end;  
  
var  
  Form1: TForm1;  
  
implementation  
  
{$R *.dfm}  
Procedure FindRecursive( Const path: String; Const mask: String);  
  Var  
    fullpath: String;  
  Function Recurse( Var path: String; Const mask: String ): Boolean;  
    Var  
      SRec: TSearchRec;  
      retval: Integer;  
      oldlen: Integer;  
    Begin  
      Recurse := True;  
      oldlen := Length( path );  
      retval := FindFirst( path+mask, faAnyFile, SRec );  
      While retval = 0 Do Begin  
        If (SRec.Attr and (faDirectory or faVolumeID)) = 0 Then  
        form1.ListBox1.items.Add(path+srec.name); {добавление}  
        {очередного найденного файла в ListBox}  
       {-------------------------------------}  
       {здесь можно производить слежением за выполнение процедуры}  
       {например, поставить ProgressBar}  
        retval := FindNext( SRec );  
      End;  
      FindClose( SRec );  
      If not Result Then Exit;  
      retval := FindFirst( path+'*.*', faDirectory, SRec );  
      While retval = 0 Do Begin  
        If (SRec.Attr and faDirectory) <> 0 Then  
          If (SRec.Name <> '.') and (SRec.Name <> '..') Then Begin  
            path := path + SRec.Name + '\';  
            If not Recurse( path, mask ) Then Begin  
              Result := False;  
              Break;  
            End;  
            Delete( path, oldlen+1, 255 );  
          End;  
        retval := FindNext( SRec );  
      End;  
      FindClose( SRec );  
    End; { Recurse }  
  Begin  
    If path = '' Then  
      GetDir(0, fullpath)  
    Else  
      fullpath := path;  
    If fullpath[Length(fullpath)] <> '\' Then  
      fullpath := fullpath + '\';  
    If mask = '' Then  
      Recurse( fullpath, '*.*' )  
    Else  
      Recurse( fullpath, mask );  
  End;  
  
  
procedure TForm1.Button1Click(Sender: TObject);  
begin  
FindRecursive('d:\','*.*'); {вместо 'd:\' можно написать лубой каталог}  
end;  

Автор: Михаил Христосенко

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

Поиск файлов на Delphi

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

Для поиска файлов на диске в Delphi существует две функции, первая из них - это FindFirst, ниже приведено ее описание:


function FindFirst(const Path: string; Attr: Integer; var F: TSearchRec): Integer;  

Path - путь, по которому искать файл, включая его имя и расширение (возможно использовать символ *).

attr - атрибуты файла. Может принимать следующие значения:

faReadOnly $00000001 Только чтение
faHidden $00000002 Скрытый
faSysFile $00000004 Системный
faVolumeID $00000008 Метка диска
faDirectory $00000010 Директория
faArchive $00000020 Обычный
faAnyFile $0000003F Любой файл

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


type  
    TSearchRec = record  
    Time: Integer; // время создания  
    Size: Integer; //размер файла в байтах  
    Attr: Integer; // Атрибуты  
    Name: TFileName; //имя файла  
    ExcludeAttr: Integer;   
    FindHandle: THandle; //хандл на файл  
    FindData: TWin32FindData; //доп. информация о файле  
end;  

Теперь приведу простой пример использования этой функции. Поставьте на форму одну кнопку TButton, а обработчик события OnClick у нее должен иметь примерно такой вид:


procedure TForm1.Button1Click(Sender: TObject);  
 var sr:TSearchRec;  
 begin  
 findFirst('*.exe',faAnyFile,sr);  
 edit1.Text:=sr.Name;  
 end;  

Чтобы искать следующий такой же файл, надо написать FindNext (Sr); Если файл найден, то процедуры FindFirst и FindNext возвращают 0 (зеро).

Ну а теперь собственно о том, как можно применить эти функции на практике, то есть опять пример!!! Чтобы разобраться с использованием этих функций попробуем написать программку, которая выдавала список всех программ с расширением *.exe в указанной директории, а затем при нажатии на кнопку включалась бы выбранная программа. На примере я покажу, как найти все .exe файлы в директории Windows, а затем объясню как можно модифицировать программку!

Итак, ставим на форму компонент TListBox в него мы будем выводить список найденных файлов. Обработчик события OnClick для нашей первой кнопки заменяем на такой:


procedure TForm1.Button1Click(Sender: TObject);  
var sr:TSearchRec;  
Result:word;  
begin  
    ChDir('C:\windows');//меняем папку на C:\Windows  
    Result := FindFirst ('*.exe',faAnyFile,sr);  
    ListBox1.Clear;  
    While result=0 do  
Begin  
    Result:=FindNext (sr);  
    ListBox1.Items.add(sr.name);  
End;  
end;  

Как видите мы просто организовали цикличный проход по директории C:\Windows, который прекращается, как только функции возвращает не ноль! Функция ChDir была использована для смены папки с текущей на папку C:\windows\

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

У меня расширенная процедура поиска выглядит вот так:


procedure ffind(cat:string); //каталог, откуда начать поиск  
var sea:TSearchRec;  
res:integer; //результат поиска (0 или нет)  
begin  
res:=FindFirst(cat+'*.*',faAnyFile,sea); //ищем первый файл  
res:=findNext(sea);//ищем следующий файл  
While res=0 do  
begin  
if (Sea.Attr=faDirectory) and ((Sea.Name='.')or(Sea.Name='..')) then//чтобы не было файлов . и..  
begin  
Res:=FindNext(sea);  
Continue;//продолжаем цикл  
end;  
  
if (Sea.Attr=faDirectory) then//если нашли директорию, то ищем файлы в ней  
begin  
Ffind(cat+Sea.Name+'\');//рекурсивно вызываем нашу процедуру  
Res:=FindNext(Sea);//ищем след. файл  
Continue;//продолжаем цикл  
end;  
form1.ListBox1.Items.Add(Sea.Name);//добавляем в Listbox:Tlistbox имя файла  
Res:=FindNext(Sea);//ищем след. файл  
end;  
FindClose(Sea);//освобождаем пересенную поиска  
end;  

Здесь была использована процедура FindClose(var sea: TsearchRec); она необходима для освобождения поисковой переменной. В следующих примерах ее я использовать не буду, но Вы имейте ее в виду!!!

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

Теперь поставьте на форму еще кнопку для того, чтобы по ее нажатии запускать выбранную в ListBox'e программу. Обработчик события Onclick для нашей второй кнопки у меня получился таким:


procedure TForm1.Button2Click(Sender: TObject);  
begin  
    WinExec(pchar(listbox1.Items[listbox1.itemindex]),sw_show);  
end;  

Поскольку файлы находятся в директории Windows, то при вызове метода WinExec путь к файлам можно не указывать, а если вы используете какую-либо другую директорию, то вызов метода WinExec должен быть примерно таким:


WinExec(pchar('C:\Путь к вашей папке\'+listbox1.Items[listbox1.itemindex]),sw_show);   

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


DirectoryListBox1.Directory  

Поэтому в обработчике первой кнопки нужно убрать вызов функции ChDir. А в обработчике второй кнопки вставить приведенную выше конструкцию.

Таким образом приведу полный код приложения, которое получилось у меня с использованием компонента DirectoryListBox


unit Unit1;  
  
interface  
  
uses  
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,  
StdCtrls, FileCtrl;  
  
type  
TForm1 = class(TForm)  
Edit1: TEdit;  
Button1: TButton;  
ListBox1: TListBox;  
Button2: TButton;  
DirectoryListBox1: TDirectoryListBox;  
procedure Button1Click(Sender: TObject);  
procedure Button2Click(Sender: TObject);  
private  
{ Private declarations }  
public  
{ Public declarations }  
end;  
  
var  
Form1: TForm1;  
  
implementation  
  
{$R *.DFM}  
  
procedure TForm1.Button1Click(Sender: TObject);  
var sr:TSearchRec;  
Result:word;  
begin  
Result := FindFirst ('*.exe',faAnyFile,sr);  
ListBox1.Clear;  
While result=0 do  
Begin  
Result:=FindNext (sr);  
ListBox1.Items.add(sr.name);  
End;  
end;  
  
procedure TForm1.Button2Click(Sender: TObject);  
begin  
WinExec(pchar(DirectoryListBox1.Directory+'\'+listbox1.Items[listbox1.itemindex]),sw_show);  
end;  
  
end.  

Ну вот и все :)) Надеюсь, что помог Вам своими рассуждениями и примерами!

Автор: Михаил Христосенко

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

Подгружаемые модули (plugins) в Delphi

Введение

Когда я впервые столкнулся с задачей организации подгружаемых в RunTime модулей (plugins) для Delphi-программ, ответ нашелся достаточно быстро. Как это иногда бывает в подобных ситуациях, я не особо задумался о том, как подобную задачу решают другие разрабточики.

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

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

В то же время меня часто спрашивали, каким образом можно создать удобный механизм plugin'ов и я описывал свой метод. Метод, предлагаемый мною, основан на использовании механизма, которым пользуется сама Delphi IDE - пакеты (packages).

Проблема (недостатки DLL-plugin'ов)
Все используемые модули компилируются в DLL

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

Модули дублируются

Предыдущий недостаток является количественным, т.е. просто увеличивающим размер проекта. Но из него вытекает качественный недостаток. Рассмотрим его на примере. Пусть вам надо создать подгружаемые разборщики пакетов. Вы определяете абстрактный класс TParser в модуле UParser и хотите, чтобы все разборщики наследовали от него. Но для того, чтобы вы могли описать в DLL потомок от TParser, вы должны включить модуль UParser в список uses для DLL. А для того, чтобы основная программа могла обращаться с TParser и его потомками, в нее также должен быть включен uses UParses,.... Неприятность заключается в том, что эти модули будут находиться в памяти дважды и тот TParser, о котором знает основная программа не совпадает с тем, который знает plugin.

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

Средство (пакеты и функции для работы с ними)
Пакеты появились в третьей версии Delphi. Что такое пакет? Пакет - это набор компилированных модулей, объединенных в один файл. Исходный текст пакета, хранящий я в файлах .dpk содержит только указания на то, какие модули содержит (contains) этот пакет (здесь "содержит" означает также "предоставляет") и на какие другие пакеты он ссылается (requires). При компиляции пакета получается два файла - *.dcp и *.dpl. Первый используется просто как библиотека модулей. Нам же больше интересен второй.

Основной особенностью пакетов является то, что не включают в себя код, которым пользуются. Т.е. если некоторые модули используют большую библиотеку функций и классов, то можно потребовать их наличия, но не включать в пакет. Вы спросите, что же тут нового, ведь обычные модули тоже не включают в .dcu-файл весь используемый код? А нового здесь то, что dpl-пакет является полноправной DLL специального формата (т.е. с оговоренными разработчиками Delphi именами экспортируемых процедур). При загрузке пакета в память автоматически устанавливаются связи с уже загруженными пакетами, а если загружаемый пакет требует наличия еще каких-то пакетов, то загружаются и они. Кроме того, в отличие от обычных модулей, программа, использующая модули из внешнего пакета тоже не обязана включать его код. Таким образом, можно писать EXE-программы размеров в несколько десятков килобайт (естественно, будет требоваться наличие на диске соответствующего пакета, который затем подгрузится).

Функции для работы с пакетами сосредоточены в модуле SysUtils. Нас будут интересовать следующие из них:


function LoadPackage(const Name: string): HMODULE;  

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


procedure UnloadPackage(Module: HMODULE);  

Выгружает заданный пакет из памяти.

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

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

В отличие от dll-plugin'ов, вы привязываетесь к Delphi и C++ Builder'у (или это плюс ? :) ).
Конечно, существуют некоторые накладные расходы на обеспечение интерфейса пакета - самый маленький пакет имеет не нулевую длину. Кроме того, умный линкер Delphi не сможет выкинуть лишние процедуры из совместно используемых пакетов - ведь любой метод может быть затребован позже, каким-то другим внешним пакетом. Поэтому возможно увеличение размера суммарного кода программы. Это увеличение практически не заметно, если разделяемый пакет содержит только интерфейс для plugin'а и существенно больше, если необходимо разделить стандартные пакеты VCL. Впрочем, это легко окупается, если plugin'ов много. Кроме того, стандартные пакеты могут использоваться разными программами.
Возможно самый существенный недостаток, вытекающий из предыдущего. Пакет неделим, потому что неизвестно, какие его процедуры понадобятся, поэтому он грузится в память целиком. Даже если вы используете одну единственную функцию из пакета, не вызывающую другие и не ссылающуюся на другие ресурсы пакета, пакет грузится в память целиком. Это, опять таки, не очень заметно, если в пакете только голый интерфейс с небольшим количеством процедур. Но если это несколько стандартных пакетов VCL, то занимаемая программой память может увеличиться очень существенно (на несколько мегабайт). Впрочем, это снова окупается, если вы используете большое количество plugin'ов - если бы они были оформлены в виде dll, то каждая из них содержала бы приличную часть стандартных модулей и они держались бы в памяти одновременно. Фактически, предлагаемый метод является более масштабируемым, т.е. издержки начинают снижаться при увеличении количества plugin'ов.
Метод (что делаем, и что получим)
Предлагемая структура построения пиложения выглядит следующим образом: выполяемый код = Основная программа + Интерфейс plugin'ов + plugin. Все три перечисленные компоненты должны находиться в разных файлах (программа - в EXE, остальное - в пакетах BPL). Программа умеет загружать пакеты в память и обращаться к подгруженным потомкам абстрактного plugin'а. Plugin представляет собой потомок абстрактного класса, объявленного в интерфейсном модуле. Программа и plugin используют модуль интерфейса, но он находится в отдельном пакете и в памяти будет присутствовать в единственном екземпляре.

Остался единственный вопрос - как основная программа получит ссылки на объекты или на классы (class references) нужного типа? Для этого в интерфейсном модуле хранится диспетчер plugin'ов или, в простейшем случае, просто TList, в который каждый модуль заносит ставшие доступными классы. В более развитом случае диспетчер классов может обеспечивать поиск подгруженных классов, являющихся потомками заданного, приоритеты при загрузке, и.т.д.

Ясно, что мы достигли поставленой цели - избыточности кода нет (при условии, что все библиотеки, в том числе и стандартные библиотеки VCL, используются в виде пакетов), написание plugin'а упрощено до предела. Чего можно добиться еще?

А можно добиться еще более интересной вещи. Если мы всю основную програму поместим в пакет, а EXE-файл будет включать в себя только процедуру создания и открытия основной формы, то внешний plugin может получить полный доступ ко всем модулям программы, в том числе и к главной форме. Таким образом мы можем написать plugin, который самостоятельно, без каких-либо усилий со стороны головной программы, поместит свой пункт в главное меню и кнопку на панель инструментов, по команде которых будет вызываться внешний код. Это то, ради чего стоит задуматься над использованием предложенного метода - положив в определенный каталог маленький (в нем только ваш код) plugin, вы добавляете к программе очередную возможность, не перекомпилируя основной программы.

Подгружаемые модули (plugins) в Delphi: Пример 1
Постановка задачи

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

Мы создадим один предопределенный класс, экспортирующий строки в текствый файл и один внешний plugin, содержащий класс, который умеет экспортировать строки....ну, скажем, в HTML. Экспорт в Excel или в БД выведет нас за тонкую границу примера.

Абстрактный класс

Итак, рассмотрим определение абстрактного класса:


unit UExporter;  
{ ============================================= }  
interface  
{ ============================================= }  
type  TExporter = class    
public  
    class function ExporterName: string; virtual; abstract;  
    procedure BeginExport; virtual; abstract;  
    procedure ExportNextString(const s:string); virtual; abstract;  
    procedure EndExport; virtual; abstract;  end;  
{ ============================================= }  
implementation  
{ ============================================= }  
end  

Я надеюсь, никто не упрекнет меня за чрезмерное усложнение примера :) . А тех, кто, прочитав этот кусочек кода, закричит громким голосом "Это можно было сделать и в dll !" я отсылаю к размышлениям о размерах dll. Ведь потомки TExporter в методе BeginExport запросто могут выводить форму настройки экспорта.

Менеджер классов

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


unit UClassManager;  
{ ============================================= }  
interface  
{ ============================================= }  
uses  Classes;    
type  
  TClassManager = class(TList);  
  
function ClassManager: TClassManager;  
{ ============================================= }  
implementation  
{ ============================================= }  
var  Manager: TClassManager;  
function ClassManager: TClassManager;  
begin    
    Result := Manager;  
end;  
{ ============================================= }  
initialization  
{ ============================================= }  
Manager := TClassManager.Create;  
{ ============================================= }  
finalization  
{ ============================================= }  
Manager.Free;  
end  

В этом коде, по моему, пояснять нечего.

Экспорт в простой текстовый файл

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


unit UPlainFileExporter;  
{ ============================================= }  
interface  
{ ============================================= }  
uses  Classes, UExporter;  
type  
  TPlainFileExporter = class(TExporter)    
    private    F: TextFile;    
    public  
        class function ExporterName: string; override;  
        procedure BeginExport; override;  
        procedure ExportNextString(const s:string); override;  
        procedure EndExport; override;    
    end;  
{ ============================================= }     
implementation  
{ ============================================= }  
uses  
  Dialogs, SysUtils, UClassManager;{ TPlainFileExporter }  
procedure TPlainFileExporter.BeginExport;  
var  OpenDialog : TOpenDialog;  
begin  
    OpenDialog := TOpenDialog.Create(nil);    
    try    if OpenDialog.Execute then  
    begin        
        AssignFile(F,OpenDialog.FileName);        
        Rewrite(F);      
    end  
    else        
        Abort;    
    finally      
        OpenDialog.Free;    
    end;  
end;  
  
procedure TPlainFileExporter.EndExport;  
begin    
    CloseFile(F);  
end;  
  
class function TPlainFileExporter.ExporterName: string;  
begin  
  Result := 'Экспорт в текстовый файл';  
end;  
  
procedure TPlainFileExporter.ExportNextString(const s: string);  
begin  
  WriteLn(F, s);  
end;  
{ ============================================= }  
initialization  
{ ============================================= }  
ClassManager.Add(TPlainFileExporter);  
{ ============================================= }  
finalization  
{ ============================================= }  
ClassManager.Remove(TPlainFileExporter);  
end  

Мы считаем, что коррестность вызова методов BeginExport и EndExport обеспечит головная программа и не задумываемся о возможных неприятностях с открытым файлом. Кроме того, следует отметить, что используется модуль Dialogs, который использует Forms и т.п. И наконец, обратите внимание на разделы initialization и finalization модуля - мы используем возможность Delphi ссылаться на класс, как на объект.

Основная программа

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


procedure TMainForm.RefreshPluginList;  
var  i : Integer;  
begin  
    PluginsBox.Items.Clear;    
    for i := 0 to ClassManager.Count - 1 do  
        PluginsBox.Items.Add(TExporterClass(ClassManager[i]).ExporterName);  
end;  

Эта процедура просматривает список зарегистрированных классов (предполагается, что там только потомки TExporter) и выводит их "читабельные" имена в ListBox.


procedure TMainForm.LoadBtnClick(Sender: TObject);  
begin  
  PluginModule := LoadPackage(ExtractFilePath(ParamStr(0)) + 'HTMLPluginProject.bpl');  
  RefreshPluginList;  
end;  

Эта процедура загружает пакет с "зашитым" именем (ну это же просто пример :) ) и запоминает его handle. После чего происходит обновление списка, чтобы вы могли убедиться, что новый класс зарегистрировался.


procedure TMainForm.UnloadBtnClick(Sender: TObject);begin  
  UnloadPackage(PluginModule);  RefreshPluginList;end;  

Ну тут, я думаю, все ясно.


procedure TMainForm.ExportBtnClick(Sender: TObject);  
var ExporterClass: TClass;  
    Exporter: TExporter;    
    i: Integer;  
begin    
    if PluginsBox.ItemIndex < 0 then   
        Exit;        
  
    ExporterClass := ClassManager[PluginsBox.ItemIndex];  
    Exporter := TExporter(ExporterClass.Create);    
  
    try    Exporter.BeginExport;  
        try        
            for i := 0 to StringsBox.Lines.Count - 1 do  
                Exporter.ExportNextString(StringsBox.Lines[i]);      
        finally  
            Exporter.EndExport      
        end;    
    finally      
        Exporter.Free;    
    end;  
end;  

Эта процедура производит экспорт строк с помощью зарегистрированного класса plugin'а. Мы пользуемся тем, что нам известен абстрактный класс, так что мы спокойно можем вызывать соответствующие методы. Здесь следует обратить внимание на процесс создания экземпляра класса plugin'а.

Компиляция

Разверните архив в какой-то каталог ( например c:\bebebe :) ) и откройте группу проектов Demo1ProjectGroup.bpg. Использование группы полезно, так как вам часто придется переключаться между основной программой и двумя пакетами - это разные проекты. Я надеюсь, что если вы нажмете "Build All Projects" то все успешно скомпилится.

Поглядев на опции головного проекта, вы увидите, что на страничке Packages указано, какие из используемых пакетов не прилинковывать к exe-файлу. Следует отметить, что даже если вы включите туда только PluginInterfaceProject, то автоматом будут считаться внешними и все, используемые им пакеты - в нашем случае Vcl5.dpl. Зато если вы положите на основную форму какой-то компонент работы с BDE, то пакет VclDB5.bpl может быть прикомпилирован (с оптимизацией, естественно) к EXE-файлу.

Что еще можно сказать? Пожалуй, стоит отметить, что "возня" с пакетами нередко бывает утомительна и чревата "непонятными ошибками" вплоть до зависания Delphi. Однако все они в итоге оказываются следствием неаккуратности разработчика - ведь связывание на этапе выполнения это не простая штука. Поэтому следите, куда вы компилируете пакеты, следите за своевременной перекомпиляцией plugin'ов, если изменился абстрактный класс, следите, чтобы у вас на машине не валялось 10 копий dpl-пакета, потому как вы можете думать, что программа загрузит лежащий там-то и ошибетесь.

Еще. По умолчанию файлы .dcu кладутся вместе с исходниками, а пакеты - в каталог ($DELPHI)\Projects\Bpl. В примере настроки правильные - пакеты создадутся в каталоге исходников. Пожелания, вопросы, благодарности и ругань приму по адресу iamhere@ipc.ru. На все, кроме ругани постараюсь ответить.

Автор: Трофимов Игорь

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

Пишем правильные диалоги

Очень часто возникает необходимость вызвать модальное окно с полем ввода, значение которого нужно использовать в главной форме как вы обычно это делаете?
Раньше я делал так:


begin  
  somedialog:=Tsomedialog.Create;  
  if somedialog.ShowModal = MrOk then  
  begin  
    lable1.Caption:=somedialog.edit1.text;  
  end;  
end;  

и... был 3 раза не прав.

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

Предположим у нас на модальной форме 10 контролов, значения которых мы должны использовать. Значит нам придется 10 раз ссылаться на эти контролы из других форм:


begin  
   lable1.Caption:=somedialog.edit1.text;  
   lable2.Caption:=somedialog.edit2.text;  
   ...  
   lable10.Caption:=somedialog.edit10.text;  
end;   

К тому же данное окно будет вызываться допустим из 5 модулей...

А теперь представьте себе, что вы что-то изменили в этом диалоговом окне, например, у вас возникла необходимость дать нормальные названия всем контролам (типа edtName,edtLastname).

Сколько Вам придется всего переделывать. Кроме того вероятно что данный диалоговый модуль придется использовать в другом проекте - та же самая история.

Какой же выход?
Создадим скелет нашего будущего диалога:


unit dialog;  
interface  
uses  
..;  
type  
  TMyDlg = class(TForm)  
  private  
    { Private declarations }  
  public  
    { Public declarations }  
  end;  
  
var  
  MyDlg: TMyDlg;  
  
implementation  
uses ...;  
  
{$R *.DFM}  
  
function TMyDlg.Execute: boolean;  
begin  
  if ShowModal = mrOk then begin  
    result := true;  
  end else begin  
    result := false;  
  end;  
end;  
  
end;  

Вызывать наш диалог будем следующим образом:


with TMyDlg.Create(nil) do  
try  
  if execute then  
    ...  
begin  
  end;  
finally  
  free;  
end;  

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

Кроме того функцию execute в дальнейшем можно значительно расширить. Что дает нам большую гибкость в отличии от if ShowModal = MrOk then: Теперь представим что в данном диалоге находится TEdit, значение которого нам нужно передать в главную форму. Как это cделать правильно?

Есть два пути, один из них написать функцию, которая возвращает значение:


type  
  TMyDlg = class(TForm)  
  Edit1: TEdit;  
  private  
    { Private declarations }  
  public  
    { Public declarations }  
    function getEditValue: string;  
  end;  
  ...  
implementation  
  
{$R *.DFM}  
  
function TMyDlg.getEditValue: string;  
begin  
  result=Edit1.text;  
end;  

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


with TMyDlg.Create(nil) do  
try  
  if execute then  
    lable1.caption:= getEditValue;  
begin  
  end;  
finally  
  free;  
end;  

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

Другим методом передачи параметров являются свойства (property), данный метод является продолжением предыдущего метода.
Рассмотрим другой пример:


type  
  TMyDlg = class(TForm)  
  Edit1: TEdit;  
  Edit2: TEdit;  
  procedure Edit1Change(Sender: TObject);  
  procedure Edit2Change(Sender: TObject);  
  private  
    { Private declarations }  
    FValue1: String;  
    FValue2: String;  
  
    procedure getValue1;  
    procedure getValue2;  
  public  
    { Public declarations }  
    property value1: string read FValue1;  
    property value2: string read FValue2;  
  end;  
  ...  
implementation  
  
{$R *.DFM}  
  
procedure TMyDlg.getValue1;  
begin  
  if Edit1.text <> '' then  
    FValue1 := Edit1.text;  
end;  
  
procedure TMyDlg.getValue2;  
begin  
  if Edit2.text <> '' then  
    FValue2 := Edit2.text;  
end;  
  
procedure TMyDlg.Edit1Change(Sender: TObject);  
begin  
  getValue1;  
end;  
  
procedure TMyDlg.Edit2Change(Sender: TObject);  
begin  
  getValue2;  
end;  

Хоть нам и придется попотеть, описывая свойство для каждого контрола, зато в дальнейшем мы избавляемся от массы головных болей:


with TMyDlg.Create(nil) do  
try  
  if execute then  
  begin  
     lable1.caption:= Value1;  
     lable2.caption:= Value2;  
  end;  
finally  
  free;  
end;  

Только не забудьте дать человеческие названия свойствам и описать их :)
Теперь данный модуль можно использовать где угодно, не заботясь о его внутренней структуре!

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

Перетаскивание объектов

Начало перетаскивания определяется свойством DragMode, которое может устанавливаться в процессе проектирования или программно равным dmManual или dmAutomatic. Значение dmAutomatic (автоматическое) определяет автоматическое начало процесса перетаскивания при нажатии пользователем кнопки мыши над компонентом. Однако в этом случае событие OnMouseDown, связанное с нажатием пользователем кнопки мыши, для этого компонента вообще не наступает.

Значение dmManual (ручное) говорит о том, что начало процесса перетаскивания должен определить программист. Для этого он должен в соответствующий момент вызвать метод BeginDrag. Например, он может поместить вызов этой функции в обработчик события OnMouseDown, наступающего в момент нажатия кнопки мыши. В этом обработчике он может проверить предварительно какие-то условия (режим работы приложения, нажатие тех или иных кнопок мыши и вспомогательнх клавиш) и при выполнении этих условий вызвать BeginDrag.

Пусть , например, процесс перетаскавания должен начаться, если пользователь нажал левую кнопку мыши и клавишу Alt над списком ListBox1. Тогда свойство DragMode этого компонента надо установить в dmManual, а его обработчик события OnMouseDown может иметь вид:


procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;  
Shift: TShiftState; X, Y: Integer);  
begin  
if (Button = mbLeft) and (ssAlt in Shift)  
then (Sender as TControl).BeginDrag(false);  
end;  

Параметр Button обработчика события OnMouseDown показывает, какая кнопка мыши была нажата, а параметр Shift является множеством, содержащим обозначения нажатых в этот момент кнопок мыши и вспомогательных клавиш клавиатуры. Если нажата левая кнопка мыши и клавиша Alt, то вызывается метод BeginDrag данного компонента.

В функцию BeginDrag передано значение False. Это означает, чтопроцесс перетаскивания начнется не сразу , а только после того, как пользователь сдвинет мышь с нажатой при этом кнопкой. Это позволяет отличить простой щелчок мыши от начала перетаскивания. Если же передать в BeginDrag значение True, то перетаскивание начнется немедленно.

Когда начался процесс перетаскивания, обычный вид курсора изменяется. Пока он перемещается над формой или компонентами, которые не могут принять информацию, он обычно имеет вид crNoDrop . Если же он перемещается над компонентом, готовым принять информацию из перетаскиваемого объекта, то приобретает вид, определяемый свойством перетаскиваемого объекта DragCursor. По умолчанию это свойство равно crDrag, что соответствует изображению . Вид курсора определяется свойством DragCursor перетаскиваемого объекта, а не того объекта, над которым перемещается курсор.

В процессе перетаскивания компоненты, над которыми перемещаетяс курсор, могут информировать о готовности принятьинформацию от перетаскиваемого объекта. Для этого в компоненте должен быть предусмотрен обработчик события OnDragOver, наступающего при перемещении над данным компонентом курсора, перетаскивающего некоторый объект. В этом обработчике надо проверить, может ли данный компонент принять информацию перетаскиваемого объекта, и, если не может, задать значение False передаваемому в обработчик параметру Accept. По умолчанию этот параметр равен True, что означает возможность принять перетаскиваемый объект. Обработчик для списка может иметь, например, следующий вид:


procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;State: TDragState; var Accept: Boolean);  
begin  
if(Sender as TControl<> Source) then Accept := Source is TListBox else Accept := False;  
end;  

В нем сначала проверяется, не является ли данный компонент (Sender) и перетаскиваемый объект (Source) одним и тем же объектом. Это сделано, чтобы избежать перетаскивания информации внутри одного и того же списка.

Значение параметра Accept, задаваемое в обрапботчике события onDragOver, определяет вид курсора, перемещающегося при перетаскивании над данным компонентом. Этот вид показывает пользователю, может ли данный компонент принять перетаскиваемую информацию. Если в компоненте не описан обработчик события onDragOver, то считается, что данный компонент, не может принять информацию перетаскиваемого объекта.

Процедура приема информации от перетаскиваемого объекта записывается в обработчике события OnDragDrop принимающего компонента. Это событие наступает, если после перетаскивания пользовательотпустил клавишу мыши над данным компонентом. В обработчик этого события передаются параметры Source (объект-источник) и X и Y координаты курсора. Если продолжить пример перетаскивания информации из одного списка в другой, то обработчик события OnDragDrop может иметь вид:


procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);  
begin  
(Sender as TListBox).Items.Add((Source as TListBox).Items[(Source as TListBox).ItemIndex]);  
end;  

В этом обработчике сторка, выделенная в списке-источнике (Source as TListBox).Items[(Source as TListBox).ItemIndex] , добавляется в список-приемник методом (Sender as TListBox).Items.Add. Используется операция AS, позволяющая расссматривать параметры Sender и Source как указатели на объект класса TListBox. Это делается потому, что эти параметры объявлен в заголовке процедуры как указатели на объекты класса TObject. Но в классе TObject нет свойств Items и ItemIndex, которые нам требуются. Эти свойства определены в классе TListBox, являющемся наследником TObject. Поэтому с параметрами Sender и Source в данном случае надо оперировать как с указателями на объекты TListBox, что и выполняет операция as.

В данном случае можно было бы не использовать параметр Sender, заменив (Sender as TListBox) просто на ListBox1. Но запись оператора в общем виде с помощью параметра Sender позволяет воспользоваться таким обработчиком и для других компонентов ListBox, если они имеются в приложении.

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

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

Написать для одного списка обработчик события onDragOver. Для всех остальных списков сослаться в событиях onDragOver на этот же обработчик (выделив в форме все оставшиеся списки).

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

Если начинать перетаскивание нужно только при выполнении какого-то дополнительног условия, например, при нажатии клавиши Alt, то потребуется:
Задать для всех списков значение свойства DragMode, равное dmManual и написать обработчик события OnMouseDown.

В приведенном ниже примере:

многострочный редактор Memo1 готов принять информацию от TLabel и TListBox;

списки ListBox готовы принять информацию от всех других списков и при этом, если информация передается не от списка ListBox2, то их списка-источника она удаляется (переносится). Из списка ListBox2 информация только копируется.

для метки Label1 c заголовком dmAutomatic определено событие OnEndDrag так, что выводится сообщение об успешном или неуспешном завершении процесса переноса, которое выводится в случае включения флажка с заголовком «Сообщения» :


procedure TForm1.Label1EndDrag(Sender, Target: TObject; X, Y: Integer);  
begin  
If CheckBox1.Checked then  
If Target = Nil Then  
ShowMessage('Перенесение объекта '+ (Sender as TControl).Name + ' прервано else  
ShowMessage((Sender as TControl).Name + ' перенесена в ' + (Target as TControl).Name);  
end;  

для списков ListBox3 и ListBox4 перетаскивание возможно только при нажатой клавише Alt, но для ListBox4 перетаскивание начинается сразу (значение функции BeginDrag(true)), а для ListBox3 (и метки Label1) момент перетаскивания определяется началом движения мышки (значение функции BeginDrag(false)).


unit Udrag1;  
interface  
uses  
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;  
type  
TForm1 = class(TForm)  
Memo1: TMemo;  
Label1: TLabel; Label2: TLabel; Label3: TLabel;  
ListBox1: TListBox; ListBox2: TListBox;  
ListBox3: TListBox; ListBox4: TListBox;  
Label4: TLabel; CheckBox1: TCheckBox;  
procedure Memo1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);  
procedure Memo1DragDrop(Sender, Source: TObject; X, Y: Integer);  
procedure ListBox1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);  
procedure ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);  
procedure ListBox3MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
procedure Label1EndDrag(Sender, Target: TObject; X, Y: Integer);  
procedure ListBox4MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  
   
private { Private declarations }  
public { Public declarations }  
end;  
var  
Form1: TForm1;  
implementation {$R *.DFM}  
procedure TForm1.Memo1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);  
begin  
Accept := (Source is TLabel)or(Source is TListBox);  
end;  
procedure TForm1.Memo1DragDrop(Sender, Source: TObject; X, Y: Integer);  
begin  
if(Source.ClassName = 'TLabel')  
then Memo1.Lines.Add((Source as TLabel).Caption)  
else Memo1.Lines.Add((Source as TListBox).Items[(Source as TListBox).ItemIndex]); ;  
end;  
procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;  
State: TDragState; var Accept: Boolean);  
begin  
if(Sender <> Source) then Accept := Source is TListBox else Accept := False;  
end;  
procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);  
begin  
(Sender as TListBox).Items.Add((Source as TListBox).Items[(Source as TListBox).ItemIndex]);  
if (Source as TListBox).Name <> 'ListBox2'  
then (Source as TListBox).Items.Delete( (Source as TListBox).ItemIndex);  
end;  
procedure TForm1.ListBox3MouseDown(Sender: TObject; Button: TMouseButton;  
Shift: TShiftState; X, Y: Integer);  
begin  
if (Button = mbLeft) and (ssAlt in Shift) then (Sender as TControl).BeginDrag(false);  
end;  
procedure TForm1.Label1EndDrag(Sender, Target: TObject; X, Y: Integer);  
begin  
If CheckBox1.Checked then  
If Target = Nil Then  
ShowMessage('Перенесение объекта'+ (Sender as TControl).Name + ' прервано')  
else  
ShowMessage((Sender as TControl).Name + ' перенесена в ' + (Target as TControl).Name);  
end;  
procedure TForm1.ListBox4MouseDown(Sender: TObject; Button: TMouseButton;  
Shift: TShiftState; X, Y: Integer);  
begin  
if (Button = mbLeft) and (ssAlt in Shift) then (Sender as TListBox).BeginDrag(true);  
end;  
end.  

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

Перемещение изображения по форме с помощью мыши

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

Итак, задача. На форме размещены несколько изображений, загружаемых из внешних файлов (их имена 1.bmp, 2.bmp и т.д.).

Изображения должны быть перемещаемыми с помощью мыши.

Первое решение, пришедшее мне в голову - это решение "в лоб". Разместив на форме несколько Image, заставим их перемещаться вместе с мышью. Разместим на форме в нужных нам местах несколько (n) пустых Image, присвоим их свойству Tag значения от 1 до n - это пригодится при создании массива из них. Объявим следующие переменные:


implementation  
  var Pic: array[1..n] of TImage;//Сюда мы занесём наши Image  
  x0,y0:integer;//Это будут координаты нажатия мыши  
  flag:boolean;//а это тоже полезная переменная - флажок  

Для первого из наших Image создадим обработчики следующих событий


{Как вы уже догадались наша форма называется MainForm}  
  
procedure TMainForm.Image1MouseDown(Sender: TObject; Button: TMouseButton;  
  Shift: TShiftState; X, Y: Integer);  
begin  
 If button<>mbLeft Then   
  flag:=false  
 Else begin  
  flag:=true;  
  x0:=x;  
  y0:=y  
 end  
end;  
{ При нажатии левой клавиши мыши над нашим Image запомним координаты нажатия 
и установим флажок. Это делается для того, чтобы Image перемещался только при 
опущенной левой кнопке мыши}  
  
procedure TMainForm.Image1MouseUp(Sender: TObject; Button: TMouseButton;  
  Shift: TShiftState; X, Y: Integer);  
begin  
 flag:=false  
end;  
{При отпускании кнопки мыши, не важно какой, сбросим флажок}  
  
procedure TMainForm.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,  
  Y: Integer);  
begin  
 If flag Then begin //Если флажок установлен, т.е. нажата левая копка мыши  
  (Sender As TImage).Left:=(Sender As TImage).Left+x-x0;  
  (Sender As TImage).Top:=(Sender As TImage).Top+y-y0  
 //Наш Image начинает перемещаться  
 end;  
end;  

Обратите внимание, что перемещается не Image1, а Sender. Созданные нами процедуры будут применены для обработки перемещений всех изображений на форме. Для этого в процедуре создания формы запишем все Image на форме в массив Pic


procedure TMainForm.FormCreate(Sender: TObject);  
var i:byte;  
begin  
For i:=0 To MainForm.ComponentCount-1 Do  
 If (MainForm.Components[i] Is TImage) Then  
  Pic[MainForm.Components[i].Tag]:=(MainForm.Components[i] As TImage);  
{Здесь мы просматриваем компоненты формы и если рассматриваемый компонент 
- TImage присваеваем его в массив Pic c индексом Tag}  
For i:=1 To n Do  begin  
 Pic[i].Picture.LoadFromFile(IntToStr(i)+'.bmp');//Загружаем изображение  
 Pic[i].OnMouseDown:=Image1MouseDown;  
 Pic[i].OnMouseMove:=Image1MouseMove;  
 Pic[i].OnMouseUp:= Image1MouseUp  
{Присваеваем нужные процедуры нужным событиям}  
end  
end;  
{В принципе можно было бы обойтись одним циклом For, но, на мой взгляд 
два цикла наглядней и проще для понимания}  

Итак, полученный код позволяет разместить на форме n изображений и перемещать их с помощью мыши. Можно удовлетвориться полученным решением,если бы не одна страшная проблема - МЕРЦАНИЕ.

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


MainForm.ControlStyle:=MainForm.ControlStyle+[csOpaque];  

или процедуры Invalidate мне не помогло.

Следующим моим шагом было посещение Мастеров Дельфи, где я прочёл статью Михаила Христосенко "Перемещение Image'a по форме во время работы программы". Применение метода


(Sender As TImage).SetBounds((Sender As TImage).Left+x-x0,(Sender As TImage).Top+  
y-y0,(Sender As TImage).width,(Sender As TImage).height);  

в процедуре Image1MouseMove, рекомендованое Михаилом привело к снижению мерцания, но не избавило от него. Более того, в взрослых программах, таких как например само DELPHI,применяется третий из описанных Михаилом способов - перемещение не изображения, а его рамки.

Тогда я задумался, а не является ли применение TImage для перемещения изображения по форме тупиком. И тут я понял, что знаю компонент, на котором можно разместить изображение, и который не мерцает "по определению". Этот компонент (да простят меня Мастера Дельфи) - форма.

Итак следующий проект состоит из двух форм - FormMain и ImageForm. На ImageForm размещён пустой Image1, занимающий всю клиентскую область ImageForm. ImageForm относится к Available forms - это действие не принципиально, но экономит во время запуска приложения около 100 кб памяти. Свойство BorderStyle для ImageForm устанавливаем bsNone.

Для того, чтобы ImageForm перемещалась за Image1 создаём следующую процедуру:


procedure TImageForm.Image1MouseDown(Sender: TObject; Button: TMouseButton;  
  Shift: TShiftState; X, Y: Integer);  
const  SC_DragMove = $F012;  
begin  
  ReleaseCapture;  
  perform(WM_SysCommand, SC_DragMove, 0);  
end;  

На этом работа над ImageForm заканчивается.

Возвращаемся к FormMain.
Сделаем следующие объявления


implementation  
const n=4; // Сколько нам нужно изображений  
uses Unit2;  
var Fa:array[1..n]of TImageForm;  

Теперь нам нужно создать массив Fa, разместить его на форме и заполнить его изображениями. Всё это делается вручную - фокус с Tag тут уже не пройдёт. Делать это лучше не во время создания формы, а например во время активации.


procedure TFormMain.FormActivate(Sender: TObject);  
var i:byte;  
begin  
for i:=1 to n do begin  
Fa[i]:=TImageForm.Create(Self);// Создание формы  
Fa[i].Parent:=Self;//Без этой строки наши формы будут бегать по всему экрану  
Fa[i].Visible:=True; //Вывод формы на экран  
Fa[i].Image1.Picture.LoadFromFile(IntToStr(i)+'.bmp');// Загрузка картинки  
Fa[i].Top:=i*50 //Выбор места расположения (здесь ставятся ваши значения)  
 end;  
end;  

Другой вариант - разместить на форме Timer с незначительным интервалом и разместить вышеприведённый код в процедуре OnTimer, указав в конце Timer1.Enabled:=false;

Последний штрих - установите "Отображать содержимое окна при его перетаскивании" с помощью следующей процедуры


B:Bool;//Объявите B где-нибудь после implementation  

В FormCreate включите следующее


B:=True;  
SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, 0, @B,  SPIF_SENDCHANGE)// Не проверял.  

Ура! В созданная таким образом программе перемещаемые изображения не мерцают.

Однако объём памяти, занимаемый ею во время работы весьма велик. Программа состоящая из вышеприведённых процедур занимает на диске около 400 кб, а в ОП - порядка 2 мб. Попробую поискать менее ресурсоёмкое решение.

Автор: Ижогин Ян Валерьевич

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

Перемещение TImage по форме во время работы приложения

Многие, наверно, сталкивались с проблемой перемещения Image'a по форме. Решить ее можно тремя способами (может есть и больше).

Способ первый. Его суть заключается в том, что свойства Left и Top картинки изменяются на разницу между начальными и конечными координатами (нажатия и отпускания мыши соответственно). Этот способ самый простой и надежный, но у него есть один недостаток: left и top изменяются по очереди, что приводит к заметному мерцанию картинки. Тем не менее мы этот способ рассмотрим. Не забудьте положить на форму Image и вставить в нее какую-нибудь картинку. Для начала необходимо объявить глобальные переменные (они объявляются в разделе Implementation) x0, y0:integer - они будут запоминать начальные координаты. И еще нам понадобится переменная move типа boolean, чтобы нам отличать перемещение мыши над картинкой, от попытки ее сдвинуть. Эти объявления делаются примерно так:


implementation  
  
var x0,y0:integer;  
move:boolean;  
  
{$R *.DFM}  
Теперь напишем обработчик OnMouseDown для нашей картинки:


procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;  
Shift: TShiftState; X, Y: Integer);  
begin  
if button<>mbLeft then move:=false //если нажали не левой кнопкой, то перемещать не будем!  
else begin  
move:=true;  
x0:=x; //запоминаем начальные координаты  
y0:=y; //запоминаем начальные координаты  
end;  
end;  

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

Теперь напишем обработчик OnMouseMove для нашей картинки:


procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,  
Y: Integer);  
begin  
if move then begin  
image1.Left:=image1.Left+x-x0; // Изменяем позицию левого края  
image1.Top:=image1.Top+y-y0; // Изменяем позицию верхнего края  
end;  
end;  

Ну и наконец обработчик OnMouseUp для нашей картинки будет таким:


procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;  
Shift: TShiftState; X, Y: Integer);  
begin  
move:=false;  
end;  

Здесь все очень просто. Когда кнопка отпускается, то переменной move присваивается значение false, чтобы до следующего клика по картинке ее нельзя было сдвинуть.

Этот способ довольно прост, как для понимания, так и для реализации. Но такой же алгоритм перемещения можно реализовать немного красивее. У некоторых компонентов, в том числе и Image, есть такая классная процедура SetBounds(Left,Top,Width,Height), которая может изменять сразу все четыре параметра. Таким образом событие OnMouseMove можно изменить так:


procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,  
Y: Integer);  
begin  
if move then begin  
image1.SetBounds(image1.Left+x-x0,image1.Top+y-y0,image1.width,image1.height);  
end;  
end;  

Но есть еще один очень интересный выход: по экрану можно перемещать не саму картинку, а только ее рамку, когда пользователь выберет место для картинки и отпустит кнопку - она туда переместиться. Для этого нам понадобится еще одна глобальная переменная: rec: TRect, которая будет хранить параметры картинки. Теперь слегка изменим обработчики событий для картинки. Таким образом все в целом будет выглядеть так:


procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;  
Shift: TShiftState; X, Y: Integer);  
begin  
if button<>mbLeft then move:=false  
else begin  
move:=true;  
x0:=x;  
y0:=y;  
rec:=image1.BoundsRect; //запоминаем контур картинки  
end;  
end;  
  
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,  
Y: Integer);  
begin  
if move then begin  
Form1.Canvas.DrawFocusRect(rec); //рисуем рамку  
with rec do begin  
left:=Left+x-x0;  
top:=Top+y-y0;  
right:=right+x-x0;  
bottom:=bottom+y-y0;  
x0:=x;  
y0:=y; // изменяем координаты  
end;  
Form1.Canvas.DrawFocusRect(rec); // рисуем рамку на новом месте  
end;  
end;  
  
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;  
Shift: TShiftState; X, Y: Integer);  
begin  
Form1.Canvas.DrawFocusRect(rec);  
with image1 do begin  
setbounds(rec.left+x-x0,rec.top+y-y0,width,height); //перемещаем картинку  
move:=false;  
end;  
end;  

Поскольку DrawFocusRect рисует рамку методом Xor, то при повторном вызове этой функции с теми же параметрами, рамка стирается.

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

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

Перекодировщик - Gthtrjlbhjdobr

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

Чтобы в такой ситуации было меньше гемора, ты можешь САМ! написать прогу, которая бы любую мессагу такого типа расшифровывала для тебя. Для этого тебе понадобится комп, "Delphi 3" или выше, полчаса-час свободного времени и пара бутылок пива/газировки.

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

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

Поехали

Запускаем делфи

Дельфи уже сделал кое-что за тебя: панель, у которой в заголовке написано Form1, - это макет твоей программы, на нее надо будет добавлять всякие фиговины вроде кнопок, текста и так далее. Панели в Дельфах принято называть "формы", а все что к ним прикрепляется - компоненты. Итак, Form1 - главная форма твоей программы. Если ты выберешь в главном меню пункт Run и там далее тоже Run или нажмешь кнопку с треугольником, твой комп никуда не убежит, а вылезет пустая панель, которая умеет растягиваться и закрываться, - это твоя прога. Закрой ее (щелкни на косом кресте этой пустой панельки, я это к тому, чтоб Дельфу или еще чего сгоряча не закрыть) и сохрани на винте: в меню File пункт Save Project As. У тебя спросят имя файла, а затем имя проекта: он, то есть твоя прога, будет храниться в виде нескольких файлов (на каждую панель по одному файлу + еще несколько), у каждого файла может быть совершенно произвольное имя, вроде: Васин_файл. То же самое с проектом: можешь назвать его не Project1, а ПроектВека или как-то иначе, это всем по фигу.

Теперь добавь на форму необходимые компоненты: кнопки, строки ввода и все такое. Делается это очень просто: в верху экрана располагаются так называемые "палитры компонент" - это наборы стандартных виндовских прибамбасов: кнопки, диалоги, тулбары и все такое, они лежат там в виде иконок. Тебе сейчас нужна палитра Standard (она выбрана по умолчанию). Кликни один раз на компоненту Edit (найди по хинтам), а затем щелкни на главную форму: там появится одна строка ввода. Можешь потаскать ее по главной форме мышкой или порастягивать.

Теперь зацени: слева на экране вертикальная панель Object Inspector - очень важная и удобная фича: в ней отображаются все свойства всех компонент твоей проги. Сейчас вверху написано Edit1:tEdit (если ты последний раз кликнул в строку ввода, иначе Form1:TForm1) - это имя и тип выбранного сейчас компонента. Ниже, во вкладке Properties, можно найти свойство Text, сейчас там написано Edit1, а надо все напрочь стереть - это свойство говорит, что будет написано в строке ввода при запуске программы. Запусти программу и посмотри, что получится. Теперь аналогично помести на форму еще одну строку ввода и расположи ее под первой: в первую юзер будет потом впечатывать белиберду, а во вторую прога будет писать расшифровку. Сотри все в свойстве Text. Найди на палитре и помести на панель кнопку (Button) и в свойстве Caption впиши "Do it!" или что-нибудь такое - эта кнопь будет все запускать в твоей проге (свойство Caption у всех компонент отвечает за надпись, которая будет нарисована на компоненте; и еще: пока вписывай те надписи на кнопках, которые предлагаю я, чтобы мне было проще объяснить, позже ты все сможешь переделать по-своему).

Далее надо как-то дать понять юзеру, в какую из строк писать лажовую строку, а в какой будет ответ. Для этого помести на форму два компонента Label (иконка в виде буквы "А" на палитре Standard), один левее первой строки ввода, другой левее второй. В первом в свойстве Caption впиши "Вводи сюды:" или что-то в этом роде, а во втором - "Ответ тут:". Потом в низу формы помести еще две кнопки, в одной впиши "Выход", в другой "About". Значение свойства Caption может быть любым, так что пиши по-русски или по-аглицки и любую фигню - что захочешь. Теперь размести все компоненты ровнее на форме (форму можешь растягивать мышью или устанавливать свойства Height и Width ручками в Object Inspector). Если на какой-нибудь компонент щелкануть правой кнопью крысы, то выскочит менюха, в которой есть пункт Align, поэкспериментируй с ним - это выравнивание того компонента, который у тебя сейчас выбран на форме (там есть выравнивания по левому краю, по правому, по центру и др.). К этому моменту у тебя должно получиться что-то типа того:

Внутри

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

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

Начнем с простого: хочется, чтобы при нажатии на кнопку "Выход" прога закрывалась напрочь. Даблкликни на эту кнопку на главной форме (заметь, ДАБЛКЛИКНИ, до этого ты везде кликал один раз). Перед тобой откроется окошко текстового реактора... то есть редактора, где будет написано:


procedure TForm1.Button2Click(Sender: TObject);  
  
begin  
  
end;  

и еще всякой лабуды. Так вот, перед тобой процедура, которая будет выполняться после того, как кто-нибудь кликнет на кнопь "Выход" во время работы программы. Сейчас она пустая, то есть ничего не делает, поэтому такая лажа и получалась - щелкаешь по ней, а ей все по фигу. Ща все исправим: вписывай между begin и end (то есть в "тело" процедуры) такую строку:


Form1.Close;  

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

Еще можно слепить панель, которая будет выскакивать при нажатии на кнопь "О проге.." и содержать всякую лабуду. Все просто: в главном меню Дельфей выбираешь "Филе", в нем "New...", выскочит окошко, в нем смело выбирай вкладку "Forms", там по умолчанию выбран AboutBox, щелкай "ОК". Дело в том, что в комплекте Дельфей есть некоторое количество готовых форм "специально для ленивых", их надо только подправить.

Итак, есть четыре компонента Label и один Image. Сперва исправь свойства Caption у всех Labelов - не бойся их растягивать, они могут содержать несколько строк текста (для этого надо свойство WordWrap поставить True, а не False, как по умолчанию). Теперь Image - выбирай свойство Picture, щелкай где три точки и далее Load любую картинку (Bmp-формата), размеры смотри в свойствах Height и Width, можешь их изменить, но Дельфа сожмет картинку любого размера под те, что там вписаны. И, наконец, даблклик по кнопке "ОК" на панели About - и там в редакторе вписывай почти то же самое, что и раньше:


AboutBox.Close;  

(говоришь панельке About закрыться при нажатии).

Тут я хочу сказать об одной полезной фиче - все названия по умолчанию в Дельфях - "говорящие", вроде Button1, Edit1 - сразу понятно, о чем идет речь. Точно так же и с процедурами, зацени: эта процедура называется "TAboutBox.OKButtonClick", если ты знаешь английский, сразу можешь врубиться, на фига она нужна - вызывается, когда в AboutBoxе Clickнут по кнопке OK. По-моему - удобно, но это - дело вкуса.

В левом верхнем углу этой формы у нас по умолчанию написано About, но, выбрав в инспекторе AboutBox, можно поменять, как обычно, свойство Caption.

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


AboutBox.Show;  

Это для всех форм одинаково - метод Show их показывает, а метод Close - закрывает.

Сохрани проект - теперь у тебя спросят имя для файла только что сделанной панели "О проге...". Запусти свое творение (если перед запуском Дельфа что-то спросит - говори - Да) и насладись открывшимися возможностями.

Вот и настал тот момент, когда тебе все-таки придется написать основной алгоритм программы, иначе, как уже говорилось, само оно не заработает. Даблклик на кнопке "Do it!", и попадаешь в редактор.

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

Итак, редакторе ползи наверх, пока не встретишь жирную надпись var. Над ней надо вписать следующее:


const  
  
EngLet : string = '~!@#$%^&*()QWERTYUIOP{}ASDFGHJKL:"ZXCVBNM<>?qwertyuiop[]asdfghjkl;''zxcvbnm,./';  
  
RusLet : string = 'Ё!"№;%:?*()ЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЭЯЧСМИТЬБЮ,йцукенгшщзхъфывапролджэячсмитьбю.~';  
Строки эти надо набирать так: верхнюю (EngLet)- переключаешься на английский, зажимаешь shift и начинаешь слева направо последовательно нажимать клавиши той строки на клаве, где цифры, потом той, которая ниже, и так далее, потом отпускаешь shift и повторяешь (управляющие кнопки, вроде tab, enter и других, нажимать не надо); теперь нижнюю строку (RusLet) - переключаешься на русский и повторяешь все как и для предыдущей строки.

Дельфа, когда будет обрабатывать эту запись, будет читать так: "ага, написано const, значит дальше идут константы, клево, щас должно быть имя первой константы, О-ппа, написано EngLet, это оно и есть, вот двоеточие, а после него должен быть тип указан. Во! Да тут так и написано: string, значит константа будет строковой, я потрясена! Теперь равно, а опосля и значение должно быть в апострофах, и ";" - да тут все так и написано, а раз все верно, то я ругаться не буду. Блин, да тут еще одна константа!.." и так далее, ну, примерно так, тока не по-русски, а по-своему, по-Дельфивски.

Апострофы по краям говорят-показывают границы строки, в английской раскладке на клаве встречается апостроф - найди его в строке EngLet и поставь рядом еще один, теперь Дельфа врубится, что здесь не конец строки, а символ "апостроф".

Теперь найди процедуру TForm1.Button1Click и дополни ее до следующего:


procedure TForm1.Button1Click(Sender: TObject);  
var  
i, j, flag : integer;  
Result : string;  
begin  
Result:='';  
for i:=1 to length(Form1.Edit1.Text) do begin  
for j:=1 to length(EngLet) do begin  
if EngLet[j]=Form1.Edit1.Text[i] then break;  
end;  
Result := Concat( Result, RusLet[j] )  
end;  
Form1.Edit2.Text := Result;  
end;  

Попробую объяснить, что все это значит. После слова var Дельфа ищет объявление переменных, как после const она ищет константы. Мы с тобой хотим три целых переменных (integer) и одну строковую (string) - так и пишем, и указываем имена. Что делается в теле этой процедуры: берем первую букву введенной строки, пусть ввели "Rthlsr", значит первая буква "R", ищем ее в строке EngLet, запоминаем, какой по счету она стоит там, и берем символ из строки RusLet с таким же номером: можешь сам посмотреть там, где ты объявил константы EngLet и RusLet - под буквой "R" написана буква "К", запомним ее, теперь ищем вторую букву - "t", находим "и" и так далее, получаем "Кирдык".

Найденные символы мы будем сохранять в переменную Result, поэтому для начала присвоим ей пустую строку. Теперь берем цикл for от первой до последней буквы введенной строки (она хранится в свойстве Text компоненты Edit1, а функция length возвращает нам длину введенной в нее строки - для рассмотренного примера она вернет 6, и цикл будет исполняться от одного до шести). Еще один цикл for - начиная с первого символа, просматриваем строку EngLet до конца (length(EngLet) и проверяем оператором if, не совпадают ли та буква, которую мы сейчас ищем (Form1.Edit1.Text), и та, на которую сейчас указывает счетчик j внутреннего цикла (а он указывает на EngLet[j]); если совпадают - то выскакиваем из цикла при помощи оператора break, кричим во все горло "Rulezz!" и добавляем найденную буковь (RusLet[i]) к строке Result при помощи функции Concat (она берет две строки, приписывает к концу первой вторую и возвращает полученную строку. Догадайся, что вернет эта функция, если ее вызвать так: Concat( "Fu", "ck off!" ) ). Вот и все, а после того, как циклы завершатся, мы полученную строку вписываем во вторую строку ввода - в свойство Text компоненты Edit1 на форме Form1, во как. Кидалово Догадайся, где я тебя только что кинул!.. Догадался? Нет! Правильный ответ такой (запусти прогу и проверь): если ввести "Dj,kf" то прога выдаст "Вобла", а если ввести "Dj,kf b gbdj", то она ответит снова "Вобла", а "gbdj" (пиво) она зажмет и не отдаст. - Почему, нехороший человек, ты меня опять кинул? - вежливо, не ругаясь, спросишь меня ты. - А чтобы ты внимательнее относился потом к написанию кода, потому что, чтобы найти ошибку, нужно гораздо больше времени, чем на то, чтобы написать здоровенную прогу всего с одной этой ошибкой, - отвечу тебе я. Секрет в том, что когда мы во втором цикле ищем в строке EngLet символ "пробел", мы его там не находим, огорчаемся и добавляем в переменную Result символ RusLet[length(Englett)+1], а это за пределами нашей строки, и там лежит какая-то лажа. Поэтому поступим так - введем специальную переменную Flag - флажок, который мы будем по умолчанию поднимать, а опускать - если нашли нужный символ в строке EngLet. Потом если он окажется все еще поднятым после окончания цикла, мы будем добавлять в Result не из RusLet[i], а прямо из Form1.Edit1.Text[i] - то есть, в нашем случае, добавлять пробел там, где надо. Итак, исправь эту часть процедуры вот так: [DELPHI]for i:=1 to length(Form1.Edit1.Text) do begin Flag:=0; for j:=1 to length(EngLet) do begin if EngLet[j]=Form1.Edit1.Text[i] then begin Flag:=666; break; end; end; if Flag=666 then Result := Concat( Result, RusLet[j] ) else Result := Concat( Result, Form1.Edit1.Text[i] ); end;
Запусти и убедись, теперь прога работает верно.

Чтобы прога стала переводить с русского неправильного на английский правильный, скопируй все, что находится между апострофами в объявлении строки EngLet, и помести перед закрывающим апострофом в объявлении строки RusLet и наоборот (если бы строки были такими: EngLet - 'QWE', а RusLet - 'ЙЦУ', то после этих операций получилось бы: EngLet - 'QWEЙЦУ', а RusLet - 'ЙЦУQWE').

Теперь мелочи: свойство BorderStyle формы Form1 можно поставить равным bsSindle, чтобы основную панель нельзя было растянуть. А в свойстве Icon можно заменить стандартную иконку Дельфей в левом верхнем углу главной панели на любую другую.

EXE-файл своей проги ты найдешь на винте в той директории, куда ты сейвил проект.

Вот такие пироги

Сложно? Не очень. А главное - результат: ты крут! У тебя есть настоящая грамотная серьезная прога. Можешь выкладывать это файло на своем сайте и хвастать всем, что ты теперь программер, а не просто кул-хацкер. Удачи тебе, и, надеюсь, эта прога не будет для тебя последней :).

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

кликнуть по кнопке, и она выдаст правильный ответ.

Автор: Александр Симбирцев

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

Перевод в Delphi-приложениях

Реализовать перевод в приложениях Delphi можно реализовать несколькими способами:

стандартный способ локализации.
локализация с помощью текстовых ресурсов: ini-файл или xml-файл.
Стандартный способ локализации приложений
С помощью ресурсов на нужном языке (с помощью меню Project -> Languages). Этот способ часто описывается в книгах по Delphi, а так же в большом количестве статей в интернете. Поэтому, этот способ не будем описывать в этой статье.

Этот способ имеет как преимущества, так и недостатки.

К преимуществам, можно отнести: скорость работы данной реализации, а так же то, что этот способ реализован в самом Delphi.

Недостатки:

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

К преимуществам данного способа можно отнести:
- Возможность перевода без среды Delphi. Более того, из любого текстового редактора. - Как следствие предыдущего пункта – возможность перевода сот рудниками, не знаючими Delphi и не умеюми в нем работать.
- Совместимость разных версий с разными версиями программы.
К недостаткам данного способа можно отнести:
- Меньшую скорость работы, чем через ресурсы.
- Не реализован данный способ в стандартной поставке Delphi.
- Больший размер файла, чем ресурсного файла.

В текстовый формат можно сохранять в виде: ini-файла, xml-файла или текст с заданными разделителями.

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

В данной статье мы опишем способ локализации в формате xml.

Локализация с помощью xml-файлов
Для локализации, воспользуемся некоторыми из функций проекта XMLWorks: http://www.DelphiHome.com/xml

Прежде всего, нужно определиться с тем, что мы переводим.

Мы переводим:

- строковые ресурсы;

- вариантные типы;

- символьные типы;

Все остальные типы данных мы не переводим.

Процесс перевода можно разделить на 2 этапа:

1-й этап. Генерация текстового файла для последующего перевода. Сохранение его. Перевод. Перенос в каталог соответствующего языка.

2-й этап. Загрузка в приложение из xml-файла.

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

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

Так же могут быть компоненты, которые мы не хотим переводить. Их нужно исключить из перевода. Так, например, не желательно переводить TDBEdit, TDBDateTimeEditE, TDBLookupComboboxEh, т.к. нам не нужно переводить информацию, взятую из базы данных.

Ниже, приводим функцию, которая формирует xml-файл для перевода.


function GenSQLLang(SelfInp: TObject): String;  
Var i, b: integer;  
BandTmp: TcxGridDBBandedTableView;  
begin  
  
  if (SelfInp is TComponent) then  
Begin  
  
  With (SelfInp as TComponent) Do  
Begin  
Result:=ObjectToXMLElements_Lang(SelfInp,-4);  
  
  Result:=Result+Chr(13)+';  
   
  
for i:=0 to ComponentCount-1 Do  
begin  
   
  
if (Trim(Components[i].Name)<>')And  
(not((RusCompare(Components[i].ClassName,'TSaveDBGridEh'))  
Or(RusCompare(Components[i].ClassName,'TpFIBTransaction'))  
Or(RusCompare(Components[i].ClassName,'TpFIBStoredProc'))  
Or(RusCompare(Components[i].ClassName,'TDBEdit'))  
Or(RusCompare(Components[i].ClassName,'TDBDateTimeEditEh'))  
Or(RusCompare(Components[i].ClassName,'TDBLookupComboboxEh'))  
Or(RusCompare(Components[i].ClassName,'TDBComboBoxEh'))  
)) then  
begin  
Result:=Result+Chr(13)  
+'<'+Components[i].Name+'>'+Chr(13)+ObjectToXMLElements_Lang(Components[i],4)  
+'+Chr(13);  
  
   
  
  end;  
end;  
  
  Result:=Result+'+Chr(13)+Chr(13);  
  
  End;  
End;  
end;  

Функция для формирования xml для заданной компоненты:


function ObjectToXMLElements_Lang(const aObject:TObject; Space_Inp: integer): String;  
var  
i : Integer;  
s : string;  
StringList : TStringList;  
Props: TList;  
IsLangSet: Boolean;  
begin  
result := ';  
  
  StringList := TStringList.Create;  
try  
  
  Props := GetPropertyList(aObject.ClassInfo);  
try  
  
  for i := 0 to Props.Count-1 do  
begin  
  
     s := GetPropAsString_Lang(AObject, PPropInfo(Props.Items[i]), IsLangSet, Space_Inp+4);  
   
  
  if (IsLangSet)And(UpperCase(PPropInfo(Props.Items[i]).Name)<>UpperCase('Name'))And(Trim(PPropInfo      (Props.Items[i]).Name)<>') then  
  StringList.Add(Space(Space_Inp)+'<' + PPropInfo(Props.Items[i]).Name + '>' + s + Space(Space_Inp)+'  
  end;  
result := StringList.Text;  
  
  finally  
  Props.Free;  
end;  
  
  finally  
  StringList.Free;  
end;  
  
  end;   

Функция для формирования xml для заданного свойства:


function GetPropAsString_Lang(const Instance: TObject; const PropInfo: PPropInfo; Var IsLangSet: Boolean; Space_Inp: Integer): string;  
var  
  ObjectProp : TObject;  
Intf: IXMLWorksObject;  
begin  
   
  
if (not Assigned(PropInfo^.PropType^))Or(UpperCase(Trim(PropInfo^.PropType^.Name))='NAME')  
then Exit;  
   
  
result := ';  
IsLangSet:=False;  
  
  case PropInfo^.PropType^.Kind of  
  
  tkString,  
tkLString,  
tkWString:  
Begin  
  IsLangSet:=True;  
   
  
  if AnsiSameText(PropInfo^.PropType^.Name, 'XMLString') then  
  result := Trim(GetStrProp(Instance, PropInfo))  
    else if AnsiSameText(PropInfo^.PropType^.Name, 'XMLMIMEString') then  
    result := Base64Encode(GetStrProp(Instance, PropInfo))  
      else  
         begin  
              result := StrToXML(Trim(GetStrProp(Instance, PropInfo)));  
         end;  
End;  
  
  tkInt64: ;  
tkSet,  
tkInteger: ;  
tkFloat: ;  
tkVariant:  
begin  
  IsLangSet:=True;  
   
  
  if GetVariantProp(Instance, PropInfo)=null  
  then result := StrToXML(')  
  else result := VariantToXML(Trim(GetVariantProp(Instance, PropInfo)));  
end;  
  
  tkChar,  
tkWChar:  
begin  
  IsLangSet:=True;  
  result := StrToXML(Chr(GetOrdProp(Instance, PropInfo)));  
end;  
  
  tkEnumeration: ;  
  
  tkClass:  
begin  
end;  
  
  tkInterface:  
begin  
   IsLangSet:=True;  
   result := InterfaceToXML(GetIntfProp_Lang(Instance, PropInfo));  
end;  
  
  end;  
end;   

Функции, которые используются в данном коде:


function GetIntfProp_Lang(Instance: TObject; PropInfo: PPropInfo): IUnknown;  
asm  
  
  { -> EAX Pointer to instance }  
{ EDX Pointer to property info }  
{ ECX Pointer to result interface }  
PUSH ESI  
PUSH EDI  
MOV EDI,EDX  
  
  MOV EDX,[EDI].TPropInfo.Index { pass index in EDX }  
CMP EDX,$80000000  
JNE @@hasIndex  
MOV EDX,ECX { pass value in EDX }  
@@hasIndex:  
MOV ESI,[EDI].TPropInfo.GetProc  
CMP [EDI].TPropInfo.GetProc.Byte[3],$FE  
JA @@isField  
  
  JB @@isStaticMethod  
@@isVirtualMethod:  
MOVSX ESI,SI { sign extend slot offset }  
ADD ESI,[EAX] { vmt + slot offset }  
CALL DWORD PTR [ESI]  
JMP @@exit  
  
  @@isStaticMethod:  
CALL ESI  
   
  
JMP @@exit  
  
@@isField:  
AND ESI,$00FFFFFF  
ADD EAX, ESI  
MOV EDX,[EAX]  
MOV EAX, ECX  
CALL AssignIntf  
  
  @@exit:  
POP EDI  
POP ESI  
end;  
  
  
  function GetIntfProp(Instance: TObject; PropInfo: PPropInfo): IUnknown;  
asm  
  
  { -> EAX Pointer to instance }  
{ EDX Pointer to property info }  
{ ECX Pointer to result interface }  
  
  PUSH ESI  
PUSH EDI  
MOV EDI,EDX  
  
  MOV EDX,[EDI].TPropInfo.Index { pass index in EDX }  
CMP EDX,$80000000  
JNE @@hasIndex  
MOV EDX,ECX { pass value in EDX }  
@@hasIndex:  
MOV ESI,[EDI].TPropInfo.GetProc  
CMP [EDI].TPropInfo.GetProc.Byte[3],$FE  
JA @@isField  
JB @@isStaticMethod  
@@isVirtualMethod:  
  
  MOVSX ESI,SI { sign extend slot offset }  
ADD ESI,[EAX] { vmt + slot offset }  
CALL DWORD PTR [ESI]  
JMP @@exit  
@@isStaticMethod:  
CALL ESI  
  
  JMP @@exit  
   
  
@@isField:  
AND ESI,$00FFFFFF  
ADD EAX, ESI  
MOV EDX,[EAX]  
MOV EAX, ECX  
CALL AssignIntf  
  
  @@exit:  
POP EDI  
POP ESI  
  
  end;  

Загрузка в приложение из xml-файла
Нам необходимо загрузить текстовый файл, декодировать информацию в нем и установить свойства.

Итак, процедура декодирования текстового файла:


Procedure DecodeSQLLang(SelfInp: TObject;StrInp: String);  
Var PosTmp, PosTmp2: integer;  
i: integer;  
StrTmp: String;  
begin  
   
  
PosTmp:=0;  
  
if SelfInp is TComponent then  
With SelfInp as TComponent Do  
Begin  
  
  PosTmp:=Pos('ComponentsForm', StrInp);  
  
if PosTmp=0  
then StrTmp:=Copy(StrInp,1,Length(StrInp))  
else StrTmp:=Copy(StrInp,1,PosTmp-2);  
   
  
setXMLObject_Lang(SelfInp, StrInp);  
  
  for i:=0 to ComponentCount-1 Do  
begin  
  
  if (Trim(Components[i].Name)<>')And  
(not((RusCompare(Components[i].ClassName,'TSaveDBGridEh'))  
Or(RusCompare(Components[i].ClassName,'TpFIBTransaction'))  
Or(RusCompare(Components[i].ClassName,'TpFIBStoredProc'))  
Or(RusCompare(Components[i].ClassName,'TDBEdit'))  
Or(RusCompare(Components[i].ClassName,'TDBDateTimeEditEh'))  
Or(RusCompare(Components[i].ClassName,'TDBLookupComboboxEh'))  
Or(RusCompare(Components[i].ClassName,'TDBComboBoxEh'))  
)) then  
begin  
   StrTmp:=RFastParseTagXML(StrInp,Components[i].Name);  
   setXMLObject_Lang(Components[i], StrTmp);  
end;  
  
  end;  
  
  End;  
  
end;  

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


function RFastParseTagXML(const Source, Tag: AnsiString{; var Index: Integer}):  
AnsiString;  
var  
  NestLevel: Integer;  
  StartTag, StopTag: AnsiString;  
  StartLen, StopLen, SourceLen: Integer;  
  StartIndex, StopIndex: Integer;  
  
  begin  
   
  
SourceLen := Length(Source);  
StartIndex := 0;  
result := ';  
  
  if (StartIndex < SourceLen) then  
begin  
StartTag := '<' + Tag + '<';  
StartLen := Length(StartTag);  
  
  if StartLen < 2 then  
begin  
   StopTag := '  
     StopLen := Length(StopTag);  
   StartIndex := Pos(StartTag,Source);  
   StopIndex := Pos(StopTag,Source);  
   result := Copy(Source, StartIndex+StartLen, StopIndex-StartIndex-StartLen{- 1});  
end;  
  
  end;  
  
  end;   

Установка свойств:


procedure setPropAsString_Lang(Instance: TObject; PropInfo: PPropInfo; const value :  
string);  
var  
ObjectProp : TObject;  
Intf: IXMLWorksObject;  
vTemp : variant;  
StrTmp: String;  
begin  
  
  // No property  
if (PropInfo = Nil) OR (value = ') or  
// a read only simple type  
((PropInfo^.SetProc = NIL) and not (PropInfo^.PropType^.Kind in [tkClass, tkInterface]))  
  
  then  
exit;  
  
case PropInfo^.PropType^.Kind of  
  
  tkString,  
tkLString,  
tkWString:  
if AnsiSameText(PropInfo^.PropType^.Name, 'XMLString') then  
  SetStrProp(Instance, PropInfo, Value)  
else if AnsiSameText(PropInfo^.PropType^.Name, 'XMLMIMEString') then  
  SetStrProp(Instance, PropInfo, Base64Decode(Value))  
else  
  SetStrProp(Instance, PropInfo, XMLToStr(Value));  
   
  
tkSet, tkInteger:  
if AnsiSameText(PropInfo^.PropType^.Name, 'XMLRGBTColor') then  
  SetOrdProp(Instance, PropInfo, SwapRandB(StrToInt(XMLToStr(Value))))  
else  
  SetOrdProp(Instance, PropInfo, StrToInt(XMLToStr(Value)));  
   
  
tkFloat:;  
  
SetFloatProp(Instance, PropInfo, StrToFloat(XMLToStr(Value)));  
  
tkVariant:  
begin  
  vTemp := GetVariantProp(Instance,PropInfo);  
  XMLToVariant(value,vTemp);  
  SetVariantProp(Instance, PropInfo, vTemp);  
end;  
  
  tkInt64: SetInt64Prop(Instance, PropInfo, StrToInt64(XMLToStr(Value)));  
   
  
tkChar,  
tkWChar:  
begin  
StrTmp:=XMLToStr(Value);  
  
  if Length(StrTmp)>0 then  
  SetOrdProp(Instance, PropInfo, Ord({XMLToStr(Value)}StrTmp[1]));  
  
  end;  
  
  tkEnumeration: SetOrdProp(Instance, PropInfo, GetEnumValue( PropInfo^.PropType^, XMLToStr(Value)));  
  
tkClass :  
begin  
try  
  
  ObjectProp := TObject(GetOrdProp(Instance, PropInfo));  
   
  
if Assigned(ObjectProp) then  
begin  
  
  if ObjectProp.GetInterface(IXMLWorksObject, Intf) then  
Intf.ElementText := Value  
  else if (ObjectProp is TXMLCollection) then  
  TXMLCollection(ObjectProp).ElementText := Value  
    else if (ObjectProp is TXMLCollectionItem) then  
    TXMLCollectionItem(ObjectProp).ElementText := Value  
       else if (ObjectProp is TXMLObject) then  
       TXMLObject(ObjectProp).ElementText := Value  
         else if (ObjectProp is TXMLList) then  
         TXMLList(ObjectProp).ElementText := Value  
            else if (ObjectProp is TStrings) then  
            TStrings(ObjectProp).CommaText := XMLToStr(Value)  
   
  
end;  
  
  except  
   on e: Exception do  
   raise EXMLException.Create('(' + e.Message + ')Error with property - ' + PropInfo^.Name);  
end;  
  
  end;  
  
  tkInterface:  
XMLtoInterface(Value,GetIntfProp(Instance, PropInfo));  
  
  { 
Types not supported : 
tkRecord 
tkArray 
tkDynArray 
tkMethod 
tkUnknown 
}  
   
  
end;  
  
  end;  

Установка компонента:


procedure setXMLObject_Lang(Instance: TObject; p_sXML: AnsiString);  
var  
  CurrentTagIndex, OverAllIndex: Integer;  
  CurrentTag, CurrentTagContent :string;  
begin  
  try  
     CurrentTagIndex := 1;  
     OverallIndex := 1;  
  
     repeat  
         CurrentTag := FastParseTag(p_sXML, '<' , '>', OverallIndex);  
         CurrentTagContent := FastParseTagXML(p_sXML, CurrentTag, CurrentTagIndex);  
   
  
         if (Length(CurrentTag) > 0) then  
           SetPropAsString_Lang(Instance, GetPropInfo(Instance.ClassInfo, CurrentTag), CurrentTagContent);  
   
   
  
           OverAllIndex := CurrentTagIndex;  
      until (OverAllIndex<1) or (OverAllIndex > Length(p_sXML));  
  
     except  
   on EXMLException do  
       raise;  
   on e : Exception do  
       raise EXMLException.Create('(' + e.Message + ')Error Processing XML - '  
         +CurrentTag+' ('+CurrentTagContent+') '+iif_Str(Assigned(Instance),Instance.ClassName,'));  
end;  
  
  end;  

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

Файлы для разных языков мы записываем в различные каталоги, поэтому реализуем функцию для выдачи пути к файлу перевода:


Function LangPath: String;  
Begin  
  Result:=NormalDir(NormalDir(ExtractFilePath(Application.ExeName))  
  +'Langs'+User_Sets.LangInterface);  
End;  

В данной функции:

User_Sets.LangInterface – название текущего языка. Вместо этой переменной поставьте свою.

NormalDir – нормализует каталог. Эта функция взята из JVCL. Можно обойтись и без этой функции.

Формирование файла для перевода:


Procedure SaveLangTranslate(ObjInp: TObject{; LangInp: String});  
Var TransTmp: String;  
begin  
  
    TransTmp:=GenSQLLang(ObjInp);  
   
  
  if not DirectoryExists(LangPath)  
  then ForceDirectories(LangPath);  
  SaveStringToFile(TransTmp, LangPath{+Trim(LangInp)}+ObjInp.ClassName+'.xml');  
End;  

Загрузка перевода:


Procedure LoadLangTranslate(ObjInp: TObject{; LangInp: String});  
Var TransTmp: String;  
begin  
   TransTmp:=LoadStringFromFile(LangPath{+Trim(LangInp)}+ObjInp.ClassName+'.xml');  
   DecodeSQLLang(ObjInp,TransTmp);  
end;  

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

Следуем традиции и реализуем перевод с помощью xml. Для этого используем TXMLCollectionItem и TXMLCollection.

Элементы перевода (TXMLCollectionItem):


TCorp_Const_StringCollectionItem = class(TXMLCollectionItem)  
private  
  
  FIndexName: String;  
FMessString: String;  
   
  
public  
  
  destructor Destroy; Override;  
published  
  property IndexName: String read FIndexName write FIndexName;  
  property MessString: String read FMessString write FMessString;  
end;  

Коллекция элементов перевода (TXMLCollection):


TCorp_Const_StringCollection = class(TXMLCollection)  
  
  private  
  FLangInfo: String;  
  
  public  
  
  constructor Create;  
destructor Destroy; Override;  
Function AddNewItem: TCorp_Const_StringCollectionItem;  
Procedure AddString(IndexNameInp, MessStringInp: String);  
Procedure AddIfNotExist(IndexNameInp, MessStringInp: String);  
function GetItemByIndex(index:integer): TCorp_Const_StringCollectionItem;  
function GetItemByName(NameInp: String): TCorp_Const_StringCollectionItem;  
function GetMessByName(NameInp: String): String;  
   
  procedure Assign(Source: TPersistent); override;  
published  
  Property LangInfo: String read FLangInfo write FLangInfo;  
End;  
  
  …  
  
  var Corp_Const_String: TCorp_Const_StringCollection;  
  
  …  
  
  constructor TCorp_Const_StringCollection.Create;  
begin  
  inherited Create(TCorp_Const_StringCollectionItem);  
  FLangInfo:='Uk';  
end;  
  
  destructor TCorp_Const_StringCollection.Destroy;  
begin  
  Clear;  
  inherited;  
end;  
  
  function TCorp_Const_StringCollection.AddNewItem: TCorp_Const_StringCollectionItem;  
begin  
  Result:=TCorp_Const_StringCollectionItem.Create(Self);  
end;  
  
  procedure TCorp_Const_StringCollection.AddString(IndexNameInp,  
MessStringInp: String);  
begin  
  
  With AddNewItem Do  
Begin  
  IndexName:=IndexNameInp;  
  MessString:=MessStringInp;  
End;  
  
  end;  
  
  procedure TCorp_Const_StringCollection.AddIfNotExist(IndexNameInp,  
MessStringInp: String);  
Var ItemTmp: TCorp_Const_StringCollectionItem;  
begin  
ItemTmp:=GetItemByName(IndexNameInp);  
  
  if not Assigned(ItemTmp) then  
begin  
   Corp_Const_String.AddString(IndexNameInp, MessStringInp);  
end  
else  
begin  
  
    ItemTmp.IndexName:=IndexNameInp;  
  ItemTmp.MessString:=MessStringInp;  
  
end;  
   
end;  
  
  function TCorp_Const_StringCollection.GetItemByIndex(  
index: integer): TCorp_Const_StringCollectionItem;  
begin  
         result:=TCorp_Const_StringCollectionItem(items[index])  
end;  
  
  function TCorp_Const_StringCollection.GetItemByName(  
NameInp: String): TCorp_Const_StringCollectionItem;  
var i: integer;  
begin  
  
  result:=nil;  
  
  for i:=0 to Count-1 Do  
begin  
if RusUpperCase(Trim(GetItemByIndex(i).IndexName))=RusUpperCase(Trim(NameInp))  
then result:=GetItemByIndex(i);  
   
end;  
  
end;  
  
  function TCorp_Const_StringCollection.GetMessByName(NameInp: String): String;  
Var CorpConstTmp: TCorp_Const_StringCollectionItem;  
begin  
  
  CorpConstTmp:=GetItemByName(NameInp);  
  
  if not Assigned(CorpConstTmp)  
then Result:='{NameInp}  
else Result:=CorpConstTmp.MessString;  
   
end;  
  
  procedure TCorp_Const_StringCollection.Assign(Source: TPersistent);  
begin  
  
  inherited Assign(Source);   
  
end;  
Процедура для перевода всех ресурсов:


Procedure Gen_Corp_String;  
Begin  
   
  
  
if not Assigned(Corp_Const_String)  
then Corp_Const_String:=TCorp_Const_StringCollection.Create;  
  
  // Corp_Const_String.Clear;  
Corp_Const_String.AddIfNotExist('1', 'Документ-источник не является счёт-фактурой');  
Corp_Const_String.AddIfNotExist('2', 'По этому документу построен другой документ!');  
Corp_Const_String.AddIfNotExist('3', 'Необходимо удалить вначале зависимый документ.');  
Corp_Const_String.AddIfNotExist('4', 'Документа-источника нет!');  
Corp_Const_String.AddIfNotExist('5', 'Зависимого документа нет!');  
…  
  
  End;  

Рудюк С.А.

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

Первые шаги с TThread в Delphi

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

Зачем нужен Thread
Итак, зачем же нужен класс Thread и его потомки? Во-первых, этот объект позволяет создавать как бы несколько программ в одной (несколько процессов, или, потоков). Во-вторых, эти процессы могут выполняться как по очереди, так и одновременно (как запрограммирует разработчик). В-третьих, из этих процессов можно легко получить доступ ко всем глобальным данным программы, т.к. класс процесса является, по сути, просто частью программы - обычным юнитом (unit). В-четвертых, можно создать своих собственных потомков TThread и запустить сразу несколько экземпляров одного и того же созданного класса. В-пятых, каждым процессом очень легко управлять - запускать, завершать, приостанавливать, прерывать, устанавливать приоритетность, и т.д.

Краткое описание класса TThread
Итак, рассмотрим некоторые свойства, методы и события класса TThread.

Свойства Методы События
FreeOnTerminate - освобождать ли память, выделенную под экземпляр класса процесса, когда этот процесс завершается. Если True - при завершении процесса (или при вызове метода Terminate) экземпляр класса автоматически освобождается (аналогично вызову метода Free). Тип: Boolean;
Handle (ThreadID) - дескриптор процесса. Эта величина может быть использована для управления процессом через функции WinAPI. Тип: THandle;
ReturnValue - возвращаемое значение при завершении процесса. Тип: Integer;
Priority - приоритет процесса. Возможные значения этого свойства мы разберем немного позже. Тип: TThreadPriority;
Suspended - показывает, в каком состоянии находится процесс: True - приостановлен, False - в нормальном. Тип: Boolean;
Terminated - показывает, завершен ли процесс. True - завершен, False - нет. Тип: Boolean;
Create(CreateSuspended: Boolean) - создает экземпляр класса. Параметр CreateSuspended указывает на то, нужно ли создавать приостановленную задачу (True), или запускать ее сразу (False);
Suspend - приостанавливает выполнение процесса;
Resume - продолжает выполнение процесса после Suspend;
Terminate - полностью прекращает выполнение процесса;
WaitFor - ждет завершения процесса, возвращая затем код его завершения (ReturnValue);
Synchronize(Method: TThreadMethod) - синхронизирует выполнение метода процесса, позволяя ему работать параллельно с другими процессами. OnTerminate - возникает, когда процесс находится в стадии завершения.
Приоритет процесса
Итак, что же такое приоритет? Приоритет - это величина, определяющая, насколько данный процесс должен выполнятся быстрее по сравнению с другими. Т.е., другими словами, чем выше приоритет процесса, тем больше времени он отбирает у системы и других, параллельно работающих процессов. Далее разберем возможные значения свойства Priority класса TThread в порядке возрастания приоритета:

tpIdle - процесс выполняется только тогда, когда система не занята и больше нет работающих в данных момент процессов;
tpLowest - на два пункта ниже нормального;
tpLower - на один пункт ниже нормального;
tpNormal - нормальный. Такой приоритет у большинства задач;
tpHigher - на один пункт выше нормального;
tpHighest - на два пункта выше нормального;
tpTimeCritical - самый высокий приоритет - занимает все время процессора и системы. Это приоритет для систем реального времени, для которых важна каждая секунда и даже малейшая задержка может привести к сбою. Будьте осторожны с этим приоритетом!
Практика и примеры
Приведем небольшой пример того, как можно создать отдельный процесс:

Пример 1.

{Определение класса TMyThread}  
type  
  TMyThread = class(TThread)  
  private  
    { Private declarations }  
  protected  
    procedure DoWork;  
    procedure Execute; override;  
  end;  
  
implementation  
  
procedure TMyThread.Execute;  
begin  
  {Если Вы хотите, чтобы процедура DoWork выполнялась лишь один раз - удалите цикл while}  
  while not Terminated do  
    Synchronize(DoWork);  
end;  
  
procedure TMyThread.DoWork;  
begin  
  {Здесь можно уже выполнять те задачи, которые должны быть исполнены процессом}  
end;  

А теперь - замечательный пример для изучения Thread! В нижеследующем примере приложение создает два параллельно работающих процесса. Один Thread пытается установить флажок CheckBox1 в положение "включено" (Checked := True), а другой, передергивая первого - в "выключено".

Пример 2.

{В форму Form1 нужно поместить TCheckBox - CheckBox1 
  и одну кнопку TButton - Button1}  
{Определение классов двух Thread-ов}  
type  
  TMyThread1 = class(TThread)  
  private  
    { Private declarations }  
  protected  
    procedure DoWork;  
    procedure Execute; override;  
  end;  
  
  TMyThread2 = class(TThread)  
  private  
    { Private declarations }  
  protected  
    procedure DoWork;  
    procedure Execute; override;  
  end;  
  
var Form1: TForm1;  
    T1   : TMyThread1;  
    T2   : TMyThread2;  
  
implementation  
  
procedure TMyThread1.Execute;  
begin  
  {Пока процесс не прервали, выполняем DoWork}  
  while not Terminated do  
    Synchronize(DoWork);  
end;  
  
procedure TMyThread2.Execute;  
begin  
  {Пока процесс не прервали, выполняем DoWork}  
  while not Terminated do  
    Synchronize(DoWork);  
end;  
  
procedure TMyThread1.DoWork;  
begin  
  {Пытаемся победить второй процесс :-)}  
  Form1.CheckBox1.Checked := True;  
end;  
  
procedure TMyThread2.DoWork;  
begin  
  {Пытаемся победить первый процесс :-)}  
  Form1.CheckBox1.Checked := False;  
end;  
  
procedure TForm1.Button1Click(Sender: TObject);  
begin  
  {Если кнопка называется Stop...}  
  if Button1.Caption = 'Stop' then begin  
    {Прерываем оба процесса}  
    T1.Terminate;  
    T2.Terminate;  
    {Изменяем название кнопки}  
    Button1.Caption := 'Start';  
    {Выходим из процедуры}  
    Exit;  
  end;  
  {Создаем и сразу запускаем два процесса}  
  T1 := TMyThread1.Create(False);  
  T2 := TMyThread2.Create(False);  
  {Здесь можно поэкспериментировать с приоритетами: 
   T1.Priority := tpLowest; 
   T2.Priority := tpHighest; 
   }  
  {Переименовываем кнопку}  
  Button1.Caption := 'Stop';  
end;  

P.S. Отличный пример работы с TThread можно найти в подкаталоге Demos\Threads каталога, куда Вы установили Borland Delphi.

Эпилог
В этой статье отображены основные стороны работы с процессами (потоками) Thread в Borland Delphi. Если у Вас есть вопросы - скидывайте их мне на E-mail: snick@mailru.com, а еще лучше - пишите в конференции этого сайта (Delphi. Общие вопросы), чтобы и другие пользователи смогли увидеть Ваш вопрос и попытаться на него ответить!

Автор: Карих Николай

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

Пасхальные яйца в Delphi

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

Чтобы увидеть пасхальное яйцо, пользователь должен знать специальную команду или последовательность нажатия клавиш; например, нажать в нужном месте или отредактировать секретный файл. Другими словами, пасхальные яйца существуют в виде недокументированного кода, скрытого внутри операционной системы, приложения, Web-браузера, игры, и т.д.

Компилятор Delphi в данном случае не является исключением и каждая его версия содержит скрытые сообщения. Как правило, это список разработчиков, но есть и исключения из правил. Чтобы определить, какого рода яйцо скрывается в Delphi, можно покликать по ссылкам в окошке "Elsewhere on the Web".

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

Итак, проделаем следующее:

1. Выберите форму, которая будет использоваться для запуска яйца.

2. Объявите целую (integer) переменную (с именем: icnt, в секции private):


private  
  icnt : integer;  

3. Добавьте две константы (в секции interface) :


const  
  sEgg = 'ADPRULEZ';  
  iEggLen = Length(sEgg); 

4. Добавьте следующий код в обработчик события OnCreate:


procedure TForm1.FormCreate(Sender: TObject);  
begin  
 KeyPreview := True;  
 icnt:=1;  
end;  

5. Допустим, наше пасхальное яйцо будет запускаться, когда пользователь наберёт ADPRULEZ, при нажатой клавише CTRL key. Тогда событие OnKeyDown будет выглядеть следующим образом:


procedure TForm1.FormKeyDown  
  (Sender: TObject; var Key: Word;  
   Shift: TShiftState);  
begin  
 if ssCtrl in Shift then begin  
  if Key = Ord(sEGG[icnt]) then begin  
   if icnt = iEggLen then begin  
     ShowMessage('About Delphi Programming  
                  Easter Egg!');  
     icnt := 1;  
   end else begin  
    icnt := icnt + 1;  
   end;  
  end else begin  
   icnt := 1;  
  end;  
 end;  
end;  

Как это работает?
Секретное слово, которое активизируейт пасхальное яйцо хранится в константе sEgg (ADPRULEZ). Целая переменная icnt служит для подсчёта комбинаций клавиш. В обработчике события OnCreate свойство KeyPreview устанавливается в True. Таким образом Форма начинает получать события от клавиатуры до того, как появится. Основной код находится в событии OnKeyPress. Сперва проверяется - была ли нажата клавиша Ctrl. Если так, то проверяется последняя комбинация клавиш в той последовательности, в которой мы её задали. Если "секретная" комбинация была набрана, то появится диалоговое окошко с надписью: 'About Delphi Programming Easter Egg!'

Если Вам лениво набирать коды, то можно просто разместить на форме секретную область. Теперь достаточно будет кликнуть мышкой в это крохотное место на форме и наш скрытый код запустится. Для этого поместим код в обработчик события OnMouseDown. Главное, чтобы это место на форме не заслоняли никакие визуальные компоненты!


procedure TForm1.FormMouseDown(  
    Sender: TObject;   
    Button: TMouseButton;  
    Shift: TShiftState;   
    X, Y: Integer);  
var SecretSpot : TPoint;  
begin  
  SecretSpot.x := 1; {наш секретный пиксель находится}  
  SecretSpot.y := 1; {в вехнем левом углу формы}  
      
  if (X=SecretSpot.x) and (Y=SecretSpot.y) then  
    ShowMessage('Secret place!')  
end;  

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

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

Основы работы с потоками в Delphi

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

Так вот главная фича в потоках в том, что они могут выполняться почти параллельно (или по научному псевдопараллельно) именно почти, а не совсем. На самом деле настоящая параллельность возможна только на многопроцессорной машине (2 и более проца). Но WiNdoWs, может имитировать такую работу (и не вини её в этом, если винишь, то читай выше) т.е. она (Windoz) для каждого потока выделяет небольшое количество процессорного времени (несколько миллисекунд), по истечению это времени видоус даёт поработать другому потоку потом следующему и так далее. И как ты уже наверно смог догадаться, для каждого потока определен соответствующий приоритет выполнения. Проще говоря, при написание кода мы можем указывать системе как часто она должна выделять потоку процессорного времени. Как это сделать будет рассказано ниже.

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

На этом с теорией пожалуй можно закончить и перейти к самому программировании. Многопоточного программного продукта (программный продукт –какое хорошее словосочетание).

Шаг 1. Запускай Delphi (если не знаешь как, то это тебе читать еще рановато).

Шаг 2. Создай новое приложение (File->New Application).

Шаг3. На появившеюся форму брось одну кнопку ( у меня это будет Button1) и две области рисования (у меня это будет PaintBox1 и PaintBox2 соответственно{ширина и высота, которых 300}).

Шаг 4. В модуле главной формы опишем новый метод (у меня это будет gtextout), который в качестве параметра будет получать холст и выводить на нем, в произвольном месте, любой символ (у меня это будет “@” без кавычек соответственно).

Шаг 4.1. Рассмотрим подробней как выполнить на практике выше указанное действие.

Созда новую процедуру. Впиши procedure gtextout(CNV : TCanvas) перед словом private. Затем дави по написанному правой кнопкой мыши и в появившейся менюшки выбирай “Comlete class at cursor” (по-моему так пишется (Просто в Delphi3 етого еще нет)).

Если ты всё сделал правильно, то ты должен увидеть следующее:


Procedure TForm1.gTextOut(CNV : TCanvas);  
Begin  
  
End;  

Едем дальше. Между begin и end напиши код из листинга1 .

Листинг 1.


//Даем размер шрифта на холсте  
  CNV.Font.Size:=6;  
 //Даем имя шрифта на холсте  
  CNV.Font.Name:='COmicSansMs';  
 // Даем  боевую раскраску шрифта на холсте  
  CNV.Font.Color:=clRed;  
//Выводим в произвольном месте собаку (@)  
CNV.TextOut(random(300),random(300),'@');  

Думаю в более подробных объяснениях листинг1 не нуждается, скажу лишь только то, что метод TextOut в общем виде имела бы следующий вид TextOut(координата_по_Х,координата_по_Y,выводимый_символ_); (Только не забудь, что ты используешь метод объекта TCanvas, а то будет вызвана одноименная API фунция TextOut, которая так же предназначена для вывода текста, но отличается количеством и типом параметров).

Теперь дабавь еще 2 процедуры вышеуказанным способом только в первой

Между begin и end впиши gTextOut(PaintBox1.Canvas), а во второй gTextOut(PaintBox2.Canvas). На практике это должно выглядеть примерно так:


…  
Procedure TForm1.gTextOut(CNV : TCanvas); //Это уже у тебя есть  
Procedure OutD1;                          //Это добавь  
Procedure OutD2;                        //Это тоже добавь  
…  
Procedure Tform1.OutD1;  
Begin  
gTextOut(PaintBox1.Canvas);  
End;  
  
Procedure Tform1.OutD2;  
Begin  
gTextOut(PaintBox2.Canvas);  
End;  

Эти методы получают в качестве параметра Холст и затем процедура gTextOut выводит на этом холсте собаку (@). Так а зачем мы сделали так?

{Пункт1}Дело в том, что когда методы классов одновременно вызываются из нескольких потоков, это может привести к нежелательным последствиям. Например проблемы могут вылезти при быстром чередование обработки процесса вывода изображения на экран, когда системе требуется обрабатывать объекты других классов.

Ну а теперь приступим к тому собственно из-за чего мы здесь собрались то есть к созданию потока. Кликай File->New->Thread Object.

В появившемся диалоговом окне названия класса укажем TMyThread. Этот класс будет наследником класса потока TThread. После это возникает файл с пустым описанием этого класса.

Так а теперь вернемся к нашей возможной ошибки (Пункт1) и ты поимеешь зачем мы создавали 2 «лишние» процедуры. Чтобы не возникало подобных ошибок(читай Пункт1) в классе Thread определен метод гарантированно-безопасного выполнения таких методов. Этот метод отвечает за синхронизацию всех потоков. И в качестве параметра получает только название метода. Вот именно для этого нам и понадобилось создавать 2 процедуры. Вот описание метода по синхронизации:


Type TThreadMethod= procedure of object;  
Procedure Synchronize(Method : TThreadMethod);

Едем дальше. Но вот еще один проблем как определить из внутри потока какой метод нужно вызывать в данный момент? Для того, чтобы ответить на этот вопрос введем переменную типа Boolean с именем W. Затем при создание экземпляра потока ей присвоем значение TRUE если надо выполнять метод OUTD1, и FALSE если OUTD2 соответственно.


…  
 {Как нужно описать}  
  Public  
  W: Boolean  
…  

Сам процесс работы потока описывается в его методе Execute. После переопределения этого метода у нас получится следующее.


procedure TMyThread.Execute;  
begin  
 while not Terminated do  
   if w=true  then Synchronize(Form1.OUTD1)  
  else Synchronize(Form1.OUTD2);  
end;  

И так, что это нас тут такое. СвойствоTerminated получает значение TRUE, когда прога получает значение о завершение работы. => Мы будем работать до завершения работы программы. Затем если w=true то вызывается процедура OUTD1, в противном случае OUTD2.

Теперь в разделе implementation напиши следующее: uses unit1; (Подключаем модуль1);

Теперь перейдем к первому юниту (unit1).Подключи Uni2. Затем, создай обработчик событий для Button1 и напиши там листин2.

Листинг2.


var T1,T2 : TMyThread;      {1}  
…  
T1:= TmyThread.Create(true); {2}  
T1.W:=True;             {3}  
T1.Priority:=tpLower;       {4}  
  
T2:=TmyThread.Create(true);  
T2.W:=False;  
T2.Priority:=tpLowest;  
  
T1.Resume;  
T2.Resume;  

Чего мы тут натворили? В строке {1} мы описываем две переменный, это наши будущие потоки. В строке {2} мы создаем новый поток с помощью метода Create у которого есть один параметр, он имеет значение True если поток стартует после вызова метода Resume, и False если поток стартует сразу же после создания. В строке {3} устанавливаем значение переменной W ( ты же помнишь эту загогулину).В строке {4} ставим приоритет для данного потока.

Возможные варианты значений для этого свойства перечислены в таблице1.

Табл1.

Значение Приоритет потока
tpTimeCritical Максимальный приоритет
tpHighest Приоритет на 2 пункта выше нормы
tpHigher Приоритет на 1 пункт выше нормы
tpNormal Нормальный приоритет
tpLower Приоритет на 1 пункт ниже нормы
tpLowest Приоритет на 2 пункта ниже нормы
tpIdle Поток выполняется, когда твоей ОС нечего делать

P.S. Ну вроде всё. Пример хоть и простенький, но всё же познавательный. Пожалуй, дам еще небольшой совет. У тебя есть мой код небольшой проги, но ты попробую в нем чего-то изменить, может убрать что-нибудь или прибавить своего и посмотри потом, что у тебя получится, это будет намного полезней если ты прочтешь и скажешь себе усё ПОНЯТНО! и забудешь про это. Вообще выбор за тобой. Мне остаётся лишь сказать Уд@Чи в кодинге, в девушках (глупо выразился ну смысл ты понял), и большой Уд@Чи на Сессии (если ты студент, как я). 8-)… Если у тебя возникнут вопросы то пиши (litex@atan.ru)постараюсь ответить. Пока.

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

Основные операции с буфером обмена

Буфер обмена Windows - это специальный контейнер для текста или графики, которые вырезаются, копируются и вставляются из одних приложений в другие. В данной статье рассказывается, как использовать объект TClipboard для выполнения операций вырезки/копирования/вставки в Вашем Delphi-приложении.

Буфер обмена в общих чертах

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

Объект TClipboard

Для того, чтобы работать с БО в своём приложении, мы должны подключить модуль ClipBrd в uses нашего проекта, за исключением тех случаев, когда мы используем готовые методы некоторых компонент для работы с БО.
Примерами таких компонентов могут быть TEdit, TMemo, TOLEContainer, TDDEServerItem, TDBEdit, TDBImage и TDBMemo. В модуль ClipBrd включен объект TClipboard, обращаться к которому можно просто Clipboard. Мы будем использовать методы CutToClipboard, CopyToClipboard, PasteFromClipboard, Clear и HasFormat при работе с БО и манипуляциями с текстом и графикой.

Отправка и получение текста

Для того, чтобы отправить в БО некоторый текстовый фрагмент, нужно использовать свойство AsText объекта Clipboard. Если мы хотим, к примеру, отправить текст, хранящийся в переменной SomeStringData в БО, то следует использовать такой код (всё, что было в БО до этого, будет уничтожено):


uses ClipBrd;  
...  
Clipboard.AsText := SomeStringData_Variable; 

Чтобы получить текст из БО, следует делать так:


uses ClipBrd;  
...  
SomeStringData_Variable := Clipboard.AsText; 

Примечание: если требуется просто скопировать текст в буфер обмена, например из TEdit, то не обязательно подключать модуль ClipBrd. У TEdit есть метод CopyToClipboard, который автоматически копирует выделенный текст из этого компонента в БО (данные переводятся в формат CF_TEXT).


procedure TForm1.Button2Click(Sender: TObject) ;  
begin  
   //Следующий код выделяет весь текст в TEdit  
   {Edit1.SelectAll;}  
  
   Edit1.CopyToClipboard;  
end;   

Чтобы извлекать изображения из БО, программа должна знать, в каком формате там храниться изображение. Аналогично, чтобы записывать в БО графику, приложение должно "сообщить" буферу обмена тип отправляемого изображения. Некоторые возможные значения параметра Format приведены ниже; однако в Windows определено гораздо больше форматов.

CF_TEXT - Текст, где каждая строка заканчивается CR-LF комбинацией символов.
CF_BITMAP - Изображение в формате Windows bitmap.
CF_METAFILEPICT - Изображение Windows metafile.
CF_PICTURE - Объект типа TPicture.
CF_OBJECT - Любой значимый объект.

Метод HasFormat возвращает True, если данные в буфере обмена хранятся в указанном формате и могут быть прочитаны:


if Clipboard.HasFormat(CF_METAFILEPICT) then  
   ShowMessage('Clipboard has metafile');  

Чтобы отправить изображение в БО, следует использовать метод Assign. Например, следующий код скопирует bitmap из объекта, содержащего графические данные, названного MyBitmap, в буфер обмена:


Clipboard.Assign(MyBitmap);  

В общем случае, MyBitmap - это объект одного из типов: TGraphics, TBitmap, TMetafile или TPicture.

Чтобы получить графические данные из БО, нужно: проверить текущий формат содержимого БО и использовать метод Assign, указав конечный объект для импорта данных:


{Поместите на форму кнопку (TButton) и изображение (TImage)}  
{До выполнения этого кода нажмите комбинацию клавиш [Alt]+[PrintScreen]}  
uses clipbrd;  
...  
procedure TForm1.Button1Click(Sender: TObject) ;  
begin  
if Clipboard.HasFormat(CF_BITMAP) then Image1.Picture.Bitmap.Assign(Clipboard) ;  
end;   

Немного о расширенной работе с буфером обмена

Буфер обмена хранит информацию, которую мы можем перемещать между разными приложениями, в самых различных форматах; к тому же, сами приложения могут работать с разными форматами. Однако при чтении данных из БО в Delphi-приложении через объект TClipboard, мы можем использовать только стандартные форматы: текст, графика и мета-файлы.

Допустим, у нас есть 2 запущенных Delphi-приложения... Что Вы скажете насчёт того, чтобы определить собственный формат БО для пересылки данных между этими двумя приложениями? Допустим, мы создали в меню команду "Вставить" и хотим, чтобы этот пункт был недоступен, когда, к примеру, в буфере обмена нет текстовых данных... С тех пор, как с БО начала работать какая-либо другая программа, мы не можем отследить момента, когда в буфере произойдёт какое-либо изменение... У класса TClipboard не предусмотрено таких событий, которые оповещали бы нас об этом... Всё, что нам нужно сделать - это поставить "хуки" в систему событий буфера обмена и тогда наше приложение будет автоматически узнавать обо всех изменениях его содержимого.

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

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

Определение Captcha

В прошлый раз мы остановились на таблице соответствия “код в URL картинки –> пяти-значный код Captcha”. В общем виде таблица выглядела следующим образом:

7 9 5 0
1101112 1110012 1101012 1100002
8 6 7 5
1110002 1101102 1101012 1101012
2 4 5 6
1100102 1101002 1101012 1101102
Процедура, определяющая код Captcha была построена вот так:


function Captcha(URL: string):string;  
var aURL: TURLComponents;  
 ParamStr: string; //строка, содержащая код каптчи  
 code: string; //7-ми значнй код из каптчи  
 i,j:integer;  
 begin  
    //разбиваем УРЛ на составляющие  
    Result:=URL;  
    fillchar(aurl, sizeof(turlcomponents), 0);  
    with aurl do  
    begin  
        lpszscheme := nil;  
        dwschemelength := internet_max_scheme_length;  
        lpszhostname := nil;  
        dwhostnamelength := internet_max_host_name_length;  
        lpszusername := nil;  
        dwusernamelength := internet_max_user_name_length;  
        lpszpassword := nil;  
        dwpasswordlength := internet_max_password_length;  
        lpszurlpath := nil;  
        dwurlpathlength := internet_max_path_length;  
        lpszextrainfo := nil;  
        dwextrainfolength := internet_max_path_length;  
        dwstructsize := sizeof(aurl);  
     end;  
     if internetcrackurl(pchar(Result), length(Result), 0, aurl) then  
     begin  
         ParamStr:=copy(aurl.lpszExtraInfo,5, length(aurl.lpszExtraInfo)-4);  
         //выдираем 7-ми значный код и подбираем ему число  
         Result:='';  
         for I:=1 to 5 do //всего 35 цифр по 7 цифр на знак  
         begin  
            code:=copy(ParamStr,i+7*(i-1)-(i-1),7);  
            for j := 0 to High(MCat_Captcha) do  
            if code=Cat_Captcha[j] then  
            Result:=Result+IntToStr(j);  
         end;  
      end;  
    ShowMessage('Код Captcha '+Result)  
end;  

И первое, что хочется сказать по поводу этой процедуры – она просто так не заработает. Для того, чтобы разобрать любой URL на составляющие его компоненты необходимо подключать в uses модуль WinInet в котором и содержится процедура internetcrackurl.

Теперь пройдем немного дальше. Взгляните ещё раз на таблицу соответствия. Как Вы можете заметить – она содержит расшифровку не всех цифр. Так, в таблице отсутствуют цифры: 1 и 3. Я не буду повторяться и дописывать недостающие элементы, а предложу Вам более красивый с точки зрения программистов вариант расшифровки.

Берем любое число и соответствующий ему код Captchaб например:


7 –> 1101112  

Те, кто знаком с двоичной формой счисления, могут с первого взгляда определить, что в коде Captcha содержится число 7. Смотрите:


7 –> 11+0111+2

Открываем калькулятор, жмем кнопочку Bin, забиваем 0111, жмем кнопочку Dec и, о чудо, на табло высвечивается цифра 7!

Можете проверить всю таблицу таким образом – результат попадания в цель будет 100%. Теперь можно смело сократить код для расшифровки с семи до 4-х символов, т.е. отсечь первые 2 цифры – они всегда 11 и последнюю – она всегда 2. Теперь, ради спортивного интереса, можно получить семизначный код для недостающих элементов таблицы:


1 –> 1100012  
3 –> 1100112  

Теперь осталось написать функцию по переводу двоичного представления числа в десятеричную.


function BIN2DEC(BIN: string): LONGINT;  
var  
  J: LONGINT;  
  Error: BOOLEAN;  
  DEC: LONGINT;  
begin  
  DEC := 0;  
  Error := False;  
  for J := 1 to Length(BIN) do  
    begin  
      if (BIN[J] < > '0') and (BIN[J] < > '1') then  
        Error := True;  
      if BIN[J] = '1' then  
        DEC := DEC + (1 shl (Length(BIN) - J));  
{ (1 SHL (Length(BIN) - J)) = 2^(Length(BIN)- J) }  
    end;  
  if Error then  
    BIN2DEC := 0  
  else  
    BIN2DEC := DEC;  
end;  

Весь секрет работы с двоичной системой заключается в теории, которую я, кстати почерпнул из книги “Нестандартные приемы программирования на Delphi”.

Теперь переписываем основную процедуру распознавания Captcha,используя полученные знания (в листинге представлена часть измененной процедуры):


function Captcha(URL: string):string;  
var aURL: TURLComponents;  
 ParamStr: string; //строка, содержащая код каптчи  
 code: string; //7-ми значнй код из каптчи  
 i,j:integer;  
begin  
...  
 for I:=1 to 5 do //всего 35 цифр по 7 цифр на знак  
   begin  
    {получили 4-х значный код - двоичное представление числа}  
    code:=copy(copy(ParamStr,i+7*(i-1)-(i-1),7), 3, 4);  
    Result:=Result+BIN2DEC(Code); //вычислили число Captcha  
 end  
...  
end;  

Вот и весь секрет слабой Captcha. И последнее, что хотелось бы сказать – это то, что врядли Вы когда-то встретите теперь в Интернете подобную систему защиты. Судя по тому, что из 50 каталогов сайтов, использующих эту систему защиты 50 мёртвых или переделанных, можно сделать однозначный вывод – время халявы кончилось :) Теперь Captcha стала на порядок сложнее для взлома.

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