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

Назло блокноту. Или всё для работы с расширениями в Windows с помощью Delphi

Статья показывает на конкретных примерах, как ассоциировать вашу программу с каким-либо расширением Windows, самому зарегистрировать свое расширение в системе и как добавить пункт в контекстном меню Windows (типа "открыть в...") для открытия документов вашей прогой (по-видимому текстовым редактором:)

Небольшое вступление, которое надо прочитать

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

Недавно я закончил делать текстовый редактор (кому интересно, обращайтесь сюда). А когда закончил, то подумал, неплохо было бы встроить в Maks Editor (в дальнейшем за этим названием будет подразумеваться мой текстовый процессор) функции ассоциации с различными расширениями Windows, заодно сделать так, чтобы можно было самому регистрировать расширения и прописывать пункты в контекстном меню Windows, отвечающие за запуск документов (типа "открыть в...") моим текстовым процессором!!!

Кто разобрался в том, что я сказал, может пропускать следующие 3 параграфа и читать дальше, кто нет - сейчас объясню суть вышесказанных слов... Помните, когда вы создаете текстовый файл (неважно каким способом), то перед вами раскрывается блокнот (раскрываться может и что-либо другое), и значок вашего файла заменяется значком блокнота (или программы, отвечающей за обработку файлов с расширением .txt). Так вот, за каждое расширение в Windows отвечает одна программа, называемая "программой по умолчанию". Эту программу конечно можно легко изменить для любого расширения: выбираете пункт "открыть с помощью", находите нужную прогу и ставьте галочку - использовать её для всех файлов такого типа.

С ассоциацией расширений вроде бы разобрались - едем дальше. Что значит - самому регистрировать расширения? А это значит, вы должны сказать Windows: "Вот тебе новое расширение, засоси, подруга!" и прописать прогу, которая будет работать с этим расширением - будет "прогой по умолчанию". То есть: зарегистрируете вы расширение .maks, и теперь при каждом открытия файла типа *.maks, будет открываться ваша прога (которую вы, наверное, сами создали) и появляться значок, соответствующий значку проги.

С этим тоже вроде бы всё ясно - прем вперед...Прописка пункта контекстного меню. Ну тут всё легко - в главном контексте Windows создается ваш пункт, при нажатии по которому открывается ваше приложение с содержимым того файла, относительно которого находилось меню. Прогу тоже можно сделать любой.

Так вот, все эти вещи могут понадобиться вам, если вы, например, создаете текстовый редактор. Причем, не обязательно стараться над кодингом редактора - можно просто положить какой-нибудь RichEdit на форму и все... прописать пункт в контекстном меню Виндоуз типа "Открыть с MyEditor". И написать вот это в событие onshow формы:


if (ParamCount > 0) and FileExists(ParamStr(1)) then  
RichEdit.LoadFromFile(ParamStr(1)); // если мы сразу открываем файл из Windows, то загружаем его в эдитор   

Теперь вы можете легко и быстро работать с документами с помощью вашего эдитора без предварительного инсталлированя его в систему!!! Виндоуз сама опознает поле для редактирования и будет заносить туда данные после открытия!

