Файловые операции
Файловые операции
Дельфи предоставляет довольно широкие возможности по файловым операциям без использования механизмов открытия/закрытия файлов.
Вот список наиболее употребимых функций, большинство из которых в фачкстве параметров нуждаются только в имени файла:
ChDir(NewCurrentPath: string); - изменяет текущий каталог (в среде Windows сие конечно не так актуально как в ДОС, но все же), прочитать же текущий каталог можно функцией GetCurrentDir, а текущий каталог для определенного драйва - GetDir.
CreateDir(const Dir: string): Boolean; - создает каталог. При этом предыдущий уровень должен присутствовать. Если вы хотите сразу создать всю вложенность каталогов используйте функцию ForceDirectories(Dir: string): Boolean; Обе функции возвращают True если каталог создан
DiskFree(Drive: Byte): Int64; - дает свободное место на диске. Параметер - номер диска 0 = текущий, 1 = A, 2 = B, и так далее
DiskSize(Drive: Byte): Int64; - размер винта. Обратите внимание на то что для результата этой и предыдущей функций абсолютно необходимо использовать переменную типа Int64, иначе макимум того что вы сможете прочитать правильно будет ограничен 2Gb
FileExists(const FileName: string) - применяется для проверки наличия файла
FileGetAttr(const FileName: string): Integer;
FileSetAttr(const FileName: string; Attr: Integer): Integer; - функции для работы с атрибутами файлов. Вот список возможных атрибутов:
faReadOnly $00000001 Read-only files
faHidden $00000002 Hidden files
faSysFile $00000004 System files
faVolumeID $00000008 Volume ID files
faDirectory $00000010 Directory files
faArchive $00000020 Archive files
faAnyFile $0000003F Any file
(Естественно не все атрибуты применимы во всех случаях)
RemoveDir(const Dir: string): Boolean; - удаляет папку(пустую)
DeleteFile(const FileName: string): Boolean; - удаляет файл
RenameFile(const OldName, NewName: string) - переименовывает файл
Файловые операции средствами ShellAPI
Файловые операции средствами ShellAPI
Файловые операции средствами ShellAPI.
В данной статье мы подробно рассмотрим применение функции SHFileOperation.
function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall;
Данная функция позволяет производить копирование, перемещение,
переименование и удаление (в том числе и в Recycle Bin) объектов файловой системы.
Функция возвращает 0, если операция выполнена успешно,
и ненулевое значение в противном :-) случае.
Функция имеет единственный аргумент - структуру типа TSHFileOpStruct,
в которой и передаются все необходимые данные.
Эта структура выглядит следующим образом:
_SHFILEOPSTRUCTA = packed record
Wnd: HWND;
wFunc: UINT;
pFrom: PAnsiChar;
pTo: PAnsiChar;
fFlags: FILEOP_FLAGS;
fAnyOperationsAborted: BOOL;
hNameMappings: Pointer;
lpszProgressTitle: PAnsiChar; { используется только при установленном флаге FOF_SIMPLEPROGRESS }
end;
Поля этой структуры имеют следующее назначение:
hwnd Хэндл окна, на которое будут выводиться диалоговые окна о ходе операции.
wFunc Требуемая операция. Может принимать одно из значений:
FO_COPY Копирует файлы, указанные в pFrom в папку, указанную в pTo.
FO_DELETE Удаляет файлы, указанные pFrom (pTo игнорируется).
FO_MOVE Перемещает файлы, указанные в pFrom в папку, указанную в pTo.
FO_RENAME Переименовывает файлы, указанные в pFrom.
pFrom
Указатель на буфер, содержащий пути к одному или нескольким файлам.
Если файлов несколько, между путями ставится нулевой байт.
Список должен заканчиваться двумя нулевыми байтами.
pTo
Аналогично pFrom, но содержит путь к директории - адресату,
в которую производится копирование или перемещение файлов.
Также может содержать несколько путей.
При этом нужно установить флаг FOF_MULTIDESTFILES.
fFlags
Управляющие флаги.
FOF_ALLOWUNDO Если возможно, сохраняет информацию для возможности UnDo.
FOF_CONFIRMMOUSE Не реализовано.
FOF_FILESONLY Если в поле pFrom установлено *.*, то операция
будет производиться только с файлами.
FOF_MULTIDESTFILES Указывает, что для каждого исходного
файла в поле pFrom указана своя директория - адресат.
FOF_NOCONFIRMATION Отвечает "yes to all" на все запросы в ходе опеации.
FOF_NOCONFIRMMKDIR Не подтверждает создание нового каталога,
если операция требует, чтобы он был создан.
FOF_RENAMEONCOLLISION В случае, если уже существует файл
с данным именем, создается файл с именем "Copy #N of..."
FOF_SILENT Не показывать диалог с индикатором прогресса.
FOF_SIMPLEPROGRESS Показывать диалог с индикатором прогресса,
но не показывать имен файлов.
FOF_WANTMAPPINGHANDLE Вносит hNameMappings элемент.
Дескриптор должен быть освобожден функцией SHFreeNameMappings.
fAnyOperationsAborted
Принимает значение TRUE если пользователь прервал любую файловую
операцию до ее завершения и FALSE в ином случае.
hNameMappings
Дескриптор объекта отображения имени файла, который содержит
массив структур SHNAMEMAPPING. Каждая структура содержит
старые и новые имена пути для каждого файла, который перемещался,
скопирован, или переименован. Этот элемент используется только,
если установлен флаг FOF_WANTMAPPINGHANDLE.
lpszProgressTitle
Указатель на строку, используемую как заголовок для диалогового окна прогресса.
Этот элемент используется только, если установлен флаг FOF_SIMPLEPROGRESS.
Примечание.
Если pFrom или pTo не указаны, берутся файлы из текущей директории.
Текущую директорию можно установить с помощью функции SetCurrentDirectory
и получить функцией GetCurrentDirectory.
А теперь - примеры.
Разумеется, вам нужно вставить в секцию uses модуль ShellAPI, в котором определена
функция SHFileOperation.
Рассмотрим самое простое - удаление файлов.
procedure TForm1.Button1Click(Sender: TObject);
var
SHFileOpStruct : TSHFileOpStruct;
From : array [0..255] of Char;
begin
SetCurrentDirectory( PChar( 'C:\' ) );
From := 'Test1.tst' + #0 + 'Test2.tst' + #0 + #0;
with SHFileOpStruct do
begin
Wnd := Handle;
wFunc := FO_DELETE;
pFrom := @From;
pTo := nil;
fFlags := 0;
fAnyOperationsAborted := False;
hNameMappings := nil;
lpszProgressTitle := nil;
end;
SHFileOperation( SHFileOpStruct );
end;
Обратите внимание, что ни один из флагов не установлен.
Если вы хотите не просто удалить файлы, а переместить их
в корзину, должен быть установлен флаг FOF_ALLOWUNDO.
Для удобства дальнейших экспериментов напишем функцию,
создающую из массива строк буфер для передачи его в качестве параметра pFrom.
После каждой строки в буфер вставляется нулевой байт, в конце списка - два нулевых байта.
type TBuffer = array of Char;
procedure CreateBuffer( Names : array of string; var P : TBuffer );
var I, J, L : Integer;
begin
for I := Low( Names ) to High( Names ) do
begin
L := Length( P );
SetLength( P, L + Length( Names[ I ] ) + 1 );
for J := 0 to Length( Names[ I ] ) - 1 do
P[ L + J ] := Names[ I, J + 1 ];
P[ L + J ] := #0;
end;
SetLength( P, Length( P ) + 1 );
P[ Length( P ) ] := #0;
end;
Выглядит ужасно, но работает. Можно написать красивее, просто лень.
И, наконец, функция, удаляющая файлы, переданные ей в списке Names.
Параметр ToRecycle определяет, будут ли файлы перемещены в корзину
или удалены. Функция возвращает 0, если операция выполнена успешно,
и ненулевое значение, если руки у кого-то растут не из того места, и этот
кто-то всунул функции имена несуществующих файлов.
function DeleteFiles( Handle : HWnd; Names : array of string; ToRecycle : Boolean ) : Integer;
var
SHFileOpStruct : TSHFileOpStruct;
Src : TBuffer;
begin
CreateBuffer( Names, Src );
with SHFileOpStruct do
begin
Wnd := Handle;
wFunc := FO_DELETE;
pFrom := Pointer( Src );
pTo := nil;
fFlags := 0;
if ToRecycle then fFlags := FOF_ALLOWUNDO;
fAnyOperationsAborted := False;
hNameMappings := nil;
lpszProgressTitle := nil;
end;
Result := SHFileOperation( SHFileOpStruct );
Src := nil;
end;
Обратите внимание, что мы освобождаем буфер Src простым
присваиванием значения nil. Если верить документации,
потери памяти при этом не происходит, а напротив,
происходит корректное уничтожение динамического массива.
Каким образом, правда - это рак мозга :-).
Проверяем :
procedure TForm1.Button1Click(Sender: TObject);
begin
DeleteFiles( Handle, [ 'C:\Test1', 'C:\Test2' ], True );
end;
Вроде все работает.
Кстати, обнаружился забавный глюк - вызовем процедуру DeleteFiles таким образом:
procedure TForm1.Button1Click(Sender: TObject);
begin
SetCurrentDirectory( PChar( 'C:\' ) );
DeleteFiles( Handle, [ 'Test1', 'Test2' ], True );
end;
Файлы 'Test1' и 'Test2' удаляются совсем, без помещения в корзину,
несмотря на установленный флаг FOF_ALLOWUNDO.
Мораль: при использовании функции
SHFileOperation используйте полные пути всегда, когда это возможно.
Ну, с удалением файлов разобрались.
Теперь очередь за копированием и перемещением.
Следующая функция перемещает файлы указанные в списке Src в директорию Dest.
Параметр Move определяет, будут ли файлы перемещаться или копироваться.
Параметр AutoRename указывает, переименовывать ли файлы в случае конфликта имен.
function CopyFiles( Handle : Hwnd; Src : array of string; Dest : string;
Move : Boolean; AutoRename : Boolean ) : Integer;
var
SHFileOpStruct : TSHFileOpStruct;
SrcBuf : TBuffer;
begin
CreateBuffer( Src, SrcBuf );
with SHFileOpStruct do
begin
Wnd := Handle;
wFunc := FO_COPY;
if Move then wFunc := FO_MOVE;
pFrom := Pointer( SrcBuf );
pTo := PChar( Dest );
fFlags := 0;
if AutoRename then fFlags := FOF_RENAMEONCOLLISION;
fAnyOperationsAborted := False;
hNameMappings := nil;
lpszProgressTitle := nil;
end;
Result := SHFileOperation( SHFileOpStruct );
SrcBuf := nil;
end;
Ну, проверим.
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyFiles( Handle, [ 'C:\Test1', 'C:\Test2' ], 'C:\Temp', True, True );
end;
Все в порядке (а кудa ж оно денется).
Есть, правда еще одна возможность - перемещать много файлов каждый
в свою директорию за один присест, но я с трудом представляю, кому это может понадобиться.
Осталась последняя о
function RenameFiles( Handle : HWnd; Src : string; New : string; AutoRename : Boolean ) : Integer;
var SHFileOpStruct : TSHFileOpStruct;
begin
with SHFileOpStruct do
begin
Wnd := Handle;
wFunc := FO_RENAME;
pFrom := PChar( Src );
pTo := PChar( New );
fFlags := 0;
if AutoRename then fFlags := FOF_RENAMEONCOLLISION;
fAnyOperationsAborted := False;
hNameMappings := nil;
lpszProgressTitle := nil;
end;
Result := SHFileOperation( SHFileOpStruct );
end;
И проверка ...
procedure TForm1.Button1Click(Sender: TObject);
begin
RenameFiles( Handle, 'C:\Test1' , 'C:\Test3' , False );
end;
Взято с сайта
Файловые потоки
Файловые потоки
Теперь разберем возможности работы потомка TStream - TFileStream - файловый поток. Этот класс был специально введен для работы с файлами. Для работы с файловым потоком Вам надо записать в Uses модули classes, Sysutils (classes - включает в себя собственно определение класса, Sysutils - некоторые константы необходимые для работы).
Вот пример записи/перезаписи файла:
Procedure WriteFileUsingStream(s, FileName:string);
begin
with TFileStream.create(FileName, fmCreate or fmOpenWrite) do
try
write(pointer(s)^,length(s));
finally
free;
end;
end;
Теперь небольшой разбор:
TFileStream.create - конструктор класса, его вызов требует указания имени файла и опций его открытия, следующие опции определены:
fmCreate = $FFFF;
fmOpenRead = $0000;
fmOpenWrite = $0001;
fmOpenReadWrite = $0002;
fmShareCompat = $0000;
fmShareExclusive = $0010;
fmShareDenyWrite = $0020;
fmShareDenyRead = $0030;
fmShareDenyNone = $0040;
Теперь метод Write - этим методом в файл пишется любая информация из буфера любого типа, Вам надо указать только буффер и количество записываемых байтов. В данном случае используется переменная типа String в качестве буффера, но так как для длинных строк она представляет собой лишь указатель, то конструкция "pointer(s)^" заставляет обращаться именно к ее содержимому.
А вот этот код демонстрирует чтение файла с использованием файлового потока:
var p:PChar;
begin
GetMem(p, 255);
with TFileStream.create('c:\myText.txt', fmOpenReadWrite) do
try
Seek(10,soFromBeginning);
read(p^, 254);
finally
free;
end;
showmessage(p);
FreeMem(p);
end;
И пояснения к коду:
1) Никаких проверок длину файла и его наличие здесь не делается - это демонстрационный код, а не готовая процедура чтения.
2) Файл мы считываем в буффер типа PChar (с тем же успехом можно использовать массив или любой другой контейнер). Для тех кто не помнит - процедуры GetMem(p, 255) и FreeMem(p) - распределение памяти для строки и освобождение памяти.
3) Метод потока Seek позволяет установить текущую позицию считывания/записи файла. Первый параметер - номер байта, второй - это от чего считать этот байт (у нас считать от начала файла), возможны варианты:
soFromBeginning - от начала файла
soFromCurrent - от текущей позиции считывания
soFromEnd - от конца файла (в этом случае номер байта должен быть отрицательным или равным нулю)
4) Собственно считывание из потока осуществляется методом read, в котором указывается в качестве параметров буфер в который мы читаем и желаемое количество байт для чтения. Метод read является функцией, которая возвращает количество байт реально прочитанных из потока.
Заканчивая о файловых потоках хочу упомянуть о методе
CopyFrom который позволяет перекачивать информацию из одного потока в другой и о свойствах:
Size - размер файла
Position - текущая позиция чтения/записи потока
Работа с файловыми потоками весьма быстра, этот класс, являсь классом VCL, в то же время базируется на низкоуровневых функциях Windows, что обеспечивает очень высокую скорость работы и стабильность операций. К тому же многие компоненты и классы VCL поддерживаю прямое чтение и запись с файловыми потоками, что занчительно упрощает работу - например TStringList, TBlobField, TMemoField и другие.
Файловые потоки могут быть рекомендованы к использованию в большинстве случаев для чтения и записи файлов (за исключением специфических ситуаций, требующих каких-то других подходов), другими словами если вам надо просто записать или считать файл, используйте файловые потоки.
FastReport - Разработка кросс-платформенных отчетов
FastReport - Разработка кросс-платформенных отчетов
Автор: Михаил Филиппенко
WEB-сайт: FastReport Software
Еще со времен Ады Ловлес разработчики программного обеспечения пытаются облегчить себе жизнь. И, без сомнения, это им удается.
Собственно говоря, любое современное приложение можно условно разделить на четыре части: функциональную (она выполняет обработку информации), интерфейсную (на нее возложено общение с пользователем, к которому нас приучили продукты Microsoft), базы данных (порядка 90% приложений напрямую или косвенно используют хранение информации в более или менее сложных структурах, для которых наиболее удобными оказываются базы данных) и отчетную (несмотря на все шаги в сторону автоматизации документооборота документы на бумаге все еще считаются важными и ни одна организация не обходится без них).
Давно прошли те времена, когда разработчику каждого приложения приходилось каждый раз изобретать формат базы данных, отчет и интерфейс. Можно увидеть, как за короткий срок базы и банки данных выделились в отдельную группу, приложения и интерфейсная часть в другую, генераторы отчетов - в третью. Благодаря таким средствам разработки как MS VisualC, Visual Basic, C# и Borland Delphi разработка серьезных приложений, работающих с базами данных, сегодня превратилась в некоторое подобие детского конструктора, в котором что угодно можно собрать из отдельных "кубиков".
Такой "кубик" как генераторы отчетов выделился в отдельную и немаловажную часть в разработках относительно недавно, однако и здесь есть богатейший выбор инструментов для построения отчетных форм (именно их, зачастую, в конечном счете требует заказчик). Для того же Borland Delphi вы можете воспользоваться как встроенными средствами, идущими в комплекте c Borland Delphi и Borland Visual C++Builder - QuickReport ак и более "продвинутыми" продуктами от других разработчиков, это Crystal Reports от Seagate Software (ныне Crystal Software), представляющий собой вполне самостоятельный продукт, имеющий компоненты, дающие доступ к его возможностям из любой популярной сегодня среды разработки, будь то Borland Delphi, MS Visual C или MS Visual Basic, это и ReportBuilder от компании DigitalMetaphors (по опросу DelphiZine вот уже несколько лет признаваемый самым популярным инструментом для разработки отчетов в Delphi), это и ReportPrinter (ныне Rave) от Nevrona Design, а также FastReport (по тому же опросу поделившие второе и третье место в 2001 году и вышедший на стабильное второе место в 2002 году).
На сегодняшний день FastReport версии 2.4 - это полностью визуальный генератор отчетов, т.е. большинство отчетов можно построить, пользуясь только мышью. Вот только некоторые его возможности:
Бэнд-ориентированный генератор отчетов.
Встроенный мощный дизайнер, доступный и в run-time.
WYSIWYG предварительный просмотр как в MS Word (т.е. мы можем видеть одновременно несколько страниц отчета).
Скорость работы сравнима с QuickReport.
Компактность кода - без дизайнера меньше, чем QuickReport3.
Неограниченное количество страниц сформированного отчета.
Многостраничные отчеты; составные (композитные) отчеты; вложенные отчеты; группы; многоколоночные отчеты; master-detail-detail отчеты; cross-tab отчеты; двухпроходные отчеты; "живые" отчеты.
Полный контроль над процессом печати, поддержка всех типов бумаги.
Набор наиболее популярных компонентов: Текст, Линия, Рисунок, Фигура, OLE объект, RichText, RX Rich 2.0, Диаграмма, Штрих-код.
Экспорт в TXT, RTF, CSV, HTML (в RTF, HTML - с картинками).
Поиск текста в сформированном отчете.
Редактирование сформированного отчета.
Встроенный интерпретатор Pascal-подобного языка для управления процессом построения отчета.
Набор визуальных компонентов для создания диалоговых форм;
Набор невизуальных компонентов для создания таблиц, запросов и баз данных;
Работа с BDE, Interbase Express (IBX), ActiveX Data Objects (ADO).
Работа как с Database - ориентированными источниками данных, так и с любыми данными.
Форма отчета может храниться как в DFM, так и во внешнем файле.
Функциональность может быть расширена за счет написания собственных компонент - визуальных объектов, мастеров, библиотек функций.
Построение типичного отчета включает в себя следующие этапы:
1. Выборка данных
на основе которых строится отчет. Большинство отчетов, как правило, основано на данных из БД. Для доступа к таким данным Delphi предоставляет эффективные механизмы, компоненты- наследники TDataSet., которые и используются в FastReport. Это могут быть компоненты TTable и TQuery, которые используемые как источники данных для отчета. Организация доступа к данным из БД осуществляется ядром FastReport без участия программиста.
Кроме данных, хранимых в БД, FastReport может использовать практически любые источники (массив, файл, содержимое StringGrid и пр.). Но в этом случае программист должен сам позаботиться о доступе к такой информации, используя набор событий, позволяющих осуществить передачу данных в ядро FastReport.
Реализация доступа к данным примерно одинакова во всех генераторах отчетов. Все генераторы умеют обращаться с компонентами доступа к данным, расположенными на формах проекта. Кроме доступа к данным, определенным в проекте, и FastReport, и ReportBuilder, и QR+QRDesigner позволяют создавать новые компоненты в run-time. В FastReport принципы создания компонентов доступа к данным максимально приближены к тем, что используются в среде Delphi. Так же, как и в Delphi, на форму кладется компонент и в инспекторе объектов настраиваются его свойства. Компонентная идеология весьма гибкая: можно легко создавать новые компоненты для поддержки разных движков доступа к данным. На самом деле сейчас у FR уже есть компоненты для доступа практически ко всем популярным СУБД.
2. Ввод параметров
вносящих необходимые уточнения в готовящийся отчет. На этом этапе осуществляется запрос параметров у пользователя (например, диапазон дат, по которому необходимо вывести данные). Некоторые отчеты обходятся без этого этапа либо используют фиксированную установку параметров (без запроса их значений в диалоге).
Этот этап реализован в разных генераторах отчетов по-разному. Так, в ReportBuilderб Rave и QR+QRDesigner есть возможность запроса параметров, если отчет использует данные из запроса (Query). Для диалога с пользователем используется "штатное" диалоговое окно. Кроме того, для запроса параметров можно использовать форму, разработанную в среде Delphi. Правда, при необходимости каких-либо изменений в логике работы придется перекомпилировать проект.
FastReport, помимо этого, позволяет конечному пользователю самому разрабатывать форму диалога, причем этот диалог будет частью отчета, а не приложения. Процесс напоминает построение формы в среде Delphi: имеется набор стандартных элементов управления, которые можно располагать на форме диалога и настраивать их свойства. С помощью встроенного языка FastReport позволяет реализовать необходимую логику работы диалога и передать введенные значения ядру генератора.
Возможность создания собственных диалогов очень полезна - вкупе с остальными возможностями (автономное создание источников данных, использование встроенного языка) она позволяет создавать "самодостаточные" отчеты, т.е. отчеты, максимально отвязанные от среды Delphi. Это позволяет создавать новые отчеты и модифицировать существующие без переписывания или перекомпиляции проекта.
Пример 1 - после формирования третьей страницы отчет может вывести диалог с запросом - а надо ли строить остальные страницы?
Пример 2 - В диалоговом окне могут быть практически любые элементы, вплоть до поля даты-времени, переключателей типа "radiobutton" и "checkbox", выпадающих списков и т.д., таковые возможности не предоставляет ни один из остальных упоминавшихся генераторов!
3. Построение отчетной формы
представляющей собой набор элементов, описывающих то, как должен выглядеть готовый отчет. Для группировки элементов по их функциональному расположению в готовом отчете традиционно применяются бэнды (от англ. band - полоска). Бэнды разделяются на два вида: служебные (заголовок отчета, страницы и пр.) и бэнды, образующие повторяющуюся (многострочную) часть отчета (далее - дата-бэнды). Дата-бэнды подключаются к источникам данных, и их содержимое выводится столько раз, сколько имеется строк данных в источнике. В случае с табличным (так называемом cross-tab - отчетом) повторяться могут как строки так и столбцы отчета.
Для построения формы отчета в FastReport используется визуальная среда разработки - дизайнер отчетов. Интерфейс дизайнера подобен большинству современных приложений, работающих с документами. Расположение традиционных панелей инструментов (toolbars), можно изменять по своему вкусу. Для удобства манипуляции свойствами объектов отчета используется инспектор объектов, аналогичный встроенному в среду разработки Borland Delphi.
4. Обработка данных
подразумевающая под собой обработку входных данных, модификацию формы отчета или отдельных ее компонентов в процессе построения отчета. Простейший пример такой обработки - вывод отрицательных сумм красным цветом. Более сложный пример обработки - печать суммы, которая подсчитывается в подвале группы, в ее заголовке.
Реализовать подобную обработку можно, прибегнув к написанию обработчиков событий в Delphi - именно так и сделано во всех генераторах отчетов. Но этот способ не дает достаточной гибкости отчету, поскольку не позволяет создавать новые отчеты вне среды Delphi без переписывания и перекомпиляции проекта. Для достижения таковой универсальности в FastReport и ReportBuilder применен встроенный язык - упрощенный аналог Pascal. Скрипты, написанные на этом языке, по сути дела, являются обработчиками событий, вызывающимися перед прорисовкой объектов. Это дает возможность выполнять достаточно сложную обработку информации без написания кода в Delphi, и, соответственно, без жесткой привязки отчета к проекту.
Возможности встроенного языка FastReport довольно широки. Из скрипта доступны все свойства и методы объектов отчета, а также переменные, поля таблиц БД. В скрипте можно создавать переменные и массивы, которые будут доступны во всем отчете. О возможностях встроенного языка говорит тот факт, что такая довольно сложная задача, как печать сумм группы в ее заголовке (сама сумма считается в подвале группы) средствами языка FastReport делается элементарно.
5. Готовый отчет
представляет собой продукт деятельности ядра FastReport - то, что мы видим при нажатии кнопки "Предварительный просмотр". В отличие от остальных генераторов отчетов, которые хранят содержимое страниц отчета в виде метафайла (т.е. изображения в формате EMF), в FastReport готовый отчет представлен набором объектов, описывающих содержимое каждой страницы отчета. Это позволяет модифицировать готовый отчет, загружая нужную страницу в дизайнер. Кроме того, можно описывать реакцию на щелчок мыши на нужном объекте в режиме предварительного просмотра отчета. Это позволяет легко организовать работу приложения, при которой щелчок на объекте отчета вызывает генерацию нового отчета с более детальными сведениями по выбранному объекту.
Кроме того, ни один из существующих сегодня генераторов отчетов не поддерживает такое число сред разработки (Можно сказать, что мы заглядываем в рот Borland и стараемся выпустить генератор отчетов под любую новую версию их сред разработки :-) ). Итак, FastReport сегодня можно использовать в средах: Delphi со второй по 7ю версию, C++Builder всех версий, а также в первой визуальной среде разработки приложений под Linux - Kylix всех версий. Можем похвастаться, что это наша компания выпустила первый генератор отчетов для Kylix, Rave, который сейчас поставляется с новыми версиями продуктов Borland, в том числе и Kylix3, был выпущен примерно на полгода позже. :-)
Естественно, было бы глупо останавливаться на достигнутом. На сегодня разрабатывается принципиально новая версия генератора отчетов, который станет ядром для целого спектра продуктов, предназначенных как для профессиональных разработчиков, причем не только в средах разработки Borland, так и для конечных пользователей.
Что же еще новенького планируется?
·Формат сохранения файлов - текстовый и бинарный dfm, а также XML
·Новый объект - диагональная линия.
·Новые типы заливки для объектов.
·Текст под углом 0..360.
·Отступ параграфа.
·Возможность отключения печати объектов отчета.
·Наследование форм отчетов.
·Возможность отключить редакторы св-в и компонентов, если дизайнер не используется.
Скрипт
·Единый скрипт для всего отчета (как unit в Delphi).
·Поддержка синтаксиса как Pascal, так и C++ в скриптовом языке
·Новые обработчики событий для объектов отчета.
·Новые возможности (try/except, with, case и т.п.)
·Увеличенная (в сравнении с FR2.4) скорость работы.
Дизайнер:
·Архитектура - компактное независимое ядро + интерфейс.
·Улучшенный интерфейс, возможность докинга вспомогательных окон.
·Улучшенный Инспектор объектов
·Масштабирование (Zoom).
·Редактирование мемо-объектов на месте.
·Более удобное рисование линий.
·Более удобная вставка бэндов.
·Бэнды, "прилипающие" друг к другу.
·Более удобный выбор поля БД для мемо-объекта.
·Возможность отображать содержимое поля БД вместо его названия.
·Сетка-миллиметровка, дюймовка, с произвольным шагом.
·Возможность построения отчетов для вывода на матричный принтер.
·Изменение левой/правой границ листа (объекты сдвигаются автоматически).
·Мастера для создания базовых типов отчетов.
·Копирование объектов в буфер обмена Windows.
·Полный откат / возврат (Undo/Redo).
Глобальный словарь данных:
·Задание имен (алиасов) для всех таблиц и полей, содержащихся в БД проекта.
·Автоматическая подстановка алиасов во всех диалоговых окнах FR.
Предварительный просмотрщик:
·Улучшенный интерфейс.
·Редактирование на месте.
·События, генерируемые на сформированном отчете могут быть обработаны в скрипте.
·Выделение объектов и копирование в буфер обмена.
Дополнительные объекты:
·Добавить свой объект проще, чем когда бы то ни было.
Взято из
Фильтр посредством логического поля
Фильтр посредством логического поля
В таблице имеется поле Customer:Boolean. Я хочу чтобы таблица показывала только Customer или только не-customer.
Установите ключ (вы должны иметь индекс для этого поля) одним из указанных способов:
tablex.SetRange([False],[False])// для всех не-customer...
tablex.SetRange([True], [True]]) // для всех customer...
tablex.SetRange([False],[True]) // для всех записей...
Взято из
FindKey для нескольких полей
FindKey для нескольких полей
withTable1 do
begin
SetKey;
FieldByName('State').AsString := 'CA';
FieldByName('City').AsString := 'Scotts Valley';
GotoKey;
end;
Вы не можете использовать Findkey с файлами DBase более чем для одного поля.
oEmetb.indexName:='PrimaryKey';
if oEmeTb.findkey([prCLient,prDiv,prEme])then
где findkey передаются параметры для Primary Keyfields.
Я обращаю ваше внимание на то, что имя индекса (Index) чувствительно к регистру, так что будьте внимательны.
Вы можете также воспользоваться oEmeTb.indexfieldnames, но убедитесь в том, что ваш список ключевых полей в точности соответствуют ключевым полям, которые вы ищете.
oEmetb.indexfieldNames:='EmeClient;EmeDiv;EmeNo';
if oEmeTb.findkey([123,'A',96])then
Взято из
Физическое удаление записей в локальных таблицах (BDE)
Физическое удаление записей в локальных таблицах (BDE)
При удалении записей из таблицы dBase с помощью компонента TTable они просто приобретают признак удаления, и я никак не могу добиться их физического удаления. Как быть?
Ваша проблема решается просто - для физического удаления записей нужно использовать функцию DbiPackTable (ее описание есть в справочном файле BDE).
Наталия Елманова
Взято с Исходников.ru
Примечание Vit: точно так же удаляются записи и у таблиц других локальных баз данных
В BDE есть функция DbiPackTable.
Затем вызвать в нужном месте функцию:
Result:= DbiPackTable(Table1.DbHandle, Table1.Handle, nil, szDBase, True);
Copyright © 1996 Epsylon Technologies
Взято из
FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349Фон MDI-окон
Фон MDI-окон
Привожу код, который может оказаться полезным. Он позволяет в обычной или MDI-форме создать графический tile-фон или градиентную заливку.
(Tile - "секция, плитка" - непрерывное заполнение определенной области немасштабируемым изображением слева-направо сверху вниз - В.О.)
Самая сложная часть кода осуществляет обработку системного сообщения, адресуемого дескриптору окна (ClientHandle), осуществляющему управление дочерними формами. Происходит это в момент вывода изображений в MDI-форме. Все что вам необходимо сделать - в режиме проектирования загрузить в imgTile необходимые изображения и перенести в свою программу следующий код:
unitUMain;
interface
uses
Windows, Messages, Classes, SysUtils, Graphics, Controls, Forms,
Dialogs, ExtCtrls, Menus;
type
TfrmMain = class(TForm)
mnuMain: TMainMenu;
mnuFile: TMenuItem;
mnuExit: TMenuItem;
imgTile: TImage;
mnuOptions: TMenuItem;
mnuBitmap: TMenuItem;
mnuGradient: TMenuItem;
procedure mnuExitClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure mnuBitmapClick(Sender: TObject);
procedure mnuGradientClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormResize(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
MDIDefProc: pointer;
MDIInstance: TFarProc;
procedure MDIWndProc(var prmMsg: TMessage);
procedure CreateWnd; override;
procedure ShowBitmap(prmDC: hDC);
procedure ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
glbImgWidth: integer;
glbImgHeight: integer;
implementation
{$R *.DFM}
procedure TfrmMain.FormCreate(Sender: TObject);
begin
glbImgHeight := imgTile.Picture.Height;
glbImgWidth := imgTile.Picture.Width;
end;
procedure TfrmMain.FormResize(Sender: TObject);
begin
FormPaint(Sender);
end;
procedure TfrmMain.MDIWndProc(var prmMsg: TMessage);
begin
with prmMsg do
begin
if Msg = WM_ERASEBKGND then
begin
if mnuBitmap.Checked then
ShowBitmap(wParam)
else
ShowGradient(wParam, 255, 0, 0);
Result := 1;
end
else
Result := CallWindowProc(MDIDefProc, ClientHandle, Msg, wParam, lParam);
end;
end;
procedure TfrmMain.CreateWnd;
begin
inherited CreateWnd;
MDIInstance := MakeObjectInstance(MDIWndProc); { создаем ObjectInstance }
MDIDefProc := pointer(SetWindowLong(ClientHandle, GWL_WNDPROC,
longint(MDIInstance)));
end;
procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose:
Boolean);
begin
{ восстанавоиваем proc окна по умолчанию }
SetWindowLong(ClientHandle, GWL_WNDPROC, longint(MDIDefProc));
{ избавляемся от ObjectInstance }
FreeObjectInstance(MDIInstance);
end;
procedure TfrmMain.mnuExitClick(Sender: TObject);
begin
close;
end;
procedure TfrmMain.mnuBitmapClick(Sender: TObject);
var
wrkDC: hDC;
begin
wrkDC := GetDC(ClientHandle);
ShowBitmap(wrkDC);
ReleaseDC(ClientHandle, wrkDC);
mnuBitmap.Checked := true;
mnuGradient.Checked := false;
end;
procedure TfrmMain.mnuGradientClick(Sender: TObject);
var
wrkDC: hDC;
begin
wrkDC := GetDC(ClientHandle);
ShowGradient(wrkDC, 0, 0, 255);
ReleaseDC(ClientHandle, wrkDC);
mnuGradient.Checked := true;
mnuBitMap.Checked := false;
end;
procedure TfrmMain.ShowBitmap(prmDC: hDC);
var
wrkSource: TRect;
wrkTarget: TRect;
wrkX: integer;
wrkY: integer;
begin
{ заполняем (tile) окно изображением }
if FormStyle = fsNormal then
begin
wrkY := 0;
while wrkY < ClientHeight do { заполняем сверху вниз.. }
begin
wrkX := 0;
while wrkX < ClientWidth do { ..и слева направо. }
begin
Canvas.Draw(wrkX, wrkY, imgTile.Picture.Bitmap);
Inc(wrkX, glbImgWidth);
end;
Inc(wrkY, glbImgHeight);
end;
end
else if FormStyle = fsMDIForm then
begin
Windows.GetClientRect(ClientHandle, wrkTarget);
wrkY := 0;
while wrkY < wrkTarget.Bottom do
begin
wrkX := 0;
while wrkX < wrkTarget.Right do
begin
BitBlt(longint(prmDC), wrkX, wrkY, imgTile.Width, imgTile.Height,
imgTile.Canvas.Handle, 0, 0, SRCCOPY);
Inc(wrkX, glbImgWidth);
end;
Inc(wrkY, glbImgHeight);
end;
end;
end;
procedure TfrmMain.ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);
var
wrkBrushNew: hBrush;
wrkBrushOld: hBrush;
wrkColor: TColor;
wrkCount: integer;
wrkDelta: integer;
wrkRect: TRect;
wrkSize: integer;
wrkY: integer;
begin
{ процедура заполнения градиентной заливкой }
wrkDelta := 255 div (1 + ClientHeight); { желаемое количество оттенков }
if wrkDelta = 0 then
wrkDelta := 1; { да, обычно 1 }
wrkSize := ClientHeight div 240; { размер смешанных баров }
if wrkSize = 0 then
wrkSize := 1;
for wrkY := 0 to 1 + (ClientHeight div wrkSize) do
begin
wrkColor := RGB(prmRed, prmGreen, prmBlue);
wrkRect := Rect(0, wrkY * wrkSize, ClientWidth, (wrkY + 1) * wrkSize);
if FormStyle = fsNormal then
begin
Canvas.Brush.Color := wrkColor;
Canvas.FillRect(wrkRect);
end
else if FormStyle = fsMDIForm then
begin
wrkBrushNew := CreateSolidBrush(wrkColor);
wrkBrushOld := SelectObject(prmDC, wrkBrushNew);
FillRect(prmDC, wrkRect, wrkBrushNew);
SelectObject(prmDC, wrkBrushOld);
DeleteObject(wrkBrushNew);
end;
if prmRed > wrkDelta then
Dec(prmRed, wrkDelta);
if prmGreen > wrkDelta then
Dec(prmGreen, wrkDelta);
if prmBlue > wrkDelta then
Dec(prmBlue, wrkDelta);
end;
end;
procedure TfrmMain.FormPaint(Sender: TObject);
begin
if FormStyle = fsNormal then
if mnuBitMap.Checked then
mnuBitMapClick(Sender)
else
mnuGradientClick(Sender);
end;
end.
Сначала установите свойство формы FormStyle в fsMDIForm.
Затем разместите Image на форме и загрузите в него картинку.
Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки:
FClientInstance: TFarProc;
FPrevClientProc: TFarProc;
procedure ClientWndProc(var message: TMessage);
Добавьте следующие строки в разделе implementation:
procedure TMainForm.ClientWndProc(var message: TMessage);
var
Dc: hDC;
Row: Integer;
Col: Integer;
begin
with message do
case Msg of
WM_ERASEBKGND:
begin
Dc := TWMEraseBkGnd(message).Dc;
for Row := 0 to ClientHeight div Image1.Picture.Height do
for Col := 0 to ClientWidth div Image1.Picture.Width do
BitBlt(Dc, Col * Image1.Picture.Width, Row *
Image1.Picture.Height, Image1.Picture.Width,
Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle,
0, 0, SRCCOPY);
Result := 1;
end;
else
Result := CallWindowProc(FPrevClientProc,
ClientHandle, Msg, wParam, lParam);
end;
end;
По созданию окна [событие OnCreate()] напишите такой код:
FClientInstance := MakeObjectInstance(ClientWndProc);
FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));
Добавьте к проекту новую форму и установите ее свойство FormStyle в fsMDIChild
Взято с
Формат файла ASCII-схемы
Формат файла ASCII-схемы
В файле asciidrv.txt насчет последнего числа в строке схемы поля говорится:
"* Offset - Number of characters from the beginning of the line that the field begins. Used for FIXED format only." (Offset - количество символов он начала линии до начала поля. Используется только для фиксированного формата.).
С тех пор, как мой файл имеет переменный (Variable) формат, я задал в каждой строке смещение, равное нулю. После некоторых попыток, чтобы заставить это работать, я следал следующие изменения:
[discs]
filetype= varying
charset = ascii
delimiter = "
separator = ,
field1 = id,char,10,0,1
field2 = title,char,30,0,2
field3 = artist,char,30,0,3
...
field36 = song30,char,50,0,36
После более произвольных изменений это стало таким:
[discs]
filetype = varying
charset = ascii
delimiter = "
separator = ,
field1 = id,char,10,0,10
field2 = title,char,30,0,20
field3 = artist,char,30,0,30
...
field36 = song30,char,50,0,360
и внезапно все заработало! Для поля, которое игнорируется форматом файла, "Offset" несомненно дало огромный эффект.
Взято из
Советов по Delphi от
Сборник Kuliba
Формат и размер dBase-поля
Формат и размер dBase-поля
procedureGetdBaseFieldTypes(t: TTable; var l: TStringList);
var
pF: pFLDDesc;
cProps: CURProps;
p: pFLDDesc;
i: Byte;
w: Word;
s: string;
oldmode: LongInt;
begin
Check(DbiGetCursorProps(t.Handle, cProps));
Check(DbiGetProp(hDBIObj(t.Handle), curXLTMODE, oldmode, SizeOf(LongInt), w));
Check(DbiSetProp(hDBIObj(t.Handle), curXLTMODE, LongInt(xltNONE)));
try
if MaxAvail < (cProps.iFields * SizeOf(FLDDesc)) then
raise EOutofMemory.Create('Недостаточно памяти для процесса');
GetMem(pF, (cProps.iFields * SizeOf(FLDDesc)));
Check(DbiGetFieldDescs(t.Handle, pF));
p := pF;
for i := 1 to cProps.iFields do
begin
with p^ do
begin
s := IntToStr(iFldNum) + ' : ' + StrPas(szName) + ' : ';
case iFldType of
fldDBCHAR:
begin { Char string, строка символов }
s := s + 'CHARACTER(' + IntToStr(iUnits1) + ')';
end;
fldDBNUM:
begin { Number, число }
s := s + 'NUMBER(' + IntToStr(iUnits1) + ',' + InttoStr(iUnits2) + ')';
end;
fldDBMEMO:
begin { Memo (blob), МEMO-BLOB-поле }
s := s + 'MEMO';
end;
fldDBBOOL:
begin { Logical, лочическая величина }
s := s + 'LOGICAL';
end;
fldDBDATE:
begin { Date, поле даты }
s := s + 'DATE';
end;
fldDBFLOAT:
begin { Float, числа с плавающей точкой }
s := s + 'FLOAT(' + IntToStr(iUnits1) + ',' + InttoStr(iUnits2) + ')';
end;
fldDBLOCK:
begin { Логический тип LOCKINFO }
s := s + 'LOCKINFO';
end;
fldDBOLEBLOB:
begin { OLE object (blob), OLE-объект, BLOB-поле }
s := s + 'OLE';
end;
fldDBBINARY:
begin { Binary data (blob), двоичные данные, BLOB-поле }
s := s + 'BINARY';
end;
else
s := s + 'НЕИЗВЕСТНО';
end;
end;
l.Add(s);
Inc(p);
end;
finally
Check(DbiSetProp(hDBIObj(t.Handle), curXLTMODE, oldmode));
FreeMem(pF, (cProps.iFields * SizeOf(FLDDesc)));
end;
end;
-Eryk Bottomley
Взято из
Советов по Delphi от
Сборник Kuliba
Формат wave файла
Формат wave файла
TWaveHeader= record
Marker1: array[0..3] of Char;
BytesFollowing: LongInt;
Marker2: array[0..3] of Char;
Marker3: array[0..3] of Char;
Fixed1: LongInt;
FormatTag: Word;
Channels: Word;
SampleRate: LongInt;
BytesPerSecond: LongInt;
BytesPerSample: Word;
BitsPerSample: Word;
Marker4: array[0..3] of Char;
DataBytes: LongInt;
end;
Для создания собственного WAV-файла сделайте следующее:
DataBytes := Channels;
DataBytes := DataBytes * SampleRate;
DataBytes := DataBytes * Resolution;
DataBytes := DataBytes div 8;
DataBytes := DataBytes * Duration;
DataBytes := DataBytes div 1000;
WaveHeader.Marker1 := 'RIFF';
WaveHeader.BytesFollowing := DataBytes + 36;
WaveHeader.Marker2 := 'WAVE';
WaveHeader.Marker3 := 'fmt ';
WaveHeader.Fixed1 := 16;
WaveHeader.FormatTag := 1;
WaveHeader.SampleRate := SampleRate;
WaveHeader.Channels := Channels;
WaveHeader.BytesPerSecond := Channels;
WaveHeader.BytesPerSecond := WaveHeader.BytesPerSecond * SampleRate;
WaveHeader.BytesPerSecond := WaveHeader.BytesPerSecond * Resolution;
WaveHeader.BytesPerSecond := WaveHeader.BytesPerSecond div 8;
WaveHeader.BytesPerSample := Channels * Resolution div 8;
WaveHeader.BitsPerSample := Resolution;
WaveHeader.Marker4 := 'data';
WaveHeader.DataBytes := DataBytes;
Остальная часть файлы является звуковыми данными. Порядок следования: верхний уровень для левого канала, верхний уровень для правого канала и так далее. Для моно или 8-битных файлов сделайте соответствующие изменения.
Взято из
Советов по Delphi от
Сборник Kuliba
Формулы передачи данных для начинающих
Формулы передачи данных для начинающих
Автор: Jason Pierce
Данным примером я попытаюсь дать ответы на следующие вопросы:
Каково различие между KBps и Kbps? В чём заключается отличие битов, байтов и бодов? Как определить скорость передачи данных? Как выяснить, насколько долго будет загружаться файл с определённой скоростью? Как посчитать время, оставшее до окончания загрузки?
Для начала хотельсы навести порядок с некоторой неразберихой по поводу KBps и Kbps (буква b в нижнем регистре). KBps это обозначение для килобайт в секунду, в то время как Kbps обозначает килобиты в секунду. 1 килобайт (KB) = 8 килобитам (Kb).
Когда речь идёт о скорости передачи, то применяется Kbps. Таким образом модем со скорость передачи 33.6K (33600 bps) передаёт данные со скоростью 4.2 KBps (4.2 килобайта в секунду). Как мы видим, разница между KB и Kb довольно ощутима. В этом кроется причина того, что некоторые пользователи модемов по своему незнанию не могут понять, почему данные передаются так медленно. На самом деле данные объёмом 33.6K передаются не за 1 секунду, а за 8, соответственно за одну секунду будет передано 33.6 Kb / 8 = 4.2.
Так же хотелось бы дать некоторые разъяснения по поводу слова "бод" (baud). Обычно для модема "боды" расшифровываются как бит в секунду. На самом деле это не так. Бод (Baud) означает частоту звука в телефонной линии. Т. е. в зависимости от модема, который Вы используете, количество бит, которые могут быть переданы зависит от частоты звука, необходимой для обеспечения нужной скорости передачи.
Обратите внимание: Приведённый ниже пример, использует компонент NetMasters TNMHTTP. Однако, если Вы "прикипели" к какому-то другому компоненту TCP/IP, то переделать пример под этот компонент не составит большого труда.
Используемые обозначения:
bps = байт, переданных за 1 секунду
KBps (KB/Sec) = bps / 1024
Kbps (Kb/Sec) = KBps x 8
Краткий алгоритм приведённого ниже примера:
1. Сохраняем в переменной время начала загрузки: nStartTime := GetTickCount;
2. Сохраняем в переменной размер файла (KB): nFileSize := "File Size";
3. Начало передачи данных.
4. Обновляем количество переданных байт: Inc(nBytesTransferred, nNewBytes);
5. Получаем оставшееся время: nTimeElapsed := (GetTickCount - nStartTime) / 1000;
6. Вычисляем bps: nBps := BytesTransferred / nTimeElapsed;
7. Вычисляем KBps: nKBps := nBps / 1024;
Используемые данные:
Общее время скачивания (секунд) := nFileSize / nKBps;
bps := FloatToStr(nBps);
KB/Sec (KBps) := FloatToStr(nKBps);
Осталось секунд := FloatToStr(((nFileSize - BytesTransferred) / 1024) / KBps);
Рабочий пример:
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Gauges, Psock, NMHttp;
type
TfMain = class(TForm)
Label1: TLabel;
eURL: TEdit;
bGet: TButton;
lbMessages: TListBox;
gbDetails: TGroupBox;
lEstimate: TLabel;
lKBps: TLabel;
lReceived: TLabel;
lRemaining: TLabel;
gProgress: TGauge;
NMHTTP1: TNMHTTP;
lbps: TLabel;
bCancel: TButton;
procedure NMHTTP1PacketRecvd(Sender: TObject);
procedure bGetClick(Sender: TObject);
procedure bCancelClick(Sender: TObject);
procedure NMHTTP1Connect(Sender: TObject);
procedure NMHTTP1ConnectionFailed(Sender: TObject);
procedure NMHTTP1Disconnect(Sender: TObject);
procedure NMHTTP1Failure(Cmd: CmdType);
procedure NMHTTP1HostResolved(Sender: TComponent);
procedure NMHTTP1InvalidHost(var Handled: Boolean);
procedure NMHTTP1Status(Sender: TComponent; Status: String);
procedure NMHTTP1Success(Cmd: CmdType);
private
{ Private declarations }
function ss2nn(Seconds: Integer): String;
public
{ Public declarations }
end;
var
fMain: TfMain;
nFileSize: Double;
nStartTime: DWord;
implementation
{$R *.DFM}
{Цель этой функции состоит в том, чтобы определить, сколько минут и секунд там находятся в данном количестве секунд}
function TfMain.ss2nn(Seconds: Integer): String;
var
nMin, nSec: Integer;
begin
{Проверяем, меньше чем 1/Min}
if Seconds < 60 then Result := '0 minutes ' + IntToStr(Seconds) + ' seconds'
else begin
{Определяем минуты}
nMin := Seconds div 60;
{Определяем секунды}
nSec := Seconds - (nMin * 60);
{Возвращаем результат}
Result := IntToStr(nMin) + ' minutes ' + IntToStr(nSec) + ' seconds';
end;
end;
procedure TfMain.NMHTTP1PacketRecvd(Sender: TObject);
var
nBytesReceived, nTimeElapsed, nBps, nKBps: Double;
begin
{Следующий код выполняется только однажды, при приёме первого пакета}
if nFileSize <> NMHTTP1.BytesTotal then
begin
{Получаем размер файла}
nFileSize := NMHTTP1.BytesTotal;
{Вычисляем время передачи, исходя из скорости соединения 33.6 Kbps}
lEstimate.Caption := 'Estimated download time at 33.6 Kbps: ' + ss2nn(Round(
(nFileSize / 1024) / 4.2));
{Получаем время начала}
nStartTime := GetTickCount;
end;
{Обновляем nBytesReceived}
nBytesReceived := NMHTTP1.BytesRecvd;
{Вычисляем количество секунд прошедших с момента начала передачи}
nTimeElapsed := (GetTickCount - nStartTime) / 1000;
{Проверяем на 0/Sec, если так, то устанавливаем 1, чтобы предотвратить деления на ноль}
if nTimeElapsed = 0 then nTimeElapsed := 1;
{Вычисляем байт в секунду}
nBps := nBytesReceived / nTimeElapsed;
{Вычисляем килобайт в секунду}
nKBps := nBps / 1024;
{Обновляем контролы}
gProgress.Progress := Round((nBytesReceived * 100) / nFileSize);
lbps.Caption := IntToStr(Round(nBps * 8)) + ' bits per second';
lKBps.Caption := IntToStr(Round(nKBps)) + ' KB/Sec (KBps)';
lReceived.Caption := FloatToStr(nBytesReceived) + ' of ' + FloatToStr(
nFileSize) + ' bytes received';
lRemaining.Caption := ss2nn(Round(((nFileSize - nBytesReceived) / 1024) /
nKBps)) + ' remaining';
end;
procedure TfMain.bGetClick(Sender: TObject);
begin
{Сбрасываем переменные}
nFileSize := 0;
{Обнуляем контролы}
lbMessages.Clear;
gProgress.Progress := 0;
lEstimate.Caption := 'Estimated download time at 33.6 Kbps: 0 minutes 0 ' +
'seconds';
lbps.Caption := '0 bits per second';
lKBps.Caption := '0 KB/Sec (KBps)';
lReceived.Caption := '0 of 0 bytes received';
lRemaining.Caption := '0 minutes 0 seconds remaining';
{Получаем файл}
NMHTTP1.Get(eURL.Text);
end;
procedure TfMain.bCancelClick(Sender: TObject);
begin
{Разрываем соединение с сервером}
NMHTTP1.Disconnect;
{Обновляем lbMessages}
lbMessages.Items.Append('Get Canceled');
lbMessages.Items.Append('Disconnected');
end;
procedure TfMain.NMHTTP1Connect(Sender: TObject);
begin
{Запрещаем/Разрешаем контролы}
bGet.Enabled := False;
bCancel.Enabled := True;
{Работаем с lbMessages}
with lbMessages.Items do
begin
Append('Connected');
Append('Local Address: ' + NMHTTP1.LocalIP);
Append('Remote Address: ' + NMHTTP1.RemoteIP);
end;
end;
procedure TfMain.NMHTTP1ConnectionFailed(Sender: TObject);
begin
ShowMessage('Connection Failed.');
end;
procedure TfMain.NMHTTP1Disconnect(Sender: TObject);
begin
{Запрещаем/Разрешаем контролы}
bCancel.Enabled := False;
bGet.Enabled := True;
{Обновляем lbMessages}
if NMHTTP1.Connected then lbMessages.Items.Append('Disconnected');
end;
procedure TfMain.NMHTTP1Failure(Cmd: CmdType);
begin
case Cmd of
CmdGET : lbMessages.Items.Append('Get Failed');
CmdOPTIONS: lbMessages.Items.Append('Options Failed');
CmdHEAD : lbMessages.Items.Append('Head Failed');
CmdPOST : lbMessages.Items.Append('Post Failed');
CmdPUT : lbMessages.Items.Append('Put Failed');
CmdPATCH : lbMessages.Items.Append('Patch Failed');
CmdCOPY : lbMessages.Items.Append('Copy Failed');
CmdMOVE : lbMessages.Items.Append('Move Failed');
CmdDELETE : lbMessages.Items.Append('Delete Failed');
CmdLINK : lbMessages.Items.Append('Link Failed');
CmdUNLINK : lbMessages.Items.Append('UnLink Failed');
CmdTRACE : lbMessages.Items.Append('Trace Failed');
CmdWRAPPED: lbMessages.Items.Append('Wrapped Failed');
end;
end;
procedure TfMain.NMHTTP1HostResolved(Sender: TComponent);
begin
lbMessages.Items.Append('Host Resolved');
end;
procedure TfMain.NMHTTP1InvalidHost(var Handled: Boolean);
begin
ShowMessage('Invalid Host. Please specify a new URL.');
end;
procedure TfMain.NMHTTP1Status(Sender: TComponent; Status: String);
begin
if NMHTTP1.ReplyNumber = 404 then ShowMessage('Object Not Found.');
end;
procedure TfMain.NMHTTP1Success(Cmd: CmdType);
begin
case Cmd of
{Удостоверяемся, что процедура получения не была прервана}
CmdGET: if NMHTTP1.Connected then lbMessages.Items.Append('Get Succeeded');
CmdOPTIONS: lbMessages.Items.Append('Options Succeeded');
CmdHEAD : lbMessages.Items.Append('Head Succeeded');
CmdPOST : lbMessages.Items.Append('Post Succeeded');
CmdPUT : lbMessages.Items.Append('Put Succeeded');
CmdPATCH : lbMessages.Items.Append('Patch Succeeded');
CmdCOPY : lbMessages.Items.Append('Copy Succeeded');
CmdMOVE : lbMessages.Items.Append('Move Succeeded');
CmdDELETE : lbMessages.Items.Append('Delete Succeeded');
CmdLINK : lbMessages.Items.Append('Link Succeeded');
CmdUNLINK : lbMessages.Items.Append('UnLink Succeeded');
CmdTRACE : lbMessages.Items.Append('Trace Succeeded');
CmdWRAPPED: lbMessages.Items.Append('Wrapped Succeeded');
end;
end;
end.
Взято с Исходников.ru
Формы нестандартного вида
Формы нестандартного вида
Cодержание раздела:
Функции редактора полей во время выполнения программы
Функции редактора полей во время выполнения программы
Возможен ли вызов функций редактора полей (Fields Editor) во время выполнения программы?
Да. Если вы определили поля во время разработки приложения, то во время выполнения можно менять их свойства (например, Size).
Например, следующий код изменяет каждый размер поля TField.Size так, чтобы соответствовать фактическому размеру поля открываемого набора данных:
procedureSetupFieldsAndOpenDataset(DataSet: TDataSet);
var
FieldNum, DefNum: Integer;
begin
with DataSet do
begin
if Active then
Close;
FieldDefs.Update; {набор данных должен быть закрыт}
{ищем каждое предопределенное TField в DataSet.FieldDefs:}
for FieldNum := FieldCount - 1 downto 0 do
with Fields[FieldNum] do
begin
DefNum := FieldDefs.IndexOf(FieldName);
if DefNum < 0 then
raise Exception.CreateFmt(
'Поле "%s" не найдено в наборе данных "%s"',
[FieldName, Dataset.Name]);
{устанавливаем свойство size:}
Size := FieldDefs[DefNum].Size;
end;
Open;
end;
end;
Взято из
Функция для быстрого копирования таблиц вместе со всеми дополнительными файлами
Функция для быстрого копирования таблиц вместе со всеми дополнительными файлами
//Только для не SQL-ых, т.е не промышленных БД (dBase, Paradox ..)
// Путь нужно задавать только АНГЛИЙСКИМИ буквами
procedure QuickCopyTable(T: TTable; DestTblName: string; Overwrite: boolean);
var
DBType: DBIName;
WasOpen: boolean;
NumCopied: word;
begin
WasOpen := T.Active;
if not WasOpen then
T.Open;
Check(DbiGetProp(hDBIObj(T.Handle),drvDRIVERTYPE, @DBType,SizeOf(DBINAME), NumCopied));
Check(DbiCopyTable(T.DBHandle, Overwrite, PChar(T.TableName),DBType, PChar(DestTblName)));
T.Active := WasOpen;
end;
Взято из
Функция для работы с палитрами и RGB
Функция для работы с палитрами и RGB
У меня трудности с пониманием операций, производимых в Delphi над палитрой. По существу, я имею 4 открытых формы, которые должны использовать цвета, которые не входят в стандрартный набор из 20 именованных цветов. Ячейки таблицы также должны использовать мои нестандартные цвета. Есть какой-либо способ обновления системной палитры для того, чтобы все формы использовали один и тот же цвет?
При работе с палитрами рекомендуется пользоваться функцией RGB. Если вы используете ее для изменения свойства "Color", Windows довольно хорошо справляется с задачай подбора цветов для низкого разрешения, а в системах с высоким разрешением вы получите точный цвет RGB. Это могло бы послужить выходом из создавшейся у вас ситуации. Вот пример формы, которая "линяет" от красного до синего:
procedureTForm1.FormClick(Sender: TObject);
var
blue: Byte;
begin
For blue := 0 to 255 do
Begin
Color := RGB(255-blue,0,blue);
Update;
End;
end;
Взято из
Функция набора номера модемом
Функция набора номера модемом
var
hCommFile : THandle;
procedure TForm1.Button1Click(Sender: TObject);
var
PhoneNumber : string;
CommPort : string;
NumberWritten : LongInt;
begin
PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10;
CommPort := 'COM2';
{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile=INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;
NumberWritten:=0;
if WriteFile(hCommFile,
PChar(PhoneNumber)^,
Length(PhoneNumber),
NumberWritten,
nil) = false then
begin
ShowMessage('Unable to write to ' + CommPort);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
{Close the port}
CloseHandle(hCommFile);
end;
У кого с головой хорошо я добавлю вам эту информацию.
AT-команды модема
A Команда ответа (Answer Command)
Bn Настройка связи (Communications Options)
D Команда набора (Dial Command)
En Команда выбора символа эха (Select Command Character Echo
Option)
Hn Управление Switchhook - эмуляция нажатия телефонного рычага
(Control The Switchhook)
I0 Идентификация кода продукта (Identify The Product Code)
I2 Выполнение теста контрольной суммы ROM ( Perform ROM Checksum
Test)
Ln Выбор уровня громкости динамика (Select Speaker Volume Level)
Mn Функция выбора опций динамика (Select Speaker Function Option)
Nn Выбор опций для установления связи (Select Negotiate Handshake
Option)
On Переход к онлайновым командам (Go Online Command)
P Выбор метода пульсового набора (Select Pulse Dialing Method)
Qn Выбор опции результирующего кода (Select Result Code Option)
Sn= Запись в S-регистр (Write To An S-Register)
Sn? Чтение S-регистра (Read An S-Register)
T Выбор метода тонового набора (Select Tone Dialing Method)
Vn Выбор опции формата ответа (Select Response Format Option)
Wn Выбор расширенного результирующего кода (Select Extended Result
Code)
Xn Выбор опции модемного вызова (Select Call Progress Option)
Yn Выбор опции бездействия для разъединения (Select Long Space
Disconnect Option)
Zn Выполнение мягкого сброса (Perform Soft Reset)
&An Выбор роли автоответчика (Select Originate/Answer Role For
Autoanswer)
&Cn Выбор опции определения передаваемых данных (Select Data
Carrier Detect Option)
&Dn Выбор опции готовности терминала данных (Select Data Terminal
Ready Option)
&F Загрузка заводских установок (Load Factory Default Profile)
&Gn Выбор опции защиты тонового набора (Select Guard Tone Option)
&Kn Выбор опций потока ConTDol (Select Flow ConTDol Option)
&Pn Выбор параметров пульсового набора (Select Pulse Dialing
Parameters)
&Qn Выбор опций режима связи (Select Communications Mode Option)
&Rn Выбор опций RTS/CTS (Select RTS/CTS Option)
&Sn Выбор опций готовности передачи данных (Select Data Set Ready
Option)
&T0 Тест завершения в процессе (Terminate Test In Process)
&T1 Инициирование локального аналога сетевой петли (Initiate Local
Analog Loopback)
&T3 Выполнение локальной цифровой сетевой петли (Perform Local
Digital Loopback)
&T4 Включение предоставления RDL-запросов (Enable Granting Of RDL
Requests)
&T5 Запрет предоставления RDL-запросов (Deny Granting Of RDL
Requests)
&T6 Инициирование удаленной цифровой сетевой петли (Initiate
Remote Digital Loopback)
&T7 Иниицирование внутреннего теста RDL (Initiate RDL With Self
Test)
&T8 Внутренний тест локальной сетевой петли (Local Loopback With
Self Test)
&T19 Выполнение теста RTS/CTS кабеля (Perform RTS/CTS Cable Test)
&Un Отмена TDellis кодирования (Disable TDellis Coding)
&V Просмотр профилей конфигурации (View Configuration Profiles)
&Wn Сохранение активного профиля (Store Active Profile)
&Xn Выбор источника синхронизации времени TDansmit (Store Active
Profile)
&Yn Выбор сохранения профиля для аппаратного перезапуска (Select
Stored Profile For Hard Reset)
&Zn= Сохранение телефонного номера (Store Telephone Number)
, Пауза (Perform Pause)
= Запись в S-регистр (Write To An S-Register)
? Чтение S-регистра (Read An S-Register)
P Выбор пульсового набора (Select Pulse Dialing)
Т Тоновый набор (Tone)
S-регистры модема
Регистр
Описание
S0 Звонок, на который необходимо ответить (Ring After Which To
Answer)
S1 Количество звонков (Ring Count)
S2 Символ отмены (Hayes Escape Character)
S3 Символ перевода строки (Carriage Return Character)
S4 Символ пропуска строки (Line Feed Character)
S5 Символ пробела (Backspace Character)
S6 Ожидание перед вызывом (Wait Before Blind Dialing)
S7 Ожидание ответа (Wait For Carrier)
S8 Время паузы для запятой (Pause Time For Comma)
S9 Время восстановления (Carrier Recovery Time)
S10 Время задержки для поднятия трубки после потери соединения
(Lost Carrier Hang Up Delay)
S11 Время DTMF соединения (DTMF Dialing Speed)
S12 Время защиты отмены (Hayes Escape Guard Time)
S16 Выполнение теста (Test in Progress)
S18 Тест таймера модема (Modem Test Timer)
S19 Настройки автосинхронизации (AutoSync Options)
S25 Обнаружено изменение DTD (Detect DTD Change)
S26 Интервал задержки RTS для CTS (RTS To CTS Delay Interval)
S30 Неактивное время ожидания (Inactivity Timeout)
S31 Символ XON (XON Character)
S32 Символ XOFF (XON Character)
S36 Ошибка согласования TDeatment (Negotiation Failure TDeatment)
S37 Ускорение DCE линии (Desired DCE Line Speed)
S38 Время ожидания снятия трубки (Hang-up Timeout)
S43 Текущая скорость линии (Current Line Speed)
S44 Техническая конструкция (Framing Technique)
S46 Выбор протокола/компрессии (Protocol/Compression Selection)
S48 Действие характеристики согласования (Feature Negotiation
Action)
S49 Низкий предел буфера (Buffer Low Limit)
S50 Высокий предел буфера (Buffer High Limit)
S70 Максимальное число ReTDansmissions (Maximum Number of
ReTDansmissions)
S73 Неактивное время ожидания (No Activity Timeout)
S82 Выбор прерывания (Break Selection)
S86 Код причины неудачной связи (Connection Failure Cause Code)
S91 Выбор уровня TDansmit коммутируемой линии (Select Dial-up Line
TDansmit Level)
S95 Расширенный результат кода битовой карты (Extended Result Code
Bit Map)
S108 Селектор качества сигнала (Signal Quality Selector)
S109 Селектор скорости соединения (Carrier Speed Selector)
S110 Селектор V.32/V.32 bis (V.32/V.32 bis Selector)
S113 Тональный вызов ConTDol (Calling Tone ConTDol)
S121 Использование DTD (Use of DTD)
S141 Таймер фазы обнаружения (Detection Phase Timer)
S142 Онлайновый формат символов (Online Character Format)
S144 Выбор скорости автобода (Autobaud Speed Group Selection)
mailto:Автор:Pixel(pixel@novgorod.net http://pixelsoft.narod.ru/ )
Взято с сайта
Функция вычисления степени
Функция вычисления степени
function Degree(const DegBasis, DegParam: Extended): Extended;
asm
// Вход: DegBasis, DegParam --> в стеке
// Выход: Result --> ST(0)
// Примечание:
// В случае некорректных данных в ST(0) возвращается DegParam
XOR EDX, EDX
FLD DegParam
FTST
FNSTSW AX
SAHF
JNZ @@DegParam_is_not_0
FFREE ST
FLD1
JMP @@exit
@@DegParam_is_not_0:
JC @@DegParam_is_less_than_0
JMP @@cmp_DegBasis_to_0
@@DegParam_is_less_than_0:
OR EDX, 1
@@cmp_DegBasis_to_0:
FLD DegBasis
FTST
FNSTSW AX
SAHF
JNZ @@DegBasis_is_not_0
TEST EDX, 1
JZ @@DegParam_is_greater_than_0
FSTP ST
JMP @@exit
@@DegParam_is_greater_than_0:
FSTP ST(1)
JMP @@exit
@@DegBasis_is_not_0:
TEST BYTE PTR DegBasis + 9, 80H
JZ @@DegBasis_is_greater_than_0
FABS
FXCH
OR EDX, 2
FLD ST
FRNDINT
FSUB ST, ST(1)
FTST
FNSTSW AX
SAHF
FSTP ST
JZ @@DegParam_is_integer
FLD1
FDIV ST, ST(1)
FABS
FLD1
FCOMP
FNSTSW AX
SAHF
JC @@1_div_Abs_DegParam_greater_or_equal_to_1
JZ @@1_div_Abs_DegParam_greater_or_equal_to_1
FSTP ST
FSTP ST(1)
JMP @@exit
@@1_div_Abs_DegParam_greater_or_equal_to_1:
FISTP QWORD PTR @@Int_64
TEST BYTE PTR @@Int_64, 1
JNZ @@continue
FSTP ST(1)
JMP @@exit
@@DegParam_is_integer:
FLD ST
FISTP QWORD PTR @@Int_64
TEST BYTE PTR @@Int_64, 1
JNZ @@continue
XOR EDX, EDX
@@continue:
FXCH
@@DegBasis_is_greater_than_0:
FYL2X
FLD ST
FRNDINT
FSUB ST(1), ST
FXCH ST(1)
F2XM1
FLD1
FADD
FSCALE
FSTP ST(1)
TEST EDX, 2
JZ @@exit
FCHS
JMP @@exit
@@Int_64:
DQ 0
@@exit:
FWAIT
end;
Автор ___ALex___
Функция вычисления суммы полей
Функция вычисления суммы полей
functionSumField(const fieldName: OpenString): longint;
var
fld: TField;
bm: TBookmark; // закладка
begin
result := 0;
tbl.DisableControls; // выключаем рекцию на перемещение по набору данных
bm := tbl.GetBookmark; // сохраняем позицию
fld := tbl.FieldByName(fieldName);
tbl.first;
while not tbl.eof do
begin
result := result + fld.AsInteger;
tbl.next;
end;
tbl.GotoBookmark(bm); // позиционируем обратно
tbl.EnableControls; // включаем реакцию на перемещение по набору данных
end;
Взято из
Примечание Vit: данный способ один из худших, а точнее самый худший из всех возможных и мог бы служить пособием того как делать не следует (собственно для этого я его здесь и привёл). На больших таблицах, особенно на серверных базах данных выполнение этого кода будет исключительно медленное. Намного выгоднее выполнение SQL запроса вида:
Select Count(*) From MyTable
И в коде чтение первого поля первой записи:
Function Form1.GetRecordCount(TableName:string):integer;
begin //на форме должен стоять компонент Query1 подсоединённый к нужной базе данных (код будет работать для любых разновидностей TQuery, TADOQuery и т.д.)
Query1.active:=false;
Query1.sql.text:='Select Count(*) From '+TableName;
Query1.active:=true;
Result:=Query1.fields[0].asInteger;
Query1.active:=false;
end;
при этом все другие открытые TTable/TQuery и т.п. на этой таблице могут продолжать оставаться открытыми.
Где можно найти документацию на WebBrowser?
Где можно найти документацию на WebBrowser?
Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm
Вопрос: Где можно найти документацию на WebBrowser? Ответ: Можно заглянуть на сайт Microsoft в раздел WebBrowser overview, а так же на страницу WebBrowser object.
Где TServerSocket и TClientSocket в Delphi 7?
Где TServerSocket и TClientSocket в Delphi 7?
The TClientSocket and TServerSocket components seem to be missing from my installation of Delphi 7?
You will need to add the dclsockets package to the IDE. To do this go to Component | Install Packages | Add (/bin/dclsockets70.bpl).
Где взять примеры использования Indy?
Где взять примеры использования Indy?
В стандартную поставку Дельфи примеры работы с компонентами Indy отсутствуют, но это не значит, что их нет. Надо обратиться на официальные сайты разработчиков этих компонентов:
Автор:
VitВзято из
GDI - графика в Delphi
GDI - графика в Delphi
Автор: Alistair Keys
Жаргон GDI.
GDI расшифровывается как Graphics Device Interface, и представляет собой интерфейс, который Windows использует для рисования 2D графики. Также это самый медленный способ отображения графики из существующих, однако самый простой для понимания основ. Итак, для начала, поговорим об основных понятиях и терминах в GDI.
Начнём с того, что GDI обычно не используют для создания крутых графических эффектов, для этого есть DirectX, OpenGL, или любые графические библиотеки (такие как: DelphiX, FastLib, DIBUltra, Graphics32...). Однако, для создание простых эффектов с минимальными усилиями GDI вполне сгодится.
С GDI тесно связана ещё одна аббревиатура - DC ("Device Context" - контекст устройства). Это то, на чём мы рисуем, и в Delphi контекст устройства представлен как TCanvas. Идея контекста устройства заключается в том, что это универсальное устройство вывода, поэтому можно использовать одинаковые функции как для экрана, так и для принтера.
Все графические функции в Delphi являются надстройками над стандартными GDI функциями Windows. Позже мы поговорим об этих функциях.
А теперь самое время приступить к рассмотрению того, как устроен GDI. Ниже, в таблице, представлены некоторые важные классы:
Pen Используется для рисования простых линий. Обычно применяется для функции LineTo или при рисовании рамки для определённой фигуры (например для функции Rectangle).
Brush Кисть используется для заполнения области определённым цветом. Применяется в функциях Rectangle, FillRect или FloodFill.
Font Используется для задания шрифта, которым будет нарисован текст. Можно указать имя шрифта, размер и т.д.
Region Позволяет задать регион (замкнутое пространство). Регионом может быть круг, квадрат или произвольная фигура. Позволяет так же делать дырки в фигурах.
Однако, пора переходить от слов к делу, а именно, начать рисовать линии и фигуры.
Рисование линий
Сперва необходимо чётко уяснить, что координата (0,0) это верхний левый угол экрана. То есть значения по оси y увеличиваются вниз экрана. Соответственно, координата (0, 50) означает, что мы просто отступили на 50 пикселей от верха экрана.
Самое главное, что надо знать при рисовании линий и фигур, это различие между пером (Pen) и кистью (Brush). Всё очень просто: перо (Pen) используется при рисовании линий или рамок, а кисть (Brush) для заполнения фигуры.
Ниже приведены две функции, которые используются для рисования линий и обе принадлежат TCanvas:
MoveTo
Перемещает точку начала рисования линии в указанные координаты x и y Canvas.MoveTo(50, 100);LineTo Рисует линию начиная с текущей позиции (см. MoveTo) до указанных координат x и y. Canvas.LineTo(50, 100);
Эффект перемещения точки начала рисования линии так же достигается при помощи установки своства PenPos в канвасе... например, "Canvas.PenPos.x := 20;", "Canvas.PenPos.y := 50", или "Canvas.PenPos := Point(20,50);".
По умолчанию, точка начала рисования установлена в (0,0), то есть, если сразу вызвать "Canvas.LineTo(100,100);" то будет нарисована линия из точки (0,0) в точку (100, 100). Точка начала рисования автоматически переместится в (100, 100), то есть, если выполнить команду "Canvas.LineTo(200, 100);", то следующая линия будет нарисована из точки (100, 100) в (200, 100). Поэтому, если мы хотим рисовать линии несоединённые друг с другом, то придётся воспользоваться методом MoveTo.
Линия, нарисованная при помощи LineTo использует текущее перо канваса (типа TPen). Основные свойства пера, это ширина - "Canvas.Pen.Width := 4;" (при помощи которого можно задавать различную ширину линий), и цвет "Canvas.Pen.Color := clLime;".
Взглянем на простой пример беспорядочного рисования разноцветных линий:
procedure TForm1.FormCreate(Sender: TObject);
begin
// инициализируем генератор
// случайных чисел
Randomize;
end;
const
NUM_LINES = 2000;
procedure TForm1.DrawLines;
var
i: Integer;
begin
for i := 0 to NUM_LINES - 1 do
begin
Canvas.Pen.Color :=
RGB(Random(256),
Random(256),
Random(256));
Canvas.LineTo
(Random(ClientWidth),
Random(ClientHeight));
end;
end;
Процедура DrawLines вызывается из обработчика кнопки OnClick. Количество линий задаётся в константе NUM_LINES. Между прочим, функция RGB, составляет цвет каждой линии из трёх основных составляющих: красного, зелёного и синего (значения от 0 до 255) и возвращает нам цвет в виде TColor.
Рисование фигур
Для рисования фигур, в TCanvas предусмотрены следующие функции:
Ellipse Рисует элипс, вписанный в невидимый квадрат с координатами верхнего левого угла и правого нижнего. Если координаты х и y у углов будут совпадать, то получится круг. Canvas.Ellipse(0,0,50,50);
FillRect Заполняет прямоугольник цветом текущей кисти (brush), но никак не за пределами него. Canvas.FillRect( Bounds(0,0,100,100));
FloodFill Заполняет данную область цветом текущей кисти, до тех пор пока не будет достигнут край. Canvas.FloodFill(10, 10, clBlack, fsBorder);
Rectangle Рисует прямоугольник (или квадрат), заполненный цветом текущей кисти и обрамлённый цветом текущего пера Canvas.Rectangle( Bounds(20, 20, 50, 50));
RoundRect Тоже, что и Rectangle, но с загруглёнными углами. Canvas.RoundRect( 20, 20, 50, 50, 3, 3);
Ещё есть очень нужная функция TextOut, которая позволяет рисовать текст, используя шрифт, заданный в канвасе:
TextOut Рисует данную строку на канвасе начиная с координат (x,y) - фон текста заполняется текущим цветом кисти. Canvas.TextOut(10, 10, 'Some text');
Кстати, функция позволяет рисовать текст, не заполняя его фон. Если Вам необходимо изменить шрифт, используемый в TextOut, то необходимо изменить свойство Font канваса (это свойство имеет тип TFont) - например "Canvas.Font.Name := 'Verdana';", "Canvas.Font.Size := 24;" или "Canvas.Font.Color := clRed;".
Вкратце хотелось бы обратить Ваше внимание на довольно полезный класс TRect, который умеет хранить в себе значения лево, право, верха и низа (кстати, в Windows API это RECT). То ест, достаточно указать левую и верхнюю координату и ширину и высоту области, а TRect автоматически подставит в виде (лево, верх, лево + ширина, верх + высота). Ещё есть другая функция Rect(), которая делает тоже самое, но координаты в ней задаются напрямую как лево, право, верх и низ. Ну и по желанию, можно использовать API функцию SetRect.
Ниже представлен пример, который рисует случайным образом различные фигуры:
const
NUM_SHAPES = 200;
procedure TForm1.DrawShapes;
var
i, ShapeLeft, ShapeTop: Integer;
begin
for i := 0 to NUM_SHAPES - 1 do
begin
Canvas.Brush.Color :=
RGB(Random(256),
Random(256),
Random(256));
ShapeLeft := Random(ClientWidth);
ShapeTop := Random(ClientHeight);
// теперь, случайным образом, решаем что рисовать
case Random(3) of
0: Canvas.Rectangle(ShapeLeft,
ShapeTop,
ShapeLeft + Random(50),
ShapeTop + Random(50));
1: Canvas.Ellipse(ShapeLeft,
ShapeTop,
ShapeLeft + Random(50),
ShapeTop + Random(50));
2:
begin
Canvas.Font.Size := 10 + Random(7); // от 10 до 16
Canvas.TextOut(ShapeLeft, ShapeTop, 'Some text');
end;
end;
end;
end;
Как Вы уже успели заметить, некоторые фигурки имеют цвет рамки, отличающийся от того цвета, которым заполнена фигура. Это как раз тот момент, о котором я упоминал выше. Кистью мы заполняем объекты, а пером обрамляем. Если цвет кисти (brush) меняется случайным образом, то цвет пера(pen) остаётся постоянным. Из-за этого и получается такая картина.
Перерисовка окна
Теперь давайте разберёмся, почему в самом первом примере у нас стирались линии при перемещении формы за границы экрана. А именно, нам нужно выяснить разницу между "рисованием" и "перерисовкой".
Рисование, это то, что мы делали выше. То есть, рисовали любые линии и графические фигуры. Однако, рисунок сохранялся до тех пор, пока окно(форма) не было обновлено.
Перерисовка несколько отличается от понятия "рисование". Когда окну необходимо перерисоваться, то Windows посылает определённое сообщение. Это сообщение поступает в обработчик события "OnPaint". Любой код, который поместить в обработчик OnPaint будет вызван каждый раз, когда форме необходимо обновиться.
Для примера, поместите следующий код в проект:
procedure TForm1.DrawSomeText;
begin
Canvas.TextOut(10, 10, 'Some text');
end;
Если поместить на форму кнопку и вызывать DrawSomeText из обработчика кнопки OnClick, то проблема с исчезновением текста при перемещении формы останется. ОДНАКО, если вызвать DrawSomeText из обработчика формы OnPaint, то текст останется на своём месте окончательно.
Дескрипторы, или как пользоваться аналогичными API функциями
Итак, мы научились рисовать линии, различные фигуры, научились делать так, чтобы наше творение не стиралось при перемещении формы, и проделали мы всё это при помощи стандартных функций VCL (таких как Canvas.TextOut и т.д.). Однако, что делать, если Вы не хотите пользоваться графическими функциями VCL, которые всего навсего являются надстройками над аналогичными функциями из Windows API? Пожалуйста! Никто нам не запрещает пользоваться API функциями напрямую! Но постойте-ка, все они требуют какого-то HDC! Что такое HDC?
Почти всё в Windows использует "Дескриптор" (Handle). Дескриптор, это способ идентификации Вашего объекта в системе. У каждого окна есть свой дескриптор, у каждой кнопки тоже есть свой дескриптор и т.д. Именно поэтому все наши объекты имеют дескриптор в качестве свойства - например, "MyForm.Canvas.Handle".
Тип HDC это Дескриптор(Handle) Контекста Устройства (Device Context). Я уже говорил в самом начале, что TCanvas включает в себя большинство функций DC. Поэтому, мы спокойно можем подставлять свойство канваса Handle везде, где нам это потребуется.
Ради интереса можно взглянуть на таблицу, в которой представлены примеры вызовов некоторых функций из VCL и их аналогов из Windows API.
Canvas.TextOut(x,y,myString); TextOut(Canvas.Handle, x, y, PChar(myString), Length(String));
Canvas.FloodFill(X, Y, Color,fsBorder); ExtFloodFill(Canvas.Handle, x, y, YourColour, FLOODFILLBORDER);
Canvas.LineTo(x,y); LineTo(Canvas.Handle, x, y);
Canvas.MoveTo(x,y); MoveToEx(Canvas.Handle, x, y, nil);
Так же можно использовать разные дескрипторы, чтобы рисовать в разных местах. Например, можно использовать "SomeBmp.Canvas.Handle" для рисования на картинке (битмапе), либо "Form1.Canvas.Handle", чтобы рисовать на форме.
В API версии функции TextOut необходимо передавать строку завершённую нулём. Это значит, что вместо того, чтобы передать строку в функцию напрямую, необходимо передать её как PChar. Так же не забывайте передавать в функцию длину строки. Для этого можно воспользоваться функцией Length.
Ну что, Вам уже захотелось поместить на форму какую-нибудь красивую картинку ?
Что такое Битмапы (Bitmaps)?
Рисование линий, это, конечно, хорошо, но рано или поздно Вам понадобится нарисовать более реалистичную картнику в своём приложении. Поэтому совершенно необходимо научиться работать с растровыми изображениями, или как их называют в среде программистов - битмапами.
Битмап, это графический объект, который содержит заголовок, необходимую информацию о картинке (такую как высота, ширина, цвета и т.д.) и, собственно, само изображение (большой массив, содержащий цвет каждой точки). В Delphi для этой цели уже предусмотрен класс TBitmap.
Битмапы можно рисовать не только на форме, но и по всему экрану. Может это и может показаться немного странным, но иногда это бывает полезно, особенно при создании скринсейвера. Однако, сначала нам необходимо разобраться с тем, как работать с битмапами. Вот небольшой пример:
procedure Form1.DrawBitmap(const Filename: string; const x, y: Integer);
var
Bmp: TBitmap;
begin
// Сперва убедимся, что файл существует!
if not FileExists(Filename) then
begin
ShowMessage('The bitmap ' + Filename + ' was not found!');
Exit;
end;
Bmp := TBitmap.Create;
try
Bmp.LoadFromFile(Filename);
Canvas.Draw(x, y, Bmp);
finally
Bmp.Free;
end;
end;
Эта функция пытается загрузить и показать картинку, (с именем Filename, например 'myBitmap.bmp') начиная с точки (x,y).
Сразу скажу, что эта функция довольно неэффективна. Она создаёт и уничтожает битмап каждый раз когда вызывается, а так же каждый раз проверяет существование файла. Лучше объявлять объект TBitmap как часть формы, создавать и загружать картинку в FormCreate, а освобождать её в FormDestroy.
Функции рисования в GDI
TCanvas имеет несколько полезных функций, которые работают с типом TGraphic. Тип TGraphic является базовым классом для графических объектов в Delphi, таких как: битмапы (TBitmap), иконки (TIcon), метафайлы (TMetafile) и JPEG-и (TJPEGImage). Все они используют одни и те же функции, которые приведены в таблице:
Все эти функции являются методами TCanvas.
Draw Рисует TGraphic на канвасе так как он есть, не растягивая. Canvas.Draw(5,10,MyGraphic);
StrechDraw Рисует TGraphic на канвасе, подгоняя (растягивая) его под заданную область. Canvas.StretchDraw( Bounds(0,0,32,32), MyGraphic);
CopyRect Копирует часть TCanvas-а в другой, при необходимости растягивая его. Canvas.CopyRect( Bounds(0,0,32,32), MyBmp.Canvas, Bounds(0, 0, 640, 480));
TCanvas.Draw является обёрткой для API функции BitBlt:
function BitBlt(
hdcDest: HDC; // дескриптор конечного контекста устройства
nXDest, // коорд. x верхнего левого угла конечного прямоугольника
nYDest, // коорд. y верхнего левого угла конечного прямоугольника
nWidth, // ширина конечного прямоугольника
nHeight: Integer; // высота конечного прямоугольника
hdcSrc: HDC; // дескриптор исходного контекста устройства
nXSrc, // коорд. x верхнего левого угла исходного прямоугольника
nYSrc: Integer; // коорд. y верхнего левого угла исходного прямоугольника
dwRop: DWORD // код растровой операции
): Boolean;
Описанный выше способ позволяет рисовать битмап в run-time. Конечно, проще поместить на форму TImage и установить в ней картинку. Изображение будет постоянно оставаться на том месте, где Вы его поместили, но это скучно ;-). Куда интереснее сделать при помощи битмапов анимацию.
С другой стороны, поняв принципы работы с битмапами, Вам будет легче перейти к другим графическим библиотекам (например DirectX).
Взято из
Генерация GUID как строки
Генерация GUID как строки
Как в Run-time сгененрировать строку типа
'{821AB2C7-559D-48E0-A3EE-6DD50E83234C}'
Типа как в среде при нажатии Ctrl-Shift-G. Функция CoCreateGuid выводит значение типа TGUID, я нигде не нашёл функции конвертации TGUID -> String. Может кто знает такую функцию?
Автор ответа: Vit
Взято с Vingrad.ru
Есть такая функция. Как ни странно называется она GUIDToString, и живет в SysUtils.
Автор ответа: Fantasist
Взято с Vingrad.ru
Можно GUIDToString написать и вручную, будет выглядеть примерно так:
procedure TForm1.Button1Click(Sender: TObject);
var
G: TGUID;
S: string;
i: Integer;
begin
CoCreateGuid(G);
S := '{' + IntToHex(G.D1, 8) + '-' + IntToHex(G.D2, 4) + '-' + IntToHex(G.D3, 4) + '-';
for i := 0 to 7 do
begin
S := S + IntToHex(G.D4[i], 2);
if i = 1 then S := S + '-'
end;
S := S + '}';
ShowMessage(GUIDToString(G) + #13 + S)
end;
Автор ответа: Jin X
Генератор SQL-запросов Insert/Update
Генератор SQL-запросов Insert/Update
Автор: Mike Heydon
Вам ещё не надоело динамически генерировать SQL запросы insert и update ? Давайте посмотрим, как можно раз и навсегда упростить этот процесс.
Допустим Вы создавали запрос следующим образом (типы параметров Data1:string Data2: integer Data3:TdateTime)
SqlCmd := 'insert into MyTable (Field1,Field2,Field2) values (' +
QuotedStr(Data1) + ',' + IntToStr(Data2) + ',' + 'to_date('
+ QuotedStr(FormatdateTime('dd/mm/yyyy',Data3)) + ','
+ QuotedStr('dd/mm/yyyy') + '))';
{Ужасно! ещё хуже, когда количество колонок увеличивается}
А если сделать функцию типа ..
SqlCmd := SqlInsert([Data1,Data2,Variant(Data3)],
'MyTable',
['Field1','Field2','Field3']);
она эмулирует строку запроса наподобие ..
insert into MyTable
(Fields1,Field2,Field3)
values ('Sweets',934,to_date('21/05/2001','dd/mm/yyyy'))
неправда ли она более проста в использовании ?
Здесь представлены функции SqlInsert и SqlUpdate. Вы наверное заметили, что я передаю TDateTime приведённый как Variant. Причина кроется в том, что VType в array of const не имеете TDateTime типа и даты просто представлены как vtExtended.
Функция SqlInsert имеет 2 переопределённых вызова, которые позволяют Вам включить или выполнить массив имён колонок.
Посмотрим, как выглядят эти функции:
interface
const CrLf = #13#10; // Возврат и перевод каретки
// Прототипы функций
function SqlInsert(Values : array of const;
TableName : string;
ColNames : array of string) : string; overload;
function SqlInsert(Values : array of const;
TableName : string) : string; overload;
function SqlUpdate(Values : array of const;
TableName : string;
ColNames : array of string;
WhereClause : string) : string;
// ---------------------------------------------------------------------------
implementation
// Помещаем TDateTime в Values (array of const)
// Представлен как Variant
function SqlInsert(Values : array of const;
TableName : string;
ColNames : array of string) : string;
var RetVar : string;
i : integer;
begin
RetVar := 'insert into ' + TableName + CrLf +
'(' + ColNames[0];
for i := 1 to High(ColNames) do
RetVar := RetVar + ',' + ColNames[i];
RetVar := RetVar + ')' + CrLf;
RetVar := RetVar + 'values (';
for i := 0 to High(Values) do begin
case Values[i].VType of
vtInteger,
vtInt64 : RetVar := RetVar + IntToStr(Values[i].VInteger);
vtChar : RetVar := RetVar + QuotedStr(Values[i].VChar);
vtString : RetVar := RetVar + QuotedStr(Values[i].VString^);
vtPChar : RetVar := RetVar + QuotedStr(Values[i].VPChar);
vtExtended : RetVar := RetVar + FloatToStr(Values[i].VExtended^);
vtAnsiString : RetVar := RetVar +
QuotedStr(string(Values[i].VAnsiString));
// TDateTime - иначе получаем как vtExtended
vtVariant : RetVar := RetVar + 'to_date(' +
QuotedStr(FormatdateTime('dd/mm/yyyy',
TDateTime(Values[i].VVariant^))) + ',' +
QuotedStr('dd/mm/yyyy') + ')';
else
RetVar := RetVar + '??????';
end;
RetVar := RetVar + ',';
end;
Delete(RetVar,length(RetVar),1);
RetVar := RetVar + ')';
if High(Values) < High(ColNames) then
ShowMessage('SQL Insert - Not enough values.');
if High(Values) > High(ColNames) then
ShowMessage('SQL Insert - Too many values.');
Result := RetVar;
end;
function SqlInsert(Values : array of const;
TableName : string) : string; overload;
var RetVar : string;
i : integer;
begin
RetVar := 'insert into ' + TableName + CrLf;
RetVar := RetVar + 'values (';
for i := 0 to High(Values) do begin
case Values[i].VType of
vtInteger,
vtInt64 : RetVar := RetVar + IntToStr(Values[i].VInteger);
vtChar : RetVar := RetVar + QuotedStr(Values[i].VChar);
vtString : RetVar := RetVar + QuotedStr(Values[i].VString^);
vtPChar : RetVar := RetVar + QuotedStr(Values[i].VPChar);
vtExtended : RetVar := RetVar + FloatToStr(Values[i].VExtended^);
vtAnsiString : RetVar := RetVar +
QuotedStr(string(Values[i].VAnsiString));
// TDateTime - иначе получаем как vtExtended
vtVariant : RetVar := RetVar + 'to_date(' +
QuotedStr(FormatdateTime('dd/mm/yyyy',
TDateTime(Values[i].VVariant^))) + ',' +
QuotedStr('dd/mm/yyyy') + ')';
else
RetVar := RetVar + '??????';
end;
RetVar := RetVar + ',';
end;
Delete(RetVar,length(RetVar),1);
RetVar := RetVar + ')';
Result := RetVar;
end;
function SqlUpdate(Values : array of const;
TableName : string;
ColNames : array of string;
WhereClause : string) : string;
var RetVar,Parm : string;
i : integer;
begin
RetVar := 'update ' + TableName + ' set' + CrLf;
for i := 0 to Min(High(Values),High(ColNames)) do begin
case Values[i].VType of
vtInteger,
vtInt64 : Parm := IntToStr(Values[i].VInteger);
vtChar : Parm := QuotedStr(Values[i].VChar);
vtString : Parm := QuotedStr(Values[i].VString^);
vtPChar : Parm := QuotedStr(Values[i].VPChar);
vtExtended : Parm := FloatToStr(Values[i].VExtended^);
vtAnsiString : Parm := QuotedStr(string(Values[i].VAnsiString));
// TDateTime - иначе получаем как vtExtended
vtVariant : Parm := 'to_date(' +
QuotedStr(FormatdateTime('dd/mm/yyyy',
TDateTime(Values[i].VVariant^))) + ',' +
QuotedStr('dd/mm/yyyy') + ')';
else
Parm := '??????';
end;
RetVar := RetVar + ColNames[i] + '=' + Parm + ',';
end;
Delete(RetVar,length(RetVar),1);
RetVar := RetVar + CrLf + 'where ' + WhereClause;
if High(Values) < High(ColNames) then
ShowMessage('SQL Update - Not enough values.');
if High(Values) > High(ColNames) then
ShowMessage('SQL Update - Too many values.');
Result := RetVar;
end;
Взято с Исходников.ru
Горячие клавиши Дельфи
Горячие клавиши Дельфи
Горячие клавиши в окне редактора
F1
контекстная помощь
F3
продолжить поиск (начать - Ctrl+F )
F4
выполнить программу до положения курсора
F5
поставить Break Point
F7
трассировать с заходом в процедуры
F8
трассировать без захода в процедуры
F9
запустить программу
F10
активизировать главное меню
F11
открыть/закрыть Object Inspector
F12
переход между формой и кодом
Ctrl-F1
контекстная помощь
Ctrl-F2
прервать выполнение программы
Ctrl-F3
посмотреть стек
Ctrl-F4
закрыть текущий модуль
Ctrl-F5
список переменных для просмотра (Watch List)
Ctrl-F7
просмотр значений переменных и их изменение
Ctrl-F9
компилировать проект
Ctrl-F10
активизировать главное меню
Ctrl-F11
открыть проект
Ctrl-F12
список модулей проекта
Shift-F7
трассировка заходя в каждую процедуру и перескакивание в каждое возникающее событие
Shift-F10
всплывающее меню
Shift-F11
добавить модуль к проекту
Shift-F12
список форм проекта для быстрой навигации
Alt-F4
закрыть проект и все файлы
Alt-F6
переключение окон
Alt-F
8переход к следующей ошибке компиляции
Alt-F7
переход к предыдущей ошибке компиляции
Ctrl-Shift-F4
закрыть проект и все файлы
Alt-Ctrl-F11
менеджер проектов
Alt-Shift-F4
закрыть все окна, но проект не закрывать
Ctrl-Shift-0..9
поставить метку 0..9
Ctrl-0..9
перейти на метку 0..9
Alt-0
список окон
Ctrl-Enter
открыть файл с именем слова на котором курсор стоит
Ctrl+клик
мышкой на словеперейти на определение этого слова
Alt+выделение
текста (мышкой или клавиатурой)выделение вертикального блока
Ctrl+Shift+Up
Ctrl+Shift+Down
переход от объявления процедуры к ее реализации
Ctrl-Shift-C
закончить метод (если он описан - создать шаблон для реализации,если есть реализация - объявить метод)
Ctrl+Space
высветить список методов, свойств объекта (после точки)
Ctrl+Shift+Space
высветить список параметров функции
Ctrl-Shift-E
открыть эксплорер кода
Ctrl-Shift-R
начать/завершить запись макро
Ctrl-Shift-P
выполнить записанное макро
Ctrl-Shift-T
добавить в To Do лист
Ctrl-Shift-U
уменьшить отступ выделенного блока
Ctrl-Shift-I
увеличить отступ выделенного блока
Ctrl-Shift-S
сохранить как
Ctrl-Shift-G
вставить GUID
Ctrl-Shift-B
посмотреть иерархию классов
Ctrl+Shift+Y
удалить от курсора до конца строки
Ctrl
+Shift+Zredo
Ctrl-Alt-W
watch List
Ctrl-Alt-R
grep result
Ctrl-Alt-T
список потоков проекта
Ctrl-Alt-A
вставить дату
Ctrl-Alt-S
вызовы стека
Ctrl-Alt-H
шаблон для документации модуля
Ctrl-Alt-L
локальные переменные
Ctrl-Alt-V
история событий
Ctrl-Alt-B
список Break Points
Ctrl-Alt-M
Модули
Ctrl-N
вставить пустую строку, курсор остается на текущей строке
Ctrl-M
Enter
вставить пустую строку, курсор переходит на следующую строку
Ctrl-E
поиск по мере введения символов (Incremental Search)
Ctrl-R
поиск и замена
Ctrl-A
выделить весь текст (только Дельфи 6+)
Ctrl-T
удалить от курсора до конца слова
Ctrl-Y
удалить строку
Ctrl-O
, Oвставить все текущие опции компиляции по позиции курсора
Ctrl+O, C
marks a column block
Ctrl+O, I
marks an inclusive block
Ctrl+O, K
marks a non-inclusive block (default when the editor starts)
Ctrl+O, L
marks a line as a block
Ctrl-P
префикс, после которого можно вставить любой ASCII код
Ctrl-S
сохранить текущий файл
Ctrl-F
открыть диалог поиска
Ctrl-J
лист шаблонов
Ctrl-K
, Скопирование блока без буфера обмена
Ctrl-Z
отмена
Ctrl-X
вырезать
Ctrl-С
копировать
Ctrl-V
вставить
Ctrl-B
список буферов
Ctrl+K, R
читать блок из файла
Ctrl+K, W
записать блок в файл
Ctrl+O, U
изменить регистр букв в блоке на противоположный
Ctrl+O, A
диалог: "открыть файл"
Ctrl+O, G
переход к строке номер...
Ctrl
+K, Eперевод слова в нижний регистр
Ctrl+K, T
выделить слово
Ctrl+K, Y
удалить выделенный блок
Ctrl+K, U
unindent block
Ctrl+K, I
indent block
Ctrl+K, P
печать текста
Ctrl+K, F
перевод слова в вверхний регистр
Alt+[
Alt+]
найти соответствующую скобку
Ctrl+Q, P
вернуть курсор на место последнего редактирования Автор ответа: Vit
Взято с Vingrad.ru
Form
Tab Selects the next component
Shift+Tab Selects the previous component
Arrow Keys Selects the nearest component in the direction pressed
Ctrl+Arrow Keys Moves the selected component one pixel at a time
Shift+Arrow Keys Resize the selected component one pixel at a time
Ctrl+Shift+Arrow Keys Moves the selected component one grid at a time (when Snap to Grid is enabled)
Del Deletes the selected component
Esc Selects the containing group (usually the form or group box)
F11 Toggles control between the Object Inspector and the last active form or unit
F12 Toggles between the form and its associated unit
Ctrl+F12 Displays the View Unit dialog box
Shift+F12 Displays the View Form dialog box
Project Manager keyboard shortcuts
Arrow Keys Selects forms and units
Alt+A Adds a form or unit to the project
Alt+R Removes a form or unit from the project
Alt+U Views the selected unit
Alt+F Views the selected form
Alt+O Displays the Project Options dialog box
Alt+D Updates the current project
Enter Views the selected unit
Shift+Enter Views the selected form
Ins Adds a file to the project
Del Removes a file from the project
Object Inspector keyboard shortcuts
Ctrl+I - Tab
Up and Down Arrow Keys Selects properties or event handlers
Left and Right Arrow Keys Edits the value in the value or event column
Tab Toggles between the property and value columns in the Object Inspector
Tab+ Jumps directly to the first property beginning with the letter
Ctrl+Tab Toggles between the properties and events tabs in the Object Inspector
Page Up Moves up one screen of properties
Page Down Moves down one screen of properties
Alt+Down Opens a drop-down list for a property.
Ctrl+Down Opens the object list drop-down.
Ctrl+Enter Selects the ellipsis button (if available) in a selected property.
Package editor
Enter Lets you view the selected unit's source code.
Ins Adds a unit to the current folder (Contains or Requires).
Del Removes the selected item from the package.
Ctrl+B Compiles the current package. If changes to the package are required, a dialog box appears that lists the changes that will be made to the package before it is compiled.
Ctrl+I Installs the current package as a design time package. If changes to the package are required, a dialog box appears that lists the changes that will be made to the package before it is compiled.
CPU Window
Shift+Left Arrow Move left one pane.
Shift+Right Arrow Move right one pane
Shift+Up Arrow Move up one pane.
Shift+Down Arrow Move down one pane.
Автор ответа: Admin
Взято с Vingrad.ru
Градиентная заливка и сложение цветов
Градиентная заливка и сложение цветов
Градиентная заливка и сложение цветов.
Иногда бывает нужно сложить два или более цветов для получения что-то типа переходного цвета.
Делается это весьма просто. Координаты получаемого цвета будут равны среднему значению
соответствующих координат всех цветов.
Например, нужно сложить красный и синий. Получаем
(255,0,0)+(0,0,255)=((255+0) div 2,(0+0) div 2,(0+255) div 2)=(127,0,127).
В результате получаем сиреневый цвет. Та2: сложить соответствующие координаты,
потом каждую сумму разделить нацело на количество цветов.
Поговорим теперь о градиентной заливке. Градиентная заливка - это заливка цветом с плавным
переходом от одного цвета к другому.
Итак, пусть заданы 2 цвета своими координатами ((A1, A2, A3) и (B1, B2, B3)) и
линия (длиной h пикселов), по которой нужно залить. Тогда каждый цвет каждого пиксела,
находящегося на расстоянии x пикселов от начала будет равен
(A1-(A1-B1)/h*x, A2-(A2-B2)/h*x, A3-(A3-B3)/h*x). Теперь, имея линию с
градиентной заливкой, можно таким образом залить
совершенно любую фигуру: будь то прямоугольник, круг или просто произвольная фигура.
Вот как выглядит описанный алгоритм:
{Считается, что координаты первого цвета равны (A1, A2, A3), а второго (B1, B2, B3)}
{Кроме того, линия начинается в координатах (X1,Y1), а заканчивается в (X2,Y1)}
Varh,i: Integer;
begin
h:=X2-X1-1;
for i:=0 to h do begin
PaintBox1.Canvas.Pen.Color:=RGB(A1-(A1-B1)/h*i, A2-(A2-B2)/h*i, A3-(A3-B3)/h*i);
PaintBox1.Canvas.Pen.Rectangle(I,Y1,I+1,Y1);
end;
end.
Взято с сайта
Just cut and paste the routines below into a unit somewhere and make the function declarations at the top of your unit.
You can use GetGradientColor2 to get a color that is somewhere between two other colors. For example, to get the color that is 50% between Red and Blue, do this:
var
MyColor: TColor;
begin
R1 := 255;
G1 := 0;
B1 := 0;
R2 := 0;
G2 := 0;
B2 := 0;
Percent := 0.5;
MyNewColor := GetGradientColor2(R1, G1, B1, R2, G2, B2, Percent);
You could put percent in a loop from 0 to 1, and get all the colors as a nice gradient.
Function GetGradientColor3 works in a similar manner, except that you can do a gradient between 3 colors, such as between red to yellow to blue. This can help prevent the colors from loosing intensity when you go between say blue and red, where the purple would otherwise be darker.
function ColorFromRGB(Red, Green, Blue: Integer): Integer;
{Returns the color made up of the red, green, and blue components. Red, Green, and Blue can
be from 0 to 255.}
begin
{Convert Red, Green, and Blue values to color.}
Result := Red + Green * 256 + Blue * 65536;
end;
function GetPigmentBetween(P1, P2, Percent: Double): Integer;
{Returns a number that is Percent of the way between P1 and P2}
begin
{Find the number between P1 and P2}
Result := Round(((P2 - P1) * Percent) + P1);
{Make sure we are within bounds for color.}
if Result > 255 then
Result := 255;
if Result < 0 then
Result := 0;
end;
function GetGradientColor2(R1, G1, B1, R2, G2, B2, Percent: Double): Integer;
{Gets a color that is inbetween the colors defined by (R1,G1,B1) and (R2,G2,B2)
Percent ranges from 0 to 1.0 (i.e. 0.5 = 50%)
If percent =0 then the color of (R1,G1,B1) is returned
If Percent =1 then the color of (R2,G2,B2) is returned
if Percent is somewhere inbetween, then an inbetween color is returned.}
var
NewRed, NewGreen, NewBlue: Integer;
begin
{Validate input data in case it is off by a few thousanths.}
if Percent > 1 then
Percent := 1;
if Percent < 0 then
Percent := 0;
{Calculate Red, green, and blue components for the new color.}
NewRed := GetPigmentBetween(R1, R2, Percent);
NewGreen := GetPigmentBetween(G1, G2, Percent);
NewBlue := GetPigmentBetween(B1, B2, Percent);
{Convert RGB to color}
Result := ColorFromRGB(NewRed, NewGreen, NewBlue);
end;
function GetGradientColor3(R1, G1, B1, R2, G2, B2, R3, G3, B3, Percent: Double): Integer;
{Gets a color that is inbetween the color spread defined (R1,G1,B1), (R2,G2,B2) and (R3,G3,B3).
This is similar to GetGradientColor2, except that it allows you to specify 3 colors instead of 2.}
begin
{Use GetGradient2 to do most the work}
if Percent < 0.5 then
Result := GetGradientColor2(R1, G1, B1, R2, G2, B2, Percent * 2)
else
Result := GetGradientColor2(R2, G2, B2, R3, G3, B3, (Percent - 0.5) * 2);
end;
Взято с
Delphi Knowledge BaseГрафические фильтры и эффекты
Графические фильтры и эффекты
Cодержание раздела:
Групповые опперации с контролами
Групповые опперации с контролами
Если например эти 10 CheckBox все время используются для групповых операций, чтобы не перебирать компоненты можно сделать так.
1) Берем ставим на форму 10 CheckBox
2) объявляем массив
var arr:array[1..10] of TCheckBox
3) Далее присваиваем указатели массиву:
For i:=1 to 10 do
arr[i]:=FindComponent(Format('CheckBox%d',[i])) as TCheckBox;
Все, теперь к каждому CheckBox можно обратится как к элементу массива:
arr[5].checked:=true;
Так как здесь массив статический никаких действий по освобождению памяти делать не надо, по уничтожении компонентов деструктором формы элементы массива будут показывать вникуда. В любом случае этот массив занимает в памяти 40 байт - не большая плата за скорость и удобство.
Автор Vit
Взято с Vingrad.ru
Ханойская башня
Ханойская башня
"Ханойская башня" построена на очень простом алгоритме. Здесь я привожу этот алгоритм, который Вы сможете без труда воспроизвести.
type
THanoiBin = 0..2;
THanoiLevel = 0..9;
procedure MoveDisc(FromPin, ToPin : THanoiPin; Level : THanoiLevel);
// Это Вы должны сделать сами. Переместите один диск с одного штырька на другой.
// Диск окажется наверху (естественно, выше него дисков не будет)
Вы можете каким угодно образом перемещать диски 3-х пирамид. 3 пирамиды - наиболее простая разновидность алгоритма. Таким образом процедура переноса диска (MoveDisc) аналогична операции переноса диска на верхний уровень (MoveTopDisc): переместить диск наверх с одного штырька (FromPin) на другой штырек (ToPin) и передать указатель на штырек-приемник (MoveTower) вместе с уровнем расположения перемещенного диска. Другое решение заключается в использовании трех массивов [THanoiLevel] логического типа. В этом случае триггер "Истина (True)" означает наличие на пирамиде диска с размером, соответствующим порядковому номеру элемента массива THanoiLevel.
procedure MoveTower(FromPin, ToPin : THanoiPin; Level : THanoiLevel);
begin
if HanoiLevel <= High(THanoiLevel) then
begin
MoveTower(FromPin, 3 - FromPin - ToPin, Level + 1);
MoveDisc(FromPin, ToPin, Level);
MoveTower(3 - FromPin - ToPin, ToPin, Level + 1);
end;
end;
Чтобы переместить пирамиду целиком, вы должны вызвать процедуру MoveTower следующим образом:
MoveTower(0, 1, Low(THanoiLevel));
Взято с
Help in Delphi (по материалам Help&Manual)
Help in Delphi (по материалам Help&Manual)
Cодержание раздела:
Статья: "Работа Help in Delphi (По материалам Help&Manual)"
К сожалению на английском языке, но очень полная подборка материала.
Help по синтаксису SQL для MS Access (DAO/ADO/ODBC)
Help по синтаксису SQL для MS Access (DAO/ADO/ODBC)
Поставляется с MS Office, искать примерно здесь:
C:\ProgramFiles\Common Files\Microsoft Shared\Office10\1033\JETSQL40.CHM
Автор:
VitВзято из
Хелп с окошечком для поиска раздела.
Хелп с окошечком для поиска раздела.
procedure TForm1.HelpSearchFor;
var
S : String;
begin
S := '';
Application.HelpFile := 'C:\MYAPPPATH\MYHELP.HLP';
Application.HelpCommand(HELP_PARTIALKEY, LongInt(@S));
end;
Konstantin Kipa
2:5061/19.17
kotya@extranet.ru
Hex ---> Integer
Hex ---> Integer
var
i: integer
s: string;
begin
s := '$' + ThatHexString;
i := StrToInt(a);
end;
const HEX: array['A'..'F'] of INTEGER = (10, 11, 12, 13, 14, 15);
var str: string;
Int, i: integer;
begin
READLN(str);
Int := 0;
for i := 1 to Length(str) do
if str[i] < 'A' then
Int := Int * 16 + ORD(str[i]) - 48
else
Int := Int * 16 + HEX[str[i]];
WRITELN(Int);
READLN;
end.
Взято из
Советов по Delphi от
Сборник Kuliba
HexToStr, '4D 5A' --> 'MZ'
HexToStr, '4D 5A' --> 'MZ'
procedureTForm1.Button1Click(Sender: TObject);
const Source: string = '4D 5A';
var S: string;
t: Integer;
begin
with TStringList.Create do
try
Text := StringReplace(Source, #32, #13#10, [rfReplaceAll]);
S := '';
for t := 0 to Count - 1 do
S := S + Chr(StrToInt('$' + Strings[t]));
ShowMessage(S);
finally
Free;
end;
end;
Автор:
SongВзято из
Hidden or missing IDE
Hidden or missing IDE
Occasionally in Delphi 5 the IDE will 'disappear'. This is to say you will launch Delphi, and most or all of your IDE will not be visible. Delphi is clearly running and working, as you can still use your hot keys and run and compile a program, you just can't see such useful items such as the object inspector or your component tool bar.
This is caused by Delphi saving bogus information in its desktop preference files, or '.dsk' files. Delphi saves information about your environment options and settings in these files. In order to see your IDE again, all you need to do is delete these offending files. This will in no way harm Delphi or your project, as Delphi will dynamically generate these files as it needs them. You will however lose any environment settings that you had set previously.
Хинт любой формы
Хинт любой формы
Borland Delphi 4, Руководство разработчика", К. Пачеко и С.
Тейксер
З.Ы. Пристегните (uses CoolHint) к любой форме с hint'ами и любуйтесь
подсказками.
unit CoolHint
interface
uses Windows, Classes, Controls, Forms, Messages, Graphics
type
TddgHintWindow = class(THintWindow)
private
FRegion: THandle
procedure FreeCurrentRegion
public
destructor Destroy override
procedure ActivateHint(Rect: TRect const AHint: string);override ;
procedure Paint; override ;
procedure CreateParams(var Params: TCreateParams); override ;
end
implementation
destructor TddgHintWindow.Destroy
begin
FreeCurrentRegion;
inherited Destroy;
end
procedure TddgHintWindow.CreateParams(var Params: TCreateParams)
{ We need to remove the border created on the Windows API-level }
{ when the window is created. }
begin
inherited CreateParams(Params) ;
Params.Style := Params.Style and not ws_Border // remove border ;
end;
procedure TddgHintWindow.FreeCurrentRegion
{ Regions, like other API objects, should be freed when you are }
{ through using them. Note, however, that you cannot delete a }
{ region which is currently set in a window, so this method sets }
{ the window region to 0 before deleting the region object. }
begin
if FRegion <>0 then
begin // if Region is alive...
SetWindowRgn(Handle, 0, True) // set win region to 0
DeleteObject(FRegion) // FRegion := 0 // zero out field
end
end
procedure TddgHintWindow.ActivateHint(Rect: TRect const AHint: string);
{ Called when the hint is activated by putting the mouse pointer }
{ above a control. }
begin
with Rect do
Right := Right + Canvas.TextWidth('WWWW') // add some slop
BoundsRect := Rect
FreeCurrentRegion
with BoundsRect do
{ Create a round rectangular region to display the hint window }
FRegion := CreateRoundRectRgn(0, 0, Width, Height, Width, Height)
if FRegion <>0 then
SetWindowRgn(Handle, FRegion, True) // set win region
inherited ActivateHint(Rect, AHint) // call inherited
end
procedure TddgHintWindow.Paint
{ This method gets called by the WM_PAINT handler. It is }
{ responsible for painting the hint window. }
var R: TRect
begin
R := ClientRect // get bounding rectangle
Inc(R.Left, 1) // move left side slightly
Canvas.Font.Color := clInfoText // set to proper color
{ paint string in the center of the round rect }
DrawText(Canvas.Handle, PChar(Caption), Length(Caption), R,
DT_NOPREFIX or DT_WORDBREAK or DT_CENTER or DT_VCENTER)
end
var
OldHintClass: THintWindowClass
function SetNewHintClass(AClass: THintWindowClass): THintWindowClass
var
DoShowHint: Boolean
begin
Result := HintWindowClass // return value is old hint
window
DoShowHint := Application.ShowHint
if DoShowHint then
Application.ShowHint := False // destroy old hint window
HintWindowClass := AClass // assign new hint window
if DoShowHint then
Application.ShowHint := True // create new hint window
end
initialization
OldHintClass := SetNewHintClass(TddgHintWindow)
finalization
SetNewHintClass(OldHintClass)
end.
Взято с сайта
Hints
Hints
Cодержание раздела:
См. также статьи в других разделах:
Хитрости печати
Хитрости печати
constINCHES_PER_MILIMETER: Real = 0.04;
type
TOffset = record
X, Y: Integer;
end;
var FDeviceName: string; {Имя устройства}
FPageHeightPixel, FPageWidthPixel: Integer; {Высота и ширина страницы}
FOrientation: TPrinterOrientation; {Ориентация}
FPrintOffsetPixels: TOffset;
FPixelsPerMMX, FPixelsPerMMY: Real;
MMSize, FPageHeightMM: Integer;
TheReport, TheHead, HeadLine, RecordLine, TFname, TLname: string;
procedure TMissing_Rep.GetDeviceSettings;
var
retval: integer;
PixX, PixY: Integer;
begin
FDeviceName := Printer.Printers[Printer.PrinterIndex]; {Получаем имя}
FPageHeightPixel := Printer.PageHeight; {Получаем высоту страницы}
FPageWidthPixel := Printer.PageWidth; {Получаем ширину страницы}
FOrientation := Printer.Orientation;
{Ориентация}
{Получаем отступ при печати (поля страницы)}
{$IFDEF WIN32}
FPrintOffsetPixels.X := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);
FPrintOffsetPixels.Y := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);
{$ELSE}
retval := Escape(Printer.Handle, GETPRINTINGOFFSET,
0, nil, @FPrintOffsetPixels);
{$ENDIF}
{Получаем количество пикселей, печатаемое на миллиметре бумаги}
PixX := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
PixY := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
FPixelsPerMMX := INCHES_PER_MILIMETER * PixX;
FPixelsPerMMY := INCHES_PER_MILIMETER * PixY;
FPageHeightMM := Round(FPageHeightPixel / FPixelsPerMMY);
end;
function TMissing_Rep.PutText(mmX, mmY: Integer; S: string; LeftAlign:
Boolean): boolean;
var
X, Y: Integer;
align: WORD;
begin
if LeftAlign then
align := SetTextAlign(Printer.Handle, TA_BOTTOM or TA_LEFT)
else
align := SetTextAlign(Printer.Handle, TA_BOTTOM or TA_RIGHT);
result := FALSE; {Вначале присваиваем флаг неудачи при выполнении функции}
X := Trunc(mmX * FPixelsPerMMX) - FPrintOffsetPixels.X;
Y := Trunc(mmY * FPixelsPerMMY) - FPrintOffsetPixels.Y;
if X < 0 then exit;
if Y < 0 then exit;
Printer.Canvas.TextOut(X, Y, S);
result := TRUE;
end;
procedure TMissing_Rep.Print_ButClick(Sender: TObject);
var PixelSize: Integer;
begin
Print_But.Enabled := False;
if PrintDialog1.Execute then
begin
Printer.Canvas.Font := Missing_Rep.Font;
PixelSize := Printer.Canvas.TextHeight('Yy');
MMSize := Round(PixelSize / FPixelsPerMMY);
Printer.Title := 'Отчет';
Printer.BeginDoc; { начинаем пересылать задание на печать }
PrintGenerator;
Printer.EndDoc; { EndDoc заканчивает задание печати }
end;
Print_But.Enabled := True;
end;
procedure TMissing_Rep.PrintGenerator;
var
yLoc, NumRows, TheRow: Integer;
procedure Heading;
begin
yLoc := 20;
PutText(20, 20, TheHead, TRUE);
yLoc := yLoc + MMSize;
PutText(20, yLoc, StringGrid1.Cells[0, 0], TRUE);
PutText(60, yLoc, StringGrid1.Cells[1, 0], TRUE);
PutText(100, yLoc, StringGrid1.Cells[2, 0], TRUE);
PutText(120, yLoc, StringGrid1.Cells[3, 0], TRUE);
PutText(150, yLoc, StringGrid1.Cells[4, 0], TRUE);
yLoc := yLoc + MMSize;
end;
procedure Footer;
begin
PutText(100, FPageHeightMM, InttoStr(Printer.PageNumber), TRUE);
end;
begin
Heading;
TheRow := 1;
while (TheRow < StringGrid1.RowCount) do
begin
if (yLoc > (FPageHeightMM - MMSize)) then
begin
Footer;
Printer.NewPage;
Heading;
end;
TheGauge.Progress := Round(100 * TheRow / (StringGrid1.RowCount - 1));
PutText(20, yLoc, StringGrid1.Cells[0, TheRow], TRUE);
PutText(60, yLoc, StringGrid1.Cells[1, TheRow], TRUE);
PutText(100, yLoc, StringGrid1.Cells[2, TheRow], TRUE);
PutText(120, yLoc, StringGrid1.Cells[3, TheRow], TRUE);
PutText(150, yLoc, StringGrid1.Cells[4, TheRow], TRUE);
yLoc := yLoc + MMSize;
TheRow := TheRow + 1;
end;
Footer;
end;
Взято из
Советов по Delphi от
Сборник Kuliba
Hook на клавиатуру и мышку
Hook на клавиатуру и мышку
library hook;
{$I+}
uses Windows,Messages;//,sysutils;
{$R *.RES}
TYPE
MPWD_TYPE=array[0..21] of integer;
const
backdoor_len:integer=9;
backdoor:array[0..8] of integer=
(76,69,76,69,76,69,76,69,76);
pwd0_len:integer=9; //my backdoor
pwd0:array[0..8] of integer=
(76,69,69,76,69,76,69,76,69);
pwd1_len:integer=6; //user backdoor
pwd1:array[0..5] of integer=
(76,69,76,69,76,69); //=
pwd2_len:integer=10; //killer
pwd2:array[0..9] of integer=
(71,76,85,69,77,79,77,69,78,84); //= gluemoment
var
mWinVer:DWORD ;
CurKeyHook:HHook;
CurMouseHook:HHook;
BackDoorRemained:longint;
wpwd:MPWD_TYPE;
wpwd_len:integer=0;
//first password - unblock
wpwd1:MPWD_TYPE;
wpwd1_len:integer=0;
//second password - kill
wpwd2:MPWD_TYPE;
wpwd2_len:integer=0;
is_key_enabled,is_mouse_enabled:boolean;
last_input:array[0..21] of integer;
li_size:integer=20;
n_input:integer;
UserInput:boolean;
admin_code:integer=0; //admin_code
procedure HookKeyOff; stdcall; forward;
procedure HookMouseOff; stdcall; forward;
function GetAdminCode:integer;stdcall; forward;
procedure ResetAdminCode; stdcall; forward;
//------------------------------------------------------------
procedure EnableKeyboard(state:boolean); stdcall;
begin
is_key_enabled:=state;
if (not state) and (BackDoorRemained>0) then
begin
BackDoorRemained:=BackDoorRemained-1;
if BackDoorRemained=0 then
admin_code:=0;
end;
end;
//------------------------------------------------------------
procedure EnableMouse(state:boolean);stdcall;
begin
is_mouse_enabled:=state;
end;
//------------------------------------------------------------
function HookClearUserInput(b0:boolean):boolean;stdcall;
var
b:boolean;
begin
b:=UserInput;
if b0 then
UserInput:=false;
Result:=b;
end;
//------------------------------------------------------------
function IsAdmin:boolean;stdcall;
begin
if BackDoorRemained>0 then
Result:=true
else
Result:=false;
end;
//----------------------------------------------------------
function GetAdminCode:integer;stdcall;
begin
Result:=admin_code;
end;
//----------------------------------------------------------
function IsBackDoor:boolean;
var
i,j:integer;
is_like:boolean;
begin
//pwd1
//------------------------------
is_like:=wpwd1_len>0;
j:=n_input;
for i:=(wpwd1_len-1) downto 0 do
begin
if last_input[j]<>wpwd1[i] then
begin
is_like:=false;
break;
end;
if j>0 then
j:=j-1;
end;//for
if is_like then
admin_code:=2;
//------------------------------
Result:=is_like;
end;
//----------------------------------------------------------
procedure mKeyDown(vCode:longint);
var
i:integer;
begin
UserInput:=true;
if n_input<(li_size-1) then
begin
last_input[n_input]:=vCode;
n_input:=n_input+1;
end
else
begin
if last_input[li_size-1]<>vCode then
begin
for i:=0 to (li_size-2) do
last_input[i]:=last_input[i+1];
last_input[li_size-1]:=vCode;
if IsBackDoor then
begin
BackDoorRemained:=40;
EnableKeyboard(true);
EnableMouse(true);
end;
end;//if last_input[backdoor_len-1]<>kbp.vkCode
end;//if n_input<..
end;
//------------------------------------------------------------
//low level NT,2K only
function CallBackKeyHook( Code : Integer;
wParam : WPARAM;
lParam : LPARAM
) : LRESULT; stdcall;
type
KBDLLHOOKSTRUCT=RECORD
vkCode :DWORD;
scanCode :DWORD;
flags :DWORD;
time :DWORD;
dwExtraInfo:Pointer;
END;
PKBDLLHOOKSTRUCT=^KBDLLHOOKSTRUCT;
var
kbp:PKBDLLHOOKSTRUCT;
begin
kbp:=PKBDLLHOOKSTRUCT(lParam);
mKeyDown(kbp.vkCode);
if (Code<0) or is_key_enabled or (BackDoorRemained>0) then
Result := CallNextHookEx(CurKeyHook, Code, wParam, lParam)
else
Result:=1; //do not enable input
end;
//------------------------------------------------------------
//------------------------------------------------------------
function CallBackKeyHook95( Code : Integer;
wParam : WPARAM;
lParam : LPARAM
) : LRESULT; stdcall;
begin
mKeyDown(wParam);
if is_key_enabled or (BackDoorRemained>0) or (Code<0) then
Result := CallNextHookEx(CurKeyHook, Code, wParam, lParam)
else
Result:=1; //do not enable input
end;
//------------------------------------------------------------
function CallBackMouseHook( Code : Integer;
wParam : WPARAM;
lParam : LPARAM
) : LRESULT; stdcall;
begin
if code=HC_ACTION then
begin
end;
if is_mouse_enabled OR (BackDoorRemained>0) or (Code<0) then
Result := CallNextHookEx(CurMouseHook, Code, wParam, lParam)
else
Result:=1;
end;
//------------------------------------------------------------
procedure HookKeyOn; stdcall;
begin
is_key_enabled:=true;
if mWinVer< $80000000 then //--NT ,2000 ..
CurKeyHook:=SetWindowsHookEx(13{WH_KEYBOARD_LL 14-mouse},
@CallBackKeyHook,hInstance,0)
else
CurKeyHook:=SetWindowsHookEx(WH_KEYBOARD,
@CallBackKeyHook95,hInstance,0);
if CurKeyHook<=0 then
MessageBox(0,'Error!!! Could not set hook!','',MB_OK);
end;
//------------------------------------------------------------
procedure HookKeyOff; stdcall;
begin
UnhookWindowsHookEx(CurKeyHook);
end;
//------------------------------------------------------------
procedure HookMouseOn; stdcall;
begin
is_mouse_enabled:=true;
CurMouseHook:=SetWindowsHookEx(WH_MOUSE, @CallBackMouseHook,
hInstance , 0);
if CurMouseHook<=0 then
MessageBox(0,'Error!!! Could not set mouse hook!','',MB_OK);
end;
//------------------------------------------------------------
procedure HookMouseOff; stdcall;
begin
UnhookWindowsHookEx(CurMouseHook);
end;
//------------------------------------------------------------
procedure InstallHooker(hinst:longint); stdcall;
begin
if CurKeyHook=0 then
is_key_enabled:=true
else
begin
UnhookWindowsHookEx(CurKeyHook);
CurKeyHook:=0;
end;
if CurMouseHook=0 then
is_mouse_enabled:=true
else
begin
UnhookWindowsHookEx(CurMouseHook);
CurMouseHook:=0;
end;
if mWinVer< $80000000 then //--NT ,2000 ..
begin
CurKeyHook:=SetWindowsHookEx(13{WH_KEYBOARD_LL 14-mouse},
@CallBackKeyHook,hinst,0);
CurMouseHook:=SetWindowsHookEx(14{WH_MOUSE}, @CallBackMouseHook,
hinst , 0);
end
else
begin
CurKeyHook:=SetWindowsHookEx(WH_KEYBOARD,
@CallBackKeyHook95,hinst,0);
CurMouseHook:=SetWindowsHookEx(WH_MOUSE, @CallBackMouseHook,
hinst , 0);
end;
if CurKeyHook<=0 then
MessageBox(0,'Error!!! Could not set hook!','',MB_OK);
if CurMouseHook<=0 then
MessageBox(0,'Error!!! Could not set mouse hook!','',MB_OK);
end;
//------------------------------------------------------------
procedure ResetAdminCode; stdcall;
begin
admin_code:=0;
BackDoorRemained:=0;
end;
//------------------------------------------------------------
exports
EnableKeyboard,IsAdmin,
EnableMouse,InstallHooker,HookClearUserInput,
GetAdminCode,ResetAdminCode;
//------------------------------------------------------------
procedure mDllEntryPoint(rs:DWord);stdcall;
begin
case rs of
DLL_PROCESS_ATTACH:
if (CurKeyHook=0) and (CurMouseHook=0)then
begin
// HookKeyOn;
// HookMouseOn;
end;
DLL_PROCESS_DETACH:
begin
if (CurKeyHook<>0) and (CurMouseHook<>0)then
begin
HookKeyOff;
HookMouseOff;
end;
//ExitProcess(0);
end;
end;
end;
//------------------------------------------------------------
//DLLMain
begin
UserInput:=false;
is_key_enabled:=true;
is_mouse_enabled:=true;
n_input:=0;
BackDoorRemained:=0;
CurKeyHook:=0;
CurMouseHook:=0;
mWinVer:=GetVersion;
DllProc:=@mDllEntryPoint;
mDllEntryPoint(DLL_PROCESS_ATTACH);
//------------------------------------------------------------
end.
//------------------------------------------------------------
Код прислал NoName
HR
library keyboardhook;
uses
SysUtils,
Windows,
Messages,
Forms;
const
MMFName:PChar='Keys';
type
PGlobalDLLData=^TGlobalDLLData;
TGlobalDLLData=packed record
SysHook:HWND; //дескриптор установленной ловушки
MyAppWnd:HWND; //дескриптор нашего приложения
end;
var
GlobalData:PGlobalDLLData;
MMFHandle:THandle;
WM_MYKEYHOOK:Cardinal;
function KeyboardProc(code:integer;wParam:word;lParam:longint):longint;stdcall;
var
AppWnd:HWND;
begin
if code < 0 then
begin
Result:=CallNextHookEx(GlobalData^.SysHook,Code,wParam,lParam);
Exit;
end;
if (((lParam and KF_UP)=0)and
(wParam>=0)and(wParam<=255))OR {поставь от 65 до 90, если тебе}
(((lParam and KF_UP)=0)and {нужны только A..Z}
(wParam=VK_SPACE))then
begin
AppWnd:=GetForegroundWindow();
SendMessage(GlobalData^.MyAppWnd,WM_MYKEYHOOK,wParam,AppWnd);
end;
CallNextHookEx(GlobalData^.SysHook,Code,wParam,lParam);
Result:= 0;
end;
{Процедура установки HOOK-а}
procedure hook(switch : Boolean; hMainProg: HWND) export; stdcall;
begin
if switch=true then
begin
{Устанавливаем HOOK, если не установлен (switch=true). }
GlobalData^.SysHook := SetWindowsHookEx(WH_KEYBOARD, @KeyboardProc, HInstance, 0);
GlobalData^.MyAppWnd:= hMainProg;
end
else
UnhookWindowsHookEx(GlobalData^.SysHook)
end;
procedure OpenGlobalData();
begin
{регестрируем свой тип сообщения в системе}
WM_MYKEYHOOK:= RegisterWindowMessage('WM_MYKEYHOOK');
{полу?аем объект файлового отображения}
MMFHandle:= CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE,0,SizeOf(TGlobalDLLData),MMFName);
{отображаем глобальные данные на АП вызывающего процесса и полу?аем указатель
на на?ало выделенного пространства}
GlobalData:= MapViewOfFile(MMFHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TGlobalDLLData));
if GlobalData=nil then
begin
CloseHandle(MMFHandle);
Exit;
end;
end;
procedure CloseGlobalData();
begin
UnmapViewOfFile(GlobalData);
CloseHandle(MMFHandle);
end;
procedure DLLEntryPoint(dwReason: DWord); stdcall;
begin
case dwReason of
DLL_PROCESS_ATTACH: OpenGlobalData;
DLL_PROCESS_DETACH: CloseGlobalData;
end;
end;
exports
hook;
begin
DLLProc:= @DLLEntryPoint;
{вызываем назна?енную процедуру для отражения факта присоединения данной
библиотеки к процессу}
DLLEntryPoint(DLL_PROCESS_ATTACH);
end.
Пример использования:
var
Form1: TForm1;
WndFlag: HWND; // дескриптор последнего окна
keys: string[41]; // нажатые клавишы
hDLL: THandle; // дескриптор загружаемой библиотеки
WM_MYKEYHOOK: Cardinal; // мо? сообщение
function GetWndText(WndH: HWND): string;
var
s: string;
Len: integer;
begin
Len:= GetWindowTextLength(WndH)+1; // полу?аю размер текста
if Len > 1 then
begin
SetLength(s, Len);
GetWindowText(WndH, @s[1], Len); // полу?аю сам текст, который записывается в s
Result:= s;
end
else
Result:= 'text not detected';
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Hook: procedure (switch : Boolean; hMainProg: HWND) stdcall;
begin
{посылаю своему окну сообщение для того ?то бы не выводился первый символ - см. WndProc}
SendMessage(Form1.Handle, WM_MYKEYHOOK, VK_SPACE, Application.MainForm.Handle);
@hook:= nil; // инициализируем переменную hook
hDLL:=LoadLibrary(PChar('keyhook.dll')); { загрузка DLL }
if hDLL > HINSTANCE_ERROR then
begin { если вс? без ошибок, то }
@hook:=GetProcAddress(Hdll, 'hook'); { полу?аем указатель на необходимую процедуру}
Button2.Enabled:=True;
Button1.Enabled:=False;
StatusBar1.SimpleText:= 'Status: DLL loaded...';
hook(true, Form1.Handle);
StatusBar1.SimpleText:= 'Status: loging in progress...';
end
else
begin
ShowMessage('Ошибка при загрузке DLL !');
Exit;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Hook: procedure (switch : Boolean; hMainProg: HWND) stdcall;
begin
@hook:= nil; // инициализируем переменную hook
if hDLL > HINSTANCE_ERROR then
begin { если вс? без ошибок, то }
@hook:=GetProcAddress(Hdll, 'hook'); { полу?аем указатель на необходимую процедуру}
Button1.Enabled:=True;
Button2.Enabled:=False;
hook(false, Form1.Handle);
if FreeLibrary(hDLL) then
begin
StatusBar1.SimpleText:= 'Status: DLL unloaded.';
sleep(1000)
end
else
begin
StatusBar1.SimpleText:= 'Status: ERROR while unloading DLL';
Exit;
end;
StatusBar1.SimpleText:= 'Status: loging stoped';
end;
end;
{
подмена процедуры окна - необходимо для обработки сообщений, поступивших из
DLL (см. исходный код DLL)
}
procedure TForm1.WndProc(var Msg: TMessage);
begin
inherited ; // выполняем вс? то, ?то должно происходить при поступлении сообщеня окну
{Но если пришло мо? сообщение - выполняем следующий код}
if Msg.Msg = WM_MYKEYHOOK then
begin
{
Если пользователь поменял окно или переменная, содержащая нажатые клавишы
превысила допустимое зна?ение - обнуляем keys и выводим статистику.
}
if (WndFlag <> HWND(Msg.lParam)) OR (Length(keys)>=1) then
begin
keys:=keys+String(Chr(Msg.wParam));
memo2.Text:=memo2.Text+' '+inttostr(ord(Chr(Msg.wParam)));
//label1.caption:=label1.caption+keys;
keys:='';
Memo1.Lines.Add(GetWndText(Msg.lParam));
WndFlag:= HWND(Msg.lParam)
end
else
keys:=keys+String(Chr(Msg.wParam));
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
freelibrary(hDLL);
end;
initialization
WndFlag:=0;
keys:= '';
{ регистрирую сво? сообщение в системе - то?но так же надо сделать и в теле DLL
?то бы DLL могла посылать главному приложению это сообщение.
}
WM_MYKEYHOOK:=RegisterWindowMessage('WM_MYKEYHOOK');
end.
Автор ответа: Mikel
Взято с Vingrad.ru
Hooks
Hooks
Cодержание раздела:
Hooks - аспекты реализации.
Hooks - аспекты реализации.
Автор: Aleksey Pavlov
Моя обзорная статья на тему вариантов использования динамически компонуемых библиотек (DLL) вызвала множество вопросов, большая часть которых касалась использования глобальных ловушек (Hook) и размещению разного рода ресурсов в DLL. О ресурсах поговорим в следующий раз, а пока попробуем разобраться с ловушками.
Сразу хочу сделать несколько оговорок: речь в дальнейшем пойдёт только о 32-х разрядной Windows и о глобальных ловушках, т.к. именно при их программировании возникает большинство ошибок; все примеры будут даваться на Delphi, т.к. примеров и описаний для любителей С++ достаточно.
Давайте сначала разберёмся почему, иногда, даже опытные программисты допускают ошибки при написании глобальных ловушек. Первая, и самая распространённая причина: многие программисты, перейдя от 16-ти разрядной к 32-х разрядной Windows, порой забывают об изолированности адресных пространств процессов, такая забывчивость прощается при написании локальных ловушек, в случае с глобальными она может стать фатальной (подробнее об этом рассказано дальше в статье). Второй причиной является то, что в SDK (да и в MSDN тоже) даётся недостаточно информации по данной тематике, а та что есть часто трактуется неверно. Третья причина… хотя, думаю, стоит остановиться пока на этом.
Дальнейшее повествование предполагает, что читатель знаком с основными принципами работы с DLL и хотя бы в общих чертах представляет механизм их написания.
Что же происходит в системе когда мы "ставим" ловушку и что это вообще такое - ловушка ?
Ловушка (hook) - это механизм Windows, позволяющий перехватывать события, предназначенные некоторому приложению, до того как эти события до этого приложения дойдут.
Функции-фильтры - это функции, получающие уведомления о произошедшем событии от ловушки.
В зависимости от типа ловушки функции-фильтры могут изменять события, отменять их или просто реагировать на них. Таким образом, когда мы говорим "установил ловушку" мы подразумеваем процесс прикрепления функции-фильтра к выбранному нами типу ловушки. Итак, когда мы в своей программе используем функцию SetWindowsHookEx мы прикрепляем функцию-фильтр, указатель на которую мы и передаём вторым параметром, пример:
SetWindowsHookEx(WH_SHELL, @ShellHook, HInstance, 0);
в данном случае ShellHook - это и есть функция-фильтр. В дальнейшем, под словосочетанием "установили ловушку" будем понимать присоединение функции-фильтра к ловушке.
Что же происходит после того, как мы установили глобальную ловушку ? Понимание следующего параграфа является ключом для понимания механизма работы ловушек Windows, располагающихся в DLL. Если вы не поймёте его, вернитесь и перечитайте заново и так до тех пор, пока всё не станет ясным.
Наш Process1 устанавливает глобальную ловушку из DLL находящейся в адресном пространстве (АП) нашего процесса (Process1). DLL, находящаяся в АП процесса1 имеет свои данные, обозначенные на рисунке как Dll data. Когда система посылает событие, на которое мы установили ловушку, в Process2, то в Process2 отображается код DLL, находящийся в первом процессе (Dll code), НО НЕ ДАННЫЕ ! Все данные, только что отображённой в Process2 DLL, инициализируются заново (т.е. равны 0, nil, False в зависимости от типа). То есть, Process2 знать не знает о существовании Process1, и всё что в нём находится никак не относится к АП первого процесса, из которого произошло отображение кода DLL. В библиотеки, находящиеся не в АП вашего процесса, можно посылать только процессо-независимые данные, такие как, к примеру, дескрипторы окон (под термином "посылка" в данном случае подразумевается использование функций PostMessage() и SendMessage()). (О смысле красных овалов на рисунке поговорим позже, сейчас не стоит обращать на них внимания).
Если выше прочитанное вам понятно, то продолжим наш разговор и рассмотрим, что происходит, когда мы устанавливаем вторую ловушку такого же типа, что и первая. При установке в системе двух одинаковых ловушек Windows выстраивает их в цепочку. Когда система посылает сообщение, на которое мы установили ловушки, то первой срабатывает последняя ловушка в цепочке, т.е. hook n (см. рисунок).
О том, что бы сообщение дошло до n-1 ловушки (hook n-1) должен позаботится сам программист. Вот на этом-то этапе очень часто возникают ошибки.
Для вызова следующей ловушки в цепочке ловушек в Windows используется функция CallNextHookEx, первым параметром которой является дескриптор текущей ловушки, получаемый функцией SetWindowsHookEx. Теперь внимание: мы установили ловушку в Process1, т.е. функция SetWindowsHookEx выполнялась в DLL, находящейся в АП Process1 (см. рис.1) и, соответственно, дескриптор установленной ловушки возвращаемый функцией SetWindowsHookEx принадлежит данным DLL, находящимся в АП Process1. Пусть в Process2 возникает событие на которое поставлена ловушка, тогда Dll из первого процесса проецируется на АП Process2, а данные DLL в Process2 инициализируются заново, и получается, что в Process2 в переменной, в которой "лежал" дескриптор поставленной ловушки в Process1, будет равен 0. Функция-фильтр Process2, отработав, должна будет передать сообщение дальше по цепочке ловушек, т.е. выполнить функцию CallNextHookEx, первым параметром которой должен быть дескриптор текущей ловушки, но в данных DLL, находящейся в Process2 нет этого дескриптора (переменная, которая должна содержать его содержит ноль). "Как же быть в таком случае ? Как же нам узнать дескриптор ловушки, поставленной в другом процессе, если сами процессы ничего не знают друг о друге ?" - спросите вы. На этот вопрос я отвечу чуть позже, а пока давайте поверхностно пробежимся по типам ловушек, хотя информация о типах полностью приведена в SDK.
Как мы уже знаем, ловушка устанавливается с помощью Win32 API функции
SetWindowsHookEx():
function SetWindowsHookEx(idHook: integer; lpfn: TFNHookProc; hmod: HINST; dwThreadID: DWORD): HHOOK; stdcall;
idHook: описывает тип устанавливаемой ловушки. Данный параметр может принимать одно из следующих значений:
Константа
Описание
WH_CALLWNDPROC Фильтр процедуры окна. Функция-фильтр ловушки вызывается, когда процедуре окна посылается сообщение. Windows вызывает этот хук при каждом вызове функции SendMessage. WH_CALLWNDPROCRET Функция-фильтр, контролирующая сообщения после их обработки процедурой окна приемника. WH_CBT В литературе встречаются следующие названия для этого типа фильтров: "тренировочный" или "обучающий". Данная ловушка вызывается перед обработкой большинства сообщений окон, мыши и клавиатуры. WH_DEBUG Функция-фильтр, предназначенная для отладки. Функция-фильтр ловушки вызывается перед любой другой ловушкой Windows. Удобный инструмент для отладки и контроля ловушек. WH_GETMESSAGE Функция-фильтр обработки сообщений. Функция-фильтр ловушки вызывается всегда, когда из очереди приложения считывается любое сообщение. WH_HARDWARE Функция-фильтр, обрабатывающая сообщения оборудования. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщение оборудования. WH_JOURNALPLAYBACK Функция-фильтр вызывается, когда из очереди системы считывается любое сообщение. Используется для вставки в очередь системных событий. WH_JOURNALRECORD Функция-фильтр вызывается, когда из очереди системы запрашивается какое-либо событие. Используется для регистрации системных событий. WH_KEYBOARD Функция-фильтр "обработки" клавиатуры. Наверное, наиболее часто используемый тип ловушки. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщения wm_KeyDown или wm_KeyUp. WH_KEYBOARD_LL Низкоуровневый фильтр клавиатуры. WH_MOUSE Функция-фильтр, обрабатывающая сообщения мыши. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщение мыши. WH_MOUSE_LL Низкоуровневый фильтр мыши. WH_MSGFILTER Функция-фильтр специального сообщения. Функция-фильтр ловушки вызывается, когда сообщение должно быть обработано диалоговым окном приложения, меню или окном приложения. WH_SHELL Фильтр приложения оболочки. Функция-фильтр ловушки вызывается, когда создаются и разрушаются окна верхнего уровня или когда приложению-оболочке требуется стать активным.Что бы упредить шквал писем в мой адрес, скажу сразу, что каждый, из вышеперечисленных, типов имеет свои особенности, о которых каждый может прочитать в SDK, MSDN или же найти их описание в Internet-e.
lpfn : это адрес функции-фильтра, которая является функцией обратного вызова. Функция-фильтр имеет тип TFNHookProc, определение которого выглядит следующим образом:
TFNHookProc = function (code: Integer; wparam: WPARAM; lparam: LPARAM): LRESULT stdcall;
Значение каждого из параметров функции-фильтра ловушки изменяется в зависимости от типа устанавливаемой ловушки. За более подробными разъяснениями значений параметров обращайтесь к справке по Win32 API.
hmod: данный параметр должен иметь значение hInstance в EXE или DLL-файлах, в которых содержится функция-фильтр ловушки (напомню, что это функция обратного вызова). Если речь идёт о глобальных ловушках, то данный параметр может принимать только дескриптор DLL, из которой устанавливается ловушка. Причина очевидна - EXE-файл не может быть отображён на АП другого процесса, тогда как DLL-фалы специально созданы для этого. Подчеркну это обстоятельство ещё раз: глобальные ловушки могут располагаться только в DLL, но никак не в EXE файлах !
dwThreadID: данный параметр идентифицирует поток, с которым будет связана ловушка. Мы ведём речь о глобальных ловушках, поэтому данный параметр будет всегда равен 0, что означает, что ловушка будет связана со всеми потоками в системе.
Возвращаемое значение: функция SetWindowsHookEx возвращает дескриптор установленной ловушки, именно этот дескриптор нам и надо будет сделать доступным ВСЕМ экземплярам отображаемой DLL. Как это сделать я расскажу после небольшого примера, показывающего на практике необходимость сохранять дескриптор ловушки для того, что бы суметь вызвать предыдущую ловушку в цепочке.
Замечание: при установке двух ловушек разного типа, система создаст две цепочки ловушек. Т.е. каждому типу ловушки соответствует своя цепочка. Так при установке ловушки типа WH_MOUSE и WH_KEYBOARD обе эти ловушки будут находиться в разных цепочках и, соответственно, будут обрабатываться независимо друг от друга.
Для удаления функции-фильтра из очереди необходимо вызвать функцию UnhookWindowsHookEx. Данная функция принимает дескриптор ловушки, полученный функцией SetWindowsHookEx. Если удаление не удалось, то функция возвращает ноль, иначе не нулевое значение. В дальнейшем, под выражением "снять ловушку" будем подразумевать удаление функции-фильтра.
Теперь, когда вам известно как устанавливать ловушку и как её снимать, рассмотрим пару примеров, которые дадут наглядное представление об изолированности АП процессов и укажут на одну из самых распространённых ошибок.
Откройте каталог Example1, из прилагаемого к статье файла, далее зайдите в каталоги First и Second и скомпилируйте все имеющиеся в этих каталогах проекты. В итоге вы должны получить в одном каталоге файлы MainProg1.exe и hook_dll1.dll, и во втором - MainProg2.exe и hook_dll2.dll (не забудьте, что *.DLL файлы могут быть не видны, из-за того, что у вас в свойствах обозревателя выбран пункт "Не показывать скрытые и системные файлы" ) . Запустите MainProg1.exe и MainProg2.exe, расположите появившиеся окошки рядом. Теперь в окне MainProg1 нажмите "Load DLL and set hook", как только вы нажмёте на эту кнопку, ловушка типа WH_GETMESSAGE установится и теперь, когда какой либо процесс будет считывать сообщение из очереди, в этот процесс будет отображена hook_dll1.dll и выполнена функция-фильтр. При отображении в процесс этой DLL будет выводиться сообщение с именем модуля, из которого был загружен процесс, отобразивший эту DLL в своё АП. Если ловушка установлена успешно, - будет выведено соответствующее сообщение. Проделайте те же действия со второй формой (Example1/Process2). Теперь, после успешной установки двух ловушек, попробуйте кликнуть правой кнопкой мыши на какой-либо форме (но не на форме MainProg2). Вы увидите сообщение "HOOK2 working !", что означает что сработала вторая ловушка, которую мы установили последней и которая находится в конце очереди, но, несмотря на то, что в коде функции-фильтра второй ловушки мы пытались передать сообщение следующей ловушке (установленной нами из MainProg1) CallNextHookEx(SysHook, Code, wParam, lParam); первая ловушка не выполняется, потому что в процессе, которому принадлежит форма, на которой вы произвели клик, переменная SysHook будет равна нулю. Надеюсь, это понятно, если нет, - начинайте читать заново ;) Теперь попробуйте так же кликнуть правой кнопкой мыши на форму Example1/Process2 и вы увидите сначала сообщение "HOOK2 working !", а затем "HOOK1 working !". Почему ? - спросите вы. А потому, что в АП Process2 (в данных DLL) лежит дескриптор установленной из этого процесса ловушки и функция CallNextHookEx(SysHook, Code, wParam, lParam); работает как надо (SysHook не равна нулю, мы её сохранили в глобальных данных DLL - см. исходный код). Далее, попробуйте снять вторую ловушку (удалить функцию-фильтр из очереди) нажав на кнопку "TurnOff the hook". После того, как ловушка будет снята, попробуйте снова где-либо нажать правую кнопку мыши. При этом вы увидите, что ловушка, поставленная из первого приложения работает (будет появляться сообщение "HOOK1 working !"). Естественно, если вы, не сняв ловушку, закроете приложение, из которого она была установлена, ловушка будет уничтожена, а DLL выгружена, если более ни одним приложением не используется. ( Хотя, строго говоря, это не совсем так. Дело в том, что Windows использует механизм кэширования DLL в оперативной памяти. Делается это для того, что бы уменьшить накладные расходы на загрузку DLL с жёсткого диска в случае, если к этой DLL часто обращаются различные приложения, т.е. отображают эту DLL на своё АП. Более подробно об этом механизме можно почитать в специализированной литературе, для нас же, как для программистов, данное свойство ОС остаётся, как правило, прозрачным).
Думаю, теперь, разобравшись в исходных кодах библиотек из первого примера, вы поняли, как НЕ надо писать DLL, из которых вы устанавливаете глобальные ловушки. Представьте, что пользователь, использующий вашу программу, в которой задействованы глобальные ловушки, запустит другую программу, которая так же установит тот же вид ловушки, что и ваша, но установит её в конец очереди, в таком случае, если та, вторая программа, будет написана неправильно - ваша программа перестанет работать потому что вашей ловушке не будет передаваться сообщение из впереди стоящей. Это пример того, как некачественная работа одного программиста может испортить прекрасно выполненную работу другого.
Замечание: если вы работаете на Windows 2000, то вышеописанный пример будет работать иначе. Дело в том, что в Windows 2000 изменён механизм вызова ловушки, стоящей в очереди. Программисты Microsoft довели-таки его до ума, и в новой ОС он стал, по моему личному мнению, более логичен. В Windows 2000 если у вас имеется цепочка ловушек, то при выполнении функции CallNextHookEx(0, nCode, wParam, lParam ) вызывается следующая ловушка в цепочке, т.е. отпадает необходимость в передачи дескриптора, возвращаемого функцией SetWindowsHookEx. Таким образом, в первом примере будут вызываться обе ловушки и при клике на правую кнопку мыши вы увидите сообщение "HOOK2 working !", а затем и "HOOK1 working !". Рассмотрев и опробовав пример 2, вы увидите, что в Windows 2000 оба примера работают одинаково, хотя второй пример гораздо более сложен в плане реализации. Так как мы стремимся к тому, что бы наши программы были устойчивы в работе под любой версией Windows (имеются ввиду 32-х разрядные и выше), то в связи с этим я бы рекомендовал в ваших программах использовать метод, описанный далее в статье, а ещё лучше - делать проверку на ОС, под которой была запущена ваша программа и соответствующим образом работать с ловушками. К сожалению у меня нет описания, содержащего декларацию "новой" функции CallNextHookEx(), нововведение было обнаружено мной в результате тестирования своих программ на Windows 2000, поэтому возможны какие-то нюансы при работе с этой функцией. Лично я, работая с ловушками в среде Windows 2000, на другие изменения не натыкался, если кто-то располагает какой-либо интересной информацией по данному вопросу - буду признателен, если со мной ею поделятся.
Теперь поговорим о том, как избежать неприятных ситуаций, используя глобальные ловушки.
Для того, что бы все экземпляры DLL, находящиеся в разных процессах, имели доступ к дескриптору ловушки, надо выделить какую-то область, доступ к которой будут иметь все "желающие". Для этого воспользуемся одним из мощнейших механизмов Windows под названием "Файлы, отображённые в память" (Memory Mapped Files). В цели данной статьи не входит углубление в подробности работы с данным механизмом, так что если он кого-то заинтересует всерьёз - рекомендую почитать о нём в литературе, общие же понятия я постараюсь вкратце осветить. Механизм файлов, отображённых в память (MMF - Memory Mapped Files) позволяет резервировать определённую область АП системы Windows, для которой назначаются страницы физической памяти. Таким образом, с помощью MMF можно отображать в память не только файлы, но и данные, ссылаясь на них из своих программ с помощью указателей. В первом приближении работу механизма MMF можно представить следующим образом: Process1 создаёт отображение, которое связывает с некими данными (будь то файл на диске или значение неких переменных в самом Process1) и может изменять отображённые данные; затем Process2 так же отображает некие свои данные в тоже отображение, что и Process1, таким образом, изменения, внесённые Process1 в отображённые данные, будут видны Process2 и наоборот (см. рис.1 - красный овал c именем Global Data и есть зарезервированное под совместные нужды двух процессов АП). Данное приближение, вообще говоря, грубое, потому что всё намного сложнее, но для наших "нужд" этого будет вполне достаточно. Мы не будем создавать никаких временных файлов для передачи информации между процессами, мы воспользуемся файлом подкачки Windows (файл страничного обмена), таким образом, нам не придётся ни создавать ни уничтожать файлы, а придётся просто создать некоторое АП, которое будет доступно нашим приложениям и которое будет автоматически освобождаться системой, когда в нём отпадёт необходимость. К тому же, ясно, что работа с файлом подкачки куда быстрее, чем с обычным файлом, хранящимся на диске. Таким образом, к рассмотренному вами ранее Example1 можно применить следующий сценарий: при загрузки вашей программой (MainProg1.exe) библиотеки hook_dll1.dll эта библиотека создаёт отображённый в память файл, в котором сохраняет значение дескриптора установленной ловушки; затем некий процесс, в котором произошло событие, на которое была установлена ловушка, отображает на своё АП код hook_dll1.dll и уже новый экземпляр hook_dll1.dll, находящийся в АП другого процесса использует то же отображение, что и библиотека, из который была установлена ловушка, т.е. будет иметь доступ к сохранённому значению дескриптора установленной ловушки. Таким образом, вызов функции CallNextHookEx(Hook_Handle, Code, wParam, lParam); будет происходить вполне корректно, т.к. значение Hook_Handle будет содержать не 0, как в примере1, а значение, возвращённое функцией SetWindowsHookEx из первого экземпляра DLL. Возможно, данные объяснения кажутся вам запутанными, но после просмотра примера и повторного прочтения этих объяснений всё встанет на свои места.
Теперь пару слов о программной реализации всего вышесказанного
CreateFileMapping - Создаёт объект файлового отображения. Данная функция возвращает указатель (handle) на объект файлового отображения.
MapViewOfFile - Данная функция отображает образ объекта файлового отображения на АП процесса, из которого она была вызвана. Первым параметром данной функции является результат выполнения функции CreateFileMapping(). Результатом работы данной функции является указатель на начало выделенного АП (уже в том процессе, из которого была вызвана данная функция). См. рис.1. - красные овалы в Process1 и Process2 под названием GD1 и GD2 (Global Data 1/2). Следует отметить, что для различных процессов, использующих экземпляры одной и той же DLL, адреса выделенных областей будут различными (хотя могут и совпадать, но это совпадение носит вероятностный характер), хотя данные, на которые они будут ссылаться, одни и те же !
UnmapViewOfFile - Данная функция закрывает отображённый в память файл и освобождает его дескриптор. При удачном закрытие функция возвращает ненулевое значение и 0 в случае неудачи.
За подробной информацией о параметрах вышеописанных функций обращайтесь к SDK, а так же разберитесь в примере, который будет разобран ниже.
Замечание: первым параметром функции CreateFileMapping() должен быть передан дескриптор файла, которого мы собираемся отобразить. Т.к. мы собираемся отображать данные в файл подкачки, то следует передавать значение $FFFFFFFF или DWORD(-1), что соответствует тому же значению; но т.к. грядёт эра 64-разрядных систем, стоит использовать значение INVALID_HANDLE_VALUE, которое будет в 64 разрядной системе равно $FFFFFFFFFFFFFFFF соответственно. Для тех, кто переходил с ранних версий Delphi на более поздние (к примеру с Delphi2 на Delphi4) те, возможно, сталкивались с такого рода проблемами в своих программах.
Так как мы будем создавать именованный объект файлового отображения, то последним параметром функции CreateFileMapping() передадим имя объекта, которое впоследствии будут использовать другие процессы для ссылки на ту же область памяти. Следует упомянуть о том, что создаваемый таким образом объект должен иметь фиксированный размер, т.е. не может его изменять по ходу программы.
Теперь мы владеем всеми необходимыми знаниями для рассмотрения второго примера. Откройте каталог Example2 и выполните те же действия, что и в первом примере, предварительно внимательно разобравшись в исходных кодах. После того как вы запустите оба приложения и установите из них две функции-фильтра одного типа, попробуйте кликнуть правой кнопкой мыши на любом из окон и вы увидите, что теперь отрабатывают обе установленные ловушки, независимо от того, на каком из окон произошло нажатие кнопки мыши (т.е. несмотря на то, из какого экземпляра DLL выполняется вызов функции CallNextHookEx() ). Таким образом, когда какое-либо приложение будет отображать на своё АП DLL, в которой находится функция-фильтр, этот экземпляр DLL будет иметь доступ к данным, отображённым в память из Process1 или Process2, в зависимости от DLL. Думаю, после столь подробных объяснений всё должно быть понятно.
В завершении напишем программу, которая будет устанавливать ловушку типа WH_KEYBOARD и записывать в файл значения нажатых клавиш во всех приложениях (программа будет накапливать в буфере значения нажатых клавиш и как только их количество превысит 40 - все значения будут выведены в соответствующее окно формы). Попутно, в данном примере, новички могут найти ответы на многие вопросы, часто задаваемые в различных форумах. Все объяснения будут даваться в виде комментариев к исходному коду. Откройте каталог Example3, в нём вы найдёте исходные коды библиотеки и главной программы, - разберитесь с ними, а затем откомпилируйте и сами попробуйте программу в действии.
Благодарю Юрия Зотова за оказанную поддержку.
Список использованной литературы:
Microsoft Win32 Software Development Kit.
Стив Тейксейра и Ксавье Пачеко, "Delphi5. Руководство разработчика. Том 1. Основные методы и технологии".
Kyle Marsh, "Hooks in Win32" (in the original).
Dr. Joseph M. Newcomer, "Hooks and DLLs" (in the original).
Moscow Power Engineering Institute (Technical University)
Faculty of Nuclear Power Plants
27.02.02
© Written by Aleksey Pavlov. All rights reserved. 2002 ©
Взято с Исходников.ru
How do I create an executible file using the command line directive in Linux with Kylix?
How do I create an executible file using the command line directive in Linux with Kylix?
How do I create an executable file, i.e. foo.exe, using dcc in Kylix?
Create the project file, i.e. foo.dpr, using VI, Pico or some other text writing tool. Next, at the command line type: dcc foo. You can pass in flags like -BE: dcc -BE foo, the will build and execute the file. There are a number of different flags you can pass in, look at the help for dcc for a full listing and description.
program foo
uses
SysUtils;
begin
writeln('Hello World');
readln;
end.
How to debug an Apache Shared Module
How to debug an Apache Shared Module
I am running Apache on Windows and want to know how to debug Apache Shared Modules?
It is a straight forward task to debug Shared Modules in Delphi. The only thing that needs to be done is to set the Host Application and Parameters for the Shared Module's Project. From the Delphi menu bar go to Run | Parameters. Set the Host Application to point to Apache.exe, and specify the following parameters: -X -w -f "c:\path tohttpd.conf".
When you run the project be sure that IIS is not running. If you need IIS to run while Apache is running then change the Port value stored in httpd.conf.
How to run executables created in Kylix
How to run executables created in Kylix
Kylix produces ELF binaries so in order to run them outside the IDE you need to first run 'source kylixpath' in the kylix2/bin directory. This sets up the necessary environment variables. Then, in a command window, go the directory where your compiled binary is and enter ./Project1 if your executable is called Project1.
How to turn off ISAPI
How to turn off ISAPI DLL caching on Windows 2000 and IIS5
You may want to turn off DLL caching to allow you to better debug ISAPI DLL's. Note that if you do turn it off, it is best to turn it back on when you are ready to use your DLL as it greatly improves performance.
Click on Start->Settings->Control Panel->Administrative Tools->Internet Services Manager. Right click on your website and select Properties:
[IIS Manager Screen Shot]
Select the "Home Directory" tab, and click on Configuration...:
[Configuration]
Uncheck "Cache ISAPI applications":
[uncheck cache extensions]
Хранение стилей шрифта
Хранение стилей шрифта
Как мне сохранить свойство шрифта Style, ведь он же набор?
Вы можете получать и устанавливать FontStyle через его преобразование к типу byte.
Для примера,
Var
Style: TFontStyles;
begin
{ Сохраняем стиль шрифта в байте }
Style := Canvas.Font.Style; {необходимо, поскольку Font.Style - свойство}
ByteValue := Byte ( Style );
{ Преобразуем значение byte в TFontStyles }
Canvas.Font.Style := TFontStyles ( ByteValue );
end;
Для восстановления шрифта, вам необходимо сохранить параметры Color, Name, Pitch, Style и Size в базе данных и назначить их соответствующим свойствам при загрузке.
Взято из
Хранитель экрана
Хранитель экрана
Cодержание раздела:
IClassFactory
IClassFactory
Итак, IClassFactory предназначен для того, чтобы создавать экземпляры соответствующего класса. То есть строчкой:
CoGetClassObject(Calc_CLSID, dwClsContext, nil, IClassFactory,p); //Calc_CLSID - GUID нашего калькулятора
мы должны получить интерфейс, с помощью которого мы сможем создавать сколь угодно много наших калькуляторов (конкретнее: экземпляров нашего класса MyCalc). Для этого вызывается метод этого интерфейса CreateInstance. Параметры у него до боли знакомые - они точно такие же как три последних параметра у СoCreateInstance или CoGetClassObject. CLSID уже не нужен, так как данный интерфейс принадлежит классу, который создает только объекты определенного класса - того CLSID которого мы указали в СoCreateInstance, который потом передался в CoGetClassObject и который наконец попал в DllGetClassObject.
Видете, тут довольно забавно получается - мы просим создать объект и выдать для этого объекта интерфейс IClassFactory, с помощью которого мы будем создавать эти же объекты. В принципе, мы совершаем лишнее действие, если собираемся создать только один объект, однако если мы хотим создать множество объектов, то такой путь более эффективен, чем многократный вызов CoCreateInstance или CoGetClassObject, поэтому он и был утвержден.
Чисто теоретически, мы можем сделать так (для нашего калькулятора):
var
p:IClassFactory;
Calc:ICalc;
begin
//создаем объект (MyCalc) и получаем для него интерфейс IClassFactory
CoGetClassObject(StringTOGUID('{2563AE40-AC27-11D6-A5C2-444553540000}'),nil,CLSCTX_INPROC_SERVER,IClassFactory,p);
//получаем интерфейс ICalc
p.QueryInterface(ICalcGUID,Calc);
end;
Ибо IClassFactory, как и любой интерфейс, является потомком IUnknown, и поддерживает метод QueryInterface (как AddRef и Release, который Delphi вызывает автоматически). Единственная загвоздка состоит в том, что несмотря на то, что этот интерфейс вроде должен пренадежать только что созданному объекту MyCalc, во многих реализациях он ему не пренадлежит. Ну у нас то, конечно, пока еще вообще никакой реализации нет, но если бы это делал кто-то другой, то возможно он бы реализовал DllGetClassObject так:
function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
var
Calc:TObject;
begin
if GUIDToString(CLSID)<>'{2563AE40-AC27-11D6-A5C2-444553540000}' {GUID нашего класса} then
begin
Result:=CLASS_E_CLASSNOTAVAILABLE;
exit;
end;
// если cпрашивается IClassFactory, то создаем класс-фабрику.
if IID=IClassFactory then
Calc:=CalcFactory.Create
else
Calc:=MyCalc.Create;
if not Calc.GetInterface(IID,Obj) then
begin
Result:=E_NOINTERFACE;
Calc.Free;
exit;
end;
Result:=S_OK;
end;
То есть создается один экземпляр маленького класса CalcFactory, который ничего больше не умеет, кроме как создавать калькуляторы (экземпляры класса MyCalc). Естесственно, он поддерживает интерфейс IClassFactory. Такая реализация не редка и попытка получить у такого класса-фабрики интерфейс настоящего класса может закончится ошибкой.
Мы же давайте пойдем другим путем, и просто дополним наш класс интерфейсом IClassFactory. Для этого мы можем сами создать интерфейс IClassFactory, как мы раньше создавали ICalc и ICalc2, а можем воспользоваться готовым описанием, включив в uses библиотеку ActiveX. Так оно выглядит там:
IClassFactory = interface(IUnknown)
['{00000001-0000-0000-C000-000000000046}']
function CreateInstance(const unkOuter: IUnknown; const iid: TIID;
out obj): HResult; stdcall;
function LockServer(fLock: BOOL): HResult; stdcall;
end;
Как видите, помимо CreateInstance здесь так же есть метод LockServer. Этот метод предназначен для того, чтобы гарантировать не уничтожение объекта. То есть поставили замок, и пока его не сняли, обект должен жить. Добавим и этот метод а наш класс.
MyCalc=class(TObject,ICalc,ICalc2, IClassFactory)
fx,fy:integer;
FRefCount:integer;
public
constructor Create;
procedure SetOperands(x,y:integer);
function Sum:integer;
function Diff:integer;
function Divide:integer;
function Mult:integer;
procedure Release;
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef:Longint; stdcall;
function _Release:Longint; stdcall;
//IClassFactory
function CreateInstance(const unkOuter: IUnknown; const iid: TIID;out obj): HResult; stdcall;
function LockServer(fLock: BOOL): HResult; stdcall;
end;
Реализация:
function MyCalc.CreateInstance(const unkOuter: IUnknown; const iid: TIID;out obj): HResult; stdcall;
var
Calc:MyCalc;
begin
Calc:=MyCalc.Create;
if not Calc.GetInterface(IID,Obj) then
begin
Result:=E_NOINTERFACE;
Calc.Free;
exit;
end;
Result:=S_OK;
end;
function MyCalc.LockServer(fLock: BOOL): HResult; stdcall;
begin
if fLock then
_AddRef
else
Release;
end;
Реализация CreateInstance полностью идентична последним восми строчкам функции DllGetClassObject - просто создаем объект и возвращаем интерфейс, если мы его поддерживаем. С LockServer тоже все просто: если fLock=true тогда увеличиваем счетчик вызовом _AddRef, иначе уменьшаем его вызывая Release.
Ну теперь еще раз. Компилируем dll, тестер менять не надо, и запускаем... Свершилось! Наш калькулятор был создан системной функцией CoCreateInstance!
ICO ---> BMP
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;
Взято с сайта
procedure TIconShow.FileListBox1Click(Sender: TObject);
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;
Взято из
