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

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


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 Добавил: Андрей Ковальчук

Описание множества

Введение
В Delphi разрешено определять тип объектов-множеств, элементами которых являются значения одного и того же базового типа. Базовый тип определяет перечень всех элементов, которые могут содержаться в данном множестве. Количество элементов, входящих в множество, может меняться в пределах от 0 до 256 (множество, не содержащее элементов, называется пустым).

Описание
Описание типа множества имеет вид:

type <имя типа> = set of <базовый тип>;


Здесь <имя типа> - идентификатор; <базовый тип> - один из скалярных типов, кроме вещественного. Базовый тип задаётся диапазоном или перечислением. Из стандартных типов в качестве базового типа множества могут быть указаны типы byte, char и boolean. Базовый тип вводится либо через предварительное определение в разделе описаний программы, либо с помощью прямого указания после слов set of в описании типа множества, например:


type letter = 'a' .. 'z'; // Описание ограниченного типа letter  
type SL = set of letter; // Описание множественного типа SL с базовым типом letter  
  
type SLR = set of 'a' .. 'z'; // Прямое включение определения базового типа 'a .. 'z' в описание множественного типа SLR  

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


type intset = set of byte;  
var m1, m2: intset; // Переменные описаны через указание принадлежности ранее определённому типу  
var m3: set of 1..20; // Определение типа переменной непосредственно включено в её описание  

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

[ ] - пустое множество;
[1, 3, 5 .. 12] - множество, содержащее элементы 1, 3, 5, 6, .. 12;
['a' .. 'p', 'u', 'z'] - множество, состоящее из перечисленных символов типа char.

Элементы типа множества могут задаваться в виде выражений, например: [2+4, 3 * 2]. Выражения должны иметь значения из заданного базисного множества порядкового типа. Область значений переменной множественного типа представляет собой набор всевозможных подмножеств, образованных из элементов базового типа.

В отличие от перечислений нельзя говорить о первом, втором и т.п. элементах множества, поскольку для множеств понятие упорядоченности не имеет смысла. Если множество содержит всего три элемента, то общее количество возможных комбинаций составляет 2 * 2 * 2 = 8. Зарезервированное слово set способно определять множество размерностью до 256 элементов, т.е. 1,1579208923731619542357098500869e+77 вариантов. На практике такое количество вариантов никогда не понадобится. В частности, разработчики Delphi рекомендуют использовать множество с количеством элементов не более 16.

Операции над множествами

Над переменными множественного типа могут выполняться те же операции, что и над обычными множествами:

Объединение ( + );
Пересечение ( * );
Разность ( - ).
Кроме того, определённые операции проверки принадлежности элемента множеству ( in ), проверки тождественности множеств ( = ), нетождественности, множеств ( <> ), определения принадлежности (вложенности) множеств ( >= или <= ). Примеры:


1. [1, 2, 4] = [1, 4, 2] // Результат True  
2. ['a' .. 'z'] = ['a' .. 'p'] // Результат False  
3. [1, 2, 5, 6] <> [1, 2] // Результат True  
4. ['a', 'b', 'c'] <= ['a' .. 'z'] // Результат True  
5. ['a' .. 'k'] >= ['a' .. 'z'] // Результат False  
6. [1, 2, 3] + [1, 4, 5] // Результат [1, 2, 3, 4, 5]  
7. [1, 2, 3] * [1, 3, 4, 5] // Результат [1, 3]  
8. [1, 3, 4, 5] - [1, 4, 6] // Результат [3, 5]  

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


a in [a, b, c, d] // Результат True  
2 * 4 in [0 .. 4, 7 .. 10] // Результат True  
'a' + 'b' in ['ab', 'cd', 'ef'] // Результат True  
5 in [1 * 2, 4, 5] // Результат True  
5 in [2, 4, 6, 8] // Результат False  

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

Операция in позволяет проводить эффективно сложные проверки условий. Например, вместо:


(c >= '0') and (c <= '9') or (c >= 'a') and (c <='z');  

Проще записать:


c in ['0' .. '9', 'a' .. 'z'];  

Причём последняя конструкция будет, как правило, более эффективной.