И запомните, все, что я вам сейчас покажу, требует знаний работы с реестром - но это в принципе не главное. Просто я все делал под Windows XP, а реестр XP и реестр "Леноллиума" - это разные вещи. Поэтому я не даю никакой гарантии, что у вас все будет нормально в другой операционке (я даже с уверенностью говорю, что кроме XP, у вас ассоциация и прочая белиберда вообщей не пойдет в другой системе:~(. Так что если вы читаете это пособие, уютно расположившись в Win 3.1, то можете завязывать чтение (что я вам, конечно не рекомендую, так как материал полезен для упрочнения знаний о строении и работе реестра). И не думайте, что я в этой маленькой статейке расскажу о том, как сделать текстовый редактор, я просто покажу вам по 1 примеру на каждый из этих пунктов:

Как ассоциировать стандартное расширение с прогой
Зарегистрировать свое расширение
Добавить пункт в контексте
И все это сотворить програмно с помощью нашей любимой Delphi.

Объяснять я буду, исходя из устройства Delphi 7, но в других средах этот процесс совсем не будет отличаться, так как модуль Registry действует везде.

Начинаем кодинг (или немного про реестр)

Итак начнем. Запускаем Delphi, создаем приложение, у нас появляется форма. На неё мы ложим RichEdit и изменяем его свойство align на alclient. Тем самым мы растянули его по всей форме. Также лучше стереть надпись "RichEdit1" в его свойстве Lines. Теперь создайте еще 1 форму: нажмите file->new->form. Но эта форма (буду называть её form2) у нас пока что не как не связана с главной формой (form1). Для того, что их хоть как-то связать, откройте окно редактора кода у form1 и добавьте модуль с вашей второй формой: пишете слово unit и идентификатор формы (в данной случае 2).


uses unit2; //обязательно!!!  

Соединили, ну все равно, form2 нигде не будет у нас видна при запуске проги. Для этого её надо вызвать. Как вы будете её вызывать, решать вам. Можно создать главное меню сверху и оттуда, но я не буду объяснять, как это делать. Я просто взял и поместил обычную кнопку на RichEdit1 - не слишком правильно, но на виду. Теперь обрабатываем событие onclick кнопки button1 (для этого щелкаем по ней 2 раза).


procedure TForm1.Button1Click(Sender: TObject);  
begin  
// вызываем форму так, чтобы она оставалась в фокусе, пока мы ее не вырубим  
form2.ShowModal;  
end;   

Все, теперь на form2 ложим несколько компонент: 2 edit'a, 2 checkbox'a, 3 button'a.

Первый Edit будет служить у нас полем ввода для расширения, которое мы хотим зарегистрировать, так что изменим его свойство name на extension. А первая кнопка будет у нас регистрировать это расширение - назовем её createext, вторая кнопка будет это расширение дизинтегрировать (какое слово умное я придумал:) - назовем её deleteext.Первый CheckBox будет служить у нас расширением .txt (я покажу вам пример только с одним расширением, так как работа с остальными расширениями идентична), т.е. если чекбокс включен - стоит крестик, то ассоциируем нашу прогу с расширением *.txt, если выключен - крестика нет, то отменяем интеграцию, прописав блокнот "прогой по умолчанию" (как в начале было:). Так что изменяем его имя на txt. Второй CheckBox будет работать совместно с edit2: в edit2 мы будем вводить пункт в контекстном меню, который нам надо зарегистрировать, а флажок будет указывать нам, создавать этот пункт или удалять (включен - создаем, выключен - удаляем:). Изменяем имя второго флажка на context, а имя второго edit'a на contextstr. Изменения имен я сделал только для удобства (чтобы не запутаться:). И наконец последняя кнопка под именем Gues будет делать... потом узнаете что:)

Итак начнем кодить, но сначала я дам вам некоторую инфу про реестр:

Как вы, наверное, знаете, реестр - это большая база данных вашей системы, в котором очень легко напортачить, а исправить содеянное порой просто невозможно (вообще, я вам сразу советую открыть реестр и держать его открытым до конца кодинга). Так вот в реестре 6 главных разделов, а мы будем работать с разделом HKEY_CLASSES_ROOT - в нем хранятся настройки, отвечающие за регистрацию различных расширений, контекстных меню, названий системных программ (корзины, например) и еще куча всего прочего. Открыв раздел HKEY_CLASSES_ROOT, мы первым дело видим список из 18 зарегистрированных текстовых расширений, которые начинаются со знака ! (!txt, например). Спустившись чуть пониже мы, может найти эквиваленты этих расширений типа .txt (перед названием стоит точка). В этих расширениях мы ссылаемя на расширения типа !txt, которые находятся в самом начале и содержат основную информацию о "программе по умолчанию" и иконке этой проги. Так вот, открываем раздел !txt, с которым мы будем работать, и что же мы видим: раздел defaulticon, в котором содержится строковой параметр с адресом иконки проги + , 0 и раздел типа shell->open->command. В разделе command тоже строковой параметр со значением адреса "программы по умолчанию", после которой стоит "%1". Значит нам нужно только изменить адрес проги и иконки и готово дело. В принципе да, но посмотрите в раздел .txt - в нем хранится строковой параметр со значением, ссылающимя на раздел !txt, т.е. параметр !txt.

Значит нам нужно, чтобы этот параметр тоже присутствовал - вдруг кто-нибудь нечаянно его удалит...

Действие 1: Ассоциация с расширением .txt

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


uses registry;// это обязательно  
private // заносим ее вот сюда  
procedure fileass; // функция заносит все параметры ассоциации с расширением .txt в реестр или удаляет их  

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


procedure tform9.fileass;  
var reg:TRegistry; // переменная, инициализирующая реестр  
begin  
if txt.Checked then // если флафок включен, то  
begin  
// инициализируем реестр  
reg := TRegistry.Create;  
// устанавливаем главный раздел  
reg.RootKey := HKEY_CLASSES_ROOT;  
// создается ключ ".txt", если его нет  
reg.OpenKey('.txt',true);  
// создается параметр со значением "!txt", если его нет  
reg.WriteString('', '!txt');  
// закрываем этот ключ  
reg.CloseKey;  
// создается ключ "!txt\DefaultIcon"  
reg.OpenKey('!txt\DefaultIcon',true);  
// заносится значение параметра "имя приложения, 0" - пиктограмма нашей проги  
reg.WriteString('', paramstr(0) + ', 0');  
// выходим из ключа  
reg.CloseKey;  
// создается ключ "!txt\shell\open\command"  
reg.OpenKey('!txt\shell\open\command', true);  
// создается параметр со значением "имя файла "%1"" - адрес нашей проги  
reg.WriteString('', ParamStr(0) + ' "%1"');  
// закрываем ключ  
reg.CloseKey;  
// освобождаем реестр, но настройки сохраняем  
reg.Free;  
end;  
  
if not txt.Checked then // если флажок отключен,то  
begin  
// инициализируем реестр  
reg := TRegistry.Create;  
// устанавливаем главный раздел  
reg.RootKey := HKEY_CLASSES_ROOT;  
// создается ключ ".txt"  
reg.OpenKey('.txt',true);  
// создается параметр со значением "!txt"  
reg.WriteString('', '!txt');  
// выходим  
reg.CloseKey;  
// создается ключ "!txt\DefaultIcon"  
reg.OpenKey('!txt\DefaultIcon',true);  
// заносится значение параметра "имя приложения, 0" - пиктограмма блокнота  
reg.WriteString('', 'NOTEPAD.exe' + ', 0');  
// выходим  
reg.CloseKey;  
// создается ключ "!txt\shell\open\command"  
reg.OpenKey('!txt\shell\open\command', true);  
// создается параметр со значением "имя файла %1" - адрес блокнота  
reg.WriteString('', 'NOTEPAD.exe' + ' "%1"');  
// закрываем ключ  
reg.CloseKey;  
// освобождаем реестр, но настройки сохраняем  
reg.Free;  
end;  
end;   

В принципе все... 1-я (и самая главная) функция готова. Только в адресе иконки я указал адрес программы (paramstr(0)), потому что я уже подготовил новую иконку, которая обозначает мой текстовый эдитор. Если вы ничего не сделаете. Под расширением .txt будет подразумеваться ваша прога с иконкой Delphi. Так что укажите правильный путь в ключе Defaulticon.

Действие 2: Регистрация своего расширения

Теперь сделаем сами регистрацию расширений (за это, как мы помним, у нас отвечают компоненты extension, createext,deleteext). Для этого мы создадим процедуру newext. А за дизинтеграцию у нас будет отвечать процедура delext. Как всегда добавляем их в раздел PRIVATE и потом описываем.


Private  
Procedure fileass;  
Procedure newext; // интегрирует наше расширение  
Procedure delext; // дизинтегрирует наше расширение  
  
procedure tform2.newext;  
var reg:tregistry; // наша переменная для работы с реестром  
begin  
// инициализируем её  
reg:=tregistry.Create;  
// устанавливаем начальный раздел  
reg.RootKey:=Hkey_Classes_Root;  
// создаем ключ типа ".наше расширение"  
reg.OpenKey('.'+extension.Text,true);  
// записываем в нем ссылку на ключ типа "!.наше расширение"  
reg.WriteString('','!'+extension.Text);  
// закрываем ключ  
reg.CloseKey;  
// создаем ключ типа "!.наше расширение\defaulticon"  
reg.OpenKey('!'+extension.Text+'\defaulticon',true);  
// записываем туда иконку нашей проги  
reg.WriteString('',paramstr(0)+', 0');  
// выходим  
reg.CloseKey;  
// создаем ключ типа "!.наше расширение\shell\open\command"  
reg.OpenKey('!'+extension.Text+'\shell\open\command',true);  
// записываем в него адрес проги  
reg.WriteString('',paramstr(0)+' "1"');  
// закрываем ключ  
reg.CloseKey;  
// убираемся, но настройки сохраняем  
reg.Free;  
end;   
Вторая процедурка:


procedure tform2.delext;  
var reg:tregistry; // инициализируем переменную для работы с реестром  
begin  
// создаем класс для работы с реестром  
reg:=tregistry.Create;  
// устанавливаем начальный раздел  
reg.RootKey:=HKEY_CLASSES_ROOT;  
// удаляем ключ типа ".наше расширение"  
reg.DeleteKey('.'+extension.Text);  
// удаляем ключ типа "!наше расширение"  
reg.DeleteKey('!'+extension.Text);  
// закрываемся  
reg.CloseKey;  
// вырубаем все, но настройки сохраняем  
reg.Free;  
end;   

Действие 3: Добавление пункта в контекстное меню Windows

Вот и вторая часть нашего доброго дела готова. Осталась последняя, отвечающая за добавление, удаления пункта контекстного меню. За это у нас (а ну ка вспомнили:) отвечают компоненты context и contextstr. Ну я как всегда создал новую процедуру checkcontext и написал в ней...


Private  
procedure fileass;  
procedure newext;  
procedure delext;  
procedure checkcontext; // проверяет, нажат ли флажок, в случае успеха создает пункт контекста, в случае неуспеха удаляет его  
  
procedure tform2.checkcontext;  
var reg:tregistry; // инициализируем переменную для работы с реестром  
begin  
// если флажок включен, то  
if context.Checked then  
begin  
// создаем класс для работы с реестром  
reg:=tregistry.Create;  
// устанавливаем начальный раздел  
reg.RootKey:=HKEY_CLASSES_ROOT;  
// создаем ключ типа "*\Shell\любое ваше слово"  
reg.OpenKey('*\Shell\OpenWithMaksEditor',true);  
// записываем в него строковой параметр типа "любое ваше слово"  
reg.WriteString('','OpenWithMaksEditor');  
// записываем в него строковой параметр типа "пункт контекста"  
reg.WriteString('',contextstr.Text);  
// закрываем ключ  
reg.CloseKey;  
// создаем ключ типа "*\Shell\OpenWithMaksEditor\command"  
reg.OpenKey('*\Shell\OpenWithMaksEditor\command',true);  
// записываем в него строковой параметр типа "command"  
reg.WriteString('','command');  
// записываем в него также строковой параметр типа"адрес проги+" %1""  
reg.WriteString('',paramstr(0)+' "1%"');  
// закрываем ключ  
reg.CloseKey;  
// вырубаем весь контекстный плагин нахрен, а настройки оставляем  
reg.Free;  
end else  
if not context.Checked then // иначе, если флажок отключен  
begin  
// инициализируем переменную для работы с реестром  
reg:=tregistry.Create;  
// устанавливаем начальнай раздел  
reg.RootKey:=HKEY_CLASSES_ROOT;  
// удаление ключа типа "*\Shell\любое слово"  
reg.DeleteKey('*\Shell\OpenWithMaksEditor');  
// закрываем реестр  
reg.CloseKey;  
// уходим  
reg.Free;  
end;  
end;   

Вот и последняя процедурка готова, как видно, здесь проверяется, включен ли флажок: если включен, то пункт, введенный в context, создается, если выключен, то пункт, который был предварительно создан - удаляется. Но мы еще забыли самое главное: ведь у нас есть только процедуры: а ведь их еще надо подставить куда-нибудь, чтобы они работали. Короче, подставляем процедуру, отвечающую за создание нового расширения (newext) в компонент createext (кнопка), функцию, отвечающую за удаление расширения (delext) в компонент deleteext (кнопка). А процедуру, ассоциирующую вашу прогу с .txt (fileass) и процедуру создания, удаления пункта контекста (checkcontext) в компонент Gues (кнопка) - вот она и пригодилась, она будет закрывать форму, предварительно сделав некоторые изменения, продекларированные выше! Ну конено все функции надо прописать в событии onclick кнопок:


// реакция кнопки на клик мышью - создание расширения  
procedure TForm2.createextClick(Sender: TObject);  
begin  
newext;  
end;  
  
// реакция кнопки на клик мышью - удаление расширения  
procedure TForm2.deleteextClick(Sender: TObject);  
begin  
delext;  
end;  
  
// реакция кнопки на клик мышью - ассоциация с расширением .txt и создание/удаление пункта в контексте  
procedure TForm2.GuesClick(Sender: TObject);  
begin  
fileass;  
checkcontext;  
close;  
end;   

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

И в заключение приведу весь код проги:


interface  
  
uses  
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,registry;  
  
type  
TForm2 = class(TForm)  
extension: TEdit;  
Gues: TButton;  
txt: TCheckBox;  
context: TCheckBox;  
contextstr: TEdit;  
createext: TButton;  
deleteext: TButton;  
procedure GuesClick(Sender: TObject);  
procedure createextClick(Sender: TObject);  
procedure deleteextClick(Sender: TObject);  
private  
procedure fileass;  
procedure newext;  
procedure delext;  
procedure checkcontext;  
public  
{ Public declarations }  
end;  
  
var  
Form2: TForm2;  
  
implementation  
  
{$R *.dfm}  
  
procedure tform2.fileass;  
var reg:tregistry;  
begin  
reg:=tregistry.create;  
if txt.Checked then  
begin  
reg := TRegistry.Create;  
reg.RootKey := HKEY_CLASSES_ROOT;  
// создается ключ ".my"  
reg.OpenKey('.txt',true);  
// создается параметр со значением "myfile"  
reg.WriteString('', '!txt');  
reg.CloseKey;  
// создается ключ "myfile\DefaultIcon"  
reg.OpenKey('!txt\DefaultIcon',true);  
// заносится значение параметра "имя приложения, 0" - пиктограмма  
reg.WriteString('', application.ExeName + ', 0');  
reg.CloseKey;  
// создается ключ "myfile\shell\open\command"  
reg.OpenKey('!txt\shell\open\command', true);  
// создается параметр со значением "имя файла %1"  
reg.WriteString('', ParamStr(0) + ' "%1"');  
reg.CloseKey;  
reg.Free;  
end;  
  
if not txt.Checked then  
begin  
reg := TRegistry.Create;  
reg.RootKey := HKEY_CLASSES_ROOT;  
// создается ключ ".my"  
reg.OpenKey('.txt',true);  
// создается параметр со значением "myfile"  
reg.WriteString('', '!txt');  
reg.CloseKey;  
// создается ключ "myfile\DefaultIcon"  
reg.OpenKey('!txt\DefaultIcon',true);  
// заносится значение параметра "имя приложения, 0" - пиктограмма  
reg.WriteString('', 'NOTEPAD.exe' + ', 0');  
reg.CloseKey;  
// создается ключ "myfile\shell\open\command"  
reg.OpenKey('!txt\shell\open\command', true);  
// создается параметр со значением "имя файла %1"  
reg.WriteString('', 'NOTEPAD.exe' + ' "%1"');  
reg.CloseKey;  
reg.Free;  
end;  
end;  
  
procedure tform2.newext;  
var reg:tregistry; // наша переменная для работы с реестром  
begin  
// инициализируем её  
reg:=tregistry.Create;  
// устанавливаем начальный раздел  
reg.RootKey:=Hkey_Classes_Root;  
// создаем ключ типа ".наше расширение"  
reg.OpenKey('.'+extension.Text,true);  
// записываем в нем ссылку на ключ типа "!.наше расширение"  
reg.WriteString('','!'+extension.Text);  
// закрываем ключ  
reg.CloseKey;  
// создаем ключ типа "!.наше расширение\defaulticon"  
reg.OpenKey('!'+extension.Text+'\defaulticon',true);  
// записываем туда иконку нашей проги  
reg.WriteString('',paramstr(0)+', 0');  
// выходим  
reg.CloseKey;  
// создаем ключ типа "!.наше расширение\shell\open\command"  
reg.OpenKey('!'+extension.Text+'\shell\open\command',true);  
// записываем в него адрес проги  
reg.WriteString('',paramstr(0)+' "1"');  
// закрываем ключ  
reg.CloseKey;  
// убираемся, но настройки сохраняем  
reg.Free;  
end;  
  
procedure tform2.delext;  
var reg:tregistry; // инициализируем переменную для работы с реестром  
begin  
// создаем класс для работы с реестром  
reg:=tregistry.Create;  
// устанавливаем начальный раздел  
reg.RootKey:=HKEY_CLASSES_ROOT  
// удаляем ключ типа ".наше расширение"  
reg.DeleteKey('.'+extension.Text);  
// удаляем ключ типа "!наше расширение"  
reg.DeleteKey('!'+extension.Text);  
// закрываемся  
reg.CloseKey;  
// вырубаем все, но настройки сохраняем  
reg.Free;  
end;  
  
procedure tform2.checkcontext;  
var reg:tregistry; // инициализируем переменную для работы с реестром  
begin  
// если флажок включен, то  
if context.Checked then  
begin  
// создаем класс для работы с реестром  
reg:=tregistry.Create;  
// устанавливаем начальный раздел  
reg.RootKey:=HKEY_CLASSES_ROOT;  
// создаем ключ типа "*\Shell\любое ваше слово"  
reg.OpenKey('*\Shell\OpenWithMaksEditor',true);  
// записываем в него строковой параметр типа "любое ваше слово"  
reg.WriteString('','OpenWithMaksEditor');  
// записываем в него строковой параметр типа "пункт контекста"  
reg.WriteString('',contextstr.Text);  
// закрываем ключ  
reg.CloseKey;  
// создаем ключ типа "*\Shell\OpenWithMaksEditor\command"  
reg.OpenKey('*\Shell\OpenWithMaksEditor\command',true);  
// записываем в него строковой параметр типа "command"  
reg.WriteString('','command');  
// записываем в него также строковой параметр типа"адрес проги"%1""  
reg.WriteString('',paramstr(0)+' "1%"');  
// закрываем ключ  
reg.CloseKey;  
// вырубаем весь контекстный плагин нахрен, а настройки оставляем  
reg.Free;  
end else  
if not context.Checked then // иначе, если флажок отключен  
begin  
// инициализируем переменную для работы с реестром  
reg:=tregistry.Create;  
// устанавливаем начальнай раздел  
reg.RootKey:=HKEY_CLASSES_ROOT;  
// удаление ключа типа "*\Shell\любое слово"  
reg.DeleteKey('*\Shell\OpenWithMaksEditor');  
// закрываем реестр  
reg.CloseKey;  
// уходим  
reg.Free;  
end;  
end;  
  
procedure TForm2.GuesClick(Sender: TObject);  
begin  
fileass;  
checkcontext;  
end;  
  
procedure TForm2.createextClick(Sender: TObject);  
begin  
newext;  
end;  
  
procedure TForm2.deleteextClick(Sender: TObject);  
begin  
delext;  
end;  
  
end.  

Небольшое заключение, которое надо прочитать

Я рассказал вам несколько полезных функций, но не учитывал те глюки, которые вы сразу заметите - например, я не прописывал событие oncreate и onclose формы (ну надо же сохранять настройки, отвечающие за активность флажков в Инифайлах, чтобы не было никаких изменение:). Это все я оставляю вам... на ужин...

Автор: Makswell.

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

Мониторинг SQL запросов при работе с ADO компонентами

Не секрет, что приложения баз данных составляют довольно большую долю всех вновь разрабатываемых приложений. Ни одна информационная система не может быть создана без соединения к той или иной СУБД. В первых версиях нам предлагался давно устаревший, но все еще успешно использующийся Borland Database Engine (BDE).

Одним из альтернативных способов доступа к источникам данных стали компоненты ADO.


Диалоговое окно мониторинга SQL запросов

Хотя в новых версиях Delphi добавлены более современные компоненты dbExpress, а так же огромное количество компонент сторонних производителей, компоненты ADO все еще заслуживают внимания. Из-за простоты использования, интеграции со средой разработки (в поставке Delphi Enterpise), а так же довольно высокой скорости работы имеет смысл их использовать, если не планируется переходить на мультиплатформенную разработку.

Первой из рассматриваемых компонент будет TADOConnection. Не будем останавливаться на подробном процессе настройки соединения, информацию об этом можно прочитать и в help'е. Хочется отметить на отсутствие мониторинга sql запросов при работе с ADO компонентами. А при отладке программ данная функция будет далеко не последней. Особенно при работе с параметрическими запросами. Мониторинг позволяет визуально отследить, что же в действительности посылается серверу базы данных. Особую актуальность этот режим приобретает на компьютере заказчика. Delphi IDE с собой таскать ох как не хочется. Да и не на всяком компьютере развернешь эту среду разработки. Для реализации функции мониторинга напишем пару методов на события WillExecute и ExecuteComplete компоненты TADOConnection.


fExecuteTime: dword;  
  
...  
  
procedure TDM.dbConnectionWillExecute(  
  
  Connection: TADOConnection;  
  var CommandText: WideString;  
  var CursorType: TCursorType;  
  var LockType: TADOLockType;  
  var CommandType: TCommandType;  
  var ExecuteOptions: TExecuteOptions;  
  var EventStatus: TEventStatus;  
  const Command: _Command; const Recordset: _Recordset  
  );  
var  
  i,j: integer;  
  infoStr: String;  
  tmpParameters: Parameters;  
begin  
  if gDebugMode  
  
  then MonitorEvent('WillExecute.. ',[]);  
  fExecuteTime:=GetTickCount;  
  if gSqlMonitor and gDebugMode then  
  begin  
  MonitorEvent(CommandText,['']);  
  if Assigned(Recordset) then  
  begin  
  for i := 0 to (dbConnection.DataSetCount-1) do  
    if Assigned(dbConnection.DataSets[i].Recordset)  
  and (Recordset = dbConnection.DataSets[i].Recordset) then  
  if (dbConnection.DataSets[i] is TADODataSet)  
  and (TADODataSet(dbConnection.DataSets[i]).  
  
                                   Parameters.Count > 0)  
  
  then  
  for j:=0 to TADODataSet(dbConnection.DataSets[i]).  
  
                                   Parameters.Count-1 do  
  begin  
  infoStr:='P['+IntToStr(j)+'] '  
  +TADODataSet(dbConnection.DataSets[i]).  
  
                                   Parameters.Items[j].Name+' = ';  
  if Not VarisNull(TADODataSet(dbConnection.DataSets[i]).  
  Parameters.Items[j].Value) then  
  infoStr:=infoStr+String(TADODataSet(dbConnection.DataSets[i]).  
  
                                   Parameters.Items[j].Value)  
  else  
  infoStr:=infoStr + 'Null';  
  MonitorEvent(infoStr,['']);  
  end;  
  end;  
  if Assigned(Command) then  
  begin  
  tmpParameters:=Command.Get_Parameters;  
  if (tmpParameters.Count > 0) then  
  for j:=0 to tmpParameters.Count - 1 do  
  begin  
  infoStr:=tmpParameters.Item[j].Name+' = ';  
  if Not VarisNull(tmpParameters.Item[j].Value) then  
  infoStr:=infoStr + String(tmpParameters.Item[j].Value)  
  else  
  infoStr:=infoStr + 'Null';  
  MonitorEvent(infoStr,['']);  
  end  
  end;  
  MonitorEvent('',['']);  
  end;  
end;  
  
procedure TDM.dbConnectionExecuteComplete(  
  
  Connection: TADOConnection;  
  RecordsAffected: Integer;  
  const Error: Error;  
  var EventStatus: TEventStatus;  
  const Command: _Command;  
  const Recordset: _Recordset  
  );  
begin  
  Self.fExecuteTime:=GetTickCount-Self.fExecuteTime;  
  if gDebugMode  
  
  then MonitorEvent('Execute time: '  
  
                 +FloatToStr(Self.fExecuteTime / 1000)+' s.',[]);  
end;  

Для управления режимом мониторинга и отладки введены глобальные переменные gSqlMonitor и gDebugMode. Функция вывода окна мониторинга MonitorEvent не приводится, так как написать ее очень просто. Пример реализации окна SQL мониторинга показан на рисунке.

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

Монитор, разрешения экрана

Масштабирование окон в зависимости от разрешения монитора
В ранней стадии создания приложения решите для себя хотите ли вы позволить форме масштабироваться. Преимущество немасштабируемой формы в том, что ничего не меняется во время выполнения. В этом же заключается и недостаток (ваша форма может бать слишком маленькой или слишком большой в некоторых случаях).
Если вы не собираетесь делать форму масштабируемой, установите свойство Scaled=False и дальше не читайте. В противном случае Scaled=True.
Установите AutoScroll=False. AutoScroll = True означает не менять размер окна формы при выполнении что не очень хорошо выглядит, когда содержимое формы меняет размер.
Установите шрифты формы на TrueType, например Arial. Если такого шрифта не окажется на пользовательском компьютере, то Windows выберет альтернативный шрифт из того же семейства. Этот шрифт может не совпадать по размеру, что вызовет проблемы.
Установите свойство Position в любое значение, отличное от poDesigned. poDesigned оставляет форму там, где она была во время дизайна, и, например, при разрешении 1280x1024 форма окажется в левом верхнем углу и совершенно за экраном при 800x600.
Оставляйте по-крайней мере 4 точки между компонентами, чтобы при смене положения границы на одну позицию компоненты не "наезжали" друг на друга. Для однострочных меток (TLabel) с выравниванием alLeft или alRight установите AutoSize=True. Иначе AutoSize=False.
Убедитесь, что достаточно пустого места у TLabel для изменения ширины шрифта - 25% пустого места многовато, зато безопасно. При AutoSize=False убедитесь, что ширина метки правильная, при AutoSize=True убедитесь, что есть ссвободное место для роста метки.
Для многострочных меток (word-wrapped labels), оставьте хотя бы одну пустую строку снизу.
Будьте осторожны при открытии проекта в среде Delphi при разных разрешениях. Свойство PixelsPerInch меняется при открытии формы. Лучше тестировать приложения при разных разрешениях, запуская готовый скомпилированный проект, а редактировать его при одном разрешении. Иначе это вызовет проблемы с размерами.
Не изменяйте свойство PixelsPerInch!
В общем, нет необходимости тестировать приложение для каждого разрешения в отдельности, но стоит проверить его на 800x600 с маленькими и большими шрифтами и на более высоком разрешении перед продажей.
Уделите пристальное внимание принципиально однострочным компонентам типа TDBLookupCombo. Многострочные компоненты всегда показывают только целые строки, а TEdit покажет урезанную снизу строку. Каждый компонент лучше сделать на несколько точек больше.
Масштабирование размера шрифтов
Когда программы написанные в Delphi работают на системах с установленными маленькими шрифтами, получается странный вид формы. К примеру, расположенные на форме компоненты Label становятся малы для размещения указанного теста, обрезая его в правой или нижней части. StringGrid не осуществляет положенного выравнивания и т.д. Следующий код масштабирует как размер формы, так и размер шрифтов. Вызывая его в FormCreate можно добиться не плохих результатов.

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

Так же необходимо проверить, отличается ли размер шрифта во времы выполнения от размера во время проектирования. Если во время выполнения PixelsPerInch формы отличается от PixelsPerInch во время проектирования, шрифты снова масштабируются так, чтобы форма не отличалась от той, которая была во время разработки. Масштабирование производится исходя из коэффициента, получаемого путем деления значения font.height во время проектирования на font.height во время выполнения. Font.size в этом случае работать не будет, так как это может дать результат больший, чем текущие размеры компонентов, при этом текст может оказаться за границами области компонента. Например, форма создана при размерах экрана 800x600 с установленными маленькими шрифтами, имеющими размер font.size=8. Когда вы запускаете в системе с 800x600 и большими шрифтами, font.size также будет равен 8, но текст будет больше чем при работе в системе с маленькими шрифтами. Данное масштабирование позволяет иметь один и тот же размер шрифтов при различных установках системы.

ВАЖНО! : Установите в Инспекторе Объектов свойство Scaled TForm в FALSE.


interface  
uses  
 Forms, Controls;  
  procedure geAutoScale(MForm: TForm);  
implementation  
type  
  TFooClass = class(TControl); //необходимо выяснить защищенность  
procedure geAutoScale(MForm: TForm);  
const  
 cScreenWidth: integer = 800;  
 сScreenHeight: integer = 600;  
 cPixelsPerInch: integer = 96;  
 cFontHeight: integer = -11; //В режиме проектирование значение из Font.Height  
var  
 i: integer;  
begin  
 if (Screen.width <> cScreenWidth) or (Screen.PixelsPerInch <> cPixelsPerInch) then  
  begin  
   MForm.scaled:= true;  
   MForm.height:= MForm.height * screen.Height div cScreenHeight;  
   MForm.width:= MForm.width * screen.width div cScreenWidth;  
   MForm.ScaleBy(screen.width, cScreenWidth);  
  end;  
 if (Screen.PixelsPerInch <> cPixelsPerInch) then  
  begin  
   for i:= MForm.ControlCount - 1 downto 0 do  
    TFooClass(MForm.Controls[i]).Font.Height:=  
    (MForm.Font.Height div cFontHeight) *  
    TFooClass(MForm.Controls[i]).Font.Height;  
  end;  
end;  
end.  

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

Многоязычный интерфейс приложений в Delphi

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

Для этих целей существует много коммерческих и бесплатных компонент-переводчиков, однако использовать их довольно неудобно, поскольку, необходимо помещать копию компонента на каждую форму приложения. Я предлагаю совершенно другой подход, а именно - использовать модуль-переводчик, который будет переводить все формы приложения. При достаточно высокой скорости перевода интерфейса, размер программы увеличиться всего на 3Кб (именно столько <весит> модуль)

Алгоритм работы такой: функция TranslateForm обходит все компоненты формы и переводит их на указанный язык, используя для этого специальный словарь. Словарь имеет формат Ini-файла, поэтому, как и для всех остальных Ini-файлов, для этого файла существует ограничение размера - не более 64 Кб, если я, конечно, не ошибаюсь. Решить эту проблему можно достаточно просто - использовать несколько словарей для разных языков.

Приведу раздел объявления нашего модуля (interface):

Пример 1


interface  
  
uses SysUtils, Classes, Controls, Forms, Dialogs, Quickrpt, ... ;  
  
function Translate(Text : string; Lang : string; Dict : TIniFile):string;  
procedure TranslateForm(Form : TForm; Lang : string; DictFileName : string); 

Процедура TranslateForm, как я уже писал, обходит все компоненты формы, а функция Trasnlate - выполняет перевод. Переводятся текстовые свойства компонент, например, Caption и Hint. При вызове функции нужно указать следующие параметры:


Form : TForm; Lang : string; DictFileName : string  

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

Пример 2


[Rus]  
File=Файл  
Open=Открыть  
Translate=Перевести  
Application=Приложение  
New=Создать  
Open=Открыть  
Text=Текст  
Save=Сохранить  
Save As...=Сохранить как...  
Print=Печать  
Print Setup=Параметры печати  
Exit=Выход  
Edit=Правка  
Cut=Вырезать  
Copy=Копировать  
Paste=Вставить  
Undo=Отмена  
View=Вид  
Status bar=Панель состояния  
Tool bar=Панель инструментов  
Tools=Сервис  
Settings=Параметры  
...  

Для перевода интерфейса приложения с английского на русский язык нужно вызвать процедуру TrasnlateForm так:


TranslateForm(Form1, 'Rus', 'trans.dic');  

При этом ключевым языком считается английский (см. секцию Rus в примере 2). Аналогично можно создать секцию Eng и использовать русский язык в качестве ключевого.

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


for i:=0 to Screen.FormCount-1 do  
TranslateForm(Screen.Forms[i],'Rus','trans.dic');  

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


for i:=0 to Screen.FormCount-1 do  
TranslateForm(Screen.Forms[i],'Rus','trans.dic');  
Application.Run;  

То есть перевод форм нужно выполнить до выполнения метода Application.Run;

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

Пример 3. Файл trans.pas


unit trans;  
  
interface  
  
uses SysUtils, Classes, Controls, Forms, Dialogs, Quickrpt, QRCtrls, StdCtrls,  
 Buttons, ComCtrls, ExtCtrls, DBCtrls, DB, DBGrids, Menus, Grids, Mask,  
 IniFiles;  
  
function Translate(Text : string; Lang : string; Dict : TIniFile):string;  
procedure TranslateForm(Form : TForm; Lang : string; DictFileName : string);  
  
implementation  
  
{ Непосредственный перевод текста }  
function Translate(Text : string; Lang : string; Dict : TIniFile):string;  
var s : string;  
begin  
 Result:=Text;  
 S:=Dict.ReadString(Lang, Text, '');  
 if S='' then Dict.WriteString(Lang, Text, '');  
 if S<>'' then Result:=S;  
end;  
  
procedure TranslateForm(Form : TForm; Lang : string; DictFileName : string);  
var Dict : TIniFile;  
 I,J : Integer;  
 Obj : TObject;  
begin  
{ Открываем словарь. Перед вызовом функции Translate словарь должен быть открыт! }  
  
 Dict:=TIniFile.Create(DictFileName);  
  
 if not fileexists(DictFileName) then  
 ShowMessage('No exists' + DictFileName);  
  
 Form.Caption:=Translate(Form.Caption, Lang, Dict);  
 Application.Title:=Translate(Application.Title, Lang, Dict);  
  
 { Переводим компоненты формы}  
 For I:=0 to Form.ComponentCount-1 do  
 Begin  
  
 Obj:=Form.Components[i];  
 if Obj is TMenuItem then  
 begin  
 TMenuItem(Obj).Caption:=Translate(TMenuItem(Obj).Caption, Lang, Dict);  
 TMenuItem(Obj).Hint:=Translate(TMenuItem(Obj).Hint, Lang, Dict);  
 end;  
  
 if Obj is TButton then  
 begin  
 TButton(Obj).Caption:=Translate(TButton(Obj).Caption, Lang, Dict);  
 TButton(Obj).Hint:=Translate(TButton(Obj).Hint, Lang, Dict);  
 end;  
  
 if Obj is TBitBtn then  
 begin  
 TBitBtn(Obj).Caption:=Translate(TBitBtn(Obj).Caption, Lang, Dict);  
 TBitBtn(Obj).Hint:=Translate(TBitBtn(Obj).Hint, Lang, Dict);  
 end;  
  
 if Obj is TSpeedButton then  
 begin  
 TSpeedButton(Obj).Caption:=Translate(TSpeedButton(Obj).Caption, Lang, Dict);  
 TSpeedButton(Obj).Hint:=Translate(TSpeedButton(Obj).Hint, Lang, Dict);  
 end;  
  
 if Obj is TPanel then  
 begin  
 TPanel(Obj).Caption:=Translate(TPanel(Obj).Caption, Lang, Dict);  
 TPanel(Obj).Hint:=Translate(TPanel(Obj).Hint, Lang, Dict);  
 end;  
  
 if Obj is TGroupBox then  
 begin  
 TGroupBox(Obj).Caption:=Translate(TGroupBox(Obj).Caption, Lang, Dict);  
 TGroupBox(Obj).Hint:=Translate(TGroupBox(Obj).Hint, Lang, Dict);  
 end;  
  
 if Obj is TLabel then  
 begin  
 TLabel(Obj).Caption:=Translate(TLabel(Obj).Caption, Lang, Dict);  
 TLabel(Obj).Hint:=Translate(TLabel(Obj).Hint, Lang, Dict);  
 end;  
  
 if Obj is TStaticText then  
 begin  
 TStaticText(Obj).Caption:=Translate(TStaticText(Obj).Caption, Lang, Dict);  
 TStaticText(Obj).Hint:=Translate(TStaticText(Obj).Hint, Lang, Dict);  
 end;  
  
 if Obj is TQRLabel then  
 begin  
 TQRLabel(Obj).Caption:=Translate(TQRLabel(Obj).Caption, Lang, Dict);  
 TQRLabel(Obj).Hint:=Translate(TQRLabel(Obj).Hint, Lang, Dict);  
 end;  
  
 if Obj is TEdit then  
 TEdit(Obj).Hint:=Translate(TEdit(Obj).Hint, Lang, Dict);  
  
 if Obj is TMaskEdit then  
 TMaskEdit(Obj).Hint:=Translate(TMaskEdit(Obj).Hint, Lang, Dict);  
  
 if Obj is TMemo then  
 TMemo(Obj).Hint:=Translate(TMemo(Obj).Hint, Lang, Dict);  
  
 if Obj is TRadioGroup then  
 begin  
 TRadioGroup(Obj).Caption:=Translate(TRadioGroup(Obj).Caption, Lang, Dict);  
 TRadioGroup(Obj).Hint:=Translate(TRadioGroup(Obj).Hint, Lang, Dict);  
 for J:=0 to TRadioGroup(Obj).Items.Count-1 do  
 begin  
 TRadioGroup(Obj).Items[j]:=Translate(TRadioGroup(Obj).Items[j], Lang, Dict);  
 end;  
 end;  
  
 if Obj is TCheckBox then  
 begin  
 TCheckBox(Obj).Caption:=Translate(TCheckBox(Obj).Caption, Lang, Dict);  
 TCheckBox(Obj).Hint:=Translate(TCheckBox(Obj).Hint, Lang, Dict);  
 end;  
  
 if Obj is TField then  
 TField(Obj).DisplayLabel:=Translate(TField(Obj).DisplayLabel, Lang, Dict);  
  
 if Obj is TTabSheet then  
 begin  
 TTabSheet(Obj).Caption:=Translate(TTabSheet(Obj).Caption, Lang, Dict);  
 TTabSheet(Obj).Hint:=Translate(TTabSheet(Obj).Hint, Lang, Dict);  
 end;  
  
 if Obj is TOpenDialog then  
 TOpenDialog(Obj).Title:=Translate(TOpenDialog(Obj).Title, Lang, Dict);  
  
 if Obj is TSaveDialog then  
 TSaveDialog(Obj).Title:=Translate(TSaveDialog(Obj).Title, Lang, Dict);  
  
 if Obj is TPrintDialog then  
 TPrintDialog(Obj).Title:=Translate(TPrintDialog(Obj).Title, Lang, Dict);  
  
 if Obj is TPrinterSetupDialog then  
 TPrinterSetupDialog(Obj).Title:=Translate(TPrinterSetupDialog(Obj).Title, Lang, Dict);  
  
 End;  
  
{ освобождаем память}  
  
 Dict.Free;  
end;  
  
end.  

Естественно, перед использованием модуля его нужно добавить в оператор uses:

uses ..., trans;  

Примечания
1. Теперь нужно отметить особенность функции Translate. Если слова нет в словаре, она его автоматически добавляет. Потом вам только останется самому ввести перевод этого слова!

2. Напомню, что поиск словаря, так как он является ini-файлом, по умолчанию производится в каталоге C:\Windows (точнее, в каталоге, возвращаемом функцией GetWindowsDirectory), поэтому предварительно нужно поместить туда словарь или явно указать имя файла. При этом удобно использовать функцию ExtractFileDir так:


ExtractFileDir(Application.EXEName+'\trans.dic')  

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

Мегабайты отдыхают

1. Постановка задачи
Данный способ позволяет значительно экономить ресурсы компьютера. Кроме того, все знают, что минимальный размер готового проекта с (формой) на делфи составляет 250-300 Кб. А если там не одна форма, а несколько, то проекты зачастую разрастаются до 3-4 и более Мб. Я же научу вас создавать приложения с формами, но весить такие проекты будут по 15-20 Кб.

Данный способ требует отказа от использования всех VCL, т.е. все придеться делать ручками. Он основан на использовании функции CreateWindow, которая может создавать любое окно в соответствии с заданными параметрами.
Интересно?

Читайте дальше!

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

Итак, для начала создадим проект в делфи, нажав File->New->Application. Поскольку мы договорились не использовать формы, то делаем так: Project->Remove From Project, выбираем Unit1 и нажимаем кнопку ОК. Затем нужно вывести на экран код программы: Project->View Source. Открылся текстовый редактор с кодом программы. Из секции uses удаляем все, вписываем туда windows, messages;
Затем удаляем


begin  
  Application.Initialize;  
  Application.CreateForm(TForm1, Form1);  
  Application.Run;  
end.   

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


program Project1;  
  
uses windows, messages;  
  
{$R *.res}  
  
var  
  WinClass : TWndClass; //переменная класса TWndClass для создания главного окна  
  hInst : HWND; //хандлер приложения  
  Handle : HWND; //хандлер  
  hMsgBtn : HWND; //Хандлер кнопки  
  hMsgEdit : HWND; //Хандлер эдита  
  hMsgLabel : HWND; //Хандлер лабы  
  hFont : HWND; //Хандлер шрифта  
  Msg : TMSG; //Сообщение  
  pr_Click : pointer; //Указатель на процедуру  
  
procedure Resize; //Демонстрация изменения размеров и положения компонентов программным способом, если мы изменяем окно  
  var Rect:TRect;  
begin  
  GetWindowRect(Handle,Rect); // Цепляем окошко  
  MoveWindow(hMsgEdit,30,90, Rect.Right-Rect.Left-100,22,True); // А тут можно изменить его размеры или положение  
end;  
  
procedure ShutDown; // Выключение  
begin  
  DeleteObject(hFont); //Удаляем шрифты  
  UnRegisterClass('Sample Class', hInst); //Удаляем наше окно  
  ExitProcess(hInst); // Выходим из проги  
end;  
  
procedure Click; // Задача для кнопки  
  var Label_Text:PCHAR; // Определяем переменные для текста и его длины  
  LText:integer;  
begin  
  LText:=GetWindowTextLength(hMsgEdit)+1; // Получим длину текста и не забудем его последний символ (+1)  
  GetMem(Label_Text,LText); // Выделим память под переменную текста  
  GetWindowText(hMsgEdit,Label_Text,LText); //Захватим текст из едит-бокса  
  SetWindowText(hMsgLabel,Label_Text); //Назначим текст метке  
end;  
  
function ClickProc(hwnd,msg,wparam,lParam:longint):longint;stdcall; // Обработка каждого сообщения, посланного кнопке  
begin  
  Result:=CallWindowProc(pr_Click,hWnd,Msg,wParam,lParam);  
  case Msg of  
    WM_KEYDOWN : if wparam=9 then SetFocus(hMsgBtn); //Если юзверь нажал на кнопку, то дадим ей фокус ввода  
  end;  
end;  
  
function WindowProc(hwnd, msg, wparam, lparam:longint):longint;stdcall; //То же самое для окна  
begin  
  Result:=DefWindowProc(hwnd,msg,wparam,lparam);  
  case Msg of  
    WM_SIZE : Resize; // Если изменяем окно, значит, надо его изменить ;)  
    WM_COMMAND : if lparam=hMsgBtn then Click; // Если есть нужная команда, выполним процедуру щелчка мыши  
    WM_DESTROY : ShutDown; // Если поступило сообщение уничтожения винды, то выполним его.  
  end;  
end;  
  
begin  
  hInst:=GetModuleHandle(nil); // Получим хандлер приложения  
  
  //А теперь задаем свойства окна  
  
  with WinClass do  
  begin  
    Style:= CS_PARENTDC; //Это - родитель компонентов.  
    hIcon:= LoadIcon(hInst,'MAINICON'); //Икона  
    lpfnWndProc:= @WindowProc; //Процедура обработки сообщений  
    hInstance:= hInst; //Хандлер окна  
    hbrBackground:= COLOR_BTNFACE+1; //Цвет окна  
    lpszClassName:= 'Sample Class'; //Имя класса  
    hCursor:= LoadCursor(0,IDC_ARROW); //Курсор  
    end;  
  
  //Регистрируем наш класс  
  RegisterClass(WinClass);  
  
  //Собственно создание нашего окна.  
  Handle:=CreateWindow(  
    'Sample Class', // Зарегистрированное имя класса  
    'Маленький проект', // Заголовок окна  
    WS_OVERLAPPEDWINDOW or // Стиль окна  
    WS_VISIBLE, // Оно видимое  
    10, // Левый  
    10, // верхний угол окна  
    400, // Длина  
    300, // Высота  
    0, // Хандлер окна  
    0, // Хандлер менюшки  
    hInst, // Хандлер приложения  
    nil  
  );  
  
  // Создаем кнопку  
  hMsgBtn:=CreateWindow(  
    'Button',  
    'Message',  
    WS_VISIBLE or WS_CHILD or BS_PUSHLIKE or BS_TEXT,  
    5,5,65,24,Handle,0,hInst,nil  
   );  
  
  // Создаем эдит-бокс  
  hMsgEdit:=CreateWindowEx(  
    WS_EX_CLIENTEDGE,  
    'Edit',  
    '',  
    WS_VISIBLE or WS_CHILD or ES_LEFT or ES_AUTOHSCROLL,  
    30,90,155,24,Handle,0,hInst,nil  
   );  
  
  //Создаем label  
   hMsgLabel:=CreateWindow(  
    'Static',  
    '',  
    WS_VISIBLE or WS_CHILD or SS_LEFT,  
    160,10,170,50,Handle,0,hInst,nil  
   );  
  
  //Создаем шрифт  
  hFont:=CreateFont(  
    -12, // Высота  
    0, // Длина  
    0, // Угол поворота  
    0, // Ориентация  
    0, // Жирность  
    0, // Курсивность  
    0, // Подчеркнутость  
    0, // Зачеркнутость  
    DEFAULT_CHARSET, // Char Set  
    OUT_DEFAULT_PRECIS, // Precision  
    CLIP_DEFAULT_PRECIS, // Clipping  
    DEFAULT_QUALITY, // Render Quality  
    DEFAULT_PITCH or FF_DONTCARE, // Pitch & Family  
    'MS Sans Serif' // Имя шрифта  
   );  
  
  
  SendMessage(hMsgBtn,WM_SETFONT,hFont,0); //Назначаем наш шрифт кнопке, эдит-боксу, лабе  
  SendMessage(hMsgEdit,WM_SETFONT,hFont,0);  
  SendMessage(hMsgLabel,WM_SETFONT,hFont,0);  
  
  //Назначаем кнопке процедуру  
  pr_Click:=Pointer(GetWindowLong(hMsgBtn,GWL_WNDPROC));  
  SetWindowLong(hMsgBtn,GWL_WNDPROC,Longint(@ClickProc));  
  
  //Установка фокуса ввода на кнопку  
  SetFocus(hMsgBtn);  
  
  while(GetMessage(Msg,Handle,0,0))do  
  begin  
    TranslateMessage(Msg); //Переводим все сообщения...  
    DispatchMessage(Msg); //...к черту!!! :))))))))))  
  end;  
  
  
end.   

3.Выгода при использовании данного решения.
Про выгоду я уже сказал выше-данное решение позволяет ОЧЕНЬ сильно сократить размеры исполняемого файла. Где же применять данное решение? не мне вас учить - все зависит от вашей фантазии!

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

Автор: Alex Storm

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

Массивы. Статические или динамические?

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

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


type  
TArray = array [0..15] of integer;  
var  
A: TArray;  

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


type  
TDynArray = array of integer;  
var  
B: TDynArray;  

Основные функции для работы с динамическим массивом:
SetLength - устанавливает новый размер массива.
Length - возвращает количество элементов в массиве.
Low - индекс первого элемента в массиве (всегда 0 для динамических массивов).
High - индекс последнего элемента в массиве.
Copy - возвращает подмножество элементов массива.
Slice - используется при передаче динамического массива в процедуры в качестве открытого массива (open arrays).
Переменная динамического массива (в нашем примере B) представляет собой обычный указатель (4 байта). В отличие от статического массива, где переменная (в нашем примере А) является хранилищем данных массива и имеет размер, равный произведению количества элементов на их размер.
На что же указывает переменная динамического массива?
На некую область памяти, где лежат собственно данные массива. То есть фактически на первый элемент массива. Но самое интересное, что по отрицательному смещению (то есть перед данными) лежат еще 2 четырехбайтовых счетчика. По смещению -4 находится индикатор количества элементов в массиве, а по смещению -8 находится счетчик ссылок на массив. То есть размер динамического массива всегда на 8 байт больше того, что занимают его элементы. За исключением того случая, когда количество элементов равно 0. Тогда переменная динамического массива никуда не указывает и имеет значение nil.
Зачем нужен счетчик ссылок? Он позволяет иметь несколько переменных, ссылающихся на одни и те же данные в массиве и не заботиться об управлении памятью. Компилятор самостоятельно следит за доступом к данным и при уменьшении счетчика ссылок до 0 освобождает всю память массива. Пример:


procedure Test;  
var  
B, C: TDynArray;  
begin  
SetLength( B, 10 );  
C := B; // Мы копируем не данные массива B, а всего лишь указатель на него.  
  // Но счетчик ссылок массива увеличился до двух.  
end;  

При выходе из процедуры компилятор видит, что обе переменные являются локальными, уменьшает счетчик ссылок на два и освобождает память, выделенную вызовом SetLength. Но можно было освободить массив и вручную вызовом SetLength( B, 0 ).
Автоматический менеджмент памяти компилятором на этом не заканчивается. Доступ к динамическим массивам (и длинным строкам, которые являются их разновидностью) синхронизирован. То есть к ним можно одновременно обращаться из разных потоков (threads) без необходимости в дополнительной синхронизации.
Такая архитектура динамических массивов позволяет компилятору свободно изменять размер памяти под него, перемещать в другие участки оперативной памяти, а программисту соответственно не заниматься рутиной.

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


type  
// Элемент массива  
TRecord = record  
Name: string; // любые данные  
Color: TColor;  
end;  
  
PRecords = ^TRecords; // тип указателя на массив  
TRecords = array [0..0] of TRecord; // массив из одного элемента  
  
// Собственно сам массив  
TArray = record  
Items: PRecords; // указатель на элементы массива  
Count: integer; // число элементов в массиве  
end;  
var  
A: TArray = ( Items: nil; Count: 0 );  
  
  
procedure SetRecordsLen( var AArray: TArray; const Len: integer );  
begin  
// Перераспределяем память  
ReallocMem( AArray.Items, Len * sizeof( TRecord ) );  
  
// Если новый размер больше старого, то затираем новые элементы нулями  
if Len > AArray.Count then  
FillChar( AArray.Items[AArray.Count],  
( Len - AArray.Count ) * sizeof( TRecord ), 0 );  
  
// Запоминаем новый размер  
AArray.Count:= Len;  
end;  
   
...  
...  
   
SetRecordsLen( A, 10 );  
try  
A.Items[2] := AItems[3];  
A.Items[7].Name := A.Items[7].Name + '7';  
A.Items[8].Color := clRed;  
finally  
SetRecordsLen( A, 0 ); // не забываем освободить память  
end;  

В данном примере статическому массиву, состоящему якобы из одного элемента выделяется гораздо большая память. Конечно, в опциях компилятора нужно отключить Range checking. Мы получаем высокую скорость и довольно простой способ работы с массивом. Однако следует помнить, что такой массив не обладает функциями автоматического менеджмента памяти. Так что за собой придется аккуратно убирать :)
Наш массив при желании вполне можно оформить и в виде класса. Если же размер массива изменяется часто, а особенно в случае, если таких массивов много, то очень рекомендую для увеличения скорости и уменьшения фрагментации памяти выделять память под элементы массива "пачками" по несколько штук.
Подобная техника применяется в стандартном классе TList. Его свойство Capacity отвечает как раз за это. Аналогичное поле Capacity можно добавить и к нашему массиву. При увеличении размера массива память нужно будет перераспределять только в том случае, если запрошенное количество элементов Count уже не помещается в выделенном количестве элементов Capacity.
Напоследок еще пару слов о безопасности кода в связи с массивами.
Самом собой, выход индекса за границы массива не приведет ни к чему хорошему. Будет либо испорчена память по соседству, либо получим EAccessViolation. Первый случай гораздо хуже и может приводить к чрезвычайно трудноуловимым ошибкам в работе программы.
Но сейчас я хочу сказать о довольно популярной ошибке, которая может возникнуть из-за различной природы переменных статического и динамического массивов. Вот пример кода:


type  
TArray = array [0..15] of integer;  
TDynArray = array of integer;  
var  
A: TArray;  
B: TDynArray;  
   
// Хотим обнулить память массивов  
FillChar( A, sizeof( A ) ); // OK  
   
FillChar( B, sizeof( B ) );  
// Затираем указатель B на данные массива, поскольку размер переменной B равен 4 байта.  
// Счетчик ссылок массива остается в некорректном состоянии.  
   
FillChar( B, Length( B ) * sizeof( integer ) );  
// Самый худший случай. Затираем указатель B на данные массива и  
// еще кучу памяти за ним, не имеющей никакого отношения к массиву.  

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


FillChar( B[0], Length( B ) * sizeof( integer ) );  

А еще лучше:


FillChar( B[Low( B )], Length( B ) * sizeof( integer ) );   

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


while i < High( B ) do  
begin  
B[i + 1]:= B[i + 1] + B[i]; // конкретная операция с данными здесь неважна  
inc( i );   

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

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

Автор: Владимир Волосенков

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

Массив из элементов - как с ним бороться или как с ним дружить

Однажды я опубликовал на статью, в которой создавались массивы из различных компонентов, вплоть до форм. Письма, полученные мною после опубликования, были посвящены зачастую не основной теме статьи, а вопросам по созданию массивов из объектов. Здесь я постараюсь ответить на задаваемые вопросы «оптом». Я не претендую на истину в последней инстанции, но, думаю, что этот материал может быть кому-то полезен:). Здесь информация о

