Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС
выпущен 4 ноября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Paradox и неверные индексы Windows

Автор: David W. Husch

Сообщение об ошибке: В файловой системе win95 существует ошибка, "микширующая" блокировку записи Paradox и механизм обновления. В хост-файлах Paradox в Windows 95 для работы нескольких пользователей измените следующие значения:

Select Control Panel
 System (icon)
 Performance (Tab)
 File System (Button)
 Troubleshooting (Tab)
 "Disable New File Sharing and Locking Semantics" (щелкните) (нажмите OK)
 (Выключить общий доступ к новым файлам и семантику блокировки)



Byte-поля Paradox

Автор: Mark Edington

Что за магия при записи в поле Paradox Byte? По этому поводу в документации ничего не сказано.

Есть 2 пути получить доступ к данным в TBytesField.

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

  2.  procedure SetCheckBoxStates;
     var
       CBStates: array[1..13] of Byte;
     begin
       CBStateField.GetData(CBStates);
       { Здесь обрабатываем данные... }
     end;
     

    Для записи значений вы должны использовать SetData.

  3. Используйте свойство Value, возвращающее вариантный массив байт (variant array of bytes):

  4.  procedure SetCheckBoxStates;
     var
       CBStates: Variant;
     begin
       CBStates := CBStateField.Value;
       { Здесь обрабатываем данные... }
     end;
     

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




После работы программы не сохраняются изменения в базе Paradox

Где-нибудь при закрытии главной формы выполните нижеследующие куски кода:

Для Delphi3 (при открытой таблице):


 Table.FlushBuffers;
 

Для прочих:


 Table.Open;
 Check(dbiSaveChanges(Table.Handle));
 Table.Close;
 

Чтобы сбросить кэш, можно еще после этого сделать:


 asm
   mov ah, $0D
   int $21
 end;
 




Размеры полей таблицы Paradox

Автор: John B Moore

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

Требования к предельным размерам типов полей таблицы Paradox

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

    Тип данных           Байт
    -----------------------------------------------------------
    Alphanumeric          1 байт на символ, до 255
    AutoIncrement         4 байта
    Binary (BLOB)        10 байт + 1 на символ. В пределе
                            (0 - 240) [1]
    Bytes                 1 на символ, максимально до 255.
    BCD                  17
    Currency (Денежный)   8
    Date                  4
    Formatted Memo       10 байт + 1 на символ. В пределе
                            (0 - 240)
    Graphic              10 байт + 1 на символ. В пределе
                            (0 - 240)
    Memo                 10 байт + 1 на символ. В пределе
                            (1 - 240) [2]
    Logical               1
    LongInt               4
    Numeric (Числовой)    8
    OLE                  10 байт + 1 на символ. В пределе
                            (0 - 240)
    SmallInt              2
    Time                  4
    TimeStamp             8
 
 Пределы:
    Maximum Field Count      :  255 полей
    (максимальное количество
     полей)
    Maximum Blocks per table :  64К
    (максимальное количество
     блоков в таблице)
    Maximum Block Size       :  32К символов
    (максимальный размер
     блока)
    Max Record Size, unkeyed :  Текущий размер блока - 6 байта [3]
    (максимальный размер
     записи, неключевой)
    Max Record Size, keyed   :  (BlockSize - 6) / 3, округляется в меньшую сторону
    (максимальный размер        до ближайшего размера блока. [4]
     записи, ключевой)
Сноски:

[1] Все blob-поля содержат 10-байтовые указатели на .MB-файл, которые указывают где могут быть найдены "остальные" значения поля.

[2] В отличие от данных "blob"-типа, Memo-поле требует по крайней мере один "Memo"-символ, сохраненный в .DB-файле, для обеспечения совместимости с Paradox for DOS.

[3] Размер блока по умолчанию хранится в IDAPI.CFG. Для изменения значения по умолчанию, запустите Configuration Utility и измените установку Tables, Paradox, Block Size. Значение по умолчанию 2048 и может изменяться в диапазоне от 1024 до 32К. 6 байтов в данном значении резервируются для внутренних указателей.

[4] Это следствие наличия значений ключа записей Paradox, которые передаются в .PX файл, очень похожий на табличный файл. Размер ключа не может превышать 1/3 размера блока таблицы; в противном случае Paradox будет пытаться увеличить размер блока. При выполнении вычислений не забывайте брать в расчет 6-байтные указатели.




Paradox в сети

Автор: James Presley

Я пришел к тебе с дискетой, рассказать что сеть упала.

Может мне кто-нибудь помочь? Я получаю следующую ошибку приложения....Not initialized for accessing network files (не инициализировано для доступа к сетевым файлам).

Программа Borland BDE Install НЕ включает в себя автоматически драйвер для работы в сети для таблиц Paradox, если целевой компьютер подключен к сети. Ваш пользователь получит сообщение об ошибке, если путь никем не установлен. Программы третьих фирм, устанавливающие BDE, поступают точно так же (я использую WISE). Настройка сетевого каталога возможна программным путем из самой программы, или с помощью пользователя и утилиты BDEconfig.

При запуске приложения я разворачиваю предусмотренную Borland DLL "netdir.dll" (58K), загруженную из форума PdoxWin, получаю доступ к idapi.cfg и считываю значение сетевого каталога (netdir). Следующий код проверяет был ли установлен сетевой каталог, и, если не был, то он временно устанавливается для текущего сеанса пользователя.


 {объявляем DLL функцию}
 function getCFGNetDir: pchar; far; external 'netdir' index 4;
 
 {проверяем и при необходимости восстанавливаем сетевой каталог}
 procedure TmySplashForm.FormCreate(Sender: TObject);
 var
   theNetDir: pchar;
   theChar: char;
 begin
   theChar := ':'
     theNetDir := getCFGNetDir;
   if (strscan(theNetDir, theChar) = nil) then
     session.netfiledir := 'C:\';
 end;
 




Ограничения Paradox

Автор: Eryk

Какой предел IDAPI для подключенных пользователей и размера файла для таблиц Paradox?

255 пользователей, максимальный размер таблицы по умолчанию от 128Мб до 4Гб, в зависимости от установки BLOCKSIZE в IDAPI.CFG во время создания таблицы. (максимальный размер = BLOCKSIZE x 64Mb).




Доступ к таблицам Paradox на CD или c флагом только для чтения

Пришёл программер как-то раз в ресторан, заказал себе отбивную. Берётся, значит, за дело, бац, а вилка с ножиком, аж соскальзывают с отбивной:
- Read only... - подумал программер.

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

Механиз блокирования файлов Paradox требует наличие файла PDOXUSRS.LCK, осуществляющий логику работы блокировки. Данный файл обычно создается во время выполнения приложения и располагается в том же каталоге, где и таблицы. Тем не менее, в случае с CD-ROM, во время выполнения программы нет никакой возможности создать на нем описанный выше файл. Решение простое: мы создаем этот файл и помещаем его на CD-ROM во время его (CD) создания. Следующая простейшая программка позволит создать вам файл PDOXUSRS.LCK и поместить его в образ компакта для его последующего копирования на CD-ROM:

  1. Стартуйте пустой проект и добавьте на форму следующие компоненты: TEdit, TButton и TDatabase.
  2. В обработчике кнопки OnClick используйте следующий код:

  3.  procedure TForm1.Button1Click(Sender: TObject);
     begin
       if ChkPath then
         Check(DbiAcqPersistTableLock(Database1.Handle,
           'PARADOX.DRO','PARADOX'));
     end;
     

  4. Функция ChkPath является методом, определенным пользователем для формы. Она просто проверяет путь, введенный пользователем в поле редактирования и убеждается, что он существует. Вот функция:

  5.  function TForm1.ChkPath : Boolean;
     var
     s : array[0..100] of char;
     begin
     If DirectoryExists(Edit1.Text) then begin
     DataBase1.DatabaseName:= 'TempDB';
     DataBase1.DriverName:= 'Standard';
     DataBase1.LoginPrompt:= false;
     DataBase1.Connected := False;
     DataBase1.Params.Add('Path=' + Edit1.Text);
     DataBase1.Connected := TRUE;
     Result := TRUE;
     end
     else begin
     StrPCopy(s,'Каталог : ' + Edit1.text + ' не найден');
     Application.MessageBox(s, 'Ошибка!', MB_ICONSTOP);
     Result := FALSE;
     end;
     end;
     
     { Примечание: Не забудьте добавить объявление
       функции в секцию public формы. }
     

  6. Перед компиляцией необходимо вспомнить еще об одной вещи: в список Uses нужно добавить следующие модули:
      Delphi 1.0: FileCtrl, DbiProcs, DbiTypes, DbiErrs.
       Delphi 2.0: FileCtrl , BDE
    После компиляции и выполнения, программа создаст два файла в определенном вами каталоге. Создаваемые два файла: PDOXUSRS.LCK и PARADOX.LCK.

    Примечание: Файл PARADOX.LCK необходим только для доступа к таблицам Paradox for DOS, так что вы можете его удалить.

  7. Вам осталась сделать только одну последнюю вещь: скопировать оставшийся файл (PDOXUSRS.LCK) в образ CD-ROM. Естественно, ваши таблицы будут только для чтения.

    Примечание: Если вы собираетесь довольно часто пользоваться данной утилитой, то для удобства вы можете изменить свойство Text компонента Edit на ваш "любимый" каталог, а свойство Caption кнопки поменять на что-нибудь более "интеллектуальное".

    Вот окончательная версия кода:


  8.  unit Unit1;
     
     interface
     
     uses
       Windows, Messages, SysUtils, Classes, Graphics, Controls,
       Forms, Dialogs, DB, StdCtrls, FileCtrl,
     
     {$IFDEF WIN32}
       BDE;
     {$ELSE}
       DbiProcs, DbiTypes, DbiErrs;
     {$ENDIF }
     
     type
       TForm1 = class(TForm)
         Edit1: TEdit;
         Button1: TButton;
         Database1: TDatabase;
         procedure Button1Click(Sender: TObject);
       private
         { Private declarations }
       public
         { Public declarations }
         function ChkPath: Boolean;
       end;
     
     var
       Form1: TForm1;
     
     implementation
     
     {$R *.DFM}
     
     function TForm1.ChkPath: Boolean;
     var
       s: array[0..100] of char;
     begin
       if DirectoryExists(Edit1.Text) then
       begin
         DataBase1.DatabaseName := 'TempDB';
         DataBase1.DriverName := 'Standard';
         DataBase1.LoginPrompt := false;
         DataBase1.Connected := False;
         DataBase1.Params.Add('Path=' + Edit1.Text);
         DataBase1.Connected := TRUE;
         Result := TRUE;
       end
       else
       begin
         StrPCopy(s, 'Каталог : ' + Edit1.text + ' не найден');
         Application.MessageBox(s, 'Ошибка!', MB_ICONSTOP);
         Result := FALSE;
       end;
     end;
     
     procedure TForm1.Button1Click(Sender: TObject);
     begin
       if ChkPath then
         Check(DbiAcqPersistTableLock(Database1.Handle,
           'PARADOX.DRO', 'PARADOX'));
     end;
     
     end.
     




Из Paradox в Access при помощи ADO

В данной статье мы обратим внимание на компонент TADOCommand и использование языка SQL DDL (Data Definition Language), с целью помочь Вам с проблемой переноса данных BDE/Paradox в ADO/Access.

Язык определения данных (Data Definition Language)

Не многие программисты создают базу данных программным путём, большинство из нас для этого используют некую визуальную среду наподобие MS Access для построения файла MDB. Но иногда нам всё таки приходится создавать и удалять базу данных, а так же объекты базы данных программным путём. Для этого используется наиболее распространённая на сегодняшний день технология Structured Query Language Data Definition Language (SQL DDL). Выраджения языка определения данных (DDL) - это SQL выражения, которые поддерживают определения или объявления объектов базы данных (например, CREATE TABLE, DROP TABLE, CREATE INDEX либо подобные им).

В рамки данной статьи не входит детальное ознакомление с языком DDL. Если Вы знакомы с языком SQL DML (Data Manipulation Language - это выражения типа SELECT, UPDATE и DELETE), то DDL не будет для Вас серьёзным барьером. Обратите внимание, что работа с DDL может быть весьма ухищрённой, так как каждый производитель базы данных може включать в неё собственные расширения для SQL.

Давайте взглянем на простейший пример выражения CREATE TABLE:


 CREATE TABLE PhoneBook(
 Name TEXT(50)
 Tel TEXT(50));
 

Данное DDL выражение (для MS Access) в время выполнения создаст новую таблицу с названием PhoneBook. Таблица PhoneBook будет иметь два поля: Name и Tel. Оба поля имеют строковый тип (TEXT) и размер поля 50 символов.

TFieldDef.DataType

Очевидно, что в Access тип данных, представленный строкой это TEXT. В Paradox это STRING. Чтобы передать таблицы Paradox в Access, нам необходимо знать какие типы данных присутствуют и, соответственно их имена. При работе в BDE с таблицами Paradox, TFieldDef.DataType определяет тип физического поля в (dataset) таблице. Поэтому для успешного перенесения данных из таблиц Paradox в Access Вам необходимо создать функцию, которая бы преобразовывала соотвествующие типы полей Paradox в типы Access.

Давайте посмотрим на пример функции, которая проверяет тип поля (fd) и возвращает соответствующий тип Access, а заоодно и размер поля, который необходим для выражения CREATE TABLE DDL.


 function AccessType(fd:TFieldDef):string;
 begin
   case fd.DataType of
     ftString:   Result:='TEXT('+IntToStr(fd.Size)+')';
     ftSmallint: Result:='SMALLINT';
     ftInteger:  Result:='INTEGER';
     ftWord:     Result:='WORD';
     ftBoolean:  Result:='YESNO';
     ftFloat :   Result:='FLOAT';
     ...
     else
       Result:='TEXT(50)';
   end;
 end;
 

ADOX

ADOX - это расширения ADO для Data Definition Language а так же для модели защиты (ADOX). ADOX предоставляет разработчикам богатый набор инструментов для получения доступа к структуре, модели защиты, а так же процедурам, хранимым в базе данных.