Операции ( = ) и ( <> ) позволяют проверить, равны ли два множества или нет. С помощью операций ( >= ) и ( <= ) можно определить, является ли одно множество подмножеством другого. Пример:


[red, white] = [red, green] // Результат False  
[1] <= [0 .. 4] // Результат True  

Замечания:

Пустое множество [ ] является подмножеством любого другого множества независимо от базового типа его элементов.
Множества-операнды могут иметь непересекающиеся базовые типы. Располагая, например, множествами A: set of 1 .. 99 и B: set of 100 .. 150, можно в результате объединения A+B получить новое множество с базовым типом 1 .. 150.
Следует различать конструктор множества [X .. Y] и отрезок порядкового типа X .. Y. При X > Y в первом случае речь идёт о пустом множестве, а во втором компилятор выдаст ошибку. Пример:

['a', 'b'] = ['b' .. 'a'] // Результат False  

При проверке на подмножество выполняется тест на "меньше или равно", а не только проверка на собственное подмножество, т.е без "равно". Операции ( < ) и ( > ) не предусмотрены, поэтому при необходимости проверку на собственное подмножество для множеств A и B можно провести следующим образом:


(A <= B) and (A >= B) или (A >= B) and (A <> B)  

Для задания правильного порядка выполнения операций следует учитывать принятый порядок старшинства (приоритета) операций над множествами: пересечение ( * ) имеет тот же приоритет, что и арифметические операции умножения и деления; объединение ( + ) и разность ( - ) занимают следующий, более низкий уровень приоритета, аналогично арифметическим операциям сложения и вычитания; на самом нижнем уровне находятся операции сравнения множеств ( =, <>, <=, >=) и проверки принадлежности элемента множеству ( in ). Операции одного приоритета выполняются слева направо. Для изменения порядка выполнения операций используются круглые скобки.

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


program Project1;  
  
{$APPTYPE CONSOLE}  
  
uses SysUtils;  
  
var  
str: string;  
L: byte;  
t: boolean;  
  
begin  
Writeln('Enter string');  
readln(str);  
L:=length(str); // Число введённых символов  
t:=L>0; // True, если не пустая строка  
while t and (L>0) do // Проверка с конца строки  
begin  
t:=str[L] in ['0' .. '9', 'a' .. 'z', 'A' .. 'Z']; // Проверка допустимости символа  
dec(L); // Предыдущий символ  
end;  
if t then writeln('True String') // Правильная строка  
else writeln('False string]'); // Неправильная строка  
Readln;  
end.  

Пример процедуры выводящей элементы множества с указанием их числа и её реализация (скачать здесь - 523 байт):


program Project1;  
  
{$APPTYPE CONSOLE}  
  
uses SysUtils;  
  
var  
a: set of char;  
s: string[50];  
count: integer;  
i,l: integer;  
  
procedure Mnogo;  
var  
ch: char;  
begin  
for ch:=low(char) to high(char) do  
if ch in a then  
begin  
write(ch, '');  
inc(count);  
end;  
writeln;  
writeln('Kol-vo simbol: ', count);  
end;  
  
begin  
write('Enter the String please: ');  
readln(s);  
l:=length(s);  
for i:=1 to l do a:=a+[s[i]];  
mnogo;  
readln;  
end.  

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

Обход дерева каталогов с прерыванием и возобновлением или «Куда мы идем завтра?»

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

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

Со стандартной процедурой обхода дерева сталкивались очень многие:


procedure FileFind(path:string);  
var  
  sr:Tsearchrec;// Описываем структуру, которую использует для поиска система  
  found:integer; // найдено или нет  