Создание массива
Работа с массивом
Заполнение массива во время работы программы
Использование объектов, созданных во время проектирования формы
Получение номера элемента массива в процедуре обработки события
Создание массива
Ну тут всё просто. Объявляем

var Arr: array[1..n] of TEdit; //к примеру  

и можно работать!
Так-же можно объявить и многомерный и даже динамический массив.


var Arr1: array [1..7, 1..5] of TEdit;  
  var Arr2: array of TEdit;  

Работа с массивом
Опасно не падать, а биться о землю, скалы и другие твёрдые предметы.
(альпинистско - парашютистская мудрость).

Итак, с созданным массивом надо что-то делать. Ну, для начала, чем-то заполнить. А, в отличие от чисел и строк, которые задаются в виде констант и выражений, объекты, помещаемые в наш массив, нужно создавать. Т.е. если мы описали


var ByteArr: array[1..2] of byte;  

то можно написать


ByteArr[1]:=3;  

Что же писать после := для массива из объектов? Их же как-то создать надо? (из форума)
Здесь у нас есть два пути - создавать объекты с помощью Create во время работы программы или использовать объекты, созданные во время проектирования формы. Каждый путь имеет своих путников (почти по Мао - дзе -дуну).

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


For i:=<начальное значение> to<конечное значение> do begin  
 <имя массива>[i]:=<имя класса>.Create(Self);  
 <имя массива>[i].Parent:=Self; //за объект ответит форма, на которой он создан  
 //<присвоение других свойств - по необходимости>  