Для использования ADOX в Delphi, Вам необходимы установить библиотеку типа ADOX.

  1. Select Project | Import Type Library
  2. Выберите "Microsoft ADO Ext 2.x for DDL and Security (Version 2.x)"
  3. Измените "TTable" на "TADOXTable"
  4. Измените "TColumn" на "TADOXColumn"
  5. Измените "TIndex" на "TADOXIndex"
  6. Нажмите кнопку Install (перекомпиляция пакетов (packages))
  7. Нажмите один раз OK и дважды Yes
  8. File | Close All | Yes

На вершине объектной модели ADOX находится объект Catalog. Он обеспечивает доступ к набору Таблиц (Tables), Видов (Views) и Процедур, который используется для работы со структурой базы данных, а так же к набору Пользователей (Users) и рупп (Groups), которые используются для авторизации доступа. Каждый объект Catalog связан только с одним подключением к источнику данных.

Давайте оставим ADOX (пока) и перейдём к ADOExpress.

TADOCommand

В ADOExpress компонент TADOCommand - это VCL представление объекта ADO Command. Объект Command представляет команду (запрос или выражение), которая может быть обработана источником данных. Команды могут быть выполнены методом Execute, используемым в ADOCommand. TADOCommand чаще всего используется для исполнения команд языка определения данных (DDL) SQL. Свойство CommandText содержит в себе саму команду. Свойство CommandType используется для того, как интерпретировать свойство CommandText. Тип cmdText используется для указания инструкции DDL. Впринципе, использовать компонент ADOCommand для получения данных из таблицы, запросов или хранимых процедур не имеет смысла, но никто не запрещает Вам пользоваться данным компонентов и в таких целях.

Итак, самое время приступить к реальному программированию...

Приведённый ниже проект демонстрирует следующее:

Получение списка всех таблиц из BDE, использование TFieldDefs чтобы получить определения (имя, тип данных, размер, и т.д.) полей в таблице, создание инструкции CREATE TABLE и копирование данных из таблицы BDE/Paradox в таблицу ADO/Access.

Давайте решим эту задачу по шагам:

GUI

Запускаем Delphi - получаем новый проект с пустой формой. Добавляем две кнопки, один ComboBox и один компонент Memo. Далее добавляем компоненты TTable, TADOTable, TADOConnection и TADOCommand. Чтобы установить следующие свойства, используем Object Inspector (оставьте все другие свойства как есть - например, Memo будет иметь имя по умолчанию: Memo1):


 Button1.Caption = 'Construct Create command'
 Button2.Caption = 'Create Table and copy data'
 ComboBox.name = cboBDETblNames;
 
 ADOConnection1.ConnectionString = ...
 TADOTable.name = ADOTable
 ADOTable.Connection = ADOConnection1
 TADOCommand.name = ADOCommand
 ADOCommand.Connection = ADOConnection1
 TTable.name = BDETable
 BDETable.DatabaseName = 'DBDEMOS'
 

Пример:

Для получения списка таблиц, связанных с данной базо данных (DBDEMOS) мы воспользуемся следующим кодом (OnCreate для формы):


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Session.GetTableNames('DBDEMOS', '*.db', False,
   False, cboBDETblNames.Items);
 end;
 

В самом начале ComboBox содержит имена таблиц (Paradox) в базе данных DBDEMOS. В нижеприведённом коде мы выберем таблицу Country.

Следующая наша задача - это создание инструкции CREATE TABLE DDL. Это делается в процедуре OnClick кнопки 'Construct Create command':


 //Кнопка 'Construct Create command'
 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: integer;
   s: string;
 begin
   BDETable.TableName:=cboBDETblNames.Text;
   BDETable.FieldDefs.Update;
 
   s:='CREATE TABLE ' + BDETable.TableName + ' (';
   with BDETable.FieldDefs do
   begin
     for i:=0 to Count-1 do
     begin
       s:=s + ' ' + Items[i].name;
       s:=s + ' ' + AccessType(Items[i]);
       s:=s + ',';
     end;
     s[Length(s)]:=')';
   end;
 
   Memo1.Clear;
   Memo1.lines.Add (s);
 end;
 

Вышеприведённый код просто анализирует определения полей для выбранной таблицы (cboBDETblNames) и генерирует строку, которая будет использоваться свойством CommandText компоненты TADOCommand.

Например, когда Вы выбираете таблицу Country, то Memo будет заполнен следующей строкой:


 CREATE TABLE country(
 Name TEXT(24),
 Capital TEXT(24),
 Continent TEXT(24),
 Area FLOAT,
 Population FLOAT)
 

И в заключении, пример для кнопки 'Create Table and copy data' , которая удаляет таблицу (DROP..EXECUTE), создаёт таблицу (CREATE..EXECUTE), и затем копирует данные в новую таблицу (INSERT...POST). Так же присутствует некоторая обработка ошибок, но код будет выходить на ошибку, если, например, (новая) таблица ещё не существует (в случае удаления).


 //Кнопка 'Create Table and copy data'
 procedure TForm1.Button2Click(Sender: TObject);
 var
   i: integer;
   tblName: string;
 begin
   tblName:=cboBDETblNames.Text;
 
   //обновляем
   Button1Click(Sender);
 
   //удаление & создание таблицы
   ADOCommand.CommandText:='DROP TABLE ' + tblName;
   ADOCommand.Execute;
 
   ADOCommand.CommandText:=Memo1.Text;
   ADOCommand.Execute;
 
   ADOTable.TableName:=tblName;
 
   //копируем данные
   BDETable.Open;
   ADOTable.Open;
   try
     while not BDETable.Eof do
     begin
       ADOTable.Insert;
       for i:=0 to BDETable.Fields.Count-1 do
       begin
         ADOTable.FieldByName
         (BDETable.FieldDefs[i].name).Value :=
         BDETable.Fields[i].Value;
       end;
       ADOTable.Post;
       BDETable.Next
     end;
   finally
     BDETable.Close;
     ADOTable.Close;
   end;
 end;
 

Вот и всё. Теперь проверьте Вашу базу данных Access...вуаля :) теперь в ней находится таблица Country со всеми данными из DBDEMOS.

Однако некоторые вопросы остались без ответа, например: как добавлять индексы в таблицу (CREATE INDEX ON ...), или как создавать пустую базу данных Access.




Имя пользователя Paradox

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

Вы можете выполнить эту задачу, непосредственно обращаясь к BDE. Включите следующие модули в сецию Uses вашего модуля: DBIPROCS, DBIERRS, DBITYPES

Ниже приведена функция с именем ID, возвращающая сетевое имя входа:


 function ID: string;
 var
   rslt: DBIResult;
   szErrMsg: DBIMSG;
   pszUserName: PChar;
 begin
   try
     Result := '';
     pszUserName := nil;
     GetMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN);
     rslt := DbiGetNetUserName(pszUserName);
     if rslt = DBIERR_NONE then
       Result := StrPas(pszUserName)
     else
     begin
       DbiGetErrorString(rslt, szErrMsg);
       raise Exception.Create(StrPas(szErrMsg));
     end;
     FreeMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN);
     pszUserName := nil;
   except
     on E: EOutOfMemory do
       ShowMessage('Ошибка. ' + E.Message);
     on E: Exception do
       ShowMessage(E.Message);
   end;
   if pszUserName <> nil then
     FreeMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN);
 end;
 




Разбиение и сборка файла

Не так сложно, вот как это может выглядеть:


 var
   inf: file;
   outf: file;
   size: longint;
   outsize: longint;
   amt: word;
   amtRead: word;
 begin
   assignfile(inf, 'входной файл');
   reset(inf, 1);
   size := fileSize(inf);
   repeat
     showMessage('Вставьте дискету в дисковод "A"')
       { или "B", а лучше позвольте их определять }
     assignFile(outf, 'A: выходной файл');
     rewrite(outf, 1);
     outsize := diskFree(1); { или 2, если это дисковод "B" }
     while (outsize > 0) and (size > 0) do
     begin
       amt := sizeof(buf);
       if amt > outsize then
         amt := outsize;
       blockRead(inf, buf, amt, amtRead);
       blockWrite(outf, buf, amtRead);
       dec(outSize, amtRead);
       dec(size, amtRead);
     end;
     closeFile(outf);
   until size <= 0;
   closeFile(inf);
 end;
 

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

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




BEEP для Delphi, который работает как в Pascal

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

Я применяю следующий код, однако он работает только под Win9x/me (Под WinNT/2000/XP вы можете использовать Beep(Tone, Duration) - задавать тон и продолжительность звучания).


 procedure Sound(Freq: Word);
 var
 
   B: Byte;
 begin
 
   if Freq > 18 then
   begin
     Freq := Word(1193181 div LongInt(Freq));
     B := Byte(GetPort($61));
 
     if (B and 3) = 0 then
     begin
       SetPort($61, Word(B or 3));
       SetPort($43, $B6);
     end;
 
     SetPort($42, Freq);
     SetPort($42, Freq shr 8);
   end;
 end;
 
 procedure NoSound;
 var
 
   Value: Word;
 begin
 
   Value := GetPort($61) and $FC;
   SetPort($61, Value);
 end;
 
 procedure SetPort(address, Value: Word);
 var
 
   bValue: byte;
 begin
 
   bValue := trunc(Value and 255);
   asm
 mov dx, address
 mov al, bValue
 out dx, al
   end;
 end;
 
 function GetPort(address: word): word;
 var
 
   bValue: byte;
 begin
 
   asm
 mov dx, address
 in al, dx
 mov bValue, al
   end;
   GetPort := bValue;
 end;
 




Вычисление даты Пасхи

Автор: Mark Lussier

...да, microsoft ваш мал, мягок и завис.


 function TtheCalendar.CalcEaster: string;
 var
   B, D, E, Q: Integer;
 
   GF: string;
 begin
 
   B := 225 - 11 * (Year mod 19);
   D := ((B - 21) mod 30) + 21;
   if D > 48 then
     Dec(D);
   E := (Year + (Year div 4) + D + 1) mod 7;
   Q := D + 7 - E;
   if Q < 32 then
   begin
     if ShortDateFormat[1] = 'd' then
       Result := IntToStr(Q) + '/3/' + IntToStr(Year)
 
     else
       Result := '3/' + IntToStr(Q) + '/' + IntToStr(Year);
   end
   else
   begin
     if ShortDateFormat[1] = 'd' then
       Result := IntToStr(Q - 31) + '/4/' + IntToStr(Year)
 
     else
       Result := '4/' + IntToStr(Q - 31) + '/' + IntToStr(Year);
   end;
   {вычисление страстной пятницы}
   if Q < 32 then
   begin
     if ShortDateFormat[1] = 'd' then
       GF := IntToStr(Q - 2) + '/3/' + IntToStr(Year)
     else
       GF := '3/' + IntToStr(Q - 2) + '/' + IntToStr(Year);
   end
   else
   begin
     if ShortDateFormat[1] = 'd' then
       GF := IntToStr(Q - 31 - 2) + '/4/' + IntToStr(Year)
 
     else
       GF := '4/' + IntToStr(Q - 31 - 2) + '/' + IntToStr(Year);
   end;
 
 end;
 




Вычисление даты Пасхи 2


 function Easter(Year: Integer): TDateTime;
 {----------------------------------------------------------------}
 { Вычисляет и возвращает день Пасхи определенного года.          }
 { Идея принадлежит Mark Lussier, AppVision <MLussier@best.com>.  }
 { Скорректировано для предотвращения переполнения целых, если по }
 { ошибке передан год с числом 6554 или более.                    }
 {----------------------------------------------------------------}
 
 var
   nMonth, nDay, nMoon, nEpact, nSunday,
     nGold, nCent, nCorx, nCorz: Integer;
 begin
   { Номер Золотого Года в 19-летнем Metonic-цикле: }
   nGold := (Year mod 19) + 1;
   { Вычисляем столетие: }
   nCent := (Year div 100) + 1;
   { Количество лет, в течение которых отслеживаются високосные года... }
   { для синхронизации с движением солнца: }
   nCorx := (3 * nCent) div 4 - 12;
   { Специальная коррекция для синхронизации Пасхи с орбитой луны: }
   nCorz := (8 * nCent + 5) div 25 - 5;
   { Находим воскресенье: }
   nSunday := (Longint(5) * Year) div 4 - nCorx - 10;
   { ^ Предохраняем переполнение года за отметку 6554}
   { Устанавливаем Epact - определяем момент полной луны: }
   nEpact := (11 * nGold + 20 + nCorz - nCorx) mod 30;
   if nEpact < 0 then
     nEpact := nEpact + 30;
   if ((nEpact = 25) and (nGold > 11)) or (nEpact = 24) then
     nEpact := nEpact + 1;
   { Ищем полную луну: }
   nMoon := 44 - nEpact;
   if nMoon < 21 then
     nMoon := nMoon + 30;
   { Позиционируем на воскресенье: }
   nMoon := nMoon + 7 - ((nSunday + nMoon) mod 7);
   if nMoon > l 31 then
   begin
     nMonth := 4;
     nDay := nMoon - 31;
   end
   else
   begin
     nMonth := 3;
     nDay := nMoon;
   end;
   Easter := EncodeDate(Year, nMonth, nDay);
 end; {Easter}
 




Как написать генератор паролей

Автор: Barracuda

Призвали как-то одного волосатого админа в армию служить, на границу. Поставили его в дозор. Вдруг админ слышит шаги...
- Стой! Пароль!...
ответ из темноты:
- Владивосток...
- Логин ...
- ????!!!......