begin  
  found:=FindFirst(path + '\*.*', FaAnyfile, sr); {по команде FindFirst программа создает структуру следующего типа 
  TsearchRec = record 
    Time: Integer; // время создания 
    Size: Integer; // его размер 
    Attr: Integer;// атрибуты 
    Name:TFileName // = TString; собственно имя файла 
    ExcludeAttr: Integer; найденные атрибуты 
    FindHandle: THandle; // !!! указатель на структуру поиска, которую создает система, а не наша программа. Вот для 
чего обязательно в конце поиска указывать FindClose - это высвобождает память 
    FindData: TWin32FindData; // собственно эта структура 
  end;}  
  while (found = 0) do // если хоть чтото найдено  
  begin  
    if (sr.name <> '.') and (sr.name <> '..') then  
    begin // если это не указатели на корневые каталоги, то чтото нашли  
      if (sr.attr and FaDirectory) = FaDirectory then  
    // ага вот поддиректория - вызываем себя рекурсивно, но с поиском уже в этой директории  
        FileFind(path+'\'+sr.name)  
      else  
      begin  
        // вот тут выполняем что-то с найденным файлом  
        ......  
        mainform.memo1.lines.append(path+'\'+sr.name);  
      end  
    end;  
    found:=findnext(sr); // есть ли еще файлы или каталоги  
  end;  
  FindClose(sr); // поиск закончен - нужно освободить память  
end;  

Казалось бы сохранить состояние процедуры поиска просто - достаточно сохранить структуру - sr:TSearchRec, а потом ее восстановить и поиск продолжится.

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

Второе - сама SearchRec. Казалось бы она находится в области данных нашей программы. Да это наполовину верно. Верхняя половина SearchRec действительно лежит в области данных нашей программы и делать мы с ней можем что душе угодно. Это переменные Time: Integer; Size: Integer; Attr: Integer; Name:TFileName; ExcludeAttr: Integer;. А вот вторая ее половина (FindHandle: THandle; FindData: TWin32FindData;) нам не принадлежит - ее генерирует система по нашему запросу FindFirst(.....) и уничтожает по команде FindClose(....).

Третий казалось бы простой вопрос - SearchRec.Name имеет тип TFileName=TString. Какую длину он имеет? Одни скажут 255, другие 65535. Согласен, и то и другое верно, но не тут. Длина действительно 255. А вот с типом нас нагло обманули. Реально в памяти хранится не TString [255], а PChar {Имя файла}+PChar{его расширение}. Для нас с вами это преобразуется в обычную строку при обращении, и до столкновения с данной ситуацией я свято верил что там TString[255]. Кстати в чем разница между Богом и билом гейтсом? Бог не считает себя билом гейтсом ...

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

Третий вопрос - как сохранить , а потом восстановить SearchRec, если он состоит непонятно из чего. А давайте сделаем свой SearchRec, как нам нужно. А именно так:


type // этот тип почти полностью переписывается со стандартного TSearchRec  
TMysearchRec = record  
  Time: Integer;   
  Size: Integer;   
  Attr: Integer;  
  Name: string[250];//вот тут обрабатывалось неверно при типе TString, как длина ?  
  ExcludeAttr: Integer;   
  FindHandle: THandle; // в принципе не нужен, но не будем сильно пугать читателей  
// сильными отличиями, да и бог с ними - с восемью байтами  
  FindData: TWin32FindData;  
end;  

Но нам еще требуется сохранять несколько переменных самой программы, а именно Found - найдено чтото или нет и Path - с каким параметром нас вызывали, поэтому на основе этого типа делаем еще один:


TMyRec_Sea = record  
  Rec_Sea:TMySearchRec; // наша структура поиска  
  path:String[250]; // откуда начинали  
  found:integer; // при остановке нашли чтото или нет  
end; 

Второй вопрос после первого решается не очень красиво, но довольно легко. Да система генерит структуру: FindHandle: THandle; FindData: TWin32FindData. FindData - собственно сама структура и FindHandle - указатель на нее. Пусть система генерит что угодно, если с умом, то можно обойти и это. Многие ли помнят такое INT21h->INT 13H. Думаю вспомнили. При восстановлении поиска дадим команду FindFirst, а потом подменим FindData и остальные поля, не трогая FindHandle, иначе сразу после окончания поиска (!!! ???) получим обращение к недопустимому адресу и вылет программы.


......  
// создаем запись для поиска  
FindFirst(path+'\'+mask, FaAnyfile, sr);  
delfile:=false; found:=buffer.found;  
// загоняем в SEARCHREC все кроме FINDHANDLE (он создается системой)  
sr.Time:=buffer.rec_sea.Time; sr.Size:=buffer.rec_sea.Size;  
sr.Attr:=buffer.rec_sea.Attr; sr.Name:=buffer.rec_sea.Name;  
sr.ExcludeAttr:=buffer.rec_sea.ExcludeAttr; sr.FindData:=buffer.rec_sea.FindData;  

Первый вопрос - как же сохранять состояние процедуры при рекурсии?. Давайте сохранять SearchRec в файл и используем принцип магазина (не продуктового, а от автомата калашникова) - последний вошел - первый вышел. Вот примерная структура процедуры при выполняющемся поиске (при нескольких рекурсивных вызовах):


Findfile('c:\')  
FindFile('c:\Docs')  
FindFile(c:\Docs\Delphi')  
......  

При получении сигнала на остановку процедуры начинают писать в файл в обратном порядке, а именно - FindFile(c:\Docs\Delphi'),Findfile('c:\Docs'),Findfile('c:\'). Примерно так:


Findfile('c:\')------------------------------------+  
Findfile('c:\Docs')---------------------+ !  
FindFile(c:\Docs\Delphi') ---+ ! !  
v v v  
[файл сохранений состояния] [rec1] [rec2] [rec3]  

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

Да, едва не забыл, как мы узнаем что надо приостановить поиск? Давайте заведем глобальную переменную Process. Как она станет False - пора останавливаться.

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


unit unit1;  
......  
var  
   ....  
   process:boolean; // вот глобальная переменная она и управляет поиском true - можно  
   // false - стоп с запоминанием состояния  
   .....  
   
procedure FileFind(path:string;resume:boolean);  
{ сканирует диск (вернее дерево каталогов) при вызове PATH - начальный каталог для обхода 
RESUME - если TRUE - то продолжать сохраненный поиск (тогда значение PATH игнорируется, 
кроме случая, когда не обнаружен файл сохранения поиска) 
при установке глобальной переменной PROCESS в false останавливается 
с запоминанием предыдущего состояния,внимание - РЕКУРСИЯ !!! }  
const  
   save_ext='.rec'; // в каталоге приложения создает SAVE файл с именем приложения и указанным расширением  
   mask='*.*';  
type  
   TMysearchRec = record  
   // пришлось написать свой тип SEARCHREC с NAME фиксированной длины  
   Time: Integer; Size: Integer; Attr: Integer;  
   Name: string[250]; //вот тут обрабатывалось неверно при типе TString, как длина ?  
   ExcludeAttr: Integer; FindHandle: THandle; FindData: TWin32FindData;  
end;  
TMyRec_Sea = record  
Rec_Sea:TMySearchRec;  
path:String[250]; found:integer; delfile:boolean;  
end;  
var  
   sr:TSearchRec;  
   RecFile:TFileStream;  
   buffer:tMyRec_Sea;  
   sp,save_file_name:string; found:integer; delfile:Boolean;  
   delfile:Boolean;  
begin  
   if resume then  
   // возобновить поиск или начать новый  
   begin  
      save_file_name:=ChangeFileExt(ParamStr(0),save_ext);  
      if FileExists(save_file_name) then  
      begin  
         RecFile:=TFileStream.Create(save_file_name,fmOpenReadWrite);  
         // чистим буфер, не важно, необходимо для отладки  
         fillchar(buffer,sizeof(buffer),#0);  
         // читаем сохранение начиная с конца файла  
         RecFile.Seek(-1*sizeof(buffer),soFromEnd);  
         RecFile.Readbuffer(buffer,sizeof(buffer));  
         path:=buffer.path; sp:=path;  
         // создаем запись для поиска  
         FindFirst(path+'\'+mask, FaAnyfile, sr);  
         delfile:=false; found:=buffer.found;  
         // загоняем в SEARCHREC все кроме FINDHANDLE (он создается системой)  
         sr.Time:=buffer.rec_sea.Time; sr.Size:=buffer.rec_sea.Size;  
         sr.Attr:=buffer.rec_sea.Attr; sr.Name:=buffer.rec_sea.Name;  
         sr.ExcludeAttr:=buffer.rec_sea.ExcludeAttr; sr.FindData:=buffer.rec_sea.FindData;  
         // режем кусок уже прочитали свои данные - другим они не понадобятся  
         RecFile.Seek(-1*sizeof(buffer),soFromEnd); recfile.Size:=RecFile.Position;  
         // дорезались - дозагружаться неоткуда  
         if RecFile.Size=0 then delfile:=true;  
         RecFile.Free;  
         if delfile then sysutils.DeleteFile(save_file_name);  
      end  
      else  
      // нет сохраненных поисков  
      begin  
         // начинаем новый  
         sp:=path; resume:=false;  
         // тут исправляется разница между C:\ и C:\DOCS - убираем последний слэш  
         if sp[length(sp)]='\' then sp:=copy(sp,1,length(sp)-1);  
         found:=FindFirst(sp + '\'+mask, FaAnyfile, sr);  
      end  
   end  
   else  
   begin  
      // новый поиск - пристрелить старые записи  
      save_file_name:=ChangeFileExt(ParamStr(0),save_ext);  
      if fileExists(save_file_name) then sysutils.DeleteFile(save_file_name) ;  
      sp:=path;  
      if sp[length(sp)]='\' then sp:=copy(sp,1,length(sp)-1);  
      found:=FindFirst(sp + '\'+mask, FaAnyfile, sr);  
   end;  
   // закончена подготовка - вперед поиск  
   while (found = 0) and process do  
   begin  
      application.ProcessMessages;  
      if (sr.name <> '.') and (sr.name <> '..') then  
      begin  
         if (sr.attr and FaDirectory) = FaDirectory  
         then  
         begin  
            FileFind(sp+'\'+sr.name,resume);  
         end  
         else  
         begin  
            // ну тут разные действия с найденым файлом  
            mainform.label1.caption:=('начат разбор '+sp+'\'+sr.name) ;  
            ................  
            // закончили действия  
   
            Application.ProcessMessages; // а вот без этого мы никогда не узнаем что пора поиск  
            // закончить  
         end;  
      end;  
      if process then found:=findnext(sr);  
   end;  
   if not process then  
   // получили сигнал на остановку сканирования нужно запомнить состояние  
   begin  
      save_file_name:=ChangeFileExt(ParamStr(0),save_ext);  
      if not FileExists(save_file_name) then RecFile:=TFileStream.Create(save_file_name,fmCreate)  
      else RecFile:=TFileStream.Create(save_file_name,fmOpenReadWrite);  
      RecFile.Seek(0,soFromEnd);  
      // заполняем буфер текущим состоянием  
      buffer.rec_sea.Time :=sr.Time; buffer.rec_sea.Size :=sr.Size ;  
      buffer.rec_sea.Attr :=sr.Attr ; buffer.rec_sea.Name :=sr.Name ;  
      buffer.rec_sea.ExcludeAttr :=sr.ExcludeAttr ; buffer.rec_sea.FindHandle :=sr.FindHandle ;  
      buffer.rec_sea.FindData :=sr.FindData ; buffer.path:=sp; buffer.found:=found;  
      RecFile.Writebuffer(buffer,sizeof(buffer));  
      RecFile.Free;  
   end;  
   Application.ProcessMessages;  
   sysutils.FindClose(sr);  
end;  

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

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

Обращение к Excel из DELPHI

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

Организация доступа к книге EXCEL
Для взаимодействия с MS excel в программе необходимо использовать модуль ComObj

uses ComObj;

и объявить переменную для доступа к MS excel следующего типа:
var Excel: Variant;


Инициализация переменной Excel в простейшем случае можно осуществить так:
Excel := CreateOleObject('Excel.Application');


Создание новой книги:
Excel.Workbooks.Add;

Открытие существующей книги (где path - путь к фалу с расширением xls.):
Excel.Workbooks.Open[path];


Открытие существующей книги только для чтения:
 Excel.Workbooks.Open[path, 0, True];


Закрытие Excel:
Excel.ActiveWorkbook.Close;
    Excel.Application.Quit;


Блокировка запросов (подтвеждений, уведомлений) Excel, например, запретить запрос на сохранение файла:
Excel.DisplayAlerts:=False;


Отображаем Excel на экране:
Excel.Visible := True;

или скрываем:
Excel.Visible := False;


Печать содержимого активного листа excel:
Excel.ActiveSheet.PrintOut;


Чтение/запись данных в EXCEL
Доступ к ячейке в текущей книге Excel можно осуществить следующим образом:
Excel.Range['B2']:='Привет!';- для записи значения в ячейку или
s:=Excel.Range['B2']; - для чтения,
где B2 - адрес ячейки.

Или используя стиль ссылок R1C1:
Excel.Range[excel.Cells[2, 2]]:='Привет!';, где [2, 2] - координата ячейки.

Вообще, ячейке Excel можно присваивать любое значение (символьное, целое, дробное, дата) при этом Excel установит форматирование в ячейке применяемое по умолчанию.

Формат ячеек в EXCEL
Выделить (выбрать) группу ячеек для последующей работы можно так:
Excel.Range[Excel.Cells[1, 1], Excel.Cells[5, 3]].Select;

или
Excel.Range['A1:C5'].Select;

при этом будет выделена область находящаяся между ячейкой A1 и C5.

После выполнения выделения можно установить:
1) объединение ячеек
Excel.Selection.MergeCells:=True;

2) перенос по словам
Excel.Selection.WrapText:=True;

3) горизонтальное выравнивание
Excel.Selection.HorizontalAlignment:=3;

при присваивании значения 1 используется выравнивание по умолчанию, при 2 - выравнивание слева, 3 - по центру, 4 - справа.
4) вериткальное выравнивание
Excel.Selection.VerticalAlignment:=1;

присваиваемые значения аналогичны горизонтальному выравниванию.
5) граница для ячеек
Excel.Selection.Borders.LineStyle:=1;

При значении 1 границы ячеек рисуются тонкими сплошными линиями.
Кроме этого можно указать значения для свойства Borders, например, равное 3. Тогда установится только верхняя граница для блока выделения:
Excel.Selection.Borders[3].LineStyle:=1;

Значение свойства Borders задает различную комбинацию граней ячеек.
В обоих случаях можно использовать значения в диапазоне от 1 до 10.

Использование паролей в EXCEL
Установка пароля для активной книги может быть произведена следующим образом:
try
   // попытка установить пароль
   Excel.ActiveWorkbook.protect('pass');
except
   // действия при неудачной попытке установить пароль
end;

где pass - устанавливаемый пароль на книгу.

Снятие пароля с книги аналогично, использовуем команду
Excel.ActiveWorkbook.Unprotect('pass');

где pass - пароль, установленный для защиты книги.

Установка и снятие пароля для активного листа книги Excel производится командами
Excel.ActiveSheet.protect('pass'); // установка пароля
Excel.ActiveSheet.Unprotect('pass'); // снятие пароля 

где pass - пароль, установленный для защиты книги.

Вспомогательные операции в EXCEL
Удаление строк со сдвигом вверх:
    Excel.Rows['5:15'].Select;
    Excel.Selection.Delete;

при выполнении данных действий будут удалены строки с 5 по 15.

Установка закрепления области на активном листе Excel
     // снимаем закрепление области, если оно было задано
   Excel.ActiveWindow.FreezePanes:=False;
     // выделяем нужную ячейку, в данном случае D3
   Excel.Range['D3'].Select;
     // устанавливаем закрепление области
   Excel.ActiveWindow.FreezePanes:=True;

Удачной работы!

Источник:

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

Организация доступа к книге EXCEL
Для взаимодействия с MS excel в программе необходимо использовать модуль ComObj
uses ComObj;

и объявить переменную для доступа к MS excel следующего типа:
var Excel: Variant;


Инициализация переменной Excel в простейшем случае можно осуществить так:
    Excel := CreateOleObject('Excel.Application');


Создание новой книги:
    Excel.Workbooks.Add;

Открытие существующей книги (где path - путь к фалу с расширением xls.):
    Excel.Workbooks.Open[path];


Открытие существующей книги только для чтения:
    Excel.Workbooks.Open[path, 0, True];


Закрытие Excel:
    Excel.ActiveWorkbook.Close;
    Excel.Application.Quit;


Блокировка запросов (подтвеждений, уведомлений) Excel, например, запретить запрос на сохранение файла:
    Excel.DisplayAlerts:=False;


Отображаем Excel на экране:
    Excel.Visible := True;

или скрываем:
    Excel.Visible := False;


Печать содержимого активного листа excel:
    Excel.ActiveSheet.PrintOut;


Чтение/запись данных в EXCEL
Доступ к ячейке в текущей книге Excel можно осуществить следующим образом:
Excel.Range['B2']:='Привет!';- для записи значения в ячейку или
s:=Excel.Range['B2']; - для чтения,
где B2 - адрес ячейки.

Или используя стиль ссылок R1C1:
Excel.Range[excel.Cells[2, 2]]:='Привет!';, где [2, 2] - координата ячейки.

Вообще, ячейке Excel можно присваивать любое значение (символьное, целое, дробное, дата) при этом Excel установит форматирование в ячейке применяемое по умолчанию.

Формат ячеек в EXCEL
Выделить (выбрать) группу ячеек для последующей работы можно так:
   Excel.Range[Excel.Cells[1, 1], Excel.Cells[5, 3]].Select;

или
   Excel.Range['A1:C5'].Select;

при этом будет выделена область находящаяся между ячейкой A1 и C5.

После выполнения выделения можно установить:
1) объединение ячеек
   Excel.Selection.MergeCells:=True;

2) перенос по словам
   Excel.Selection.WrapText:=True;

3) горизонтальное выравнивание
   Excel.Selection.HorizontalAlignment:=3;

при присваивании значения 1 используется выравнивание по умолчанию, при 2 - выравнивание слева, 3 - по центру, 4 - справа.
4) вериткальное выравнивание
   Excel.Selection.VerticalAlignment:=1;

присваиваемые значения аналогичны горизонтальному выравниванию.
5) граница для ячеек
   Excel.Selection.Borders.LineStyle:=1;

При значении 1 границы ячеек рисуются тонкими сплошными линиями.
Кроме этого можно указать значения для свойства Borders, например, равное 3. Тогда установится только верхняя граница для блока выделения:
   Excel.Selection.Borders[3].LineStyle:=1;

Значение свойства Borders задает различную комбинацию граней ячеек.
В обоих случаях можно использовать значения в диапазоне от 1 до 10.

Использование паролей в EXCEL
Установка пароля для активной книги может быть произведена следующим образом:
try
   // попытка установить пароль
   Excel.ActiveWorkbook.protect('pass');
except
   // действия при неудачной попытке установить пароль
end;

где pass - устанавливаемый пароль на книгу.

Снятие пароля с книги аналогично, использовуем команду
Excel.ActiveWorkbook.Unprotect('pass');

где pass - пароль, установленный для защиты книги.

Установка и снятие пароля для активного листа книги Excel производится командами
Excel.ActiveSheet.protect('pass'); // установка пароля
Excel.ActiveSheet.Unprotect('pass'); // снятие пароля 

где pass - пароль, установленный для защиты книги.

Вспомогательные операции в EXCEL
Удаление строк со сдвигом вверх:
    Excel.Rows['5:15'].Select;
    Excel.Selection.Delete;

при выполнении данных действий будут удалены строки с 5 по 15.

Установка закрепления области на активном листе Excel
     // снимаем закрепление области, если оно было задано
   Excel.ActiveWindow.FreezePanes:=False;
     // выделяем нужную ячейку, в данном случае D3
   Excel.Range['D3'].Select;
     // устанавливаем закрепление области
   Excel.ActiveWindow.FreezePanes:=True;

Удачной работы!

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

Обмен данными с Excel

В delphi 5, для обмена данными между Вашим приложением и excel можно использовать компонент texcelapplication, доступный на servers page в component palette.
Совместимость: delphi (5.x или выше). На форме находится tstringgrid, заполненный некоторыми данными и две кнопки, с названиями to excel и from excel. Так же на форме находится компонент texcelapplication со свойством name, содержащим xlapp и свойством connectkind, содержащим cknewinstance. Когда нам необходимо работать с excel, то обычно мы открываем excelapplication, затем открываем workbook и в конце используем worksheet. Итак, несомненный интерес представляет для нас листы (worksheets) в книге (workbook).

Давайте посмотрим как всё это работает.

Посылка данных в excel

Это можно сделать с помощью следующей процедуры :


procedure tform1.bitbtntoexcelonclick(sender: tobject);  
var  
workbk : _workbook; // определяем workbook  
worksheet : _worksheet; // определяем worksheet  
i, j, k, r, c : integer;  
iindex : olevariant;  
tabgrid : variant;  
begin  
if genericstringgrid.cells[0,1] <> '' then  
begin  
iindex := 1;  
r := genericstringgrid.rowcount;  
c := genericstringgrid.colcount;  
// Создаём массив-матрицу  
tabgrid := vararraycreate([0,(r - 1),0,(c - 1)],varolestr);  
i := 0;  
// Определяем цикл для заполнения массива-матрицы  
repeat  
for j := 0 to (c - 1) do  
tabgrid[i,j] := genericstringgrid.cells[j,i];  
inc(i,1);  
until  
i > (r - 1);  
// Соединяемся с сервером texcelapplication  
xlapp.connect;  
// Добавляем workbooks в excelapplication  
xlapp.workbooks.add(xlwbatworksheet,0);  
// Выбираем первую workbook  
workbk := xlapp.workbooks.item[iindex];  
// Определяем первый worksheet  
worksheet := workbk.worksheets.get_item(1) as _worksheet;  
// Сопоставляем delphi массив-матрицу с матрицей в worksheet  
worksheet.range['a1',worksheet.cells.item[r,c]].value := tabgrid;  
// Заполняем свойства worksheet  
worksheet.name := 'customers';  
worksheet.columns.font.bold := true;  
worksheet.columns.horizontalalignment := xlright;  
worksheet.columns.columnwidth := 14;  
// Заполняем всю первую колонку  
worksheet.range['a' + inttostr(1),'a' + inttostr(r)].font.color := clblue;  
worksheet.range['a' + inttostr(1),'a' + inttostr(r)].horizontalalignment := xlhalignleft;  
worksheet.range['a' + inttostr(1),'a' + inttostr(r)].columnwidth := 31;  
// Показываем excel  
xlapp.visible[0] := true;  
// Разрываем связь с сервером  
xlapp.disconnect;  
// unassign the delphi variant matrix  
tabgrid := unassigned;  
end;  
end;  
Получение данных из excel  
Это можно сделать с помощью следующей процедуры :  
procedure tform1.bitbtnfromexcelonclick(sender: tobject);  
var  
workbk : _workbook;  
worksheet : _worksheet;  
k, r, x, y : integer;  
iindex : olevariant;  
rangematrix : variant;  
nomfich : widestring;  
begin  
nomfich := ‘c:mydirectorynameoffile.xls’;  
iindex := 1;  
xlapp.connect;  
// Открываем файл excel  
xlapp.workbooks.open(nomfich,emptyparam,emptyparam,emptyparam,emptyparam,  
emptyparam,emptyparam,emptyparam,emptyparam,emptyparam,emptyparam,  
emptyparam,emptyparam,0);  
workbk := xlapp.workbooks.item[iindex];  
worksheet := workbk.worksheets.get_item(1) as _worksheet;  
// Чтобы знать размер листа (worksheet), т.е. количество строк и количество // столбцов, мы активируем его последнюю непустую ячейку  
worksheet.cells.specialcells(xlcelltypelastcell,emptyparam).activate;  
// Получаем значение последней строки  
x := xlapp.activecell.row;  
// Получаем значение последней колонки  
y := xlapp.activecell.column;  
// Определяем количество колонок в tstringgrid  
genericstringgrid.colcount := y;  
// Сопоставляем матрицу worksheet с нашей delphi матрицей  
rangematrix := xlapp.range['a1',xlapp.cells.item[x,y]].value;  
// Выходим из excel и отсоединяемся от сервера  
xlapp.quit;  
xlapp.disconnect;  
// Определяем цикл для заполнения tstringgrid  
k := 1;  
repeat  
for r := 1 to y do  
genericstringgrid.cells[(r - 1),(k - 1)] := rangematrix[k,r];  
inc(k,1);  
genericstringgrid.rowcount := k + 1;  
until  
k > x;  
// unassign the delphi variant matrix  
rangematrix := unassigned;  
end;  

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