end; 

После этих действий у нас на форме появятся необходимые компоненты, к которым можно обращаться, используя индекс массива, например так: <имя массива>. В следующем примере по щелчку по кнопке будет предложено ввести требуемое количество полей, которое и будет создано в центре формы. [DELPHI]procedure TForm1.Button1Click(Sender: TObject); var c: string; i,n:integer; begin c := InputBox('Введите','число:','7'); try n := StrToInt(c); except on EConvertError do ShowMessage('Что-то не срослось...'); end;//Try SetLength(Arr2, n); for i:=0 to n-1 do begin Arr2[i] := TEdit.Create(Self); Arr2[i].Parent := Self; //Эти две строки создают компонент, далее произвольные действия. Arr2[i].Top:=i*Arr2[i].Height; Arr2[i].Left:=(ClientWidth-Arr2[i].Width)div 2 ; Arr2[i].Text:='Поле '+IntToStr(i); end;//for Button1.Visible:=FormArraylse; end;
При заполнении многомерного массива компонентов таким способом никаких подводных камней нет - организуем несколько циклов.


procedure TForm1.FormCreate(Sender: TObject);  
var i, j: byte;  
begin  
  for i:=1 to 7 do  
   for j:=1 to 5 do begin  
   Arr1[i,j]:=TEdit.Create(Self);  
   Arr1[i,j].Parent := Self;  
  //Эти две строки создают компонент, далее произвольные действия.  
   Arr1[i,j].Top:=(i-1)*Arr1[i,j].Height;  
   Arr1[i,j].Left:=(j-1)*Arr1[i,j].Width;  
   Arr1[i,j].Text:='Поле '+ IntToStr(i*j);  
  end;//for j  
 end;  