Hi всем! Начнём с того что кинем на форму три Edit -а , Батон (Button), два GroopBox-a , popUp меню и UpDown. На одну панель бросаем три RadioButton-a, на другую три CheckBox-a. Ассоциируем UpDown с первым Edit-ом, здесь будет выбор кол-ва букв в пароле. Второй Edit будет для вывода пароля, а третий для побуквенного вывода сгенереного пароля. CheckBox-ы называем C1,C2,C3,C4,C5. RadioButton-ы называем Ra1,Ra2,Ra3. В меню делаем два пункта, их каптионы называем +10 и -10. Caption-ы CheckBox-ов обзываем 'Латиница','Кирилица','0..9','Спецсимволы ' и 'Смесь'. Это для выбора символов из которых генерится пароль. Caption-ы RadioButton-ов обзываем 'Upper Case' 'Lower Case' 'Misc' -для выбора регистра. Один CheckBox и RadioButton делаем выделеными по умолчанию. Батон используем как стартовую кнопку. А дальше смотрите код:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls, Spin, ExtCtrls, Menus, ComCtrls, Buttons;
 
 type
   TForm1 = class(TForm)
     Gen: TButton;
     Label1: TLabel;
     Status: TStatusBar;
     PopupMenu2: TPopupMenu;
     N101: TMenuItem;
     N102: TMenuItem;
     edit2: TEdit;
     edit3: TEdit;
     edit1: TMemo;
     U1: TUpDown;
     C1: TCheckBox;
     C2: TCheckBox;
     C3: TCheckBox;
     C4: TCheckBox;
     C5: TCheckBox;
     Ra1: TRadioButton;
     Ra2: TRadioButton;
     Ra3: TRadioButton;
     GroupBox1: TGroupBox;
     GroupBox2: TGroupBox;
     procedure GenClick(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure N101Click(Sender: TObject); {Обработка пунктов меню}
     procedure N102Click(Sender: TObject); {Обработка пунктов меню}
     procedure SpinKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
     procedure edit1KeyPress(Sender: TObject; var Key: Char);
   private
     { Private declarations }
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
   kol: integer;
   ss: string;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.GenClick(Sender: TObject);
 label
   1;
 const
   con1='qwertyuiopasdfghjklzxcvbnm';
   con2='QWERTYUIOPASDFGHJKLZXCVBNM';
   con3='qwertyuiopasdfghjklzxcvbnmQWERTYUIOPASDFGHJKLZXCVBNM';
   con4='!@#$%^&*()_+|\=-<>.,/?''; :"][}{';
   con5='йцукенгшщзхъфывапролджэячсмитьбю';
   con6='ЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЭЯЧСМИТЬБЮ';
   con7='йцукенгшщзхъфывапролджэячсмитьбюЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЭЯЧСМИТЬБЮ';
 var
   s: string;
   r, m, k, l: integer;
 begin
   randomize;
   if edit1.text<>'' then
     kol:=strtoint(edit1.text)
   else
   begin
     goto 1;
   end;
   begin
     edit2.text:='Введите значение...';
   end;
   edit3.clear; status.simpletext:='Подождите, пароль генерируется...';
   repeat
     r:=random(8)+1;
     if kol>0 then
       if (c1.Checked=true) or (c2.Checked=true) or
       (c3.Checked=true) or (c4.Checked=true) then
         case r of
           1:if (c2.Checked=true) and (ra1.Checked=true) then
               s:=s+con1[random(25)+1];
           2:if (c2.Checked=true) and (ra2.Checked=true) then
               s:=s+con2[random(25)+1];
           3:if (c2.Checked=true) and (ra3.Checked=true) then
               s:=s+con3[random(49)+1];
 
           4:if c4.Checked=true then
               s:=s+con4[random(30)+1];
           5:if c1.Checked=true then
               s:=s+inttostr(random(10));
 
           6:if (c3.Checked=true) and (ra1.Checked=true) then
               s:=s+con5[random(31)+1];
           7:if (c3.Checked=true) and (ra2.Checked=true) then
               s:=s+con6[random(31)+1];
           8:if (c3.Checked=true) and (ra3.Checked=true) then
               s:=s+con7[random(63)+1];
         end
     else
     begin
       s:='Выберите символы которые вы хотите использовать';
       kol:=length(s);
     end;
   until
     length(s)>=kol;
   while length(s)>kol do
     delete(s,1,1);
 
   1:
   if edit1.text='' then
   begin
     s:='Выберите кол-во символов в пароле!';
     kol:=length(s);
     status.simpletext:='Выберите кол-во символов в пароле!';
     edit2.text:=s;
     edit3.text:= 'Выберите кол-во символов в пароле!';
   end
   else
   begin
     edit2.text:=s;
     for m:=1 to kol do
       edit3.text:=edit3.text+' '+s[m];
   status.simpletext:='Пароль готов!';
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   edit2.clear;edit3.clear;
   edit2.text:='Здесь будет пароль!';
   u1.position:=8;
   edit3.text:='А здесь каждый символ отдельно!'; kol:=0;
 end;
 
 procedure TForm1.N101Click(Sender: TObject);
 begin
   u1.position:=u1.position+10
 end;
 
 procedure TForm1.N102Click(Sender: TObject);
 begin
   if u1.position>10 then
     u1.position:=u1.position-10
   else
     status.simpletext:='Слишком маленькое значение!!!';
 end;
 
 procedure TForm1.SpinKeyDown(Sender: TObject; var Key: Word;
 Shift: TShiftState);
 begin
   if (key=13) then genclick(gen) ;
 end;
 
 procedure TForm1.edit1KeyPress(Sender: TObject; var Key: Char);
 begin
   if not (key in ['0'..'9']) then key:=#0;
 end;
 
 end.
 

Ну всё, Удачи...




Как в Memo перехватить нажатие Ctrl+V и вставить текст не из буфера обмена

Вот ещё круче фишка: Сижу на лекции, пишу, вдруг попадается английское слово.. долго искала, где у меня шрифт переключается...


 uses
   ClipBrd;
 
 procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word;
 Shift: TShiftState);
 begin
   if ((Key = ord('V')) and (ssCtrl in Shift)) then
   begin
     if Clipboard.HasFormat(CF_TEXT) then
       ClipBoard.Clear;
     Memo1.SelText := 'Delphi World is COOL!';
     key := 0;
   end;
 end;
 




Пропатчить двоичный файл - заменить строку


 // Replaces a string in a file with new string. 
 // Ersetzt eine Zeichenkette in einer Datei mit einer anderen Zeichenkette. 
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   f: file;
   l: Longint;
   FileName, oldstring, newstring, s: string;
 begin
   oldstring := 'old string';
   newstring := 'new string';
   FileName  := 'c:\YourFileName.xyz';
 
   s := oldstring;
   AssignFile(f, FileName);
   Reset(f, 1);
   for l := 0 to FileSize(f) - Length(oldstring) - 1 do
   begin
     Application.ProcessMessages;
     Seek(f, l);
     BlockRead(f, oldstring[1], Length(oldstring));
     if oldstring = s then
     begin
       Seek(f, l);
       BlockWrite(f, newstring[1], Length(newstring));
       ShowMessage('String successfully replaced!');
     end;
     Application.ProcessMessages;
   end;
   CloseFile(f);
 end;
 




Путь и Имя папки My Computer

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

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

Операционная система windows 32 основывается на оболочке, которая использует виртуальные папки, такие, как 'my computer' (Мой компьютер), 'desktop' (Рабочий Стол) и 'recycle bin' (Корзина). Некоторые из них являются частью физической файловой системы. Другими словами, они имеют соответствующий реальный каталог в файловой системе. Это относится, например, к системным папкам 'desktop' и 'recycle bin'. Данные каталоги могут быть использованы как InitialDir в TOpenDialog, но сначала вы должны получить их физическое месторасположение, которое может различаться на других компьютерах. Чтобы узнать их реальное месторасположение на локальном диске, вы должны воспользоваться некоторыми специальными вызовами API (смотри пример ниже). Другие папки, типа 'my computer' и 'printers' не являются частью файловой системы, они чисто виртуальные. Обращаю ваше внимание на то, что такие папки можно использовать в TOpenDialog, но никак не в InitialDir.

Виртуальные папки (я немного упрощаю) имеют тип SHITEMID (идентификатор элемента). Получить к ним доступ можно используя pointers to item identifiers list (PIDL, указатель на элемент списка идентификаторов). Для того, чтобы получить PIDL специальной папки, вы должны использовать функцию SHGetSpecialFolder. Физическое месторасположение соответствующей директории можно получить, передавая PIDL в качестве входного параметра функции GetPathFromIDList. Если папка является частью файловой системы, функция возвращает путь к ней в виде строки (которая впоследствии может использоваться как InitialDir). Но если вы хотите использовать OpenDialog только с виртуальными папками (например, с 'my computer'), то в принципе вы должны использовать PIDL как InitialDir, но это работать не будет. Я думаю дело в том, что TOpenDialog использует PIDLs только для просмотра, а для InitialDir требуются только реальные (физические) каталоги.

Вот пример, показывающий как получить путь к 'recent documents' (последние документы) и использовать его в качестве InitialDir:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   PIDL: Pointer;
   Path: LPSTR;
 const
   CSIDL_RECENT = $0008;
 begin
   Path := StrAlloc(MAX_PATH);
   SHGetSpecialFolderLocation(Handle, CSIDL_RECENT, @PIDL);
   // возвращает False если папка не является частью файловой системы
   if SHGetPathFromIDList(PIDL, Path) then
   begin
     OpenDialog1.InitialDir := Path;
     OpenDialog1.Execute;
   end;
   StrDispose(Path);
 end;
 

Я думаю вам необходимо создать класс-оболочку для этих вызовов API. Они располагаются в shell32.dll. Наилучший совет, который я могу дать при изучении этого вопроса - копнуть поглубже файл ShlObj.h. Я также не программирую в C, но почерпнул оттуда немало ценной информации.

Вот некоторые константы, которые вам могут понадобиться:


 CSIDL_DESKTOP            = $0000;
 CSIDL_PROGRAMS           = $0002;
 CSIDL_CONTROLS           = $0003;
 CSIDL_PRINTERS           = $0004;
 CSIDL_PERSONAL           = $0005;
 CSIDL_STARTUP            = $0007;
 CSIDL_RECENT             = $0008;
 CSIDL_SENDTO             = $0009;
 CSIDL_BITBUCKET          = $000a;
 CSIDL_STARTMENU          = $000b;
 CSIDL_DESKTOPDIRECTORY   = $0010;
 CSIDL_DRIVES             = $0011;  // Мой компьютер
 CSIDL_NETWORK            = $0012;
 CSIDL_NETHOOD            = $0013;
 CSIDL_FONTS              = $0014;
 CSIDL_TEMPLATES          = $0015;
 




Преобразовать PChar и String

Разговор двух программистов:
- Что пишешь?
- Сейчас запустим - узнаем!

Все функции API для работы с текстом используют неудобный тип String, а PChar – быстрее. Преобразовать строку String в PChar очень просто: PChar('It is my string'). Можно использовать то, что PChar – это адрес персого символа строки, заканчивающейся символом #0. И, наконец, еще одно удобство. Delphi воспринимает массив типа Char и как обычную строку, и как строку PChar. Полная совместимость. Эта программа демонстрирует демонстрирует все это.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   s: array [0..99] of char;
   p: integer;
 begin
   s := 'Delphi World';
   FindWindow(nil, s);
   p := pos('lp', s);
   Form1.Caption := copy(s, p, Length(s) - p);
 end;
 




PChar в TStringList

Автор: Neil

Это просто. Допустим у нас имеется PChar P, содержащий символы перевода строки #13 или #13#10, и TStringList с именем TS, для копирования P в TS достаточно следующей команды:


 TS.SetText(P);
 




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


Идет похмельный программист по лесу. Смотрит, сидит лягушка и говорит ему человеческим голосом:
- Я заколдованная царевна, возьми меня, поцелуй, и я превращусь в красивую девушку, ты на мне женишься (со всеми вытекающими последствиями). Программист взял ее посадил в карман и дальше пошел. А Лягушка дергает его за пиджак:
- Эй! Ты не понял! Меня надо поцеловать и т.д.
А он ей отвечает:
- Понимаешь, я - программист. Мне с девушками возиться некогда. А говорящая лягушка - это прикольно!

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

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

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

Создание Пасхального яйца

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

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

  1. Выберите форму, которая будет использоваться для запуска яйца.
  2. Объявите целую (integer) переменную (с именем: icnt, в секции private):

 private
   icnt: integer;
 

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

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

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

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

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

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

Как это работает?

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

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


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

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




Поиск фраз и записей переменной длины

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

  1. при внесении в базу данных новой записи она сканируется на предмет определения ключевых слов (это может быть как предопределенный список ключевых слов, так и всех слов, не встречающиеся в стоп-листе [пример: "the", "of", "and"])

  2. ключевые слова вносятся в список ключевых слов со ссылкой на номер записи, например, "hang",46 или "PC",22.

  3. когда пользователь делает запрос, мы извлекаем все записи, где встречается каждое из ключевых слов, например, "hang" может возвратить номера записей 11, 46 и 22, тогда как "PC" - записи с номерами 91, 22 и 15.

  4. затем мы объединяем числа из всех списков c помощью какого-либо логического оператора, например, результатом приведенного выше примера может быть запись под номером 22 (в случае логического оператора AND), или записи 11, 15, 22, 46 и 91 (в случае оператора OR). Затем извлекайте и выводите эти записи.

  5. для синонимов определите таблицу синонимов (например, "hang","kaput"), и также производите поиск синонимов, добавляя их к тому же списку как и оригинальное слово.

  6. слова, имеющие общие окончания (например, "hang" и "hanged"), можно также сделать синонимами, или, как это делает большинство систем, производить анализ окончаний слов, вычисляя корень по их перекрытию (например, слову "hang" соответствует любое слово, чьи первые 4 буквы равны "hang").

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




Как сделать генератор PH, не зная алгоритма его вычисления

Едет программер с девушкой в троллейбусе. Девушка:
- Мечтаю съездить на могилку к Янке... Программер (немного подумав):
- А я мечтаю съездить на могилку к Биллу Гейтсу.

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

Мне понадобилось перевести несколько видеороликов в стандарт MPEG, а для сего я скачал с www.download.com XingMPEG Encoder 2.20 – во всех отношениях просто замечательную программу, кроме одного: это trial-версия (т.е. она работает только 30 дней), но главное – trial позволяет делать файлы не более 30 секунд. А поскольку большинство роликов заметно больше 30 секунд, мы займемся исправлением этого недоразумения.

Для начала с помощью SoftICE. При запуске программы появится окошко с логотипом фирмы и сообщением, что это не полная версия. Внизу окошка – бегунок, показывающий количество дней до конца халявы, а так же 3 кнопки: "Buy Now", "Try First" и "Cancel".

Нажимаем кнопку "Buy Now" и попадаем в окно регистрации, где заполним больше десятка полей всяческой ерундой. Пару раз щелкаем "Дальше". Попали в окошко, где надо вводить данные о кредитной карточке. Я заполнил поля так:


   Тип карточки	– American Express
   Card Number	– 1234 1234 1234 1234
   Expiration	– 11/11
   Name on card	– You!
 

Трижды щелкаем "Дальше", и попадем в окно с выбором платежа. Выберем "ORDER BY MAIL/FAX", т.к. все остальные отпадают по понятным причинам. Теперь, когда мы снова запустим программу и нажмем "Buy Now", мы попадем в само окно регистрации, где и необходимо ввести код, якобы присланный нам по почте после оплаты.

Теперь поставим в SoftICE контрольную точку на выполнение MessageBoxA(). Вводим в окно для кода любое число, но меньше 10 знаков (можно и 10, но тогда придется прокручивать страниц пять текста, чтобы найти команду перехода). Щелкаем "ОК" и попадаем в SoftICE. Жмем F12, "ОК" в окошке с сообщением о неверном коде, и попадаем обратно в SoftICE. Наблюдаем такую картину:


 :10005635  call [user32!MessageBoxA]
 :1000563B  mov ecx, [10031774] <--- Мы здесь.
 :10005641  or eax, -01
 

Прокрутим код немного вверх, пока не натолкнемся на строчки:


 :1000560C  repnz scasb
 :1000560E  not ecx
 :10005610  dec ecx
 :10005611  cmp ecx, 0A <---- Проверка длины.
 :10005614  jz 10005655 <---- Сюда bpx.
 :10005616  lea edx, [esp+10]
 

Отключим предыдущие контрольные точки, и поставим новую на выполнение команды jz 10005655 (просто двойным щелчком по этой строке), вернемся в программу и введем теперь точно 10 цифр в окно для кода (а можно просто поменять значение регистра флагов Z) и снова попытаемся зарегистрироваться. Произойдет остановка на jz 10005655 (JUMP), протрассируем (F10) немного программу, пока не дойдем до места:


 :10005698  push ecx
 :10005699  push edx
 :1000569A  push eax
 :1000569B  call 1000B950 <---- Остановимся тут.
 :100056A0  add esp, 0C
 

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


   d ecx – пусто
   d edx – крупненькая константа = Er5286RteWa2314HmN
   d eax – номер, у меня – 4872151134
 

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

Проверим это, выполнив call. Посмотрим, что теперь находится в ранее пустом ecx:


 d ecx – регистрационный код, у меня – QLRHMLIRYR
 

На этом первая часть заканчивается. Теперь можно ввести код в окне регистрации – и полностью рабочий XingMPEG Encoder 2.20 у нас в руках.

Убрать регистрацию можно так:

  • Uninstall.
  • Удалить из реестра ключ HKEY_CLASES_ROOT\ultxfile\Format\MSHVVEN2 (или типа такого).
  • Переустановить программу.

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

Для примера возьмём все тот же XingMPEG Encoder v2.20 (как найти правильный РН с помощью SoftICE я объяснять здесь не буду, об этом мы уже говорили в первой части, да и о нахождении большинства необходимых данных можно прочитать там же).

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


 :10005698  51           push ecx
 :10005699  52           push edx
 :1000569A  50           push eax
 :1000569B  E8B0620000   call 1000B950
 :100056A0  83C40C       add esp, 0C
 

Обращаем внимание на то, что процедура эта находится в rsagnt32.dll. Также уделяем внимание EIP, из которого можно сделать вывод, что rsagnt32.dll грузилась по стандартному адресу 10000000. Так что несложно будет вычислить адрес и самой функции: 1000В950h – 10000000h = В950h. Самое время посмотреть, какие функции являются в rsagnt32.dll экспортируемыми (для этой цели я использовал DumpBin).

Вот собственно и есть эти функции:


 Ordinal  Hint     RVA             Name
 
    1      0     00002A40     SAAddProductItem
    2      1     00011590     SAChargeTax
    3      2     00011580     SACheckEnable
    4      3     00002B70     SACleanup
    5      4     00002930     SAInitialize
    6      5     0000E350     SAPurchaseOrderEnable
    7      6     000085B0     SAPurchaseOrderSetFaxNumber
    8      7     0000E360     SAPurchaseOrderSetInstParagraph
    9      8     0000E3C0     SAPurchaseOrderSetOrderInfoParagraph
   10      9     00010660     SAReceiptSetNoSerialNumber
   11      A     00010600     SAReceiptSetParagraph
   12      B     000115A0     SASelectTransMethod
   13      C     000029E0     SASetHelpDir
   14      D     000088E0     SASetMailInstruction
   15      E     00008930     SASetNoWaitMail
   16      F     00002980     SASetScreenText
   17     10     00008580     SASetVendorName
   18     11     000012E0     startSalesAgent
 

И что же мы видим? А ничего. Экспортируемой функции с RVA=0000В950 просто нет!

Вот теперь мы перейдём к самому интересному. А что если нам написать программку (я использовал С++), которая будет делать следующее:

  • Загружать rsagnt32.dll. Можно использовать HINSTANCE hInst=LoadLibrary(rsagnt32), при этом hInst - не что иное, как RVA самой DLL (как 10000000, см.выше).
  • Вычислять адрес этой функции. Чтобы получить адрес функции, нам нужно к hInst прибавить В950h. Теперь у нас есть адрес функции (далее KeyMaker()), которую мы будем вызывать, осталось только найти нужные параметры.
  • Вызывать эту функцию, передав ей нужные параметры. Для этого вернемся ещё раз к самой функции из SoftICE:

 :10005698  51          push ecx         <----- Buffer
 :10005699  52          push edx         <----- Const
 :1000569A  50          push eax         <----- PersonalCode
 :1000569B  E8B0620000  call 1000B950    <----- Вызов ф-ции
 :100056A0  83C40C      add esp, 0C      <----- Правка стека

  • Мы видим, что функции передаются три параметра: Buffer, Const и PersonalCode. Buffer - то место, куда запишется правильный код, Const имеет вид Er5286RteWa2314HmN, а PersonalCode берётся из rsagent.ini. (или из окошка в программе регистрации).

Теперь к самой программе:


 char* Const="Er5286RteWa2314HmN";
 char Buffer[10];
 char* PersonalCode="4872151134" //PersonalCode можно читать из rsagent.ini
                                 // используя GetPrivateProfileString()
 

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


 _asm
 
 {
 push offset Buffer
 mov eax, [Const]
 push eax
 mov eax, [PersonalCode]
 push eax
 call dword ptr [KeyMaker]       // KeyMaker это и есть адрес функции, который мы вычислили
 add esp, 0x0C
 }
 

После всего этого в Buffer стоит правильный РН. Ну что, смог я вас убедить?




Как показать картинку в программе из ресурса DLL библиотеки


 uses Sysutils;
 
 procedure TfrmMain.CheckForAddFlow;
 var
   SearchRec: TSearchRec;
   LibHandle: Cardinal;
   ResStream: TResourceStream;
 begin
   if FindFirst('your-lib.dll', faAnyFile, SearchRec) <> 0 then
   begin
     {Загружаем библиотеку}
     LibHandle := LoadLibrary('your_lib.dll');
     if Handle <> 0 then
       {Загружаем ресурс}
       ResStream := TResourceStream.Create(LibHandle,
         PChar('res_name'), RT_BITMAP);
     try
       ImageViewer.Picture.Graphic.LoadFromStream(ResStream);
     finally
       ResStream.Free();
     end;
   end;
 end;
 
 //ShowMessage(IntToStr(AllocMemCount) + ':' + IntToStr(AllocMemSize));
 end;
 
 




Как получить картинку с видео источника

Для использования следующиего примера необходимо иметь "Microsoft Video for Windows SDK". Пример показывает, как открыть видео устройство для захвата видео, как сграбить фрейм с устройства, как сохранить этот фрейм на диск в виде файла .BMP, как записать .AVI файл (со звуком, но без предварительного просмотра), и как закрыть устройство.

Замечание: Для работы примера необходимо иметь установленное устройство захвата видео (video capture device).

Пример:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, ExtCtrls, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Panel1: TPanel;
     OpenVideo: TButton;
     CloseVideo: TButton;
     GrabFrame: TButton;
     SaveBMP: TButton;
     StartAVI: TButton;
     StopAVI: TButton;
     SaveDialog1: TSaveDialog;
     procedure FormCreate(Sender: TObject);
     procedure OpenVideoClick(Sender: TObject);
     procedure CloseVideoClick(Sender: TObject);
     procedure GrabFrameClick(Sender: TObject);
     procedure SaveBMPClick(Sender: TObject);
     procedure StartAVIClick(Sender: TObject);
     procedure StopAVIClick(Sender: TObject);
   private
     { Private declarations }
     hWndC: THandle;
     CapturingAVI: bool;
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 const
   WM_CAP_START = WM_USER;
 const
   WM_CAP_STOP = WM_CAP_START + 68;
 const
   WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;
 const
   WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11;
 const
   WM_CAP_SAVEDIB = WM_CAP_START + 25;
 const
   WM_CAP_GRAB_FRAME = WM_CAP_START + 60;
 const
   WM_CAP_SEQUENCE = WM_CAP_START + 62;
 const
   WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20;
 
 function capCreateCaptureWindowA(lpszWindowName: PCHAR;
   dwStyle: longint;
   x: integer;
   y: integer;
   nWidth: integer;
   nHeight: integer;
   ParentWin: HWND;
   nId: integer): HWND;
   stdcall external 'AVICAP32.DLL';
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   CapturingAVI := false;
   hWndC := 0;
   SaveDialog1.Options :=
     [ofHideReadOnly, ofNoChangeDir, ofPathMustExist]
 end;
 
 procedure TForm1.OpenVideoClick(Sender: TObject);
 begin
   hWndC := capCreateCaptureWindowA('My Own Capture Window',
     WS_CHILD or WS_VISIBLE,
     Panel1.Left,
     Panel1.Top,
     Panel1.Width,
     Panel1.Height,
     Form1.Handle,
     0);
   if hWndC <> 0 then
     SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);
 end;
 
 procedure TForm1.CloseVideoClick(Sender: TObject);
 begin
   if hWndC <> 0 then
   begin
     SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0);
     hWndC := 0;
   end;
 end;
 
 procedure TForm1.GrabFrameClick(Sender: TObject);
 begin
   if hWndC <> 0 then
     SendMessage(hWndC, WM_CAP_GRAB_FRAME, 0, 0);
 end;
 
 procedure TForm1.SaveBMPClick(Sender: TObject);
 begin
   if hWndC <> 0 then
   begin
     SaveDialog1.DefaultExt := 'bmp';
     SaveDialog1.Filter := 'Bitmap files (*.bmp)|*.bmp';
     if SaveDialog1.Execute then
       SendMessage(hWndC,
         WM_CAP_SAVEDIB,
         0,
         longint(pchar(SaveDialog1.FileName)));
   end;
 end;
 
 procedure TForm1.StartAVIClick(Sender: TObject);
 begin
   if hWndC <> 0 then
   begin
     SaveDialog1.DefaultExt := 'avi';
     SaveDialog1.Filter := 'AVI files (*.avi)|*.avi';
     if SaveDialog1.Execute then
     begin
       CapturingAVI := true;
       SendMessage(hWndC,
         WM_CAP_FILE_SET_CAPTURE_FILEA,
         0,
         Longint(pchar(SaveDialog1.FileName)));
       SendMessage(hWndC, WM_CAP_SEQUENCE, 0, 0);
     end;
   end;
 end;
 
 procedure TForm1.StopAVIClick(Sender: TObject);
 begin
   if hWndC <> 0 then
   begin
     SendMessage(hWndC, WM_CAP_STOP, 0, 0);
     CapturingAVI := false;
   end;
 end;
 
 end.
 




Pipeline-компоненты


Новая сказка про трех медведей. Мишутка, глядя на нулевой баланс на счету у провайдера:
- Кто юзал мой аккаунт и весь его выюзал?!

Эта область разработки возникла в моем текущем проекте. Pipeline components - это COM-объекты, которые выполняются в pipeline, который в свою очередь вызывается на выполнение обычно через ASP. Pipeline представляет собой цепочку pipeline component, выполняющихся последовательно один за одним. На вход pipeline передается объект IDictionary, который передается всем компонентам в цепочке. Результатом работы этих компонент может быть видоизмененный IDictionary, либо еще чего-нибудь.

Описание

Pipeline компоненты должны поддерживать интерфейс IPipelineComponent, а также несколько других. Обо всех будет рассказано поподробнее ниже.

Представим себе, что мы хотим создать компонент, который сбрасывает содержимое IDictionary в xml-файл на диск. Причем мы хотим иметь возможность задавать имя этого файла в Properties Page внутри Pipeline Editor. Для ознакомления с Pipeline Editor советую обратиться на сайт Microsoft.

В первую очередь, для создания компонента в Delphi необходимо создать ActiveX Library. Для этого выполним команду File|New -> Activex tabsheet -> ActiveX Library. Затем там добавим Automation Object. Назовем объект DumpOrderToXml. Добавим методы SetXmlFilename и GetXmlFilename. Результатом должны быть следующие объявления:


 function SetXmlFilename(XmlFileName: WideString):
 HResult [dispid $00000001]; stdcall;
 
 function GetXmlFileName(retval XmlFileName: WideString):
 HResult [dispid $00000002]; stdcall;
 

Для дальнейшей успешной работы Вы должны иметь на диске следующие файлы: COMMERCELib_TLB.pas, MSCSAspHelpLib_TLB.pas, MSCSCoreLib_TLB.pas, PIPELINELib_TLB.pas. Их можно сгенерировать с помощью tipe library editor, предоставляемого Delphi, либо скачать у меня. Также необходимо иметь на диске ComPUtil.pas и PipeConsts.pas файлы, которые есть у меня.

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


 type
   TDumpOrderToXml = class(TAutoObject, IDumpOrderToXml, IPipelineComponent,
   ISpecifyPropertyPages, IPersistStreamInit)
   private
     FXmlFileName: WideString;
   protected
     { IDumpOrderToXml methods }
     function GetXmlFileName(out XmlFileName: WideString): HResult; stdcall;
     function SetXmlFilename(const XmlFileName: WideString): HResult; stdcall;
     { IPipelineComponent methods }
     function EnableDesign(fEnable: Integer): HResult; stdcall;
     function Execute(const pdispOrder, pdispContext: IDispatch;
     lFlags: Integer; out plErrorLevel: Integer): HResult; stdcall;
     { ISpecifyPropertyPages methods }
     function GetPages(out pages: TCAGUID): HResult; stdcall;
     { IPersistStreamInit methods }
     function GetClassID(out classID: TCLSID): HResult; stdcall;
     function IsDirty: HResult; stdcall;
     function Load(const stm: IStream): HResult; stdcall;
     function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;
     function GetSizeMax(out cbSize: Largeint): HResult; stdcall;
     function InitNew: HResult; stdcall;
 end;
 