Результат - таблица из Edit`ов, с индексированными ячейками.

Таким образом можно создать даже массив из форм. Разместим форму для создаваемого массива в Unit2.


uses Unit2;//задействуем его  
var FormArray: array [1..5] of TForm2;  
 //Теперь нам нужно создать массив FormArray, разместить его на главной форме и заполнить его изображениями.  
 //Делать это лучше не во время создания формы, а например во время активации.  
 procedure TForm1.FormActivate(Sender: TObject);  
 var i: byte;  
 begin  
  for i:=1 to 5 do begin  
   FormArray[i]:=TForm2.Create(Self);  
   FormArray[i].Parent:=Self;// Создание формы  
   // и что-то с ней делаем  
   FormArray[i].Visible:=True; //Вывод формы на экран  
   FormArray[i].Top:=i*50//Выбор места расположения (здесь ставятся ваши значения)  
  end;//for  
 end;  

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

Использование объектов, созданных во время проектирования формы
Раньше как было - код, компиляция, запуск, а лицо невесты можно увидеть только после свадьбы. Сейчас всё намного гуманнее. Есть проект, в нём форма, а на форму ставишь компоненты. И почему бы их не «объединить» в массиве?

Итак, на вашу форму во время проектирования помещено несколько Edit`ов, и вы хотите присвоить их элементам массива Arr.
Можно конечно написать Arr[1]:=Edit1; Arr[2]:=Edit2; и т.д., но это как-то не хорошо:(.
Значительно лучше просмотреть существующие компоненты и, если компонент - TEdit, поместить его в массив. Вот так:


procedure TForm1.FormCreate(Sender: TObject);  
var i, j: byte;  
begin  
 j:=1;  
 for i:=0 to ComponentCount-1 do //просматриваем  
  if (Components[i] is TEdit) then begin //если подходит  
   Arr[j]:=(Components[i] as TEdit);//помещаем  
   j:=j+1;  
  end;//if  
// а теперь посмотрим, в каком порядке они попали в массив  
 for i:=1 to 5 do  
  Arr[i].Text:='Arr['+IntToStr(i)+']';  
end;  

На самом деле, такой способ не намного менее коряв, чем присваивание «напрямую». В массив попадут все Edit`ы, присутствующие на форме, причём в порядке их создания. А как быть, если хочется поместить их не все и в своём порядке?
Очевидно, надо указать где-то, кого и в каком порядке мы хотим видеть принятым в члены массива. Под это где-то хорошо заточено свойство Tag - есть у любого компонента, целое число, используется «без вопросов». На этапе проектирования укажите в Tag`е, на каком месте в массиве вы хотите видеть данный компонент. Затем используйте следующий код:


procedure TForm1.FormCreate(Sender: TObject);  
var i: byte;  
begin  
 for i:=0 to ComponentCount-1 do  
  if Components[i].Tag>0 then //Tag больше нуля  
   Arr[Components[i].Tag]:=(Components[i] as TEdit);//Значит клиент наш!  
end.  

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


var Arr1: array [1..3] of TEdit;  
    Arr2: array [1..3] of TEdit;  
   procedure TForm1.FormCreate(Sender: TObject);  
   var i: byte;  
   begin  
    for i:=0 to ComponentCount-1 do  
     if Components[i].Tag>0 then   
      if Components[i].Tag<10 then  
       Arr1[Components[i].Tag]:=(Components[i] as TEdit)  
                                          else  
       Arr2[Components[i].Tag-10]:=(Components[i] as TEdit);  
    end;  

При создании многомерного массива используем тот-же приём - немного поработаем с тагом. Edit`ы протагированы 11.12.13.21.22.23:


var Arr1: array [1..3,1..2] of TEdit;  
  
procedure TForm1.FormCreate(Sender: TObject);  
var i, j: byte;  
begin  
 for i:=0 to ComponentCount-1 do  
  if Components[i].Tag>0  then  
   Arr1[Components[i].Tag mod 10,Components[i].Tag div 10 ]:=(Components[i] as TEdit);  
//убедимся,  что всё получилось  
for i:=1 to 3 do  
 for j:=1 to 2 do  
  arr1[i,j].text := IntToStr(i)+' '+IntToStr(j);  
end;  

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


var ArrE: array [1..3] of TEdit;  
     ArrC: array [1..8] of TComboBox;  
procedure TForm1.FormCreate(Sender: TObject);  
var i: byte;  
begin  
for i:=0 to ComponentCount-1 do  
if Components[i].Tag>0 then begin  
 if (Components[i] is TEdit)  
  then ArrE[Components[i].Tag]:=(Components[i] as TEdit);  
 if (Components[i] is TComboBox)  
  then  ArrC[Components[i].Tag]:=(Components[i] as TComboBox);  
end;//if  
end;  

При необходимости создания более сложных массивов - комбинируйте эти способы.

Лирическое отступление. Присвоение объектов происходит не совсем так, как у «обычных» переменных. Если у переменных присваивние не отоджествляет переменные т.е. после a:=3;b:=a;a:=5; в переменной b находится 3, а не 5, то с объектами всё наоборот. После ArrL[1]:=Label1; ArrL[1] и Label1 cтановятся одним объектом, и например ArrL[1].Caption:='Вася'; изменит надпись Label1. В некоторых языках для разруливания этой ситуации для блондинок введён специальный оператор присваивания объектов (Vb, set). Ну мы то, Дельфийцы, народ умный...

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


var ArrB: array [1..3] of TButton;  
    n: byte;// Здесь будет храниться индекс  
procedure TForm1.Clicker(Sender:TObject);  
var i: byte;  
begin  
 for i:=1 to 3 do  
  if Sender = ArrB[i] then n:=i;  
  //находим индекс компонента, к которому относится событие  
 ShowMessage('Нажата кнопка '+IntToStr(n)); //что-то делаем  
end;  
  
procedure TForm1.FormCreate(Sender: TObject);  
var i: byte;  
begin  
 for i:=0 to ComponentCount-1 do  
  if Components[i].Tag > 0  
   then ArrB[Components[i].Tag]:=(Components[i] as TButton);//наполняем массив  
 for i:=1 to 3 do  
  ArrB[i].OnClick:=Clicker; //устанавливаем обработчик  
end;  

Ну, как говорится, спасибо за внимание.

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

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

ЛОВИМ БАГИ или ПОЧЕМУ ПРОГРАММЫ ДОПУСКАЮТ &quot;НЕДОПУСТИМЫЕ ОПЕРАЦИИ&quot;

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

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


Access violation at address <HEX_value>  
in module <Application.Exe>.  
Read of address <HEX_value_2>  

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

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

Мы можем поделить AVS, с которыми сталкиваются при разработке в Delphi на два основных типах: ошибки при выполнения и некорректная разработка проекта, что вызывает ошибки при работе программы.

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

Эти ошибки могут быть вызваны различными источниками, включая систему BIOS, операционную систему или аппаратные подпрограммы драйверов. Некоторые видео-, звуковые или сетевые платы могут фактически вызывать подобного рода ошибки в Delphi. Для решения подобных аппаратных проблем можно предпринять последовательность неких "стандартных" ходов:

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

попробовать слегка уменьшить "аппетита" видеодрайвера - поставить меньшее разрешение;

в случае если у вас двухпроцесорная система обеспечить равное изменение шага для каждого процессора;

И в конце концов просто попытаться заменить драйвера на более свежие.

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

Хотя Windows 9X популярная система, разработку лучше проводить в Windows NT или Windows 2000 - это более устойчивые операционные системы. Естественно при переходе на них придется отказаться от некоторых благ семейства Windows 95/98/Me - в частности не все программы адоптированы для Windows NT/2000. Зато вы получите более надежную и стабильную систему.

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

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

Контролируйте все программные продукты установленные на вашей машине и деинсталлируйте те из них, которые сбоят. Фаворитами AV среди них являются шароварные утилиты и программы и бета версии программных продуктов.

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

Вы могли бы рассмотреть компилирование вашего приложения с директивой {$D}, данная директива компилятора может создавать файлы карты (файлы с расширением map, которые можно найти в том же каталоге, что и файлы проекта), которые могут послужить большой справкой в локализации источника подобных ошибок. Для лучшего "контроля" за своим приложением, компилируйте его с директивой {$D}. Таким образом, вы заставите Delphi генерировать информацию для отладки, которая может послужить подспорьем при выявление возникающих ошибок.

Следующая позиция в Project Options - Linker & Compiler позволяет вам, определить все для последующей отладки. Лучше всего, если помимо самого выполняемого кода будет доступна и отладочная информация - это поможет при поиске ошибок. Отладочная информация увеличивает размер файла и занимает дополнительную память при компилировании программ, но непосредственно на размер или быстродействие выполняемой программы не влияет. Включение опций отладочной информации и файла карты дают детальную информацию только, если вы компилируете программу с директивой {$D+}.

Эта информация состоит из таблицы номеров строк для каждой процедуры, которая отображает адреса объектных кодов в номера строк исходного текста. Директива $D обычно используется совместно с другой директивой - $L, что позволяет или запрещает генерацию информации о локальных символах для отладки.

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


procedure TfrMain.OnCreate(Sender: TObject);  
 var BadForm: TBadForm;  
 begin  
   BadForm.Refresh; // причина  ошибки  
 end;  

Попытаемся разобратся в этой ситуации. Предположим, что BadForm есть в списке "Available forms " в окне Project Options|Forms. В этом списке находятся формы, которые должны быть созданы и уничтожены вручную. В коде выше происходит вызов метода Refresh формы BadForm, что вызывает нарушение доступа, так как форма еще не была создана, т.е. для объекта формы не было выделено памяти.

Если вы установите "Stop on Delphi Exceptions " в Language Exceptions tab в окне Debugger Options, возможно возникновения сообщение об ошибке, которое покажет, что произошло ошибка типа EACCESSVIOLATION. EACCESSVIOLATION - класс исключение для недопустимых ошибок доступа к памяти. Вы будете видеть это сообщение при разработке вашего приложения, т.е. при работе приложения, которое было запущено из среды Delphi.

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


Access violation at address 0043F193  
in module 'Project1.exe'  
Read of address 000000.  

Первое шестнадцатиричное число ('0043F193') - адрес ошибки во время выполнения программы в программе. Выберите, опцию меню 'Search|Find Error', введите адрес, в котором произошла ошибка ('0043F193') в диалоге и нажмите OK. Теперь Delphi перетранслирует ваш проект и покажет вам, строку исходного текста, где произошла ошибка во время выполнения программы, то есть BadForm.Refresh.

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

Недопустимый параметр API
Если вы пытаетесь передать недопустимый параметр в процедуру Win API, может произойти ошибка. Необходимо отслеживать все нововведения в API при выходе новых версий операционных систем и их обновлений.

Уничтожение исключения
Никогда не уничтожайте временный объект исключения. Обработка исключения автоматически уничтожает объект исключения. Если вы уничтожите объект самостоятельно, то приложение попытается уничтожать объект снова, и произойдет ошибка.


Zero:=0;  
try  
   dummy:= 10 / Zero;  
except on E: EZeroDivide do  
   MessageDlg('Can not divide by zero!', mtError, [mbOK], 0);  
   E.free. // причина ошибки  
end;

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


var s: string;  
begin  
   s:='';  
   s[1]:='a'; // причина ошибки  
end;  

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


procedure TForm1.Button1Click(Sender: TObject);  
var  
  p1 : pointer;  
  p2 : pointer;  
begin  
  GetMem(p1, 128);  
  GetMem(p2, 128);  
 {эта строка может быть причиной ошибки}  
  Move(p1, p2, 128);  
 {данная строка корректна }  
  Move(p1^, p2^, 128);  
  FreeMem(p1, 128);  
  FreeMem(p2, 128);  
end;  

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

Удачной вам ловли багов, господа!

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

Липкие окошки

В статье рассматривается приём создания обработчиков сообщений, которые позволяют форме при перетаскивании "прилипать" к краям экранной области.

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

Итак, при перемещении окну посылается сообщение WM_MOVING. Обрабатывая данное сообщение, приложение может отслеживать размер и расположение перетаскиваемого квадрата и при необходимости изменять их.

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

Чаще всего с сообщением передаются дополнительные параметры, которые сообщают нам необходимую информацию. Например, сообщение WM_MOVE, указывающее на то, что форма изменила своё местоположение, также передаёт в параметре LPARAM новые координаты X и Y.

Сообщение WM_WINDOWPOSCHANGING передаёт нам только один параметр - указатель на структуру WindowPos, которая содержит информацию о новом размере и местоположении окна. Вот как выглядит структура WindowPos:


TWindowPos = packed record  
  hwnd: HWND; {Identifies the window.}  
  hwndInsertAfter: HWND; {Window above this one}  
  x: Integer; {Left edge of the window}  
  y: Integer; {Right edge of the window}  
  cx: Integer; {Window width}  
  cy: Integer; {Window height}  
  flags: UINT; {Window-positioning options.}  
end;  

Наша задача проста: нам необходимj, чтобы форма прилипла к краю экрана, если она находится на определённом расстоянии от него (допустим, 20 пикселей).

Пример

К новой форме добавьте Label, один Edit и четыре Checkbox. Измените имя Edit на edStickAt. Измените имена чекбоксов на chkLeft, chkTop, и т.д. Для установки количества пикселей используем edStickAt, который будет использоваться для определения необходимого расстояния до края экрана, достаточного для приклеивания формы.

Нас интересует только одно сообщение - WM_WINDOWPOSCHANGING. Обработчик для данного сообщения будет объявлен в секции private. Ниже приведён полный код этого процедуры "прилипания" вместе с комментариями. Обратите внимание, что Вы можете предотвратить "прилипание" формы к определённому краю путём снятия нужной галочки.

Для получения рабочей области декстопа (минус панель задач, панель Microsoft и т.д.), используем SystemParametersInfo, первый параметр которой SPI_GETWORKAREA.


...
  
  private  
   procedure WMWINDOWPOSCHANGING  
            (var Msg: TWMWINDOWPOSCHANGING);  
             message WM_WINDOWPOSCHANGING;  
  
...  
  
procedure TfrMain.WMWINDOWPOSCHANGING  
          (var Msg: TWMWINDOWPOSCHANGING);  
const  
  Docked: Boolean = FALSE;  
var  
  rWorkArea: TRect;  
  StickAt : Word;  
begin  
  StickAt := StrToInt(edStickAt.Text);  
    
  SystemParametersInfo  
     (SPI_GETWORKAREA, 0, @rWorkArea, 0);  
  
  with Msg.WindowPos^ do begin  
    if chkLeft.Checked then  
     if x <= rWorkArea.Left + StickAt then begin  
      x := rWorkArea.Left;  
      Docked := TRUE;  
     end;  
  
    if chkRight.Checked then  
     if x + cx >= rWorkArea.Right - StickAt then begin  
      x := rWorkArea.Right - cx;  
      Docked := TRUE;  
     end;  
  
    if chkTop.Checked then  
     if y <= rWorkArea.Top + StickAt then begin  
      y := rWorkArea.Top;  
      Docked := TRUE;  
     end;  
  
    if chkBottom.Checked then  
     if y + cy >= rWorkArea.Bottom - StickAt then begin  
      y := rWorkArea.Bottom - cy;  
      Docked := TRUE;  
     end;  
  
    if docked then begin  
      with rWorkArea do begin  
      // не должна вылезать за пределы экрана  
      if x < Left then x := Left;  
      if x + cx > Right then x := Right - cx;  
      if y < Top then y := Top;  
      if y + cy > Bottom then y := Bottom - cy;  
      end; {ширина rWorkArea}  
    end; {}  
  end; {с Msg.WindowPos^}  
  
  inherited;  
end;  
end.  

Теперь достаточно запустить проект и перетащить форму к любому краю экрана. Вот собственно и всё.

А вот другой более короткий (и может быть, даже лучший) способ:


procedure TCustomGlueForm.WMWindowPosChanging1(var Msg: TWMWindowPosChanging);  
var  
WorkArea: TRect;    
StickAt : Word;    
begin  
StickAt := 10;    
SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0);    
with WorkArea, Msg.WindowPos^ do      
begin  
// Сдвигаем границы для сравнения с левой и верхней сторонами    
Right:=Right-cx;    
Bottom:=Bottom-cy;    
if abs(Left - x) <= StickAt then x := Left;    
if abs(Right - x) <= StickAt then x := Right;    
if abs(Top - y) <= StickAt then y := Top;    
if abs(Bottom - y) <= StickAt then y := Bottom;    
end;    
inherited;    
end;  

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

Леворекурсивный парсер

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

Для такого преобразования обычно применяют алгоритмы, которые называются парсерами. Для определённого круга задач уже давно написаны свои готовые парсеры. Например для анализа XML. В случае простых данных можно обычно обойтись простыми функциями Pos/Copy. Но как только данные чуточку усложняются – код становится огромным и неудобным. И каждое новое добавление функциональности превращается в пытку и бессонные ночи отладки.

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

В нескольких статьях я попробую рассказать, как написать один из простейших вариантов парсера – леворекурсивный. При правильной реализации этот парсер является одним из самых быстрых. Но он не может распарсить абсолютно всё. Например, код на языке Pascal можно распарсить с помощью чистого леворекурсивного парсера. Начиная с первых версий Delphi, парсер не такой уж и чисто леворекурсивный, однако он и не слишком усложнён. Код на языке С++ нельзя распарсить этим парсером. Для этого языка применяется парсер с возвратами. Это одна из причин, почему компилятор Делфи значительно быстрее компилятора С++. Хотя есть и ещё десяток причин :-)

Не бойтесь, если многие слова непонятны. Через какое-то время они будут восприниматься подсознательно.

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

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

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

Для начала сделаем примитивную форму для тестов, которую мы будем использовать в большинстве последующих примеров. Для кнопки «Расчёт!» напишем такой код:


procedure TForm1.Button1Click(Sender:TObject);  
begin  
  Edit2.Text := FloatToStr(Parser(Edit1.Text));  
end;  



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

Заготовка парсера
Привожу код самого парсера с комментариями. (Полный проект – в папке Demo1).


unit MyParser;  
   
interface  
  uses SysUtils;  
function Parser(s: string): double;  
   
implementation  
   
var  
  InpStr:   string; //Копия входной строки  
  InpPos:   integer;//Номер текущего символа  
  CurrChar: char;   //Копия текущего символа  
   
//Процедура берёт следующий символ из строки  
procedure GetNextChar;  
begin  
  if InpPos < length(InpStr) then begin  
    Inc(InpPos);  
    CurrChar := InpStr[InpPos];  
  end  
  else  
    CurrChar := #0;  
end;  
   
//Функция чтения числа  
function GetNumber:Double;  
begin  
  result := 0;  
  while CurrChar in ['0'..'9'] do begin  
    result := result * 10 + ord(CurrChar) -  
ord('0');  
    GetNextChar;  
  end;  
end;  
   
//Парсер :)  
function Parse: double;  
begin  
  result := GetNumber;  
  if CurrChar <> #0 then  
    raise Exception.create('В конце строки неизвестные символы!');  
end;  
   
//Иницализация и запуск парсера  
function Parser(s: string): double;  
begin  
  InpStr := s;  
  InpPos := 0;  
  GetNextChar;  
  Result := Parse;  
end;  
   
end.  

Этот код будет основой для всех последующих парсеров. Давайте кратко разберём фунции.

Функция Parser. Эта функция вначале инициализирует внутренние переменные (первые две строки), читает первый символ (он автоматически помещается в глобальную переменную CurrChar) и последней строкой вызывает функцию, которая, собственно, и делает парсинг.

Функция Parse также не делает ничего сложного. Она читает число из потока (об этом ниже). После того, как она прочитала число, там больше ничего не должно быть, это ведь функция преобразования строки в число. Если там что-то обнаружено – генерируем исключение.

Продвигаемся дальше вглубь. Функция GetNumber. Перед её анализом, давайте подумаем, что такое обычное целое число. Это просто последовательность цифр. А теперь смотрим на функцию. Она работает просто. Проверяет текущий символ: если он - цифра, то сохранённый результат умножает на 10 и добавляет значение цифры. Перевод из символа цифры в число я делаю конструкцией Ord(CurrChar) - Ord('0'). Это очень старый, но очень быстрый способ. Можно было, конечно, использовать функцию StrToInt, но смысл? :-) После обработки текущего символа переходим к новому (процедура GetNextChar).

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

Заметье, что функция GetNumber читает до тех пор, пока в входном потоке есть цифры. Если их там нет – она выходит. Её абсолютно не волнует, что там дальше. Это забота другого кода.

И на последок рассмотрим процедуру GetNextChar. Она работает тоже крайне примитивно. Пока в строке есть ещё символы – она увеличивает счётчик и присваевает CurrChar текущий символ. Если символов больше нет – возвращает нулевой символ.

А теперь попробуйте ответить на простой вопрос. Знает ли функция Parse или GetNumber о том, откуда берутся следующие символы? Нет! Им этого и не нужно знать. Только процедура GetNextChar знает, как их получить, ну и функция Parser умеет подготовить данные. Это позволяет с лёгкостью заметить источник данных без переделки всего кода. Например, захотели мы читать данные из файла. Нам надо переделать только эти две функции. А как именно – это будет первым домашним заданием.

Первое улучшение
Парсер у нас хороший, но если ввести не просто число, а добавить пару пробелов в начало и в конец, то он уже ругается. Непорядок! Надо исправить. И для этого нам нужно всего пару строк (этот пример можно найти в папке Demo2).

Первое – напишем простую процедуру:


procedure SkipSpace;  
begin  
  while CurrChar in [' ', #9] do  
    GetNextChar;  
end;  

Эта процедура читает из входного потока символы, и, пока они пробелы или символы табуляции, пропускает их. Если вам захочется, что бы символ подчёркивания тоже был пробельным символом – просто добавьте его в этот список.

Теперь осталось добавить вызов. Пока я сделал так:


//Функция чтения числа  
function GetNumber:Double;  
begin  
  result := 0;  
  SkipSpace;  
  while CurrChar in ['0'..'9'] do begin  
    result := result * 10 + ord(CurrChar) - ord('0');  
    GetNextChar;  
  end;  
  SkipSpace;  
end;  

Запустите программу и попробуйте вводить различные строки. Она с лёгкостью переваривает их!

Простой калькулятор
Я надеюсь, вы заметили название формы – простой калькулятор. И мы сейчас его сделаем! Правда, он будет уметь только складывать и вычитать числа. Но зато он будет уметь это делать!

Итак, научим наш калькулятор понимать выражения вида «1 + 23 + 456 - 789» Заметьте, с пробелами, и со знаками плюс и минус. Для начала посмотрим на эту строку. Что же мы видим? Вначале надо прочитать число, потом в цикле читать знак и ещё одно число, и производить операцию.

Посмотрите на то, что написано ниже:


//Парсер :)  
function Parse: double;  
begin  
  Result := GetNumber;  
  repeat  
    case CurrChar of  
      #0: exit; //Достигли конца строки  
      '+':      //Нужно сложить  
      begin  
        GetNextChar;  
        Result := Result + GetNumber;  
      end;  
      '-':      //Нужно вычесть  
      begin  
        GetNextChar;  
        Result := Result - GetNumber;  
      end;  
      else  //Какой-то неизвестный символ.  
        raise Exception.CreateFmt(  
          'Я пока умею складывать и вычитать!'#13#10+  
          ' В строке обнаружен символ %s в позиции %d',  
          [CurrChar, InpPos]);  
    end;  
  until False;  
end;  

Как видно – ничего больше, чем я сказал, когда давал определение.

Домашнее задание

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

Научите парсер уммножать и делить. Пока что без учёта старшинства операций. Можно и степень ввести (символ ^).

Научите парсер понимать выражение вида PI * 2, где PI – это 3.14, то есть, число пи. Хотя это и кажется сложным заданием, на самом деле оно очень простое.

Найдите и попробуйте исправить как минимум две ошибки в реализации функции GetNumber.

А дальше?
В следующей части мы научим наш парсер работать с дробными числами и с шестнадцатеричными.

Примеры к статье (исходники 3 демо-проектов)

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

Корректное построение программного кода. Рисование. Построение графика функции

Бесконечные циклы, громоздкие операции и прочие зависшие программы.

Ну кто из вас хоть раз не завершал зависшее приложение через Ctrl+Alt+Del? А ведь в большинстве случаев в ситуации, когда программа зависает, виноват программист, а не пользователь, который ее довел до этого состояния. Зачастую программы имеют в себе до 30% различной проверочных команд. Когда проверяются переполнение списков, проверяется корректность созданного объекта, компонента, проверяется или запущено то или иное внешнее приложение. Именно от этих условий и зависит дальнейшее корректное выполнение вашего приложения.

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


procedure TForm1.Button1Click(Sender: TObject);  
begin  
while true do  
   begin  
      // бесконечный цикл  
   end;  
end;  
  
procedure TForm1.Button2Click(Sender: TObject);  
begin  
ShowMessage('Нажата кнопка Button1');  
end;  

В первой процедуре мы видим типичный программный код, при выполнении которого программа зависнет. Или говоря языком юзера - бесконечно выполняет одно и то же. Естественно, что выхода из такой процедуры не существует, а сама программа ожидает выхода из нее, чтобы выполнять другие события, в том числе и системные.
Принцип работы операционной системы windows основан на посылке сообщений компонентам программы. События при этом становятся в очередь и ожидают своей обработки. Поскольку выхода из первой процедуры нами не предусмотрено, то очередь сообщений не будет обрабатываться, и при нажатии на кнопки Ctrl+Alt+Del через некоторое время, мы видим, что приложение "не отвечает на системные запросы".
В подобных случаях это совсем не означает, что программа не работает. Она может зациклиться на обработки одной или нескольких команд, ожидая выхода из цикла по определенному условию (например, прочтения данных с диска) или обрабатывать большой объем данных опять таки в одной процедуре. А, как известно, корректная работа программы забота программиста, то есть нас с вами. Мы должны учесть все возможные ситуации, просчитать приблизительное время обработки операций даже на слабых компьютерах, при необходимости применить компонент ProgressBar, для того, чтобы пользователь не скучал, глядя на "неотвечающую" программу.

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

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


Application.ProcessMessages;  

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

Исключительные ситуации.

Это другой неприятный момент для пользователя и программиста. Это когда появляются неожиданные англоязычные ошибки и выполняемая процедура завершает свою работу с места появления ошибки. Разработчики Borland Delphi таким контролем за ошибками и выходом из работающих модулей программы позаботились об остальных частях программы. Если ошибка появилась в первой строке, то имеет ли смысл выполнять вторую?

Рассмотрим такой пример:


procedure TForm1.Button1Click(Sender: TObject);  
Var x,y,z:Double; // переменные.  
begin  
   x:=0;  
   z:=1;  
   y:=z/x; // деление на нуль  
   ShowMessage(FloatToStr(y));  
end;  

При выполнении данного кода мы получаем сообщение "Floating point division by zero". И процедура дальше уже не обрабатывается. После команды деления мы не видим его результат ShowMessage(РЕЗУЛЬТАТ) Или еще такой пример:


procedure TForm1.Button1Click(Sender: TObject);  
begin  
   Form1.ShowModal; // открыть окно модально  
   ShowMessage('Окно открыто модально');  
end;  

Если у нас окно Form1 уже открыто, то повторная попытка открыть его модально приведет к возникновению ошибки "Cannot make a visible window modal". И опять программа завершает обработку процедуры. Это приведены примитивные процедуры, но бывает такие, что даже сам программист не ожидает появления подобной ситуации, но нужно предусмотреть все.
Что же делать, если мы открыли несколько файлов, заполняем список, создали вручную некоторые объекты. Выход из процедуры приводит к тому, что файлы не закрыты и повторный вызов этой процедуры приведут к возникновению другой ошибки - открытие уже открытого файла. Созданные объекты мы теряем при выходе из процедуры, а при повторном их создании, если они глобальные, получаем еще одну ошибку. А эта трата драгоценной памяти, которая занимается объектом и остается даже после выхода их программы. И так далее со всеми вытекающими последствиями.

Во-первых, надо при всех операциях деления предусматривать что-то подобное


if x<>0 then y:=z/x; // если x не равно нулю, то делить.  

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


Var st:String;  
y:Double;  
...  
InputQuery('Ввод числа','введите любое число',st);  
y:=StrToFloat(st);  

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

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


if not Form1.Visible then Form1.ShowModal; // если окна нет на экране, то открыть его модально 

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

В уроке15 мы рассматривали пример, в котором есть директива компилятору об отключении контроля ошибок ввода-вывода. Мы открывали файл, при отключенном автоматическом контроле, после чего сами обрабатывали ошибку открытия.


{$I-} // отключение контроля ошибок ввода-вывода  
Reset(f); // открытие файла для чтения  
{$I+} // включение контроля ошибок ввода-вывода  
if IOResult<>0 then // если есть ошибка открытия, то  
   begin  
      ShowMessage('Ошибка открытия файла C:\1.TXT');  
      Exit; // выход из процедуры при ошибке открытия файла  
   end;  

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


try // начало опасно-ошибочной части процедуры:  
   Form1.ShowModal;  
except // если возникла ошибка, то выполняется следующее:  
   ShowMessage('Ошибка открытия окна');  
end; // конец try  
ShowMessage('Дальнейшая обработка процедуры'); 

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

Аналогом try-except есть try-finally


procedure TForm1.Button1Click(Sender: TObject);  
Var StringList:TStringList; // список строк  
begin  
try  
   StringList:=TStringList.Create; // создание списка строк  
finally // при успешной обработки создания списка:  
   StringList.Free; // удалить и освободить память  
end;  
ShowMessage('Дальнейшая обработка процедуры');  
end;  

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

Рисование на форме или на компоненте PaintBox. Генератор колебаний. Пример

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

У формы и у компонента PaintBox (страница System палитры компонентов) есть свойство Canvas. Это свойство представляет собой растровое изображение, на котором можно рисовать или в которое можно загрузить рисунок. Я не буду рассказывать подробно об особенностях рисования, тем более, что я в этом не силен, но основные сведения дам.
Свойство Canvas доступно только во время работы приложения и с помощью его можно:
* Canvas.Brush - свойство фона. У него можно установить свойство Canvas.Brush.Color в необходимый цвет и с помощью следующей за ней командой Canvas.FillRect(ClientRect) можно очистить всю рабочую область компонента под заданный цвет. С помощью свойтва Canvas.Brush можно в качестве фона установить рисунок. Для этого есть свойство Canvas.Brush.Bitmap, которому нужно присваивать переменную с растровым рисунком.
* Canvas.MoveTo(x,y) - устанавливает перо в заданную точку, где x и y - координаты точки, относительно компонента. Начало координат, точка [0,0] находится в верхнем левом углу. После этой команды перо установлено, но точка не нарисована. Чтобы провести линию от текущего положения пера до заданного Canvas.LineTo(x,y). Поставить точку определенного цвета на холсте Canvas.Pixels[x,y]:=ЦВЕТ_ТОЧКИ.
* Через Canvas можно писать текст, рисовать дуги, сектор круга, овал, прямоугольник, ломаную линию, кривую.
* Свойства пера содержатся в Canvas.Pen. Здесь можно задать толщину пера Canvas.Pen.Width:=ТОЛЩИНА_В_ТОЧКАХ. Задать цвет Canvas.Pen.Color:=ЦВЕТ.

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

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

Программа имеет только одно окно Form1, у которого сразу переименовываем заголовок на подходящее название.
Устанавливаем свойство Form1.Position в poDesktopCenter, чтобы окно при каждом запуске и при любом экранном разрешении всегда было ровно посередине экрана.
Устанавливаем свойство Form1.BorderStyle в bsSingle, для неизменяемого размера окна. Оставляем во вложенных свойствах BorderIcons только biSystemMenu в true, остальные в false. Это для того, чтобы окно нельзя было свернуть в значек, развернуть во весь экран и окно имело иконку в заголовке.
Устанавливаем в форму компонент PaintBox, два компонента RadioButton, CheckBox, три кнопки Button и TrackBar, расположенный на странице Win32.
RadioButton1.Caption переименовываем в "Sin". Этот флаг будет признаком рисования синусоиды. RadioButton2.Caption переименовываем в "Cos" - косинусоида. Начальное значение флага Checked для RadioButton1 в true.
CheckBox1.Caption переименовываем в "Все". Если флаг установлен, то будет рисоваться два графика.
Названия кнопок Button1 - "Старт", Button2 - "Стоп (пауза)" и Button3 - "Выход". Названия на кнопках меняются через свойство Caption. Теперь назначение этих кнопок понятно.
Компонент TrackBar1 свойство минимального значения Min устанавливаем в 1, максимальное значение Max - 50.
PaintBox1, на котором будет непосредственно рисоваться график размеры высоты Height=140, ширина Width=500.
Привожу текст модуля для окна Form1.

Сразу после слова implementation в модуле окна объявляем глобальные переменные, которые будут доступны из любой процедуры в этом модуле.


Var stop:boolean; // признак рисования  
x:Integer; // координата оси X 

Реакция на событие нажатия на кнопку Button1 (Начало рисования)


procedure TForm1.Button1Click(Sender: TObject);  
Var y:Integer; // ось Y  
begin  
if x=0 then // если точка в начале координат, то:  
   begin  
      PaintBox1.Canvas.Brush.Color:=clWhite; // цвет фона белый  
      PaintBox1.Canvas.FillRect(ClientRect); // заливка всей рабочей области  
   end;  
stop:=false; // флаг старта процесса рисования  
While not stop do // бесконечный цикл, пока флаг остановки не поднят:  
   begin  
      if (RadioButton1.Checked)or(CheckBox1.Checked) then // если установлен "Sin" или "Все", то:  
         begin  
            y:=Round(Sin(pi*x/100)*50)+70; // вычисление положения синусоиды  
            PaintBox1.Canvas.Pixels[x,y]:=clBlack; // нарисовать черную точку  
         end;  
      if (RadioButton2.Checked)or(CheckBox1.Checked) then // если установлен "Cos" или "Все", то:  
         begin  
            y:=Round(Cos(pi*x/100)*50)+70; // вычисление положения косинусоиды  
            PaintBox1.Canvas.Pixels[x,y]:=clBlack; // нарисовать черную точку  
         end;  
      inc(x); // увеличить значение X на едицину. Аналог X:=X+1  
      if x>500 then // если X вышел за пределы PaintBox1, то:  
         begin  
            x:=0; // установить X на начало координат  
            PaintBox1.Canvas.Brush.Color:=clWhite; // Цвет фона белый  
            PaintBox1.Canvas.FillRect(ClientRect); // Очистка рабочей области PaintBox1  
         end;  
  
      Sleep(TrackBar1.Position); // Процедура "засыпает" на заданное время в миллисекундах  
      Application.ProcessMessages; // Обработка всей очереди сообщений  
   end;  
end;  

Коротко расскажу работу этой процедуры.
Как только нажата кнопка "Старт" Компонент PaintBox1 очищается и начинается бесконечный цикл While, выйти из которого можно только, пока переменная Stop не примет значение true. Это можно сделать кнопкой Button2, соответствующая процедура которой обработается во время Application.ProcessMessages. С помощью бегунка TrackBar1 можно менять скорость рисования кривой. Этот параметр передается в команду Sleep.

Процедура нажатия на кнопку остановки Button2:


procedure TForm1.Button2Click(Sender: TObject);  
begin  
Stop:=true; // установить флаг остановки процесса рисования  
end;  

Процедура создания окна Form1OnCreate:


procedure TForm1.FormCreate(Sender: TObject);  
begin  
x:=0; // начальное значение X  
end;  

Если нажата кнопка "Выход", то реакция на это событие будет таким:


procedure TForm1.Button3Click(Sender: TObject);  
begin  
Close; // закрыть окно  
end;  

И реакция перед закрытием окна OnClose. Без этой процедуры, если рисование включено, то окно не закроется.


procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);  
begin  
Stop:=true; // остановить (если включен) цикл рисования  
end;  

После запуска программы, установки флажка "Все" и нажатии на кнопку "Старт" на экране отобразится этот график:

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


if x>500 then // если X вышел за пределы PaintBox1, то:  
   begin  
      x:=0; // установить X на начало координат  
      PaintBox1.Canvas.Brush.Color:=clWhite; // Цвет фона белый  
      PaintBox1.Canvas.FillRect(ClientRect); // Очистка рабочей области PaintBox1  
   end;  

измените на:


if x>500 then // если X вышел за пределы PaintBox1, то:  
    begin  
       x:=0; // установить X на начало координат  
       Stop:=true; // остановка рисования  
    end;  

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

Y:=140 - ФУНКЦИЯ;


Как видите, поле для экспериментов велико. Приступайте к самостоятельному изучению.

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

Копирование файлов

В данной статье показаны некоторые методы копирования файлов. Существуют и готовые функции - CopyFile(), CopyFileEx(), но порой они неприменимы. Например, при использовании функции CopyFile() с большими файлами мы не имеем доступа к процессу копирования, т.е. программа на некоторое время просто "зависает". Из методов, приведённых ниже, только первый позволяет контроллировать процесс копирования - можно добавить прогресс-индикатор выполнения или отображать объём скопированных данных.

1. Копирование методом Pascal

type   
  TCallBack=procedure (Position,Size: Longint); {Для индикации процесса копирования}   
   
procedure FastFileCopy(Const InfileName, OutFileName: String; CallBack: TCallBack);   
const BufSize = 3*4*4096; { 48Kbytes дает прекрасный результат }   
type   
  PBuffer = ^TBuffer;   
  TBuffer = array [1..BufSize] of Byte;   
var   
  Size             : integer;   
  Buffer           : PBuffer;   
  infile, outfile  : File;   
  SizeDone,SizeFile: Longint;   
begin   
  if (InFileName <> OutFileName) then   
  begin   
    buffer := Nil;   
    AssignFile(infile, InFileName);   
    System.Reset(infile, 1);   
    try   
      SizeFile := FileSize(infile);   
      AssignFile(outfile, OutFileName);   
      System.Rewrite(outfile, 1);   
      try   
        SizeDone := 0; New(Buffer);   
        repeat   
          BlockRead(infile, Buffer^, BufSize, Size);   
          Inc(SizeDone, Size);   
          CallBack(SizeDone, SizeFile);   
          BlockWrite(outfile,Buffer^, Size)   
        until Size < BufSize;   
        FileSetDate(TFileRec(outfile).Handle,   
        FileGetDate(TFileRec(infile).Handle));   
      finally   
        if Buffer <> Nil then Dispose(Buffer);   
        System.Close(outfile)   
      end;   
    finally  
      System.Close(infile);   
    end;   
  end  
else   
  Raise EInOutError.Create('File cannot be copied into itself');   
end;  

2. Копирование методом потока.

procedure FileCopy(Const SourceFileName, TargetFileName: String);  
var  
  S,T: TFileStream;  
begin  
  S := TFileStream.Create(sourcefilename, fmOpenRead);  
  try  
    T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);  
    try  
      T.CopyFrom(S, S.Size);  
      FileSetDate(T.Handle, FileGetDate(S.Handle));  
    finally  
      T.Free;  
    end;  
  finally  
    S.Free;  
  end;  
end;  

3. Копирование методом LZExpand

uses LZExpand;  
   
procedure CopyFile(FromFileName, ToFileName  : string);  
var  
  FromFile, ToFile: File;  
begin  
  AssignFile(FromFile, FromFileName);  
  AssignFile(ToFile, ToFileName);  
  Reset(FromFile);  
  try  
    Rewrite(ToFile);  
    try  
    if LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle) < 0 then  
      raise Exception.Create('Error using LZCopy')  
    finally  
      CloseFile(ToFile);  
    end;  
  finally  
    CloseFile(FromFile);  
  end;  
end;  

4. Копирование методами Windows

uses ShellApi;  
   
function WindowsCopyFile(FromFile, ToDir : string) : boolean;  
var F : TShFileOpStruct;  
begin  
  F.Wnd := 0; F.wFunc := FO_COPY;  
  FromFile:=FromFile+#0; F.pFrom:=pchar(FromFile);  
  ToDir:=ToDir+#0; F.pTo:=pchar(ToDir);  
  F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;  
  Result:=ShFileOperation(F) = 0;  
end;  
   
// Пример копирования:  
procedure TForm1.Button1Click(Sender: TObject);  
begin  
  if not WindowsCopyFile('C:\UTIL\ARJ.EXE', GetCurrentDir) then  
    ShowMessage('Copy Failed');  
end;  

Мной были сделаны некоторые эксперименты с данными функциями. Во всех случаях копировался один и тот же файл объёмом 122 Мб. Конечно, говорить о правильности результатов можно с трудом, ведь жёсткий диск работает по-разному - иногда быстрее, а иногда медленее.

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

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

Копирование и удаление файлов в Delphi

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

В самом простом случае вопрос копирования файлов очень прост (хотя поступило много пожеланий рассказать именно об этом)! Для этого достаточно посмотреть в хелп по Delphi :))

Копирование файлов
В Delphi есть функция CopyFile. Вот ее описание из хелпа

BOOL CopyFile(
  LPCTSTR lpExistingFileName, // pointer to name of an existing file 
  LPCTSTR lpNewFileName, // pointer to filename to copy to 
  BOOL bFailIfExists // flag for operation if file exists 
);

Параметры передаваемые в эту функцию:

Указатель на имя существующего файла (нуль терминированная строка т.е. тип PChar! )
Указатель на имя файла, который будет создан/перезаписан после копирования (нуль терминированная строка т.е. тип PChar! )
Если этот параметр True и файл с таким именем уже существует, то функция вернет False. Если же файл, с именем указанным во втором параметре существует и в качестве третьего параметра передан False - то функция перезапишет файл и благополучно завершится.
Приведу небольшой пример использования этой функции. Создайте на диске C:\ файл '1.txt', а на форму поставьте кнопку:


procedure TForm1.Button1Click(Sender: TObject);  
begin  
  if CopyFile('c:\1.txt','c:\2.txt',true) then  
  ShowMessage('Файл успешно скопирован!')  
  else ShowMessage('Неудача!');  
end;  

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


procedure TForm1.Button1Click(Sender: TObject);  
begin  
  if CopyFile('c:\1.txt','c:\2.txt',true) then  
    ShowMessage('Файл успешно скопирован!')  
  else  
    ShowMessage('Ошибка! Вот ее код: '+IntToStr(GetLastError));  
end;  

Таким образом нажав второй раз на кнопку мы получим сообщение: "Ошибка! Вот ее код: 80". Это говорит нам, что файл существует.

Коды всех ошибок можно легко найти в хелпе.

Для углубления рассматриваемого вопроса приведу пример копирования файлов с помощью файлового потока (TFileStream). В приведенной пользовательской функции введены два дополнительных параметра From и Count, которые указывают, соответственно, с какого и по какой байт нужно копировать файл. Если необходимо скопировать весь файл, то необходимо передать нули. Вот код этой функции:


function MyCopyFile( InFile,OutFile: String; From,Count: Longint ): Longint;  
var  
  InFS,OutFS: TFileStream;  
begin  
  InFS := TFileStream.Create( InFile, fmOpenRead );//создаем поток  
  OutFS := TFileStream.Create( OutFile, fmCreate );//создаем поток  
  InFS.Seek( From, soFromBeginning );//перемещаем указатель в From  
  Result := OutFS.CopyFrom( InFS, Count );  
  InFS.Free;//освобождаем  
  OutFS.Free;//освобождаем  
end;  

Удаление файлов
Для удаления файлов в Delphi так же предусмотрена специальная процедура DeleteFile. В качестве параметра, передаваемого в функцию, выступает строка типа PChar, указывающая имя файла, который нужно удалить. Сразу предлагаю Вам простой пример на использование этой функции:


procedure TForm1.Button1Click(Sender: TObject);  
begin  
  if DeleteFile('c:\2.txt') then  
    ShowMessage('Файл успешно удален!')  
  else  
  ShowMessage('Ошибка! Вот ее код: '+IntToStr(GetLastError));  
end;  

Удаление пустой директории
Чтобы удалить пустую директорию с помощью Delphi достаточно обратиться к функции RemoveDir.


function RemoveDir(const Dir: string): Boolean;  

Эта функция возвращает True если директория, указанная в единственном параметре, передаваемом в функцию, успешно удалена, в противном случае функция возвратит False.

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


function MyRemoveDir(sDir : String) : Boolean;   
var   
  iIndex : Integer;   
  SearchRec : TSearchRec;   
  sFileName : String;   
begin   
  Result := False;   
  sDir := sDir + '\*.*';   
  iIndex := FindFirst(sDir, faAnyFile, SearchRec);   
  
  while iIndex = 0 do begin   
    sFileName := ExtractFileDir(sDir)+'\'+SearchRec.Name;   
    if SearchRec.Attr = faDirectory then begin   
      if (SearchRec.Name <> '' ) and   
      (SearchRec.Name <> '.') and   
      (SearchRec.Name <> '..') then   
        MyRemoveDir(sFileName);   
      end else begin   
        if SearchRec.Attr <> faArchive then   
        FileSetAttr(sFileName, faArchive);   
        if NOT DeleteFile(sFileName) then   
        ShowMessage('Could NOT delete ' + sFileName);   
    end;   
    iIndex := FindNext(SearchRec);   
  end;   
  
  FindClose(SearchRec);   
  
  RemoveDir(ExtractFileDir(sDir));   
  Result := True;   
end;  

А сейчас пример использования этой функции:


procedure TForm1.Button1Click(Sender: TObject);  
begin  
  if MyRemoveDir('C:\testDir') then ShowMessage('Директория успешно удалена')  
  else ShowMessage('Не получается удалить директорию');  
end;  

Общие замечания по данной теме
Перед копированием или удалением файлов всегда проверяйте его наличие функцией FileExists:

if FileExists('c:\1.txt') then  
 if CopyFile('c:\1.txt','c:\2.txt',true) then  
  ShowMessage('Файл успешно скопирован!')  

Чтобы использовать в функциях CopyFile и DeleteFile имена файлов полученные с помощью, например, OpenDialog, надо из привести к типу PChar:

if CopyFile(Pchar(OpenDialog1.FileName),Pchar(SaveDialog1.FileName),true) then ...  

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

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

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

Конвертирование графических форматов

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

1. Конвертирование BMP в EMF
Следующая несложная процедура конвертирует bmp-файл SourceFileName в emf-файл и располагает его в той же директории, что и исходный файл.


function bmp2emf( const SourceFileName: TFileName): Boolean;   
var Metafile: TMetafile; MetaCanvas: TMetafileCanvas; Bitmap: TBitmap;   
begin   
  Metafile := TMetaFile.Create;   
  try   
    Bitmap := TBitmap.Create;   
    try   
      Bitmap.LoadFromFile(SourceFileName);   
      Metafile.Height := Bitmap.Height;   
      Metafile.Width := Bitmap.Width;   
      MetaCanvas := TMetafileCanvas.Create(Metafile, 0);   
      try   
        MetaCanvas.Draw(0, 0, Bitmap);   
      finally   
        MetaCanvas.Free;   
      end;   
    finally   
      Bitmap.Free;   
    end;   
    Metafile.SaveToFile(ChangeFileExt(SourceFileName, '.emf'));   
  finally   
    Metafile.Free;  
  end;   
end;  

Пример вызова:


procedure TForm1.Button1Click(Sender: TObject);   
begin   
  bmp2emf('C:\TestBitmap.bmp');  
end;  

2. Конвертирование BMP в JPG
Данная процедура выполняет такое конвертирование:


procedure TfrmMain.ConvertBMP2JPEG;   
var   
  jpgImg: TJPEGImage;   
begin   
  chrtOutputSingle.CopyToClipboardBitmap;   
  Image1.Picture.Bitmap.LoadFromClipboardFormat(cf_BitMap, ClipBoard.GetAsHandle(cf_Bitmap), 0);   
  jpgImg := TJPEGImage.Create;   
  jpgImg.Assign(Image1.Picture.Bitmap);   
  jpgImg.SaveToFile('TChartExample.jpg');   
end;  

В Uses необходимо добавить модули Jpeg и Clipbrd. В данном примере chrtOutputSingle - это объект TChart (страница Additional). Перед вызовом функции в буфере обмена должен находиться объект типа TBitmap.

3. Конвертирование BMP в WMF
Данное конвертирование также не составляет труда:


procedure ConvertBMP2WMF (const BMPFileName, WMFFileName: TFileName);   
var   
  MetaFile : TMetafile;   
  Bitmap : TBitmap;   
begin   
  Metafile := TMetaFile.Create;   
  Bitmap := TBitmap.Create;   
  try   
    Bitmap.LoadFromFile(BMPFileName);   
    with MetaFile do   
    begin   
      Height := Bitmap.Height;   
      Width := Bitmap.Width;   
      Canvas.Draw( 0 , 0 , Bitmap);   
      SaveToFile(WMFFileName);   
    end;   
  finally   
    Bitmap.Free;   
    MetaFile.Free;   
  end;  
end; 

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


ConvertBMP2WMF('c:\mypic.bmp','c:\mypic.wmf');

4. Обратное конвертирование: WMF в BMP
Обратное конвертирование мало чем отличается от предыдущего:


procedure ConvertWMF2BMP (const WMFFileName, BMPFileName: TFileName);   
var   
  MetaFile : TMetafile;   
  Bitmap : TBitmap;   
begin   
  Metafile := TMetaFile.Create;   
  Bitmap := TBitmap.Create;   
  try   
    MetaFile.LoadFromFile(WMFFileName);   
    with Bitmap do   
    begin   
      Height := Metafile.Height;   
      Width := Metafile.Width;   
      Canvas.Draw( 0 , 0 , MetaFile);   
      SaveToFile(BMPFileName);   
    end;   
  finally   
    Bitmap.Free;   
    MetaFile.Free;   
  end;  
end;  

Использование:


ConvertWMF2BMP('c:\mypic.wmf','c:\mypic.bmp');  

5. Конвертирование BMP в DIB
Допустим, что файл хранится в формате BMP. Нужно его преобразовать в DIB и отобразить. Итак... Это не тривиально, но помочь нам смогут функции GetDIBSizes и GetDIB из модуля GRAPHICS.PAS. Приведу две процедуры: одну для создания DIB из TBitmap и вторую для его освобождения:


procedure BitmapToDIB(Bitmap: TBitmap;   
var  
  BitmapInfo: PBitmapInfo;   
  InfoSize: integer;   
  Bits: pointer;   
  BitsSize: longint);   
begin   
  BitmapInfo := nil ;   
  InfoSize := 0;   
  Bits := nil;   
  BitsSize := 0;   
  if not Bitmap.Empty then   
    try   
      GetDIBSizes(Bitmap.Handle, InfoSize, BitsSize);   
      GetMem(BitmapInfo, InfoSize);   
      Bits := GlobalAllocPtr(GMEM_MOVEABLE, BitsSize);   
      if Bits = nil then   
        raise EOutOfMemory.Create( 'Не хватает памяти для пикселей изображения' );  
      if not GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapInfo^, Bits^) then  
        raise Exception.Create( 'Не могу создать DIB' );  
    except  
      if BitmapInfo <> nil then  
        FreeMem(BitmapInfo, InfoSize);  
      if Bits <> nil then  
        GlobalFreePtr(Bits);  
      BitmapInfo := nil;  
      Bits := nil;  
      raise ;  
    end;  
end;  
   
{ используйте FreeDIB для освобождения информации об изображении и битовых указателей }   
   
procedure FreeDIB(BitmapInfo: PBitmapInfo; InfoSize: integer; Bits: pointer; BitsSize: longint);   
begin   
  if BitmapInfo <> nil then  
    FreeMem(BitmapInfo, InfoSize);  
  if Bits <> nil then  
    GlobalFreePtr(Bits);  
end;  

Создаём форму с TImage Image1 и загружаем в него 256-цветное изображение, затем рядом размещаем TPaintBox. Добавляем следующие строчки к private-объявлениям нашей формы:


{ Private declarations }   
BitmapInfo : PBitmapInfo;   
InfoSize : integer;   
Bits : pointer;   
BitsSize : longint;  

Создаем нижеприведенные обработчики событий, которые демонстрируют процесс отрисовки DIB:


procedure TForm1.FormCreate(Sender: TObject);   
begin   
  BitmapToDIB(Image1.Picture.Bitmap, BitmapInfo, InfoSize, Bits, BitsSize);   
end;   
   
procedure TForm1.FormDestroy(Sender: TObject);   
begin   
  FreeDIB(BitmapInfo, InfoSize, Bits, BitsSize);  
end;   
   
procedure TForm1.PaintBox1Paint(Sender: TObject);   
var   
  OldPalette: HPalette;  
begin   
  if Assigned(BitmapInfo) and Assigned(Bits) then   
    with BitmapInfo^.bmiHeader, PaintBox1.Canvas do   
    begin   
      OldPalette := SelectPalette(Handle,Image1.Picture.Bitmap.Palette,false);   
      try   
        RealizePalette(Handle);   
        StretchDIBits(Handle, 0 , 0 , PaintBox1.Width, PaintBox1.Height, 0 , 0 ,   
  
        biWidth, biHeight, Bits, BitmapInfo^,  
DIB_RGB_COLORS, SRCCOPY);  
      finally  
        SelectPalette(Handle, OldPalette, true);  
      end;  
    end;  
end;  

Это поможет вам сделать первый шаг. Единственное, что вы можете захотеть, это создать собственный HPalette на основе DIB, вместо использования TBitmap и своей палитры. Функция с именем PaletteFromW3DIB из GRAPHICS.PAS как раз этим и занимается, но она не объявлена в качестве экспортируемой, поэтому для ее использования необходимо скопировать ее исходный код и вставить его в модуль.

6. Конвертирование BMP в ICO
Вам необходимо создать два битмапа, битмап маски (назовём его "AND" bitmap) и битмап изображения (назовём его XOR bitmap). Вы можете пропустить обработчики для "AND" и "XOR" битмапов в Windows API функции CreateIconIndirect() и использовать обработчик возвращённой иконки в Вашем приложении.


procedure TForm1.Button1Click(Sender: TObject);   
var   
  IconSizeX : integer;   
  IconSizeY : integer;   
  AndMask : TBitmap;   
  XOrMask : TBitmap;   
  IconInfo : TIconInfo;   
  Icon : TIcon;   
begin   
  {Получаем размер иконки}   
  IconSizeX := GetSystemMetrics(SM_CXICON);   
  IconSizeY := GetSystemMetrics(SM_CYICON);   
   
  {Создаём маску "And"}   
  AndMask := TBitmap.Create;   
  AndMask.Monochrome := true;   
  AndMask.Width := IconSizeX;   
  AndMask.Height := IconSizeY;   
   
  {Рисуем на маске "And"}   
  AndMask.Canvas.Brush.Color := clWhite;   
  AndMask.Canvas.FillRect(Rect( 0 , 0 , IconSizeX, IconSizeY));   
  AndMask.Canvas.Brush.Color := clBlack;   
  AndMask.Canvas.Ellipse( 4 , 4 , IconSizeX - 4 , IconSizeY - 4 );   
   
  {Рисуем для теста}  
  Form1.Canvas.Draw(IconSizeX * 2 , IconSizeY, AndMask);  
   
  {Создаём маску "XOr"}  
  XOrMask := TBitmap.Create;  
  XOrMask.Width := IconSizeX;  
  XOrMask.Height := IconSizeY;  
   
  {Рисуем на маске "XOr"}  
  XOrMask.Canvas.Brush.Color := ClBlack;  
  XOrMask.Canvas.FillRect(Rect( 0 , 0 , IconSizeX, IconSizeY));  
  XOrMask.Canvas.Pen.Color := clRed;  
  XOrMask.Canvas.Brush.Color := clRed;  
  XOrMask.Canvas.Ellipse( 4 , 4 , IconSizeX - 4 , IconSizeY - 4 );  
   
  {Рисуем в качестве теста}  
  Form1.Canvas.Draw(IconSizeX * 4 , IconSizeY, XOrMask);  
   
  {Создаём иконку}  
  Icon := TIcon.Create;   
  IconInfo.fIcon := true;   
  IconInfo.xHotspot := 0 ;   
  IconInfo.yHotspot := 0 ;   
  IconInfo.hbmMask := AndMask.Handle;   
  IconInfo.hbmColor := XOrMask.Handle;   
  Icon.Handle := CreateIconIndirect(IconInfo);   
   
  {Уничтожаем временные битмапы}   
  AndMask.Free;   
  XOrMask.Free;   
   
  {Рисуем в качестве теста}   
  Form1.Canvas.Draw(IconSizeX * 6 , IconSizeY, Icon);   
   
  {Объявляем иконку в качестве иконки приложения}   
  Application.Icon := Icon;   
   
  {генерируем перерисовку}   
  InvalidateRect(Application.Handle, nil , true);   
   
  {Освобождаем иконку}   
  Icon.Free;   
end;  

Способ преобразования изображения размером 32x32 в иконку:


procedure TForm1.Button1Click(Sender: TObject);   
var   
  winDC, srcdc, destdc: HDC;   
  oldBitmap: HBitmap;   
  iinfo: TICONINFO;   
begin   
  GetIconInfo(Image1.Picture.Icon.Handle, iinfo);   
   
  WinDC := getDC(handle);   
  srcDC := CreateCompatibleDC(WinDC);   
  destDC := CreateCompatibleDC(WinDC);   
  oldBitmap := SelectObject(destDC, iinfo.hbmColor);   
  oldBitmap := SelectObject(srcDC, iinfo.hbmMask);   
   
  BitBlt(destdc, 0 , 0 , Image1.Picture.Icon.Width, Image1.Picture.Icon.Height,   
  
  srcdc, 0 , 0 , SRCPAINT);   
  Image2.Picture.Bitmap.Handle := SelectObject(destDC, oldBitmap);   
  DeleteDC(destDC);   
  DeleteDC(srcDC);   
  DeleteDC(WinDC);   
   
  Image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName) + 'myfile.bmp' );   
end;  
   
procedure TForm1.FormCreate(Sender: TObject);   
begin   
  Image1.Picture.Icon.LoadFromFile('c:\myicon.ico');  
end;  

7. Конвертирование BMP в RTF
Да, и такое тоже возможно. Вот так например:


function BitmapToRTF(pict: TBitmap): string ;   
var   
  bi, bb, rtf: string ;   
  bis, bbs: Cardinal;   
  achar: ShortString;   
  hexpict: string ;   
  I: Integer;   
begin   
  GetDIBSizes(pict.Handle, bis, bbs);   
  SetLength(bi, bis);   
  SetLength(bb, bbs);   
  GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);   
  rtf := '{\rtf1 {\pict\dibitmap0 ' ;   
  SetLength(hexpict, (Length(bb) + Length(bi)) * 2 );   
  I := 2 ;   
  for bis := 1 to Length(bi) do   
  begin   
    achar := IntToHex(Integer(bi[bis]), 2 );   
    hexpict[I - 1] := achar[ 1 ];   
    hexpict[I] := achar[ 2 ];   
    Inc(I, 2 );   
  end ;   
  for bbs := 1 to Length(bb) do   
  begin   
    achar := IntToHex(Integer(bb[bbs]), 2 );   
    hexpict[I - 1] := achar[ 1 ];   
    hexpict[I] := achar[ 2 ];   
    Inc(I, 2);   
  end ;   
  rtf := rtf + hexpict + ' }}';   
  Result := rtf;   
end;  

8. Конвертирование CUR в BMP
Преобразование курсора в TBitmap:


procedure TForm1.Button1Click(Sender: TObject);   
var   
  hCursor: LongInt;   
  Bitmap: TBitmap;   
begin   
  Bitmap := TBitmap.Create;   
  Bitmap.Width := 32 ;   
  Bitmap.Height := 32 ;   
  hCursor := LoadCursorFromFile( 'test.cur' );   
  DrawIcon(Bitmap.Canvas.Handle, 0 , 0 , hCursor);   
  Bitmap.SaveToFile( 'test.bmp' );   
  Bitmap.Free;   
end;  

9. Конвертирование ICO в BMP

var  
  Icon : TIcon;   
  Bitmap : TBitmap;   
begin   
  Icon := TIcon.Create;   
  Bitmap := TBitmap.Create;   
  Icon.LoadFromFile( 'c:\picture.ico' );   
  Bitmap.Width := Icon.Width;   
  Bitmap.Height := Icon.Height;   
  Bitmap.Canvas.Draw( 0 , 0 , Icon);   
  Bitmap.SaveToFile( 'c:\picture.bmp' );   
  Icon.Free;   
  Bitmap.Free;   
end; 

Вариант 2:


var   
  MyIcon: TIcon;   
  MyBitMap: TBitmap;   
begin  
  MyIcon := TIcon.Create;   
  MyBitMap := TBitmap.Create;   
   
  try  
    { получаем имя файла и связанную с ним иконку}   
    strFileName := FileListBox1.Items[FileListBox1.ItemIndex];   
    StrPCopy(cStrFileName, strFileName);   
    MyIcon.Handle := ExtractIcon(hInstance, cStrFileName, 0 );   
   
    { рисуем иконку на bitmap в speedbutton }   
    SpeedButton1.Glyph := MyBitMap;   
    SpeedButton1.Glyph.Width := MyIcon.Width;   
    SpeedButton1.Glyph.Height := MyIcon.Height;   
    SpeedButton1.Glyph.Canvas.Draw( 0 , 0 , MyIcon);   
   
    SpeedButton1.Hint := strFileName;   
   
  finally  
    MyIcon.Free;  
    MyBitMap.Free;  
  end;   
end;  

Чтобы преобразовать Icon в Bitmap, используйте TImageList. Для обратного преобразования замените метод AddIcon на Add, и метод GetBitmap на GetIcon.


function Icon2Bitmap(Icon: TIcon): TBitmap;   
begin   
  with TImageList.Create ( nil ) do   
  begin   
    AddIcon (Icon);   
    Result := TBitmap.Create;   
    GetBitmap ( 0 , Result);   
    Free;  
  end;  
end;  

10. Конвертирование JPG в BMP.

uses JPEG;  
   
procedure JPEGtoBMP( const FileName: TFileName);  
var  
  jpeg: TJPEGImage;  
  bmp: TBitmap;  
begin   
  jpeg := TJPEGImage.Create;   
  try   
    jpeg.CompressionQuality := 100 ; {Default Value}   
    jpeg.LoadFromFile(FileName);   
    bmp := TBitmap.Create;   
    try   
      bmp.Assign(jpeg);   
      bmp.SaveTofile(ChangeFileExt(FileName, '.bmp' ));   
    finally  
      bmp.Free;  
    end;  
  finally  
    jpeg.Free;  
  end;  
end;  

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