Интерфейс IDumpOrderToXml предоставляет нам возможность задавать и получать имя xml-файла для хранения на диске. Интерфейс IPipelineComponent - стержневой для класса, он позволяет запустить компонент на выполнение с помощью метода Execute. Интерфейс ISpecifyPropertyPage позволяет задать classid для Property Page нашего нового класса. Интерфейс IPersistStreamInit позволяет хранить введеные параметры с помощью Pipeline Editor в файле .pcf.

Приступим к реализации этих методов. Методы GetXmlFilename и SetXmlFilename достаточно просты - они просто читают (пишут) значение из (в) поле FXmlFileName. Метод EnableDesing вызывается для уведомления класса, что редактор переводит его в режим дизайна. В принципе крутые компоненты могут что-либо делать в этот момент. Нам это не нужно, поэтому просто вернем S_OK. Точно также поступим с методами InitNew и IsDirty. Это несущественные методы, которые в принципе можно реализовать более детально, но не для нас.

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


 function TDumpOrderToXml.Save(const stm: IStream;
 fClearDirty: BOOL): HResult;
 var
   OleStream: TOleStream;
   FileNameLen: Byte;
 begin
   OleStream := TOleStream.Create(stm);
   try
     FileNameLen := Length(FXmlFileName);
     OleStream.write(FileNameLen, 1);
     OleStream.write(FXmlFileName[1], FileNameLen * Sizeof(WideChar));
   finally
     OleStream.Free;
   end;
   Result := S_OK;
 end;
 
 
 function TDumpOrderToXml.Load(const stm: IStream): HResult;
 var
   OleStream: TOleStream;
   FileNameLen: Byte;
 begin
   OleStream := TOleStream.Create(stm);
   try
     OleStream.read(FileNameLen, 1);
     SetLength(FXmlFileName, FileNameLen);
     OleStream.read(FXmlFileName[1], FileNameLen * Sizeof(WideChar));
   finally
     OleStream.Free;
   end;
   Result := S_OK;
 end;
 

Метод GetClassID позволяет вернуть наш classid для внешнего потребителя. Ниже приведенное решение в принципе универсальное для любого класса.


 function TDumpOrderToXml.GetClassID(out classID: TCLSID): HResult;
 begin
   classID := Factory.ClassID;
   Result := S_OK;
 end;
 

Метод GetSizeMax возвращает размер, который наш класс хочет занять в потоке. Пусть это будет 255 widechar-ов.


 function TDumpOrderToXml.GetSizeMax(out cbSize: Largeint): HResult;
 begin
   cbSize := 255 * sizeof(WideChar) + 1;
   Result := S_OK;
 end;
 

Теперь приступим к реализации метода Execute. В первую очередь нам необходимо получить ссылку на IDictionary из параметров метода. Для этого воcпользуемся функцией GetDictFromDispatch из модуля ComPUtil.pas. Затем вызовем функцию ExportDictionaryToXml, сохраним результат во временной строке, представляющей собой xml-текст и запишем эту строку в файл на диске.


 function TDumpOrderToXml.Execute(const pdispOrder, pdispContext: IDispatch;
 lFlags: Integer; out plErrorLevel: Integer): HResult;
 var
   hFile: Integer;
   tmpXML: WideString;
   Order: IDictionary;
   tmpOutXml: string;
 begin
   try
     tmpXML := '';
     if GetDictFromDispatch(pdispOrder, Order) = S_OK then
     begin
       ExportDictionaryToXML(Order, tmpXML);
       tmpXML := '' + tmpXML + '';
     end;
     tmpOutXml := tmpXML;
     hFile := FileCreate(string(FXmlFileName));
     FileWrite(hFile, tmpOutXml[1], Length(tmpOutXML));
     FileClose(hFile);
   finally
     Result := S_OK;
     Order := nil;
   end;
 end;
 

Как видим, метод довольно несложный - вся нагрузка ложится на метод ExportDictionaryToXml. Рассмотрим его поподробнее. Как известно, dictionary представляет собой список именованных вариантов. Вариант сам по себе может быть IDictionary, ISimpleList или другой интерфейс. Для перечисления своих элементов dictionary поддерживает интерфейс IEnumVARIANT. Соотвественно, наша задача - взять IEnumVARIANT, пробежаться по его элементам и сохранить их имена и значение в строке.


 Result := E_FAIL;
 hr := InitKeyEnumInDict(Dict, Enum);
 if hr = S_OK then
 begin
   repeat
   hr := GetNextKeyInDict(Enum, Key);
   if hr <> S_OK then
     Break;
   hr := GetDictValueVariant(Dict, LPCWSTR(Key), ItemValue);
   if hr <> S_OK then
     Break;
   case VarType(ItemValue) of
     ...
   else
     Break;
   end;
 until
   hr <> S_OK;
 end;
 XmlStr := Res;
 Result := S_OK;
 

Основное место в теле метода занимает оператор case. В нем определяются обычные значения варианта и сложные, такие как интерфейсы. Для обычных типов обработка будет такая:


 Res := Res + Format('<%s>%s</%s>', [string(Key), string(ItemValue), string(Key)]);
 

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


 Res := Res + Format('<%s>IUnknown</%s>',[string(Key), string(Key)]);
 

Наиболее сложная обработка для типа varDispatch. Здесь нам необходимо убедится, что элемент является либо IDictionary, либо ISimpleList. Для других случаев используем тоже самое, как для varUnknown:


 if GetDictFromDispatch(ItemValue, NewDict) = S_OK then
 begin
   if ExportDictionaryToXML(NewDict, NewXml) = S_OK then
   begin
     Res := Res + Format('<%s type="Dictionary">%s</%s>',
     [string(Key), string(NewXml), string(Key)]);
   end
   else
     Exit;
 end
 else
 if GetSimpleListFromDispatch(ItemValue, NewList) = S_OK then
 begin
   if ExportSimpleListToXML(NewList, NewXml) = S_OK then
   begin
     Res := Res + Format('<%s type="SimpleList">%s</%s>',
     [string(Key), string(NewXml), string(Key)]);
   end
   else
     Exit;
 end
 else
 begin
   Res := Res + Format('<%s>IDispatch</%s>',
   [string(Key), string(Key)]);
 end;
 

Поскольку вариант может быть другим IDictionary, то в результате получим рекурсивный алгоритм. Замечу, что в случае ISimpleList вызывается еще один метод - ExportSimpleListToXml. Его реализация достаточно проста. Необходимо пробежаться по элементам списка, каждый из которых IDictionary, и вызывать ExportDictioanryToXml:


 Result := E_FAIL;
 hr := GetNumItems(List, Count);
 if hr <> S_OK then
   Exit;
 
 for I := 0 to Count - 1 do
 begin
   if GetNthItem(List, I, NewDict) = S_OK then
   begin
     if ExportDictionaryToXML(NewDict, NewXml) = S_OK then
     begin
       Res := Res + Format('<LISTITEM%d>'#13#10'%s</LISTITEM%d>'#13#10,
       [I, string(NewXml), I]);
     end
     else
       Exit;
   end;
 end;
 XmlStr := Res;
 Result := S_OK;
 

Вот собственно и вся реализация метода Execute. Для полной красоты картины, нам необходимо научиться редактировать поле FXmlFilename в Pipeline редакторе. Для этого добавим в проект Property Page. На форму добавим из палитры Textbox, Label, Button и SaveDialog.

В обработчик нажатия кнопки добавим код по вызову SaveDialog:


 if SaveDialog1.Execute then
 begin
   Edit1.Text := SaveDialog1.FileName;
 end;
 

Для реализации поведения Property Page, мы должны реализовать два метода UpdatePropertyPage и UpdateObject. Первый метод восстанавливает значение из объекта в textbox. Второй, наоборот, записывает значение из textbox в объект.


 procedure TDumpToXMLPropertyPage.UpdatePropertyPage;
 var
   StrXmlFilename: WideString;
 begin
   { Update your controls from OleObject }
   (OleObjects.First as IDumpOrderToXml).GetXmlFileName(StrXmlFilename);
   Edit1.Text := StrXmlFilename;
 end;
 
 procedure TDumpToXMLPropertyPage.UpdateObject;
 var
   StrXmlFilename: WideString;
 begin
   { Update OleObject from your controls }
   StrXmlFilename := Edit1.Text;
   (OleObjects.First as IDumpOrderToXml).SetXmlFileName(StrXmlFilename);
 end;
 

Для того, чтобы Pipeline Editor знал, что у компонента есть дополнительные property-странички, необходимо реализовать метод GetPages у нашего класса.


 function TDumpOrderToXml.GetPages(out pages: TCAGUID): HResult;
 begin
   pages.cElems := 1;
   pages.pElems := CoTaskMemAlloc(sizeof(TGUID));
   if pages.pElems = nil then
     Result := E_OUTOFMEMORY
   else
   begin
     pages.pElems^[0] := Class_DumpToXMLPropertyPage;
     Result := S_OK;
   end;
 end;
 

Этот метод занимается тем, что наполняет структуру, в которой хранятся все guid-ы наших property-страничек. В нашем случае это одна страничка - Class_DumpToXmlPropertyPage. Этот guid генерируется автоматически средой, когда мы создаем новую property page.

Теперь подошел черед модифицировать .dpr файл. В нем указывается экспортная функция DllRegisterServer, которую надо переделать:


 function DllRegisterServer: HResult;
 begin
   Result := ComServ.DllRegisterServer;
   if Result = S_OK then
   begin
     { Register DumpOrderToXml class }
     Result := RegisterCATID(CLASS_DumpOrderToXml, CATID_MSCSPIPELINE_COMPONENT);
     if Result >= 0 then
       Result := RegisterCATID(CLASS_DumpOrderToXml, CATID_MSCSPIPELINE_ANYSTAGE);
     { Here you should register others pipeline components }
   end;
 end;
 

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

На этом разработка закончена. Осталось откомпилировать и зарегистриовать dll. Это можно сделать через командную строку:


 regsvr32 testpipelines.dll
 




Как создать Bitmap из массива пикселей

Cегодня вот... оживленно треплюсь с парнем, сидящим за соседним компом... и от возбуждения разговором слегка теряю равновесие и почти падаю на него :))... Он мне говорит: "отойди от меня...", - "отойти на 20 пунктов?" - несмело интересуюсь я... "Нет", - задумчиво продолжает он... - "отойди на 30 пикселей"...

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


 {$IFNDEF WIN32}
 type
   {Used for pointer math under Win16}
   PPtrRec = ^TPtrRec;
   TPtrRec = record
     Lo: Word;
     Hi: Word;
 end;
 {$ENDIF}
 
 {Used for huge pointer math}
 function GetBigPointer(lp: pointer; Offset: Longint): Pointer;
 begin
   {$IFDEF WIN32}
   GetBigPointer := @PByteArray(lp)^[Offset];
   {$ELSE}
   Offset := Offset + TPtrRec(lp).Lo;
   GetBigPointer := Ptr(TPtrRec(lp).Hi + TPtrRec(Offset).Hi *
   SelectorInc,
   TPtrRec(Offset).Lo);
   {$ENDIF}
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   hPixelBuffer : THandle; {Handle to the pixel buffer}
   lpPixelBuffer : pointer; {pointer to the pixel buffer}
   lpPalBuffer : PLogPalette; {The palette buffer}
   lpBitmapInfo : PBitmapInfo; {The bitmap info header}
   BitmapInfoSize : longint; {Size of the bitmap info header}
   BitmapSize : longint; {Size of the pixel array}
   PaletteSize : integer; {Size of the palette buffer}
   i : longint; {loop variable}
   j : longint; {loop variable}
   OldPal : hPalette; {temp palette}
   hPal : hPalette; {handle to our palette}
   hBm : hBitmap; {handle to our bitmap}
   Bm : TBitmap; {temporary TBitmap}
   Dc : hdc; {used to convert the DOB to a DDB}
   IsPaletteDevice : bool;
 begin
   Application.ProcessMessages;
   {If range checking is on - turn it off for now}
   {we will remember if range checking was on by defining}
   {a define called CKRANGE if range checking is on.}
   {We do this to access array members past the arrays}
   {defined index range without causing a range check}
   {error at runtime. To satisfy the compiler, we must}
   {also access the indexes with a variable. ie: if we}
   {have an array defined as a: array[0..0] of byte,}
   {and an integer i, we can now access a[3] by setting}
   {i := 3; and then accessing a[i] without error}
   {$IFOPT R+}
   {$DEFINE CKRANGE}
   {$R-}
   {$ENDIF}
 
   {Lets check to see if this is a palette device - if so, then}
   {we must do palette handling for a successful operation.}
   {Get the screen's dc to use since memory dc's are not reliable}
   dc := GetDc(0);
   IsPaletteDevice :=
   GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
   {Give back the screen dc}
   dc := ReleaseDc(0, dc);
 
   {Размер информации о рисунке должен равняться размеру BitmapInfo}
   {плюс размер таблицы цветов, минус одна таблица}
   {так как она уже объявлена в TBitmapInfo}
   BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255);
 
   {The bitmap size must be the width of the bitmap rounded}
   {up to the nearest 32 bit boundary}
   BitmapSize := (sizeof(byte) * 256) * 256;
 
   {Размер палитры должен равняться размеру TLogPalette}
   {плюс количество ячеек цветовой палитры - 1, так как}
   {одна палитра уже объявлена в TLogPalette}
   if IsPaletteDevice then
     PaletteSize := sizeof(TLogPalette) + (sizeof(TPaletteEntry) * 255);
 
   {Выделяем память под BitmapInfo, PixelBuffer, и Palette}
   GetMem(lpBitmapInfo, BitmapInfoSize);
   hPixelBuffer := GlobalAlloc(GHND, BitmapSize);
   lpPixelBuffer := GlobalLock(hPixelBuffer);
 
   if IsPaletteDevice then
     GetMem(lpPalBuffer, PaletteSize);
 
   {Заполняем нулями BitmapInfo, PixelBuffer, и Palette}
   FillChar(lpBitmapInfo^, BitmapInfoSize, #0);
   FillChar(lpPixelBuffer^, BitmapSize, #0);
   if IsPaletteDevice then
     FillChar(lpPalBuffer^,PaletteSize, #0);
 
   {Заполняем структуру BitmapInfo}
   lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
   lpBitmapInfo^.bmiHeader.biWidth := 256;
   lpBitmapInfo^.bmiHeader.biHeight := 256;
   lpBitmapInfo^.bmiHeader.biPlanes := 1;
   lpBitmapInfo^.bmiHeader.biBitCount := 8;
   lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
   lpBitmapInfo^.bmiHeader.biSizeImage := BitmapSize;
   lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
   lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
   lpBitmapInfo^.bmiHeader.biClrUsed := 256;
   lpBitmapInfo^.bmiHeader.biClrImportant := 256;
 
   {Заполняем таблицу цветов BitmapInfo оттенками серого: от чёрного до белого}
   for i := 0 to 255 do
   begin
     lpBitmapInfo^.bmiColors[i].rgbRed := i;
     lpBitmapInfo^.bmiColors[i].rgbGreen := i;
     lpBitmapInfo^.bmiColors[i].rgbBlue := i;
   end;
 end;
 




Проиграть Flash файл в приложении

Мой компьютер постоянно обыгрывает меня в шахматы. Зато я всегда побеждаю его в боксерском поединке!

To make use of SWF files in your Delphi application you should have the swf plugin installed then follow these steps:

{English}

In the Delphi IDE

- click on "Component", "Import ActiveX Control"
- chose "Shockwave Flash" and click on "install".

Now you have a TShockwaveFlash component in your IDE on the ActiveX tabsheet. Place the TShockwaveFlash Component onto your form, resize it as needed but for now do not assign a movie to it.

You will need to register the ocx file if it is not installed on the target computer. So you should have a resource file with

- the swflash.ocx and your Flash ( *.swf) file.
- Copy swflash.ocx (from i.e. windows\system32\macromed\flash) and your custom swf file to your project path.
- Create a textfile with a code like this:

SHOCKWAVEFILE RCDATA yourfile.swf
SHOCKWAVEOCX RCDATA swflash.ocx

(Where yourfile.swf is your swf-file)

- Save this file as flash.rc
- Goto Commandline, change to your project dir and enter the line:

"Brcc32 -r flash.rc"

- Now you have your new resource as flash.res file


 uses
   ShockwaveFlashObjects_TLB; // will be used automatically 
 
 implementation
 
 {$R *.DFM}
 {$R flash.res} // your new created resource 
 {...}
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   SystemDir: array[0..MAX_PATH] of Char;
   SWFDir, AppDir: string;
   Fres: TResourceStream;
   Ffile: TFileStream;
 begin
   GetSystemDirectory(@SystemDir, MAX_PATH);
   SWFDir := SystemDir + '\macromed\flash\';
   GetDir(0, AppDir); // Get current directory 
 
   //check whether the sw-flash ocx is already installed 
   if FileExists(SWFDir + 'swflash.ocx') = False then
   begin
     //create directories if needed and extract file from resource. 
     {$i-} //compiler directive to suppress i/o error messages 
     MkDir(SystemDir + '\macromed');
     MKDir(SystemDir + '\macromed\flash');
     {$i+}
     Fres := TResourceStream.Create(0, 'SHOCKWAVEOCX', RT_RCDATA);
     Ffile := TFileStream.Create(SWFDir + 'swflash.ocx', fmCreate);
     Ffile.CopyFrom(Fres, Fres.Size);
     Fres.Free;
     Ffile.Free;
 
     //register ocx (simple but useful) 
     WinExec(PChar('regsvr32 /s ' + SWFDir + 'swflash.ocx'), SW_HIDE);
   end;
   // extract ShockwaveFile from resource to application directory 
   Fres := TResourceStream.Create(0, 'SHOCKWAVEFILE', RT_RCDATA);
   Ffile := TFileStream.Create('flashmovie.swf', fmCreate);
   Ffile.CopyFrom(Fres, Fres.Size);
   Fres.Free;
   Ffile.Free;
 
   //Assign the extracted swf file to your TShockwaveFlash object 
   FlashMovie.Movie := AppDir + '\flashmovie.swf';
 end;
 
 (*
   If you dont want to have the popup menu displayed on right click
   you may chose menu property of TShockWave to false.
 *)
 




Проигрывать MPEG файл в Delphi-программе

Разговор программиста с женой. Программер:
- Ты слыхала, что через 10-15 лет станет возможным иметь секс с компьютером?
- А тебе-то что? Для тебя ничего не изменится...

Если в системе Windows MMSystem установлен декодер MPEG - используя компонент TMediaPlayer


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   with MediaPlayer1 do
   begin
     Filename := 'C:\Download\delphiworld.mpg';
     Open;
     Display := Panel1;
     DisplayRect := Panel1.ClientRect;
     Play;
   end;
 end;
 




Как проиграть WAV без MediaPlayer

Приехал программер в деревню в гости к бабушке. На следующий день вся деревня в руинах, кругом валяются трупы людей и животных, а программер ходит с гранатометом по развалинам и приговаривает:
- Хорошо иметь DOOMик в деревне!


 uses
   mmsystem;
 
 // PLAY
 sndPlaySound('C:\DELPHIWORLD.WAV', SND_ASYNC);
 
 // Loop Mode (зацикливание)
 sndPlaySound('C:\DELPHIWORLD.WAV', SND_ASYNC + SND_LOOP);
 
 //STOP
 sndPlaySound(nil, SND_ASYNC);
 




Как можно проиграть звуки, закрепленные за событиями Windows


- Что такое FreeBSD?
Давайте рассуждать логически. BSD - это, определенно, Blue Screen of Death. Поскольку MS Windows (тм) не бесплатно, то FreeBSD - это винды с пиратского компакта.


 unit
   mmsystem;
 
 PlaySound('SystemExit', null, SND_SYNC);
 //или
 sndPlaySound('SystemExit', SND_SYNC);
 




Плазменная заливка формы

Если вам надоели обычные монотонные формы, то эта статья - спасенье для вас!!! Всё, что вам нужно сделать для того, чтобы ваше окно выглядело так же эффектно, как и показанное на рисунке - это только написать несколько строк кода:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics,
   Controls, Forms, Dialogs;
 
 type
   TForm1 = class(TForm)
     procedure FormPaint(Sender: TObject);
   private
     { Private declarations }
     plasma: array [0..768, 0..768] of byte;
     procedure makeplasma;
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormPaint(Sender: TObject);
 var
   x, y: integer;
 begin
   makeplasma;
   for x := 0 to 255 do
   begin
     for y := 0 to 255 do
     begin
       Form1.Canvas.Pixels[x, y] := rgb(plasma[x, y],
       plasma[x + 256, y + 256], plasma[x + 512, y + 512]);
     end;
     Form1.update;
   end;
 end;
 
 procedure TForm1.makeplasma;
 
   procedure halfway(x1,y1,x2,y2: integer);
 
     procedure adjust(xa,ya,x,y,xb,yb: integer);
     var
       d: integer;
       v: double;
     begin
       if plasma[x,y]<>0 then
         exit;
       d:=Abs(xa-xb)+Abs(ya-yb);
       v:=(plasma[xa,ya]+plasma[xb,yb])/2+(random-0.5)*d*2;
       if v<1 then
         v:=1;
       if v>=193 then
         v:=192;
       plasma[x,y]:=Trunc(v);
     end;
 
   var
     x, y: integer;
     v: double;
   begin
     if (x2-x1<2) and (y2-y1<2) then
       exit;
     x:=(x1+x2) div 2;
     y:=(y1+y2) div 2;
     adjust(x1,y1,x,y1,x2,y1);
     adjust(x2,y1,x2,y,x2,y2);
     adjust(x1,y2,x,y2,x2,y2);
     adjust(x1,y1,x1,y,x1,y2);
     if plasma[x,y]=0 then
     begin
       v:=(plasma[x1,y1]+plasma[x2,y1]+plasma[x2,y2]+plasma[x1,y2])/4;
       plasma[x,y]:=Trunc(v);
     end;
     halfway(x1,y1,x,y);
     halfway(x,y1,x2,y);
     halfway(x,y,x2,y2);
     halfway(x1,y,x,y2);
   end;
 
 var
   x, y: integer ;
 begin
   randomize;
   plasma[0,768]:=random(192);
   plasma[768,768]:=random(192);
   plasma[768,0]:=random(192);
   plasma[0,0]:=random(192);
   halfway(0,0,768,768);
 end;
 
 end.
 




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

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

Введение

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

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

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

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

Проблема (недостатки DLL-plugin'ов)

  • Все используемые модули компилируются в DLL.

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

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

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

Задача (чего бы нам хотелось)

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

Средство (пакеты и функции для работы с ними)

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

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

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


 function LoadPackage(const Name: string): HMODULE;
 

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


 procedure UnloadPackage(Module: HMODULE);
 

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

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

Минусы

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

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

Метод (что делаем, и что получим)

Предлагемая структура построения пиложения выглядит следующим образом: выполяемый код = Основная программа + Интерфейс plugin'ов + plugin. Все три перечисленные компоненты должны находиться в разных файлах (программа - в EXE, остальное - в пакетах BPL). Программа умеет загружать пакеты в память и обращаться к подгруженным потомкам абстрактного plugin'а. Plugin представляет собой потомок абстрактного класса, объявленного в интерфейсном модуле. Программа и plugin используют модуль интерфейса, но он находится в отдельном пакете и в памяти будет присутствовать в единственном екземпляре.

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

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

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

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

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

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

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

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


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

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

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

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


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

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

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

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


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

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

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

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


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

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


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

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


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

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


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

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

Компиляция

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

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

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

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




Как написать свой Plugin для поддержки различных форматов файлов

Создал бог Адама. Адаму было скучно и он сказал богу : "Я хочу тра%аться!". И бог создал Еву. Адаму опять стало скучно и он сказал богу :"Я хочу тра%аться весь день ". И бог создал любовницу. Ему опять надоело и он сказал: "Я хочу тра%аться день и ночь". И бог создал операционную систему Windows 95.

Типовая задача - разрабатывается некая задача и при этом

Некоторые ее компоненты могут не инсталлироваться баз ущерба для работоспособности

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

Некоторые компоненты могут разрабатываться другими программистами и распространяться независимо от программы

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

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

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

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

Пример (приложение имеет одно окно, на нем кнопка):


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
   public
 end;
 
 // Тип "процедура". Естественно, можно определит типы
 // "функция" или "функция с параметрами" ...
 TDllProc = procedure;
 
 var
   Form1: TForm1;
   DllProcPtr : TDllProc;
   LibInstance : HMODULE; // Логический номер модуля DLL
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   // Проверим, загружена ли DLL
   if LibInstance=0 then
   begin
     // Не загружена, попробуем загрузить
     LibInstance := LoadLibrary('plug_in.dll');
     // Проверим, успешна ли загрузка (LibInstance=0 - неуспешно)
     if LibInstance=0 then
     begin
       ShowMessage('Ошибка загрузки библиотеки plug_in.dll');
       exit;
     end;
     // Ищем функцию по ее имени (имя должно точно совпадать)
     DllProcPtr := TDllProc(GetProcAddress(LibInstance,'MyProc'));
     // Проверим, нашли ли (если нашли, то Assigned вернет true)
     if not Assigned(DllProcPtr) then
     begin
       // Не нашли - выгружаем DLL из памяти
       FreeLibrary(LibInstance);
       LibInstance:=0;
       ShowMessage('Ошибка: функция MyProc не найдена');
       exit;
     end;
     // Непосредственно вызов функции
     DllProcPtr;
     // Выгрузка библиотеки
     FreeLibrary(LibInstance);
     LibInstance:=0;
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   DllProcPtr:=nil;
   LibInstance:=0;
 end;
 
 end.
 

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

Особенности:

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

Обычно имеет смысл создать ряд функции типа GetInfo, GetAutor, GetCopyRight ..., чтобы вызывающая программа могла получить информацию о назначении данной DLL

Расширение DLL не является обязательным, поэтому можно применять свои расширения (например DRV)




Как корректно определить изменения в оборудовании Plug&Play



Вот pаньше, года этак в 60-е, все было классно - sex, drugs & rock'n'roll. А сейчас? Suxx, bugs & plug'n'play.


 type
   TForm1 = class(TForm)
     Button1: TButton;
   private
     { Private declarations }
     procedure WMDeviceChange(var message: TMessage); message WM_DEVICECHANGE;
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 const DBT_DEVICEARRIVAL = $8000;
 const DBT_DEVICEQUERYREMOVE = $8001;
 const DBT_DEVICEQUERYREMOVEFAILED = $8002;
 const DBT_DEVICEREMOVEPENDING = $8003;
 const DBT_DEVICEREMOVECOMPLETE = $8004;
 const DBT_DEVICETYPESPECIFIC = $8005;
 const DBT_CONFIGCHANGED = $0018;
 
 procedure TForm1.WMDeviceChange(var message: TMessage);
 var
   s : string;
 begin
   {Do Something here}
   case message.wParam of
     DBT_DEVICEARRIVAL :
       s := 'A device has been inserted and is now available';
     DBT_DEVICEQUERYREMOVE:
     begin
       s := 'Permission to remove a device is requested';
       ShowMessage(s);
       {True grants premission}
       message.Result := integer(true);
       exit;
     end;
     DBT_DEVICEQUERYREMOVEFAILED :
       s := 'Request to remove a device has been canceled';
     DBT_DEVICEREMOVEPENDING :
       s := 'Device is about to be removed';
     DBT_DEVICEREMOVECOMPLETE :
       s := 'Device has been removed';
     DBT_DEVICETYPESPECIFIC :
       s := 'Device-specific event';
     DBT_CONFIGCHANGED :
       s:= 'Current configuration has changed'
     else
       s := 'Unknown Device Message';
   end;
   ShowMessage(s);
   inherited;
 end;
 




Протокол POP3 (Post Office Protocol)

- Ты что, Интернет подключил?
- А, что, гдаза умные стали?
- Нет, красные.

Post Office Protocol (POP) - протокол доставки почты пользователю из почтового ящика почтового сервера РОР. Многие концепции, принципы и понятия протокола POP выглядят и функционируют подобно SMTP. Команды POP практически идентичны командам SMTP, отличаясь в некоторых деталях. На рис.7 изображена модель клиент-сервер по протоколу POP. Сервер POP находится между агентом пользователя и почтовыми ящиками.

В настоящее время существуют две версии протокола POP - РОР2 и РОРЗ, обладающими примерно одинаковыми возможностями, однако несовместимыми друг с другом. Дело в том, что у РОР2 и РОРЗ разные номера портов протокола. Между ними отсутствует связь, аналогичная связи между SMTP и ESMTP. Протокол РОРЗ не является расширением или модификацией РОР2 - это совершенно другой протокол. РОР2 определен в документе RFC 937 (Post Office Protocol-Version 2, Butler, et al, 1985), a РОРЗ - в RFC 1225 (Post Office Protocol-Version 3, Rose, 1991). Далее кратко рассмотрим POP вообще и более подробно - РОРЗ. PОРЗ разработан с учетом специфики доставки почты на персональные компьютеры и имеет соответствующие операции для этого.

Назначение протокола РОРЗ

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

Описание протокола РОРЗ

Конструкция протокола РОРЗ обеспечивает возможность пользователю обратиться к своему почтовому серверу и изъять накопившуюся для него почту. Пользователь может получить доступ к РОР-серверу из любой точки доступа к Интернет. При этом он должен запустить специальный почтовый агент (UA), работающий по протоколу РОРЗ, и настроить его для работы со своим почтовым сервером. Итак, во главе модели POP находится отдельный персональный компьютер, работающий исключительно в качестве клиента почтовой системы (сервера). Подчеркнем также, что сообщения доставляются клиенту по протоколу POP, а посылаются по-прежнему при помощи SMTP. То есть на компьютере пользователя существуют два отдельных агента-интерфейса к почтовой системе - доставки (POP) и отправки (SMTP). Разработчики протокола РОРЗ называет такую ситуацию "раздельные агенты" (split UA). Концепция раздельных агентов кратко обсуждается в спецификации РОРЗ.

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

Команды протокола POP версии 3 (для минимальной конфигурации):

  • USER - Идентифицирует пользователя с указанным именем
  • PASS - Указывает пароль для пары клиент-сервер
  • QUIT - Закрывает TCP-соединение
  • STAT - Сервер возвращает количество сообщений в почтовом ящике плюс размер почтового ящика
  • LIST - Сервер возвращает идентификаторы сообщений вместе с размерами сообщений (параметром команды может быть идентификатор сообщения)
  • RETR - Извлекает сообщение из почтового ящика (требуется указывать аргумент-идентификатор сообщения)
  • DELE - Отмечает сообщение для удаления (требуется указывать аргумент - идентификатор сообщения)
  • NOOP - Сервер возвращает положительный ответ, но не совершает никаких действий
  • LAST - Сервер возвращает наибольший номер сообщения из тех, к которым ранее уже обращались
  • RSET - Отменяет удаление сообщения, отмеченного ранее командой DELE

В протоколе РОРЗ определено несколько команд, но на них дается только два ответа: +ОК (позитивный, аналогичен сообщению-подтверждению АСK) и -ERR (негативный, аналогичен сообщению "не подтверждено" NAK). Оба ответа подтверждают, что обращение к серверу произошло и что он вообще отвечает на команды. Как правило, за каждым ответом следует его содержательное словесное описание. В RFC 1225 есть образцы нескольких типичных сеансов РОРЗ. Сейчас мы рассмотрим несколько из них, что даст возможность уловить последовательность команд в обмене между сервером и клиентом.

Авторизация пользователя

После того как программа установила TCP-соединение с портом протокола РОРЗ (официальный номер 110), необходимо послать команду USER с именем пользователя в качестве параметра. Если ответ сервера будет +ОК, нужно послать команду PASS с паролем этого пользователя:


 CLIENT: USER kcope ERVER: +ОК CLIENT:
 PASS secret SERVER: +ОК kcope's maildrop has 2 messages (320 octets)
 (В почтовом ящике kcope есть 2 сообщения (320 байтов) ...)
 

Транзакции РОРЗ

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

Команда STAT возвращает количество сообщений и количество байтов в сообщениях:


 CLIENT: STAT
 SERVER: +ОК 2 320
 

Команда LIST (без параметра) возвращает список сообщений в почтовом ящике и их размеры:


 CLIENT: LIST
 SERVER: +ОК 2 messages (320 octets)
 SERVER: 1 120
 SERVER: 2 200
 SERVER: . ...
 

Команда LIST с параметром возвращает информацию о заданном сообщении:


 CLIENT: LIST 2
 SERVER: +ОК 2 200 ...
 CLIENT: LIST 3
 SERVER: -ERR no such message, only 2 messages in maildrop
 

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


 CLIENT: TOP 10 SERVER: +ОК SERVER: <the POP3 server sends the headers of the message,
 a blank line, and the first 10 lines of the message body>
 (сервер POP высылает заголовки сообщений, пустую строку и
 первые десять строк тела сообщения)
 SERVER: . ... CLIENT: TOP 100 SERVER: -ERR no such message
 

Команда NOOP не возвращает никакой полезной информации, за исключением позитивного ответа сервера. Однако позитивный ответ означает, что сервер находится в соединении с клиентом и ждет запросов:


 CLIENT: NOOP
 SERVER: +ОК
 

Следующие примеры показывают, как сервер POP3 выполняет действия. Например, команда RETR извлекает сообщение с указанным номером и помещает его в буфер местного UA:


 CLIENT: RETR 1 SERVER: +OK 120 octets SERVER: <the POPS server sends the entire message here>
 (РОРЗ-сервер высылает сообщение целиком) SERVER: . . . . . .
 

Команда DELE отмечает сообщение, которое нужно удалить:


 CLIENT: DELE 1
 


 SERVER: +OK message 1 deleted ... (сообщение 1 удалено) CLIENT: DELE 2 SERVER:
 -ERR message 2 already deleted сообщение 2 уже удалено)
 

Команда RSET снимает метки удаления со всех отмеченных ранее сообщений:


 CLIENT: RSET
 SERVER: +OK maildrop has 2 messages (320 octets)
 (в почтовом ящике 2 сообщения (320 байтов) )
 

Как и следовало ожидать, команда QUIT закрывает соединение с сервером:


 CLIENT: QUIT SERVER: +OK dewey POP3 server signing off CLIENT:
 QUIT SERVER: +OK dewey POP3 server signing off (maildrop empty) CLIENT:
 QUIT SERVER: +OK dewey POP3 server signing off (2 messages left)
 

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




PopupComponent и шрифты

Автор: Pat Ritchey

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

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

Хитрость заключается в создании в вашей секции implementation следующего описания класса:


 type
   THack = class(TControl)
     public
       property Font;
   end;
 

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


 if Popup1.PopupControl is TControl then
   if FontDialog1.Execute then
     THack(Popup1.PopupControl).Font := FontDialog1.Font;
 




Вызов контекстного меню в координатах курсора мыши

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

- В мой компьютер попал вирус.
- Ну и что же ты сделал?
- Прививку.
- Куда?
- Под мышку.

Предлагаю свою процедуру в раздел "Компоненты" - "PopupMenu" - "Вызов контекстного меню в координатах курсора мыши"


 procedure TForm1.Form1MouseDown(Sender: TObject; Button:
   TMouseButton; Shift: TShiftState; X, Y: integer);
 var
   FCursor: TPoint;
 begin
   if Button = mbRight then
   begin
     GetCursorPos(FCursor);
     PopupMenu1.Popup(FCursor.X, FCursor.Y);
   end;
 end;
 

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




Вызов контекстного меню в позиции курсора

Автор: Ed Jordan

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

Это будет работать:


 procedure TForm1.Form1MouseDown(Sender: TObject; Button:
 TMouseButton; Shift: TShiftState; X, Y: Integer);
 begin
   if Button = mbRight then
     with ( Sender as TControl ).ClientToScreen( Point( X, Y )) do
       PopupMenu1.Popup( X, Y );
 end;
 




Вызов контекстного меню в позиции курсора 2

...вызов popup-меню связан с координатами экрана. Координаты, получаемые в вашем обрабочике события, вероятно относятся к объекту, который создал это сообщение. Для преобразования координат вам необходимо воспользоваться функцией ClientToScreen.

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


 procedure TfrmExplorer.TreeViewMouseDown(Sender: TObject;
   Button: TMouseButton;
   Shift: TShiftState;
   X, Y: Integer);
 var
   P: TPoint;
 begin
   if Button <> mbRight then
     exit;
   TreeMenu.AutoPopup := False;
   if TreeView.GetNodeAt(X, Y) <> nil then
   begin
     TreeView.Selected := TreeView.GetNodeAt(X, Y);
     P.X := X;
     P.Y := Y;
     P := TreeView.ClientToScreen(P);
     TreeMenu.Popup(P.X, P.Y);
   end;
 end;
 




Вызов контекстного меню в позиции курсора 3


 procedure TForm1.Memo1MouseUp(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 var
   ClientPoint, ScreenPoint: TPoint;
 begin
   if Memo1.SelLength > 0 then
   begin
     ClientPoint.X := X;
     ClientPoint.Y := Y;
     ScreenPoint := ClientToScreen(ClientPoint);
     PopupMenu1.Popup(ScreenPoint.X, ScreenPoint.Y);
   end;
 end;
 




Порты

Здесь приводится список номеров портов и показывается за каким портом какая служба закреплена

  • 7 echo
  • 9 discard
  • 11 systat
  • 13 daytime
  • 15 netstat
  • 17 qotd
  • 19 chargen
  • 20 ftp-data
  • 21 ftp
  • 23 telnet
  • 25 smtp
  • 37 time
  • 39 rlp
  • 42 name
  • 43 whois
  • 53 domain
  • 57 mtp
  • 67 bootp
  • 69 tftp
  • 77 rje
  • 79 finger
  • 87 link
  • 95 supdup
  • 101 hostnames
  • 102 iso-tsap
  • 103 dictionary
  • 104 x400-snd
  • 105 csnet-ns
  • 109 pop
  • 110 pop3
  • 111 portmap
  • 113 auth
  • 115 sftp
  • 117 path
  • 119 nntp
  • 123 ntp
  • 137 nbname
  • 138 nbdatagram
  • 139 nbsession
  • 144 News
  • 153 sgmp
  • 158 tcprepo
  • 161 snmp
  • 162 snmp-trap
  • 170 print-srv
  • 175 vmnet
  • 315 load
  • 400 vmnet
  • 500 sytek
  • 512 biff
  • 513 login
  • 514 shell
  • 515 printer
  • 517 talk
  • 518 ntalk
  • 520 efs
  • 525 timed
  • 526 tempo
  • 530 courier
  • 531 conference
  • 532 netnews
  • 533 netwall
  • 540 uucp
  • 543 klogin
  • 544 kshell
  • 550 new-rwho
  • 556 remotefs
  • 560 rmonitor
  • 561 monitor
  • 600 garcon
  • 601 maitrd
  • 602 busboy
  • 700 acctmaster
  • 701 acctslave
  • 702 acct
  • 703 acctlogin
  • 704 acctprinter
  • 705 acctinfo
  • 706 acctslave2
  • 707 acctdisk
  • 750 kerberos
  • 751 kerberos_master
  • 752 passwd_server
  • 753 userreg_server
  • 754 krb_prop
  • 888 erlogin



Как из программы отправить команду POST с параметрами на сервер


Дочка спрашивает маму:
- А кто этот страшный, волосатый дядя с красными глазами?
- А это твой папа
- А он что заболел?
- Нет, к интернету подключился.

NMHTTP компонент, закладка FastNet. Там есть то что нужно - Функция post.




Многоразовая обработка сообщения



 unit PostForm;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TFormManyMess = class(TForm)
     LBox: TListBox;
     Button1: TButton;
     ButtonPost: TButton;
     ButtonSend: TButton;
     ButtonPerform: TButton;
     ButtonMouseDown: TButton;
     ButtonOnMouseDown: TButton;
     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure ButtonPostClick(Sender: TObject);
     procedure ButtonSendClick(Sender: TObject);
     procedure ButtonPerformClick(Sender: TObject);
     procedure ButtonMouseDownClick(Sender: TObject);
     procedure ButtonOnMouseDownClick(Sender: TObject);
   private
     { Private declarations }
   public
     procedure WndProc(var Message: TMessage); override;
     procedure DefaultHandler(var Message); override;
     procedure WmLButtonDown (var Message: TWMMouse);
       message wm_lButtonDown;
     procedure MouseDown(Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer); override;
     procedure ApplicationMessage (var Msg: TMsg;
       var Handled: Boolean);
   end;
 
 var
   FormManyMess: TFormManyMess;
 
 implementation
 
 {$R *.DFM}
 
 procedure TFormManyMess.FormMouseDown(Sender: TObject;
   Button: TMouseButton; Shift: TShiftState;
   X, Y: Integer);
 begin
   if Button = mbLeft then
     LBox.Items.Add (Format ('%s in (%d, %d)',
       ['FormMouseDown', X, Y]));
 end;
 
 procedure TFormManyMess.WndProc(var Message: TMessage);
 begin
   if Message.Msg = wm_LButtonDown then
     LBox.Items.Add (Format ('%s in (%d, %d)',
       ['WndProc', LoWord (Message.LParam),
       HiWord (Message.LParam)]));
   inherited;
 end;
 
 procedure TFormManyMess.DefaultHandler(var Message);
 begin
   with TMessage (Message) do
     if Msg = wm_LButtonDown then
       LBox.Items.Add (Format ('%s in (%d, %d)',
         ['DefaultHandler', LoWord (LParam),
         HiWord (LParam)]));
   inherited;
 end;
 
 procedure TFormManyMess.WmLButtonDown (var Message: TWMMouse);
 begin
   LBox.Items.Add (Format ('%s in (%d, %d)',
     ['WmLButtonDown', Message.XPos, Message.YPos]));
   inherited;
 end;
 
 procedure TFormManyMess.MouseDown(Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   if Button = mbLeft then
     LBox.Items.Add (Format ('%s in (%d, %d)',
       ['MouseDown', X, Y]));
   inherited;
 end;
 
 procedure TFormManyMess.ApplicationMessage (var Msg: TMsg;
   var Handled: Boolean);
 begin
   if (Msg.Message = wm_LButtonDown) and
       (Msg.hWnd = Handle) then
     LBox.Items.Add (Format ('%s in (%d, %d)',
       ['ApplicationMessage', LoWord (Msg.LParam),
       HiWord (Msg.LParam)]));
   Handled := False;
 end;
 
 procedure TFormManyMess.FormCreate(Sender: TObject);
 begin
   Application.OnMessage := ApplicationMessage;
 end;
 
 procedure TFormManyMess.Button1Click(Sender: TObject);
 begin
   LBox.Clear;
 end;
 
 procedure TFormManyMess.ButtonPostClick(Sender: TObject);
 begin
   LBox.Items.Add (' --- PostMessage ---');
   PostMessage (Handle, wm_lButtonDown,
     0, MakeLong (10, 10));
   PostMessage (Handle, wm_lButtonUp,
     0, MakeLong (10, 10));
 end;
 
 procedure TFormManyMess.ButtonSendClick(Sender: TObject);
 begin
   LBox.Items.Add (' --- SendMessage ---');
   SendMessage (Handle, wm_lButtonDown,
     0, MakeLong (10, 10));
   SendMessage (Handle, wm_lButtonUp,
     0, MakeLong (10, 10));
 end;
 
 procedure TFormManyMess.ButtonPerformClick(Sender: TObject);
 begin
   LBox.Items.Add (' --- Perform ---');
   Perform (wm_lButtonDown,
     0, MakeLong (10, 10));
   Perform (wm_lButtonUp,
     0, MakeLong (10, 10));
 end;
 
 procedure TFormManyMess.ButtonMouseDownClick(Sender: TObject);
 begin
   LBox.Items.Add (' --- MouseDown ---');
   MouseDown (mbLeft, [], 10, 10);
 end;
 
 procedure TFormManyMess.ButtonOnMouseDownClick(Sender: TObject);
 begin
   LBox.Items.Add (' --- OnMouseDown ---');
   OnMouseDown (self, mbLeft, [], 10, 10);
 end;
 
 end.

Загрузить исходный код проекта




Возвести в степень

У программиста спрашивают:
- Hе помнишь, сколько будет два в четвеpтой?
- (без запинки) Шестнадцать.
- А шестнадцать в четвеpтой?
- (без запинки) Шестьдесят пять тысяч пятьсот тpидцать шесть.
- Вот голова, ну ты даешь!!! Hу, а тpи в четвеpтой?
- (после паузы) Hе помню точно. Дpобное число получается.

Чтобы возвести 2 в нужную степень можно создать цикл:


 a := 1;
 for i := 1 to 20 do
   a := a * 2;
 

Можно воспользоваться функциями Power, IntPower или LdExp из модуля Math, но есть способ быстрее. Можно сдвигать двоичные порядки на N порядков. Это приводит к умножению или делению числа на 2 в степени N. При этом обязательно работать с целочисленным типом.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   Res, Exponent: integer;
 begin
   Exponent := 10;
   Res := 10 shl Exponent;
   Form1.Caption := IntToStr(Res) + #32;
   Res := Res shr Exponent;
   Form1.Caption := Form1.Caption + IntToStr(Res);
 end;
 




Предварительная загрузка элементов

Автор: Scott Samet

Я пытаюсь осуществить предварительную загрузку элементов наследника TListBox со множеством строк. Для этого я перекрываю конструктор, добавляя в него строки типа items.add('foo'); но когда я выполняю это, то получаю исключение "window has no parent window" (окно не имеет родительского окна). Почему у меня не получается сделать это?

Listbox сохраняет элементы, передавая их Windows. При этом требуется дескриптор окна, а дескриптору окна требуется родитель. Родитель не устанавливается даже после возврата из конструктора.

Решение проблемы:

    SaveVis := Visible;
    Visible := False;
    Parent  := Owner;
    <заполнение ListBox>
    Parent  := Nil;
    Visible := SaveVis;



Как узнать, какие принтеры установлены в системе

Поместите на форму кнопку (Button1) и ListBox (ListBox1). В uses добавьте registry unit. Следующий код поместите в событие кнопки OnClick:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   m: TRegistry;
   i: integer;
   l: TstringList;
   s: string;
 begin
   m := TRegistry.Create; l := TStringList.Create;
   s := '\System\CurrentControlSet\Control\Print\Printers';
   m.RootKey := HKEY_LOCAL_MACHINE;
   m.OpenKey(s, false);
   m.GetKeyNames(l); // получаем список принтеров
   m.CloseKey;
   ListBox1.Items.Clear;
   for i := 0 to l.Count - 1 do begin
     m.OpenKey(s + '\' + l[i], false);
       // Здесь, ради теста, можно сделать проверку на наличие нужного имени драйвера
       // if m.ReadString('Printer Driver') = 'my printer driver' then ..
       // добавляем имя принтера в список
     ListBox1.Items.Add(m.ReadString('Name'));
     m.CloseKey;
   end;
   m.Free;
   l.Free;
 end;
 




Как узнать, какие принтеры установлены в системе 2


 // uses printers
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: integer;
 begin
   ListBox1.Items.Clear;
   for i := 0 to Printer.Printers.Count - 1 do
     ListBox1.items.Add(Printer.Printers.Strings[i]);
 end;
 




Управляющие коды принтера

Как мне послать на принтер управляющие коды принтера (Printer Control Codes) без перевода их в непечатные символы? Наверняка без Windows API в Delphi не обойтись. Когда я передаю управляющие коды принтера, они печатаются как непечатные символы, а не воспринимаются принтером как управляющие коды.

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


 unit Passthru;
 
 interface
 
 uses printers, WinProcs, WinTypes, SysUtils;
 
 procedure PrintTest;
 
 implementation
 
 type
   TPassThroughData = record
     nLen: Integer;
     Data: array[0..255] of byte;
   end;
 
 procedure DirectPrint(s: string);
 var
   PTBlock: TPassThroughData;
 begin
   PTBlock.nLen := Length(s);
   StrPCopy(@PTBlock.Data, s);
   Escape(printer.handle, PASSTHROUGH, 0, @PTBlock, nil);
 end;
 
 procedure PrintTest;
 begin
   Printer.BeginDoc;
   DirectPrint(CHR(27) + '&l1O' + 'Привет, Вася!');
   Printer.EndDoc;
 end;
 
 end.
 




Метрики принтера

Люблю я струйный принтер. За чернила...

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

  • Font.Height дает вам высоту шрифта в пикселях с учетом интервала.
Как мне преобразовать высоту в пикселях в дюймы печатаемой страницы?

  • Не делайте этого, используйте у TPrinter свойства PageHeight и PageWidth.
Хорошо, но я еще что-то не учел. Например, я использую шрифт Courier New размером 9 точек:

Printer.Canvas.Font.Height = -12
Printer.PageHeight = 3150

Даже отбрасывая загадку унарного минуса, я получаю 3150 div 12, или 262 строк на страницу.

  • Посмотри электронную справку по теме 'Printer.Canvas.TextHeight'. Это свойство покажет вам, какую высоту будет использовать 'текущий шрифт'. Это то, что вы должны использовать для определения 'количество строк на странице'. Например, шрифт Courier New размером 9 точек имеет значение TextHeight, равное 40. Поделите 3150 на эту величину и вы получите 78 'строк', почти правильную величину для 9-точечного шрифта, если принимать во внимание то, что на дюйме помещается примерно 8 строк.
  • Для определения количества точек на дюйм (как горизонтально, так и вертикально) можно использовать API функцию GetDeviceCaps. Полученные значения позволят вам правильно преобразовать пиксели в дюймы.
  • Значение -12 для 9-точечного шрифта Courier - это высота шрифта для устройства с разрешением 96DPI (например, ваш экран). Попробуйте назначить величину 9 свойству Size после того как вы вызвали BeginDoc и посмотрите на значение свойства Height. Это должно быть значительно большей величиной.
  • Вызывая команду Printer.NewPage, вы _не_ начинаете печать очередной строки, а заставляете принтер закончить печать на текущем листе и начать печать сверху нового листа (кажется, принтер HPLJ IIIP понимает эту команду иначе). После вызова Printer.NewPage следующая строка печатается примерно в полдюйме от верха бумаги.

Кроме того, приведу здесь текст моей текущей программы для печати текста компонента Memo с заголовком на каждой странице:


 procedure btPrintMemoWithHeader(Memo: TCustomMemo;
   Printer: TPrinter;
   PrintDialog: TPrintDialog;
   HeaderText: string;
   TopMargin, BottomMargin, LeftMargin: Integer);
 var
   FirstPage: Boolean;
   i, LinesPerPage, CurrentLine, Line: Integer;
   PrintText: System.Text;
   LeftMarginString, Header: string;
 begin
   if PrintDialog.Execute then
   begin
     with Printer do
     begin
       AssignPrn(PrintText);
       Rewrite(PrintText);
       {Заполняем левую часть строки определенным количеством пробелов.}
       LeftMarginString := '';
       for i := 0 to LeftMargin do
         LeftMarginString := LeftMarginString + ' ';
       {Назначаем принтеру такой же шрифт, как и в компоненте Memo.:\}
       Canvas.Font := (Memo as TMemo).Font;
       {Вычисляем количество строк на странице.}
       LinesPerPage := PageHeight div Canvas.TextHeight('X');
       LinesPerPage := LinesPerPage - 8 - TopMargin - BottomMargin;
       CurrentLine := LinesPerPage;
       FirstPage := True;
       {Печать Memo.}
       for Line := 0 to Memo.Lines.Count - 1 do
       begin
         {Если конец страницы, начинаем новую.}
         if CurrentLine >= LinesPerPage then
         begin
           {Печатаем "Form Feed", если это не новая страница принтера.}
           if not FirstPage then
             Write(PrintText, #12); {Если не первая страница, то меняем лист}
           FirstPage := False;
           {Печатаем определенное количество пустых строк для верхнего поля.}
           for i := 0 to TopMargin do
             Writeln(PrintText, '');
           {Форматируем и печатаем строку заголовока.}
           Header := Format('Страница %s     %s  %s     %s'#13#10,
             [IntToStr(Printer.PageNumber), DateToStr(Date),
             TimeToStr(Time), HeaderText]);
           Write(PrintText, LeftMarginString);
           Writeln(PrintText, Header);
           {Сбрасываем номер текущей строки на 1 для следующей страницы.}
           CurrentLine := 1;
         end;
         {Печатаем строку из Memo.}
         Write(PrintText, LeftMarginString);
         Writeln(PrintText, Memo.Lines[Line]);
         Inc(CurrentLine);
       end;
       CloseFile(PrintText);
     end;
   end;
 end;
 




Настройки принтера

Юзeру надоел его принтер: то бумагу зажуёт, то расходники кончатся, то текст размажет... Решил юзeр от принтера избавиться. Но как? Продать - никто не купит. Подарить - врагов нет, а друзей оскорблять неохота. Выбросить из окна - а вдруг на чью-то голову... и т.п. Наконец придумал утопить. Бросил в реку, а он поверху плавает. Топил, топил - всплывает! "Вот чёрт! А ведь правду говорят - д@рьмо не тонет!"

Ниже приведены некоторые участки кода, позволяющие изменять настройки принтера. Тот код, который позволяет менять установки, позволяет также вам узнать принцип управления настройками. Смотри документацию по структурам ExtDeviceMode, TDEVMODE и escape функциям принтера GETSETPAPERBINS и GetDeviceCaps().

Один из путей изменения установок принтера перед печатью документа - изменение devicemode (режим устройства) принтера.

Пример:


 var
   Device: array[0..255] of char;
   Driver: array[0..255] of char;
   Port: array[0..255] of char;
   hDMode: THandle;
   PDMode: PDEVMODE;
 begin
   Printer.PrinterIndex := Printer.PrinterIndex;
   Printer.GetPrinter(Device, Driver, Port, hDMode);
   if hDMode <> 0 then
   begin
     pDMode := GlobalLock(hDMode);
     if pDMode <> nil then
     begin
       pDMode^.dmFields := pDMode^.dmFields or DM_COPIES;
       pDMode^.dmCopies := 5;
       GlobalUnlock(hDMode);
     end;
     GlobalFree(hDMode);
   end;
   Printer.PrinterIndex := Printer.PrinterIndex;
   Printer.BeginDoc;
   Printer.Canvas.TextOut(100, 100, 'Тест 1');
   Printer.EndDoc;
 

Другой путь - изменение TPrinter. Это позволит изменять установки во время работы. Вы можете изменять настройки МЕЖДУ страницами.

Чтобы сделать это:

Прежде чем поступит команда startpage() (см. модуль printers.pas в каталоге Source\VCL), вы можете передать принтеру следующий код:


 DevMode.dmPaperSize:=DMPAPER_LEGAL
 {сброс настроек}
 
 Windows.ResetDc(dc,Devmode^);
 

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

Но это решение потребует перекомпиляции исходного кода vcl с добавлением пути к новому модулю (tools..options.. library...libaray). Если вы все-таки на это решились, не забудьте после этого перезагрузить Delphi и помните, что после этого ваш исходный код становится несовместимым со стандартной версией Delphi.

Маленькое замечание...

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

Вот два примера:


 uses Printers;
 var
   MyFile: TextFile;
 begin
   AssignPrn(MyFile);
   Rewrite(MyFile);
   Printer.Canvas.Font.Name := 'Courier New';
   Printer.Canvas.Font.Style := [fsBold];
   Printer.Canvas.Font.PixelsPerInch :=
     GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);
   Writeln(MyFile, 'Печатаем этот текст');
   System.CloseFile(MyFile);
 end;
 


 uses Printers;
 
 begin
   Printer.BeginDoc;
   Printer.Canvas.Font.Name := 'Courier New';
   Printer.Canvas.Font.Style := [fsBold];
   Printer.Canvas.Font.PixelsPerInch:=
   GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);
   Printer.Canvas.Textout(10, 10, 'Печатаем этот текст');
   Printer.EndDoc;
 end;
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS