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

ВИДЕОКУРС ВЗЛОМ
выпущен 1 марта!


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

БОЛЬШОЙ FAQ ПО DELPHI



Как использовать в своей программе API DirectSound и DirectSound3D

Юзеры с компьютером на "Вы", программисты - на "Ты", а хакеры - на "Ты, козел..."

Представляю вашему вниманию рабочий пример использования DirectSound на Delphi + несколько полезных процедур. В этом примере создается один первичный SoundBuffer и 2 статических, вторичных; в них загружаются 2 WAV файла. Первичный буфер создается процедурой AppCreateWritePrimaryBuffer, а любой вторичный - AppCreateWritePrimaryBuffer. Так как вторичный буфер связан с WAV файлом, то при создании буфера нужно определить его параметры в соответствии со звуковым файлом, эти характеристики (Samples, Bits, IsStereo) задаются в виде параметров процедуры. Time - время WAV'файл в секундах (округление в сторону увеличения). При нажатии на кнопку происходит микширование из вторичных буферов в первичный. AppWriteDataToBuffer позволяет записать в буфер PCM сигнал. Процедура CopyWAVToBuffer открывает WAV файл, отделяет заголовок, читает чанк 'data' и копирует его в буфер (при этом сначала считывается размер данных, так как в некоторых WAV файлах существует текстовый довесок, и если его не убрать, в динамиках возможен треск).

Пример 1-ый


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Timer1: TTimer;
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
     DirectSound : IDirectSound;
     DirectSoundBuffer : IDirectSoundBuffer;
     SecondarySoundBuffer : array[0..1] of IDirectSoundBuffer;
     procedure AppCreateWritePrimaryBuffer;
     procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer;
       SamplesPerSec: Integer; Bits: Word; isStereo:Boolean; Time: Integer);
     procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
       OffSet: DWord; var SoundData; SoundBytes: DWord);
     procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer);
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
     raise Exception.Create('Failed to create IDirectSound object');
   AppCreateWritePrimaryBuffer;
   AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0], 22050,8,False,10);
   AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1], 22050,16,True,1);
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 var
   i: ShortInt;
 begin
   if Assigned(DirectSoundBuffer) then
     DirectSoundBuffer.Release;
   for i:=0 to 1 do
     if Assigned(SecondarySoundBuffer[i]) then
       SecondarySoundBuffer[i].Release;
   if Assigned(DirectSound) then
     DirectSound.Release;
 end;
 
 procedure TForm1.AppWriteDataToBuffer;
 var
   AudioPtr1, AudioPtr2 : Pointer;
   AudioBytes1, AudioBytes2 : DWord;
   h : HResult;
   Temp : Pointer;
 begin
   H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0);
   if H = DSERR_BUFFERLOST then
   begin
     Buffer.Restore;
     if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then
       raise Exception.Create('Unable to Lock Sound Buffer');
   end
   else
   if H <> DS_OK then
     raise Exception.Create('Unable to Lock Sound Buffer');
   Temp := @SoundData;
   Move(Temp^, AudioPtr1^, AudioBytes1);
   if AudioPtr2 <> nil then
   begin
     Temp := @SoundData; Inc(Integer(Temp), AudioBytes1);
     Move(Temp^, AudioPtr2^, AudioBytes2);
   end;
   if Buffer.UnLock(AudioPtr1, AudioBytes1,AudioPtr2, AudioBytes2) <> DS_OK then
     raise Exception.Create('Unable to UnLock Sound Buffer');
 end;
 
 procedure TForm1.AppCreateWritePrimaryBuffer;
 var
   BufferDesc: DSBUFFERDESC;
   Caps: DSBCaps;
   PCM: TWaveFormatEx;
 begin
   FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
   FillChar(PCM, SizeOf(TWaveFormatEx),0);
   with BufferDesc do
   begin
     PCM.wFormatTag:=WAVE_FORMAT_PCM;
     PCM.nChannels:=2;
     PCM.nSamplesPerSec:=22050;
     PCM.nBlockAlign:=4;
     PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
     PCM.wBitsPerSample:=16;
     PCM.cbSize:=0;
     dwSize:=SizeOf(DSBUFFERDESC);
     dwFlags:=DSBCAPS_PRIMARYBUFFER;
     dwBufferBytes:=0;
     lpwfxFormat:=nil;
   end;
   if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then
     raise Exception.Create('Unable to set Coopeative Level');
   if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then
     raise Exception.Create('Create Sound Buffer failed');
   if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then
     raise Exception.Create('Unable to Set Format ');
   if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then
     raise Exception.Create('Unable to set Coopeative Level');
 end;
 
 procedure TForm1.AppCreateWriteSecondaryBuffer;
 var
   BufferDesc: DSBUFFERDESC;
   Caps: DSBCaps;
   PCM: TWaveFormatEx;
 begin
   FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
   FillChar(PCM, SizeOf(TWaveFormatEx),0);
   with BufferDesc do
   begin
     PCM.wFormatTag:=WAVE_FORMAT_PCM;
     if isStereo then
       PCM.nChannels:=2
     else
       PCM.nChannels:=1;
     PCM.nSamplesPerSec:=SamplesPerSec;
     PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
     PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
     PCM.wBitsPerSample:=Bits;
     PCM.cbSize:=0;
     dwSize:=SizeOf(DSBUFFERDESC);
     dwFlags:=DSBCAPS_STATIC;
     dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
     lpwfxFormat:=@PCM;
   end;
   if DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK then
     raise Exception.Create('Create Sound Buffer failed');
 end;
 
 procedure TForm1.CopyWAVToBuffer;
 var
   Data : PChar;
   FName : TFileStream;
   DataSize : DWord;
   Chunk : string[4];
   Pos : Integer;
 begin
   FName:=TFileStream.Create(name,fmOpenRead);
   Pos:=24;
   SetLength(Chunk,4);
   repeat
     FName.Seek(Pos, soFromBeginning);
     FName.read(Chunk[1],4);
     Inc(Pos);
   until
     Chunk = 'data';
   FName.Seek(Pos+3, soFromBeginning);
   FName.read(DataSize, SizeOf(DWord));
   GetMem(Data,DataSize);
   FName.read(Data^, DataSize);
   FName.Free;
   AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
   FreeMem(Data,DataSize);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   CopyWAVToBuffer('1.wav',SecondarySoundBuffer[0]);
   CopyWAVToBuffer('flip.wav',SecondarySoundBuffer[1]);
 
   if SecondarySoundBuffer[0].Play(0,0,0) <> DS_OK then
     ShowMessage('Can''t play the Sound');
 
   if SecondarySoundBuffer[1].Play(0,0,0) <> DS_OK then
     ShowMessage('Can''t play the Sound');
 end;
 
 end.
 

Пример 2-ой

Представляю вашему вниманию очередной пример работы с DirectSound на Delphi. В этом примере показан принцип работы с 3D буфером. Итак, процедуры AppCreateWritePrimaryBuffer, AppWriteDataToBuffer, CopyWAVToBuffer я оставил без изменения (см. письма с до этого). Процедура AppCreateWriteSecondary3DBuffer является полным аналогом процедуры AppCreateWriteSecondaryBuffer, за исключением флага DSBCAPS_CTRL3D, который указывает на то, что со статическим вторичным буфером будет связан еще один буфер - SecondarySound3DBuffer. Чтобы его инициализировать, а также установить некоторые начальные значения (положение в пространстве, скорость и .т.д.) вызывается процедура AppSetSecondary3DBuffer, в качестве параметров которой передаются сам SecondarySoundBuffer и связанный с ним SecondarySound3DBuffer. В этой процедуре SecondarySound3DBuffer инициализируется с помощью метода QueryInterface c соответствующим флагом. Кроме того, здесь же устанавливается положение источника звука в пространстве: SetPosition(Pos,1,1,0). X,Y,Z Таким образом в начальный момент времени источник находится на высоте 1 м (ось Y направлена вертикально вверх, а ось Z - "в экран"). Если смотреть сверху :

 ^ Z
 |
 |
 |
 O----------------> X
 

Точка O (фактически вы) имеет координаты (0,0), источник звука А(-25,1). Разумеется понятие "метр" весьма условно. При нажатии на кнопку в буфер SecondarySoundBuffer загружается звук 'xhe4.wav'. Это звук работающего винта вертолета, его длина (звука) ровно 3.99 с (а размер буфера ровно 4 с). Далее происходит микширование из вторичного буфера в первичный с флагом DSBPLAY_LOOPING, что позволяет сделать многократно повторяющийся звук; время в 0.01 с ухом практически не улавливается и получается непрерывный звук летящего вертолета. После этого запускется таймер (поле INTERVAL в Инспекторе Оъектов установлено в 1). Разумеется вам совсем необязательно делать именно так, это просто пример. В процедуре Timer1Timer просто меняется координата X с шагом 0.1. В итоге получаем летящий вертолет слева направо. Заодно можете проверить, правильно ли у вас расположены колонки.


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Timer1: TTimer;
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     procedure Timer1Timer(Sender: TObject);
   private
     { Private declarations }
     DirectSound : IDirectSound;
     DirectSoundBuffer : IDirectSoundBuffer;
     SecondarySoundBuffer : IDirectSoundBuffer;
     SecondarySound3DBuffer : IDirectSound3DBuffer;
     procedure AppCreateWritePrimaryBuffer;
     procedure AppCreateWriteSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
     SamplesPerSec: Integer;
     Bits: Word;
     isStereo:Boolean;
     Time: Integer);
     procedure AppSetSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
     var _3DBuffer: IDirectSound3DBuffer);
     procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
     OffSet: DWord; var SoundData;
     SoundBytes: DWord);
     procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer);
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   Result: HResult;
 begin
   if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
     raise Exception.Create('Failed to create IDirectSound object');
   AppCreateWritePrimaryBuffer;
   AppCreateWriteSecondary3DBuffer(SecondarySoundBuffer, 22050,8,False,4);
   AppSetSecondary3DBuffer(SecondarySoundBuffer, SecondarySound3DBuffer);
   Timer1.Enabled:=False;
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 var
   i: ShortInt;
 begin
   if Assigned(DirectSoundBuffer) then
     DirectSoundBuffer.Release;
   if Assigned(SecondarySound3DBuffer) then
     SecondarySound3DBuffer.Release;
   if Assigned(SecondarySoundBuffer) then
     SecondarySoundBuffer.Release;
   if Assigned(DirectSound) then
     DirectSound.Release;
 end;
 
 procedure TForm1.AppCreateWritePrimaryBuffer;
 var
   BufferDesc: DSBUFFERDESC;
   Caps: DSBCaps;
   PCM: TWaveFormatEx;
 begin
   FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
   FillChar(PCM, SizeOf(TWaveFormatEx),0);
   with BufferDesc do
   begin
     PCM.wFormatTag:=WAVE_FORMAT_PCM;
     PCM.nChannels:=2;
     PCM.nSamplesPerSec:=22050;
     PCM.nBlockAlign:=4;
     PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
     PCM.wBitsPerSample:=16;
     PCM.cbSize:=0;
     dwSize:=SizeOf(DSBUFFERDESC);
     dwFlags:=DSBCAPS_PRIMARYBUFFER;
     dwBufferBytes:=0;
     lpwfxFormat:=nil;
   end;
   if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then
     raise Exception.Create('Unable to set Cooperative Level');
   if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then
     raise Exception.Create('Create Sound Buffer failed');
   if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then
     raise Exception.Create('Unable to Set Format ');
   if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then
     raise Exception.Create('Unable to set Cooperative Level');
 end;
 
 procedure TForm1.AppCreateWriteSecondary3DBuffer;
 var
   BufferDesc: DSBUFFERDESC;
   Caps: DSBCaps;
   PCM: TWaveFormatEx;
 begin
   FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
   FillChar(PCM, SizeOf(TWaveFormatEx),0);
   with BufferDesc do
   begin
     PCM.wFormatTag:=WAVE_FORMAT_PCM;
     if isStereo then
       PCM.nChannels:=2
     else
       PCM.nChannels:=1;
     PCM.nSamplesPerSec:=SamplesPerSec;
     PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
     PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
     PCM.wBitsPerSample:=Bits;
     PCM.cbSize:=0;
     dwSize:=SizeOf(DSBUFFERDESC);
     dwFlags:=DSBCAPS_STATIC or DSBCAPS_CTRL3D;
     dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
     lpwfxFormat:=@PCM;
   end;
   if DirectSound.CreateSoundBuffer(BufferDesc, Buffer, nil) <> DS_OK then
     raise Exception.Create('Create Sound Buffer failed');
 end;
 
 procedure TForm1.AppWriteDataToBuffer;
 var
   AudioPtr1, AudioPtr2 : Pointer;
   AudioBytes1, AudioBytes2 : DWord;
   h : HResult;
   Temp : Pointer;
 begin
   H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
   AudioPtr2, AudioBytes2, 0);
   if H = DSERR_BUFFERLOST then
   begin
     Buffer.Restore;
     if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then
       raise Exception.Create('Unable to Lock Sound Buffer');
   end
   else
   if H <> DS_OK then
     raise Exception.Create('Unable to Lock Sound Buffer');
   Temp:=@SoundData;
   Move(Temp^, AudioPtr1^, AudioBytes1);
   if AudioPtr2 <> nil then
   begin
     Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1);
     Move(Temp^, AudioPtr2^, AudioBytes2);
   end;
   if Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK then
     raise Exception.Create('Unable to UnLock Sound Buffer');
 end;
 
 procedure TForm1.CopyWAVToBuffer;
 var
   Data : PChar;
   FName : TFileStream;
   DataSize : DWord;
   Chunk : string[4];
   Pos : Integer;
 begin
   FName:=TFileStream.Create(name,fmOpenRead);
   Pos:=24;
   SetLength(Chunk,4);
   repeat
     FName.Seek(Pos, soFromBeginning);
     FName.read(Chunk[1],4);
     Inc(Pos);
   until
     Chunk = 'data';
   FName.Seek(Pos+3, soFromBeginning);
   FName.read(DataSize, SizeOf(DWord));
   GetMem(Data,DataSize);
   FName.read(Data^, DataSize);
   FName.Free;
   AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
   FreeMem(Data,DataSize);
 end;
 
 var
   Pos: Single = -25;
 
 procedure TForm1.AppSetSecondary3DBuffer;
 begin
   if Buffer.QueryInterface(IID_IDirectSound3DBuffer, _3DBuffer) <> DS_OK then
     raise Exception.Create('Failed to create IDirectSound3D object');
   if _3DBuffer.SetPosition(Pos,1,1,0) <> DS_OK then
     raise Exception.Create('Failed to set IDirectSound3D Position');
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   CopyWAVToBuffer('xhe4.wav',SecondarySoundBuffer);
 
   if SecondarySoundBuffer.Play(0,0,DSBPLAY_LOOPING) <> DS_OK then
     ShowMessage('Can''t play the Sound');
 
   Timer1.Enabled:=True;
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   SecondarySound3DBuffer.SetPosition(Pos,1,1,0);
   Pos:=Pos + 0.1;
 end;
 
 end.
 




Работа с автоинкрементальными (AutoInc) полями

Работа с автоинкрементальным типом поля (Auto-increment, поле с автоприращением)

В приложениях Delphi, при использовании таблиц, содержащих автоинкрементальные поля или поля, автоматически увеличивающие каким-либо способом, неизвестным приложению, свое значение, могут наблюдаться проблемы. Таблицы Paradox, InterBase, Sybase и Informix имеют средства автоматической вставки и обновления значений полей, без вмешательства сервисов и конечных приложений. Тем не менее, не каждая операция с таблицой поддерживается таким механизмом. Данный документ призван продемонстрировать основные методы работы с такими типами полей в таблицах Paradox 5.0, Informix 5.x, MS/Sybase SQL Server 4.x, InterBase 4.0 и Local InterBase.

У каждого типа таблицы за кулисами работает собственный механизм. Таблицы Paradox поддерживают автоинкрементальный (Autoincrement) тип поля. Когда к таким таблицам добавляются новые записи, Borland Database Engine определяет максимальное текущее значение в данной колонке, прибавляет единицу, и обновляет новую строку с новым значением.

Для таблиц Informix данное поведение предусматривается специфическим типом Informix-поля, названного Serial. Колонки Serial отличаются от автоприращиваемых (Autoincrement) полей Paradox тем, что в таблицах Informix значения этого типа полей могут быть изменены, тогда как в таблицах Paradox они предназначены только для чтения.

Таблицы InterBase и MS/Sybase SQL Server не имеют поддерживающего данную характеристику специального типа поля, но для выполнения той же задачи можно воспользоваться триггерами. Триггеры являются специализированными процедурами, которые находятся на сервере баз данных и автоматически выполняются в ответ на какое-либо событие, например, добавление в таблицу, обновление и удаление. Использование таблиц со связанными триггерами может быть особенно проблематичным, поскольку триггеры способны делать намного больше функций, чем просто увеличивать значения приращиваемой колонки.

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

Обработка Update и/или Append BatchMoves

Таблицы Paradox

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

Таблицы Informix

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

Таблицы InterBase
Таблицы MS/Sybase SQL Server

Триггеры в таблицах InterBase и SQL Server могут отследить любые неверные изменения, сделанные в таблице, но это всецело зависит от установок самого триггера. Здесь также вас необходимо предупредить о возможных проблемах, поскольку обновляемые триггером колонки могут быть использованы в качестве первичного ключа.

Привязки таблиц посредством MasterSource & MasterFields

Таблицы Paradox
Таблицы Informix

Если свойства MasterFields и MasterSource используются для привязки таблиц с отношениями мастер-деталь и одно из полей в "деталь"-таблице является автоинкрементальным или Serial-полем, то соответствующее поле в "мастер"-таблице должно иметь тип Long Integer или быть Serial-полем. Если "мастер"-таблица не является таблицей Paradox, то ключевое поле "мастер"-таблицы может быть полем любого целого типа, которого она поддерживает.

Таблицы InterBase
Таблицы MS/Sybase SQL Server

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

Простая вставка/обновление (Inserts/Updates)

Таблицы Paradox

Поскольку автоинкрементальные поля Paradox имеют аттрибут только для чтения, они обычно не предназначены для обновления и вставки новых записей. Следовательно, свойство Required для field-компонентов, базирующихся на автоинкрементальных полях, должны всегда быть установлены в False. Это может быть выполнено из Delphi с помощью Fields Editor определением field-компонентов в режиме разработки) двойной щелчок на компоненте TQuery или TTable), или во время работы программы с помощью следующего кода:


 Table1.Fields[0].Required := False;
 

или


 Table1.FieldByName('Fieldname').Required := False;
 

Таблицы Informix

Хотя Serial-поля Informix и являются обновляемыми, но если у них должна быть использована характеристика автоприращения, то свойство Required для field-компонентов, базирующихся на таком поле, должно быть установлена в False. Делайте все также, как это было описано для таблиц Paradox.

Таблицы InterBase
Таблицы MS/Sybase SQL Server

Обработка вставки этих изменяемых триггером типов таблиц требует предпринять некоторое количество шагов. Дополнительные шаги особенно необходимы в том случае, если вставка выполняется посредством стандартных элементов управления для работы с базами данных, типа DBEdits или DBMemos.

Вставка строк в изменяемые триггерами InterBase- и SQL Server таблицы может с достаточной долей вероятности вызвать сообщение об ошибке 'Record/Key Deleted'. Это сообщение об ощибки появляется несмотря на то, что таблица правильно обновляется на сервере. Это происходит в случае, если:

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

2a. Другие колонки таблицы имеют связанные значения по умолчанию. Это выполняется ПО УМОЛЧАНИЕ в случае создания таблицы InterBase или хранимой на сервере SQL Server процедурой sp_bindefault.

или

2b. При вставке новой строки обновляются поля, имеющие тип Blob.

или

2b. В таблице InterBase определены калькулируемые поля.

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

Во-первых, field-компоненты изменяемых триггером полей должны иметь свойство Required, установленное в False. Делайте все также, как это было описано для таблиц Paradox.

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

Наконец, если условие 1, приведенное выше, невозможно, но возможно наступление событий 2a, 2b или 2c, то необходимо создать обработчик события AfterPost компонента TTable как показано ниже:


 procedure TForm1.Table1AfterPost(DataSet: TDataset);
 begin
   Table1.Refresh;
 end;
 

Метод Refresh вновь перечитывает значения, измененные сервером.

Если выполнение условий 2a, 2b или 2c невозможно, то таблица могла бы быть обновлена без элементов управления Delphi для работы с базами данных. Это может быть выполенено с помощью компонента TQuery, ссылающегося на ту же самую таблицу. После того, как будет послан запрос на обновление, любые TTable-компоненты, использующие ту же самую таблицу, должны быть обновлены (Refreshed).




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

1) Может ли мое приложение иметь доступ к файлам, расположенным на сетевых дисках?

Да.

2) Когда я попытался это сделать, программа выдала сообщение об ошибке "Not initialized for accessing network files" (не инициализировано для доступа к сетевым файлам).

Вероятно вам необходимо задать правильный путь к каталогу в поле 'NET DIR' файла IDAPI.CFG. Директория должна быть одна и быть доступна всем пользователям приложения с применением одинаковых подключенных сетевых дисков. (т.е.: если NET DIR указывает на F:\PUBLIC\NETDIR, пользователи с подключенным сетевым диском и имеющим путь G:\NETDIR доступа не получат).

3) Возможно ли запустить приложение, относящееся к описываемой категории, с сетевого диска без установленного на локальной машине BDE (за исключением возможных ссылок в локальном файле WIN.INI на копии элементов программы BDE/IDAPI, расположенных на сетевом диске)?

Да. Установите BDE в сети и затем добавьте следующие секции в файл WIN.INI каждой рабочей станции:

 [IDAPI]
 CONFIGFILE01=F:\IDAPI\IDAPI.CFG
 DLLPATH=F:\IDAPI
 
 [Borland Language Drivers]
 LDPath=F:\IDAPI\LANGDRV
 

...пути должны отражать текущее месторасположение каталога IDAPI.

4) Для установки "NET DIR" мне нужно запустить BDECFG на каждой рабочей станции или просто сделать это на "сервере"?

C помощью утилиты BDECFG отредактируйте файл IDAPI.CFG и сохраните его в сетевом каталоге IDAPI. Следовательно, вам необходимо проделать данную операцию всего-лишь один раз.

5) Если мне нужно сделать это только на сервере, то как все рабочие станции узнают о месторасположении сетевых файлов ("NET DIR")?

Рабочая станция открывает файл IDAPI.CFG из каталога, указанного в WIN.INI, и уже оттуда читает настройки NET DIR.




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


В Windows 2005, рядом с пунктом "Выполнить...", появился пункт "Выполнить недопустимую операцию"

Это код, который я использую для установки chartfx.


 chart1.Opendata[cod_values]:=makelong(no_of_series,no_of_classes);
 {установка последовательных значений}
 chart1.closedata[cod_values]:=0;
 


 unit TstChart;
 
 interface
 
 uses = 20
 
   WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Menus,
   Dialogs, StdCtrls, Buttons, ExtCtrls, Tabs,
   ChartFX, {Похоже, действительно необходимо включить этот модуль
   в список, чтобы иметь доступ к константам, например к COD_VALUES}
   VBXCtrl, Chart2fx;
 
 type
 
   TF_Chart = 3 D class(TForm)
     SpeedPanel: TPanel;
     ExitBtn: TSpeedButton;
     NB: TNotebook;
     TB: TTabSet;
     Chart1: TChartFX;
     Chart2: TChartFX;
     procedure ExitItemClick(Sender: TObject);
     procedure FormCreate(Sender: TObject);
 
     procedure TBClick(Sender: TObject);
     procedure FormResize(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     procedure Build1(Ch: TChartFX);
     procedure Build2(Ch: TChartFX);
   end;
 
 var
 
   F_Chart: TF_Chart;
 
 implementation
 
 {$R *.DFM}
 
 procedure TF_Chart.ExitItemClick(Sender: TObject);
 begin
 
   Close;
 end;
 
 procedure TF_Chart.FormCreate(Sender: TObject);
 begin
 
   TB.Tabs := 3 D NB.Pages;
 
   NB.PageIndex := 3 D 0;
   Build1(Chart2);
   Build2(Chart2); {добавляем значения для Chart2: length... и т.д.}
 end;
 
 procedure TF_Chart.TBClick(Sender: TObject);
 begin
 
   NB.PageIndex := 3 D TB.TabIndex;
 end;
 
 procedure TF_Chart.Build1(Ch: TChartFX);
 begin
 
   {Эта процедура изменяет свойства, которые могут устанавливаться
   во время разработки или временя выполнения. В коментариях подробно
   указано чем занимается метод Design}
 
   with Ch do
   begin
 
     Adm[CSA_GAP] := 3 D 25.0;
 
     {Design:   Используйте свойство AdmDlg для изменения координаты Y}
 
     pType := 3 D BAR or CT_LEGEND;
     {Design: Изменяем свойство ChartType с 1 - line
     на 2 - bar.}
 
     DecimalsNum[CD_YLEG] := 3 D 0;
     {Design: Изменяем свойство Decimals с 2 до 0}
 
     Stacked := 3 D CHART_STACKED;
     {Design: Изменяем свойство Stacked с 0 - None на 1 - Normal}
 
     RightGap := 3 D 20;
     {Design: Тоже}
 
     OpenData[COD_COLORS] := 3 D 2;
 
     Color[0] := 3 D clBlack;
     Color[1] := 3 D clYellow;
     CloseData[COD_COLORS] := 3 D 0; {Фу!!}
     {Design: Для изменения цветов 2 серий:
     1)  Убедитесь, что ThisSerie установлен в 0.  Измените
     ThisColor на clBlack.
     2)  Установите ThisSerie в 1.  Измените ThisColor на
     clYellow.}
 
     Title[CHART_TOPTIT] := 3 D 'Статьи и заголовки';
     Title[CHART_LEFTTIT] := 3 D 'CCM';
     Title[CHART_BOTTOMTIT] := 3 D 'Карты';
     {Design:  щелкните на свойстве TitleDlg и
     установите верхний, левый и нижний заголовки}
   end;
 end;
 
 procedure TF_Chart.Build2(Ch: TChartFX);
 {Данная процедура устанавливает свойства, которые не могут
 
 (насколько я определил это) быть установлены в режиме разработки}
 const
 
   XAbbrevs: array[0..4] of string[4] = 3 D
   ('Acc', 'Bar', 'Mas', 'Amex', 'Din');
   SeriesTitles: array[0..1] of string[8] = 3 D
   ('Статьи', 'Заголовки');
   XTitles: array[0..4] of string[20] = 3 D
 
   ('Access', 'Barclaycard', 'Mastercard', 'American Express',
     'Diners');
   {естественно, вы должны нормально читать из базы данных
   xTitles и значения}
   Values: array[0..1, 0..4] of double = 3 D
   ((50, 60, 70, 80, 90),
     (30, 35, 25, 37, 42));
 var
 
   i, SerieNo: integer;
 begin
 
   with Ch do
   begin
 
     LegendWidth := 3 D 120;
 
     {Установка количества серий, количества значений ******************}
     OpenData[COD_INIVALUES] := 3 D MAKELONG(2, 5);
 
     CloseData[COD_INIVALUES] := 3 D 0;
     {*********************************************************}
 
     OpenData[COD_VALUES] := 3 D 2;
     {если вы пропускаете приведенное выше утверждение,
     (в котором вы вводите номер SERIES и VALUES), и CloseData ниже,
     назначение значений не создает ошибки, но и не работает! Назначение
     значений Legend и KeyLeg работает без OpenData/CloseData}
     ThisSerie := 3 D 0;
     for i := 3 D 0 to 1 do
 
       SerLeg[i] := 3 D SeriesTitles[i];
     for i := 3 D 0 to 4 do
       = 20
     begin
       Legend[i] := 3 D XTitles[i];
       KeyLeg[i] := 3 D XAbbrevs[i];
     end;
     SerieNo := 3 D 0;
     for SerieNo := 3 D 0 to 1 do
       = 20
     begin
       ThisSerie := 3 D SerieNo;
       for i := 3 D 0 to 4 do
         Value[i] := 3 D Values[SerieNo, i];
     end;
 
     CloseData[COD_VALUES] := 3 D 0;
   end;
 end;
 
 procedure TF_Chart.FormResize(Sender: TObject);
 var
 
   w, h: longint;
 begin
 
   w := 3 D NB.Width;
   H := 3 D NB.Height;
   {при необходимости увеличиваем/уменьшаем размер диаграммы}
   Chart1.Width := 3 D W - 18;
   Chart1.Height := 3 D H - 12;
   Chart2.Width := 3 D W - 18;
   Chart2.Height := 3 D H - 12;
 
   {перемещаем кнопку выхода в правый угол}
   ExitBtn.Left := 3 D SpeedPanel.Width - 32;
 end;
 
 end.
 




Как использовать консоль в не-консольном приложении

Для того, чтобы добавить в не-консольное приложение ввод/вывод из консоли, необходимо воспользоваться функциями AllocConsole и FreeConsole.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   s: string;
 begin
   AllocConsole;
   try
     Write('Type here your words and press ENTER: ');
     Readln(s);
     ShowMessage(Format('You typed: "%s"', [s]));
   finally
     FreeConsole;
   end;
 end;
 




Обрабатываем выделенные строки в DBGrid

Я целюсь не рукой; кто целится рукой, тот забыл лицо своего отца. Я целюсь глазом. Я стреляю не рукой; кто стреляет рукой, тот забыл лицо своего отца. Я стреляю разумом. Я убиваю не оружием; кто убивает оружием, тот забыл лицо своего отца. Я убиваю сердцем.
Древнее заклинание Квакеров


 function TForm1.Grid_Edit(dbgIn: TDBGrid; qryIn: TQuery): Longint;
 begin
   Result := 0;
   with dbgIn.DataSource.DataSet do
   begin
     First;
     DisableControls;
     try
       while not EOF do
       begin
         if (dbgIn.SelectedRows.CurrentRowSelected = True) then
         begin
           //Здесь можно обработать строку илил вызвать функцию для обработки
           Inc(Result);
         end;
         Next;
       end;
     finally
       EnableControls;
     end;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Form1.Caption := 'Обработано: ' + IntToStr(Grid_Edit(DBGrid1, Query1));
 end;
 




Добавление псевдонима с помощью функции DbiAddAlias

Автор: Tom Stickle


 var
   pszAliasName: PChar;  { Имя псевдонима }
   pszDriverType: PChar; { Тип драйвера для псевдонима }
   pszParams: PChar;     { Дополнительные параметры }
   bPersist: Bool;       { Постоянный или временный псевдоним }
   dbiRes: Integer;      { Возвращаемый код }
 begin
   pszAliasName := strAlloc(25);
   pszDriverType := strAlloc(25);
   pszParams := strAlloc(100);
 
   try
     bPersist := True;
     strPcopy(pszAliasName, 'Lance');
     strPcopy(pszDriverType, 'PARADOX');
     strPcopy(pszParams, 'PATH:' + 'c:\Paradox\');
 
     dbiRes := DbiAddAlias(nil, pszAliasName, pszDriverType, pszParams,
       bPersist);
 
   finally
     strDispose(pszAliasName);
     strDispose(pszDriverType);
     strDispose(pszParams);
   end;
 end;
 




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

Автор: Reinhard Kalinke

Вот пример поиска пользователей данной таблицы. Имейте в виду, что свойство TStringList Duplicate установлено в dupIgnore, поскольку пользователь может иметь более одной блокировки таблицы. При работе с dBase возвращается только блокировка текущего сеанса, тогда как с Paradox функция покажет всех пользователей, получивших доступ к этому же NET-файлу.


 procedure GetTableUserList(ATable: TTable; AStringList: TStringList);
 var
   hUserCur: hDBICur;
   pUserBuf: pByte;
 begin
   AStringList.Clear;
   AStringList.Duplicates := dupIgnore;
   Check(DBIOpenLockList(ATable.Handle, True, True, hUserCur));
   GetMem(pUserBuf, SizeOf(LOCKDesc));
   try
     while (DBIGetNextRecord(hUserCur, dbiNOLOCK, pUserBuf, nil) = DBIERR_NONE) do
       AStringList.Add(StrPas(pLOCKDesc(pUserBuf)^.szUserName))
   finally
     FreeMem(pUserBuf, SizeOf(LOCKDesc));
     DBICloseCursor(hUserCur);
   end;
 end;
 




Простой пример работы с базой данных из DLL

Автор: Steve Schafer

Это простейший DLL, экспортирующий единственную функцию. Вызывающий ее оператор передает функции значение ключа и строку со значением. Функция открывает демонстрационную базу данных BIOLIFE, находит по ключу запись и добавляет строку после всех записей в поле Notes:


 library Mydll;
 
 uses
   DBTables;
 
 function Modify(Key: Double; const Info: string): Boolean; export;
 var
   Table: TTable;
   Stream: TBlobStream;
 begin
   Table := TTable.Create(nil);
   Table.DatabaseName := 'D:\';
   Table.TableName := 'BIOLIFE';
   Table.TableType := ttParadox;
   Table.Open;
   if Table.FindKey([Key]) then
   begin
     Result := True;
     Table.Edit;
     Stream := TBlobStream.Create(TMemoField(Table.FieldByName('Notes')),
       bmReadWrite);
     Stream.Seek(0, 2);
     Stream.Write(Info[1], Length(Info));
     Stream.Free;
     Table.Post;
   end
   else
     Result := False;
   Table.Free;
 end;
 
 exports
   Modify;
 
 begin
 end.
 

Вот как это можно вызвать из приложения:


 function Modify(Key: Double; const Info: String): Boolean; far;
 external 'MYDLL';
 ...
 // Modify(90200, 'Васек Трубачев');
 

и это классно работает.

Поскольку в DLL вы используете BDE, изучите текущие замечания относительно его использования в файле README.TXT.




Как использовать базу данных BDE, не указывая ее имя

Если база данных находится в той же директории, что и экзешник, то в качестве имени базы можно использовать .\ в поле DatabaseName в TTable.




Использование Debug API. Пример перехвата вызовов функций Win32 API

Винда на компьютере должна быть правильная.
Вот Линукс - это правильная винда.

С чего все начиналось:

С начала. Мне нужно было написать перехватчик вызовов WinSock. Дабы любая программа могла работать через SOCKS5-проксик. Я посчитал, что перехват вызовов DLL'ки проще, чем судорожные попытки написать драйвер (да и сейчас так считаю). Енота, правда, ехидно улыбалась и говорила "ну-ну", но я-таки справился. SOCKS сниффер еще пишу, но в принципах перехвата уже разобрался :-) [Енота: разобраться-то он действительно разобрался, а соксифиера нет до сих пор...]

Как все будет:

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

Исходники:

Наконец-то... начнем.


 procedure DoDebugLoop;
 { собственно, это главная процедура перехватчика.
 большую часть времени он крутится именно в ней }
 var
   Event: TDebugEvent;
   { стандартная Win32 структура. для интересующихся:}
   ЕDebugEvent = record
     dwDebugEventCode: DWORD; // тип пришедшего события
     dwProcessId: DWORD;   // Id прерванного процесса
     dwThreadId: DWORD; // Id прерванного потока
     case Integer of
       0: (Exception: TExceptionDebugInfo);
       1: (CreateThread: TCreateThreadDebugInfo);
       2: (CreateProcessInfo: TCreateProcessDebugInfo);
       3: (ExitThread: TExitThreadDebugInfo);
       4: (ExitProcess: TExitThreadDebugInfo);
       5: (LoadDll: TLoadDLLDebugInfo);
       6: (UnloadDll: TUnloadDLLDebugInfo);
       7: (DebugString: TOutputDebugStringInfo);
       8: (RipInfo: TRIPInfo);
       // эти части смотрите сами - не могу же я все разжевывать! :-)
   end;
 

следует добавить, что Microsoft - ребята странные. Функция GetThreadContext, при помощи которой реализуется пошаговая отладка и просмотр регистров, требует на входе хэндл процесса. а нам дают только его Id. после безуспешных поисков функции типа ConvertThreadIdToHandle [Енота: мечтатель, однако...] я решил, что придется заводить список запущенных потоков. в событии CREATE_THREAD_DEBUG_EVENT нам дают-таки хэндл. придется запоминать все созданные потоки (не забывая их забывать ( сорри :-) в EXIT_THREAD_DEBUG_EVENT). позже Sleepyhead сказал, что я все придумал очень правильно (ай да Кэтмар! ай да сукин сын! простите, классика :-) - так люди и делают. ну он большой, ему виднее :-) }

dwContinueStatus: DWORD;
{ как системе обрабатывать событие в ContinueDebugEvent. обнаружилось, что если это событие - не исключение (EXCEPTION_DEBUG_EVENT), то этот флажок системе "по сараю". а если исключение, то есть два варианта: DBG_CONTINUE - наш "отладчик" успешно обработал все сам, и DBG_EXCEPTION_NOT_HANDLED, что значиит - передать исключение системе на обработку }
CurThread: DWORD;
{ хэндл потока, найденный в нашем списке потоков (см. замечание чуть повыше) }
HProc: DWORD;
{ хэндл процесса, который мы отлаживаем }
Context: TContext;
{ контекст потока. проще говоря - содержание его регистров }
ThreadList: array[0..99] of record Id, Handle: DWORD; end;
{ тот самый пресловутый список потоков, который мы своими ручками будем создавать и поддерживать. в принципе, это должен быть список или динамический массив, ибо количество потоков, которые может создать программа, заранее не известно, но не будем заморачиваться. код-то демонстрационный! }
RetAddr: DWORD;
{ здесь будет храниться адрес возврата из перехваченной API-функции (так, на всякий случай. чтобы вы видели, как и откуда его можно добыть) }
BPAddr: DWORD;
{ в учебных целях мы будем перехватывать только одну функцию. поэтому вместо списка обойдемся просто переменной. здесь будет храниться адрес первого байтика перехваченной функции }
OrigByte: Byte;
{ а здесь будет храниться сам первый байтик }
RestoreBreak: Boolean;
{ флажок, который указывает обработчику события EXCEPTION_SINGLE_STEP надо ли восстанавливать точку останова. весь перехват выглядит так:
  • нашли стартовый адрес процедуры (это можно сделать просмотром таблицы экспорта у соответствующей DLL-ки. как именно - здесь не пишу. или разбирайтесь сами, или качайте мои исходники - там все есть. не то чтобы мне жалко, но к Debug API это имеет отношение весьма косвенное. опять же, если народ будет очень интересоваться, сделаю статью с quick overview формата PE);
  • запомнили ее первый байт;
  • записали вместо первого байта код $CC (это Int3 - DEBUG_EXCEPTION);
по приходу DEBUG_EXCEPTION:
проверили, точно ли мы прервались на адресе нашей точки останова. если нет - не делаем ничего. иначе:
  • восстановили первый байт;
  • установили флажок SINGLE_STEP;
  • установили флажок ResoteBreak;
  • ожидаем прихода события EXCEPTION_SINGLE_STEP;
по приходу EXCEPTION_SINGLE_STEP:
если установлен флажок RestoreBreak:
  • вернули на место $CC;
  • сбросили флажок ResoteBreak; }
ProcessFinished: Boolean;
{ флажок, указывающий, завершился ли отлаживаемый процесс. Sleepyhead говорит, что иногда процесс не завершается корректно (к примеру, отладчик, который отлаживает отладчик, который отлаживает отладчик... [Енота: GNU's not Unix :-)]), поэтому если процесс не завершится сам, мы прибьем его руками }

 begin
   FillChar(ThreadList, SizeOf(ThreadList), 0);
 
   HProc := 0;
   { хэндл процесса, который будем отлаживать.
   пока процесс не запущенным считается,
   соответственно - хэндла нету }
   ProcessFinished := True;
   { поскольку процесс не запустился,
   то он считается завершенным :-) }
   BPAddr := 0;
   { точку останова уточним,
   когда загрузится нужная DLL }
   RestoreBreak := False;
 
   repeat
     if not WaitForDebugEvent(Event, INFINITE) then
       break;
     { ожидаем прихода отладочного события. в реальном отладчике здеесь
     вместо INFINITE лучше задать маленькую константу, ожидать в цикле,
     там же в цикле организовывать взаимодействие с юзверем. или вообще
     для интерфейса отдельный поток создать }
     dwContinueStatus := DBG_EXCEPTION_NOT_HANDLED;
     { поскольку большинство исключений мы не обрабатываем,
     то по умолчанию так и говорим системе }
     CurThread := GetThreadHandleFromList(ThreadList, Event.dwThreadId);
     { просто поиск в массиве ThreadList. Id нам известен, ищем хэндл }
     case Event.dwDebugEventCode of
       { проверим - а что, собственно случилось? }
       CREATE_PROCESS_DEBUG_EVENT:
       { запустился новый процесс. запомним его хэндл, и сбросим флажок ProcessFinished }
       begin
         HProc := Event.CreateProcessInfo.HProcess;
         ProcessFinished := False;
         AddThreadToList(ThreadList, Event.dwThreadId, Event.CreateProcessInfo.hThread);
       end;
       EXIT_PROCESS_DEBUG_EVENT:
       { процесс завершился - значит, можно смело закрывать наш перехватчик.
       заодно установим флажок ProcessFinished }
       begin
         ProcessFinished := True;
         ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, DBG_CONTINUE);
         { это на всякий случай - чтобы ось точно прибила и процесс, и отладчик.
         в принципе, оно не надо, но смотри выше комментарий к ProcessFinished }
         break; { все, из цикла отладки можно смело выходить }
       end;
       CREATE_THREAD_DEBUG_EVENT:
         { процесс запустил новый поток. здесь у нас есть единственная возможность
         запомнить его хэндл. так и делаем }
         AddThreadToList(ThreadList, Event.dwThreadId, Event.CreateThread.hThread);
       EXIT_THREAD_DEBUG_EVENT:
         { процесс завершил исполнение потока. забудем его хэндл }
         DeleteThreadFromList(ThreadList, Event.dwThreadId);
       LOAD_DLL_DEBUG_EVENT:
         { процесс загрузил какую-то DLL'ку. проверим, не та ли
         это, которая нам нужна. если та, установим точку останова.
         текст процедуры смотрите ниже }
         ProcessDLLExport(HProc, DWORD(Event.LoadDll.lpBaseOfDll));
       UNLOAD_DLL_DEBUG_EVENT:
         { процесс выгрузил какую-то DLL'ку. по-правилам,
         это надо бы обработать, но поскольку я перехватываю вызовы kernel32.dll,
         который всегда (за очень-очень редким исключением :-) линкуется статически,
         то это событие я просто игнорирую. а вообще-то надо запомнить
         адрес загрузки нужной нам DLL в LOAD_DLL_DEBUG_EVENT
         (ибо это единственный способ идентифицировать DLL'ку),
         а здесь проверять - не наша ли это. если наша - обнулить BPAddr.
         можете дописать сами - как любят говорить авторы книг:
         "в качестве упражнения" :-) [Енота: ага. а сам, когда видит
         в книге эту фразу, разражается потоком нецензурной лексики :-)] }
         WriteLn('unloading DLL: ', IntToHex(DWORD(Event.UnloadDll.lpBaseOfDll), 8));
       EXCEPTION_DEBUG_EVENT:
         { какое-то исключение. проверим поточнее... }
         case Event.Exception.ExceptionRecord.ExceptionCode of
         EXCEPTION_BREAKPOINT:
         { это - точка останова. здесь мы уточним: наша или нет. дело в том,
         что система сама генерирует это событие, когда процесс загрузился,
         но перед тем, как он запущен (полсе того, как системный загрузчик
         загрузил процесс и все его DLL'ки. как раз перед тем, как исполнить
         первую инструкцию процесса). плюс - мало ли, какой код внутри
         исследуемого процесса может быть? так что... }
         begin
           dwContinueStatus := DBG_CONTINUE;
           { скажем системе, что это исключение мы обработали сами, пусть не напрягается }
           Context.ContextFlags := CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS;
           GetThreadContext(CurThread, Context);
           { получили контекст прерванного потока. больше всего нас интересуют IP и Flags.
           остальные регистры запросили просто для полноты картины }
           if (BPAddr <> 0) and (Context.EIP = BPAddr + 1) then
           begin
             { если мы уже установили нашу точку останова и прервались именно на ней... }
             RetAddr := ReadProcessLong(HProc, Context.ESP);
             { то получим адрес возврата из перехваченной нами функции.
             он нам не нужен, на самом-то деле, это просто пример - откуда его брать.
             если вам нужны параметры - ReadProcessLong(HProc, Context.ESP + 4)
             будет первым, ...+ 8) - вторым, и так далее... кстати, ReadProcessLong -
             просто обертка для системной функции ReadProcessMemory. читает 4 байтика.
             для удобства. думаю, что у вас не будет проблем сделать себе такую же :-) }
             WriteLn('Return address: 0x', IntToHex(RetAddr, 8));
             { дальше - уменьшим IP на еденичку (чтобы исполнить ту инструкцию,
             которую мы заменили на нашу точку останова)... реально, EIP-1
             хранится в BPAddr. так и запишем... }
             Context.EIP := BPAddr;
             { ...и восстановим оригинальный первый байтик этой инструкции }
             WriteProcessByte(HProc, BPAddr, OrigByte);
             { установим флажок для того, чтобы система генерировала
             событие EXCEPTION_SINGLE_STEP. в этом событии надо будет вернуть
             точку останова на место, иначе перехват состоится ровно один раз :-)
             [Енота: а то бы читатель сам не догадался...] }
             RestoreBreak := True;
             Context.EFlags := Context.EFlags or EFLAGS_TRACE;
             { вышеприведенной инструкцией мы сообщаем системе,
             что хотим получать по событию (EXCEPTION_SINGLE_STEP) после каждой
             исполненной в отлаживаемом процессе машинной команды. кстати,
             значение константы EFLAGS_TRACE = $100 }
             Context.ContextFlags := CONTEXT_CONTROL;
             SetThreadContext(CurThread, Context);
             { установим новое значение регистров потока }
           end;
         end;
         EXCEPTION_SINGLE_STEP:
         { выполнена одна машинная команда. скорее всего,
         возниконовение этого события - результат выполнения нашей точки останова,
         но кто знает? проверим флажки. если надо - восстановим точку останова }
         begin
           dwContinueStatus := DBG_CONTINUE;
           { скажем системе, что это исключение мы обработали сами, пусть не напрягается }
           Context.ContextFlags := CONTEXT_CONTROL;
           GetThreadContext(CurThread, Context);
           if RestoreBreak and (Context.EIP >= BPAddr) and (Context.EIP <= BPAddr + 32) then
           begin
             { это действительно "наше" событие. восстановим точку останова,
             чтобы перехватчик работал и дальше }
             OrigByte := WriteInt3(HProc, BPAddr);
             RestoreBreak := False;
 
             Context.EFlags := Context.EFlags and not EFLAGS_TRACE;
             { сбросим флажок трассировки, ибо больше это событие нам не надо }
           end
           else
             if RestoreBreak then
               Context.EFlags := Context.EFlags or EFLAGS_TRACE;
           { вернем флажок трассировки, если событие не наше -
           нам ведь надо нашего дождаться. у меня система сама скидывает сей флаг,
           так что на всякий случай... }
 
           Context.ContextFlags := CONTEXT_CONTROL;
           SetThreadContext(CurThread, Context);
         end;
       end;
     end;
 
     if not ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, dwContinueStatus) then
       break;
     { все. смело позволяем отлаживаемому процессу исполняться дальше }
   until
     False;
   { сюда мы попадем только при каком-нибудь сбое или завершении процесса.
   на всякий случай (по совету SleepyHead'а) проверим: а точно наш
   отлаживаемый процесс завершился? если нет - прибьем руками }
   if not ProcessFinished then
   begin
     repeat
       TerminateProcess(HProc, RetAddr);
       if not WaitForDebugEvent(Event, INFINITE) then
         break;
       if (Event.dwDebugEventCode = EXIT_PROCESS_DEBUG_EVENT) then
         break;
       if not ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, DBG_CONTINUE) then
         break;
     until
       False;
     ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, DBG_CONTINUE);
   end;
   { все. закончили :-) }
 end;
 
 { а вот процедурка, которая устанавливает точку останова }
 procedure ProcessDLLExport(PrcH, Base: DWORD);
 var
   DLLName: string;
   ExpTbl: TExportHeader;
   N: DWORD;
 begin
   if (BPAddr <> 0) then
     exit;
   { если уже установлена - не делать ничего }
   if not FindExportTable(PrcH, Base, ExpTbl) then
     exit;
   { если не смогли найти в DLL'ке таблицу экспорта (мало ли...) -
   тоже ничего не делать }
   DLLName := ANSILowerCase(GetASCIIZString(PrcH, ExpTbl.NameRVA + Base));
   { получили имя DLL'ки }
   if (DLLName <> 'kernel32.dll') then
     exit;
   { не наша? если да - снова не делаем ничего }
   N := FindExportIndexByName(PrcH, Base, 'AllocConsole', ExpTbl);
   N := FindExportByIndex(PrcH, Base, N, ExpTbl);
   { нашли по таблице экспорта точку входа (если не нашли -
   опять же ничего делать не надо }
   if (N = 0) then
     exit;
   { а если нашли - запомним необходимую информацию и установим останов }
   BPAddr := N;
   OrigByte := WriteInt3(PrcH, N);
   { WriteInt3 просто возвращает в качестве результата старый байтик,
   и на его место записывает код $CC - инструкция Int3. когда система
   встречает эту инструкцию, она генерирует исключение EXCEPTION_BREAKPOINT }
 end;
 

Все. Не так страшен черт, как его малюют [Енота: или: не так страшен Гейтс... :-)]. Остались мелочи.

Если вы запускаете процесс сами, не забудьте указать в CreateProcess флажок DEBUG_ONLY_THIS_PROCESS, чтобы отладчик мог работать, и чтобы процессы, которые может запустить отлаживаемая программа не отлаживались нами (а зачем нам дочерние процессы? если хотим перехватывать вызовы и в них, проще будет ловить непосредственно CreateProcess, и для каждого "новорожденного" запускать свою копию отладчика. Тем более, что если мы присоединяемся к уже запущенному процессу, то система по умолчанию ставит флажок DEBUG_ONLY_THIS_PROCESS. Так что перехватывать CreateProcess надежнее).

Если же вы хотите присоединиться к уже запущенному процессу, то узнайте его Id (с помощью TaskManager в NT или программно), и смело пишите DebugActiveProcess(ProcessId). В дальнейшем никаких различий между работой с процессом, запущенным нами и процессом, к которому мы присоединились "на лету" уже нет.

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

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

Полные рабочие исходники можно взять с нашего сайта: http://www.piranha-home.org. Если кто-то поможет в деле перевода статьи на английский - буду очень благодарен.




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

Рабочий пример использования DirectSound на Delphi + несколько полезных процедур. В этом примере создается один первичный SoundBuffer и 2 статических, вторичных; в них загружаются 2 WAV файла. Первичный буфер создается процедурой AppCreateWritePrimaryBuffer, а любой вторичный - AppCreateWritePrimaryBuffer. Так как вторичный буфер связан с WAV файлом, то при создании буфера нужно определить его параметры в соответствии со звуковым файлом, эти характеристики (Samples, Bits, IsStereo) задаются в виде параметров процедуры. Time - время WAV'файла в секундах (округление в сторону увеличения).


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Timer1: TTimer;
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
     DirectSound: IDirectSound;
     DirectSoundBuffer: IDirectSoundBuffer;
     SecondarySoundBuffer: array [0..1] of IDirectSoundBuffer;
     procedure AppCreateWritePrimaryBuffer;
     procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer;
       SamplesPerSec: Integer; Bits: Word; isStereo:Boolean; Time: Integer);
     procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
       OffSet: DWord; var SoundData; SoundBytes: DWord);
     procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer);
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
     raise Exception.Create('Failed to create IDirectSound object');
   AppCreateWritePrimaryBuffer;
   AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0], 22050, 8, False, 10);
   AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1], 22050, 16, True, 1);
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 var
   i: ShortInt;
 begin
   if Assigned(DirectSoundBuffer) then
     DirectSoundBuffer.Release;
   for i:=0 to 1 do
     if Assigned(SecondarySoundBuffer[i]) then
       SecondarySoundBuffer[i].Release;
   if Assigned(DirectSound) then
     DirectSound.Release;
 end;
 
 procedure TForm1.AppWriteDataToBuffer;
 var
   AudioPtr1, AudioPtr2: Pointer;
   AudioBytes1, AudioBytes2: DWord;
   h: HResult;
   Temp: Pointer;
 begin
   H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
   AudioPtr2, AudioBytes2, 0);
   if H = DSERR_BUFFERLOST then
   begin
     Buffer.Restore;
     if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
     AudioPtr2, AudioBytes2, 0) <> DS_OK then
       raise Exception.Create('Unable to Lock Sound Buffer');
   end
   else
   if H <> DS_OK then
     raise Exception.Create('Unable to Lock Sound Buffer');
   Temp := @SoundData;
   Move(Temp^, AudioPtr1^, AudioBytes1);
   if AudioPtr2 <> nil then
   begin
     Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1);
     Move(Temp^, AudioPtr2^, AudioBytes2);
   end;
   if Buffer.UnLock(AudioPtr1, AudioBytes1,AudioPtr2, AudioBytes2) <> DS_OK then
     raise Exception.Create('Unable to UnLock Sound Buffer');
 end;
 
 procedure TForm1.AppCreateWritePrimaryBuffer;
 var
   BufferDesc: DSBUFFERDESC;
   Caps: DSBCaps;
   PCM: TWaveFormatEx;
 begin
   FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
   FillChar(PCM, SizeOf(TWaveFormatEx),0);
   with BufferDesc do
   begin
     PCM.wFormatTag:=WAVE_FORMAT_PCM;
     PCM.nChannels:=2;
     PCM.nSamplesPerSec:=22050;
     PCM.nBlockAlign:=4;
     PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
     PCM.wBitsPerSample:=16;
     PCM.cbSize:=0;
     dwSize:=SizeOf(DSBUFFERDESC);
     dwFlags:=DSBCAPS_PRIMARYBUFFER;
     dwBufferBytes:=0;
     lpwfxFormat:=nil;
   end;
   if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then
     raise Exception.Create('Unable to set Coopeative Level');
   if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then
     raise Exception.Create('Create Sound Buffer failed');
   if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then
     raise Exception.Create('Unable to Set Format ');
   if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then
     raise Exception.Create('Unable to set Coopeative Level');
 end;
 
 procedure TForm1.AppCreateWriteSecondaryBuffer;
 var
   BufferDesc: DSBUFFERDESC;
   Caps: DSBCaps;
   PCM: TWaveFormatEx;
 begin
   FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
   FillChar(PCM, SizeOf(TWaveFormatEx),0);
   with BufferDesc do
   begin
     PCM.wFormatTag:=WAVE_FORMAT_PCM;
     if isStereo then PCM.nChannels:=2 else PCM.nChannels:=1;
     PCM.nSamplesPerSec:=SamplesPerSec;
     PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
     PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
     PCM.wBitsPerSample:=Bits;
     PCM.cbSize:=0;
     dwSize:=SizeOf(DSBUFFERDESC);
     dwFlags:=DSBCAPS_STATIC;
     dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
     lpwfxFormat:=@PCM;
   end;
   if DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK then
     raise Exception.Create('Create Sound Buffer failed');
 end;
 
 procedure TForm1.CopyWAVToBuffer;
 var
   Data: PChar;
   FName: TFileStream;
   DataSize: DWord;
   Chunk: string[4];
   Pos: Integer;
 begin
   FName:=TFileStream.Create(name,fmOpenRead);
   Pos:=24;
   SetLength(Chunk,4);
   repeat
     FName.Seek(Pos, soFromBeginning);
     FName.read(Chunk[1],4);
     Inc(Pos);
   until
     Chunk = 'data';
   FName.Seek(Pos+3, soFromBeginning);
   FName.read(DataSize, SizeOf(DWord));
   GetMem(Data,DataSize);
   FName.read(Data^, DataSize);
   FName.Free;
   AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
   FreeMem(Data,DataSize);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   CopyWAVToBuffer('1.wav',SecondarySoundBuffer[0]);
   CopyWAVToBuffer('flip.wav',SecondarySoundBuffer[1]);
   if SecondarySoundBuffer[0].Play(0,0,0) <> DS_OK then
     ShowMessage('Can''t play the Sound');
   if SecondarySoundBuffer[1].Play(0,0,0) <> DS_OK then
     ShowMessage('Can''t play the Sound');
 end;
 
 end.
 




Как использовать форму из DLL

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

Это файл Form.dpr, из которого получается DLL:


 library Form;
 uses
   Classes,
   Unit1 in 'Unit1.pas' {Form1};
 exports
   CreateMyForm,
   DestroyMyForm;
 end.
 

Это его Unit1:


 unit Unit1;
 
 interface
 
 // раздел uses и определение класса Form1
 
   procedure CreateMyForm(AppHandle: THandle); stdcall;
   procedure DestroyMyForm; stdcall;
 
 implementation
 {$R *.DFM}
 
 procedure CreateMyForm(AppHandle: THandle);
 begin
   Application.Handle := AppHandle;
   Form1 := TForm1.Create(Application);
   Form1.Show
 end;
 
 procedure DestroyMyForm;
 begin
   Form1.Free;
 end;
 
 end.
 

Это UnitCall вызывающего EXE-шника:


 unit
   UnitCall;
 
 interface
 
 // раздел uses и определение класса Form1
 
   procedure CreateMyForm(AppHandle: THandle); stdcall; external 'Form.dll';
   procedure DestroyMyForm; stdcall; external 'Form.dll';
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   CreateMyForm(Application.Handle);
 end;
 
 procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
 begin
   DestroyMyForm;
 end;
 
 end.
 




Использование файла помощи

Автор: Neil

Жизнь - игра, в которой нет tutorial`а.

Вот код для трех стандартных пунктов меню "Help":


 procedure TForm1.Contents1Click(Sender: TObject);
 begin
   Application.HelpCommand(HELP_CONTENTS, 0);
 end;
 
 procedure TForm1.SearchforHelpOn1Click(Sender: TObject);
 begin
   Application.HelpCommand(HELP_PARTIALKEY, 0);
 end;
 
 procedure TForm1.HowtoUseHelp1Click(Sender: TObject);
 begin
   Application.HelpCommand(HELP_HELPONHELP, 0);
 end;
 




Как использовать процедуру mouse_event для имитации событий мыши


Один юзер другому:
- Я себе счетчик на мышь поставил. Теперь я знаю, что моя мышь пробежала 1138 метров.

На форму вынесены две кнопки. По нажатию первой напишем:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage('Button 1 clicked');
 end;
 

А нажатие второй обработаем так:


 procedure TForm1.Button2Click(Sender: TObject);
 var
   Pt: TPoint;
 begin
   {Позволим кнопке Button2 перерисоваться}
   Application.ProcessMessages;
   {Найдем координаты центра button 1}
   Pt.x := Button1.Left + (Button1.Width div 2);
   Pt.y := Button1.Top + (Button1.Height div 2);
   {Преобразуем Pt к координатам экрана}
   Pt := ClientToScreen(Pt);
   {Преобразуем Pt к "mickeys" (аболютным координатам курсора мышки}
   Pt.x := Round(Pt.x * (65535 / Screen.Width));
   Pt.y := Round(Pt.y * (65535 / Screen.Height));
   {Переместим курсор мыши}
   Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE, Pt.x, Pt.y, 0, 0);
   {Имитируем нажатие левой кнопки мыши}
   Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, Pt.x, Pt.y, 0, 0);
   {Имитируем отпускание левой кнопки мыши}
   Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, Pt.x, Pt.y, 0, 0);
 end;
 




Использование многомерного массива

Автор: Michael Day


 type
   RecType = integer; {<-- здесь задается тип элементов массива}
 
 const
   MaxRecItem = 65520 div sizeof(RecType);
 
 type
   = MyArrayType = array[0..MaxRecItem] of RecType;
 type
   = MyArrayTypePtr = ^MyArrayType;
 
 var
   MyArray: MyArrayTypePtr;
 begin
   ItemCnt := 10; {количество элементов массива, которые необходимо распределить}
   GetMem(MyArray, ItemCnt * sizeof(MyArray[1])); {распределение массива}
   MyArray^[3] := 10; {доступ к массиву}
 
   FreeMem(MyArray, ItemCnt * sizeof(MyArray[1]));
     {освобождаем массив после работы с ним}
 end;
 




Использование холста в собственных компонентах

Вот мой совет по использованию холста в компонентах собственного приготовления:


 TScrollingPaintBox = class(TScrollingWinControl)
 
 private
   FCanvas: TCanvas;
 public
   constructor Create(aOwner: TComponent); override;
   destructor Destroy; override;
   property Canvas: TCanvas read FCanvas;
 end;
 
 constructor TScrollingPaintBox.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FCanvas := TControlCanvas.Create;
   TControlCanvas(FCanvas).Control := Self;
 end;
 
 destructor TScrollingPaintBox.Destroy;
 begin
   FCanvas.Free;
   inherited Destroy;
 end;
 

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




Как приложению воспользоваться своими шрифтами

Может ли кто-нибудь подсказать или решить такую проблему: мне нужно убедиться, что мое приложение использует доступные, а не ближайшие шрифты, установленные пользователем в системе? Я пробовал копировать файл #.ttf в директорию пользователя windows\system, но мое приложение так и не смогло их увидеть и выбрать для дальнейшего использования.

Ниже приведен код для Delphi, который динамически устанавливает шрифты, загружаемые только во время работы приложения. Вы можете расположить файл(ы) шрифтов в каталоге приложения. Они будут инсталлированы при загрузке формы и выгружены при ее разрушении. Вам возможно придется модифицировать код для работы с Delphi 2, поскольку он использует вызовы Windows API, которые могут как измениться, так и нет. Если в коде вы видите "...", то значит в этом месте может располагаться какой-либо код, не относящийся к существу вопроса.

Ну и, конечно, вы должны заменить "MYFONT" на реальное имя файла вашего шрифта.


 type
   TForm1 = class(TForm)
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     ...
     private
     { Private declarations }
     bLoadedFont: boolean;
   public
     { Public declarations }
   end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   sAppDir: string;
   sFontRes: string;
 begin
   sAppDir := Application.ExeName;
   sAppDir := copy(sAppDir, 1, rpos('\', sAppDir));
 
   sFontRes := sAppDir + 'MYFONT.FOT';
   if not FileExists(sFontRes) then
   begin
     sFontRes := sFontRes + #0;
     sFont := sAppDir + 'MYFONT.TTF' + #0;
     CreateScalableFontResource(0, @sFontRes[1], @sFont[1], nil);
   end;
 
   sFontRes := sAppDir + 'MYFONT.FOT';
   if FileExists(sFontRes) then
   begin
     sFontRes := sFontRes + #0;
     if AddFontResource(@sFontRes[1]) = 0 then
       bLoadedFont := false
     else
     begin
       bLoadedFont := true;
       SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
     end;
   end;
   ...
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 var
   sFontRes: string;
 begin
   if bLoadedFont then
   begin
     sFontRes := sAppDir + 'MYFONT.FOT' + #0;
     RemoveFontResource(@sFontRes[1]);
     SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
   end;
 end;
 

Я поработал с данным кодом и внес некоторые поправки для корректной работы на Delphi 2.0. На Delphi 3.0 не испытано.

Электронная справка по продукту InstallShield показывает, что в системах Win95 и WinNT FOT-файл не нужен. Вам нужен только TTF-файл.

В результате процедура FormCreate стала выглядеть так:


 var
   sAppDir, sFontRes: string;
 begin
   {...другой код...}
   sAppDir := extractfilepath(Application.ExeName);
 
   sFontRes := sAppDir + 'MYFONT.TTF';
   if FileExists(sFontRes) then
   begin
     sFontRes := sFontRes + #0;
     if AddFontResource(@sFontRes[1]) = 0 then
       bLoadedFont := false
     else
     begin
       bLoadedFont := true;
       SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
     end;
   end;
   {...}
 end; {FormCreate}
 

А FormDestroy так:


 var
   sFontRes, sAppDir: string;
 begin
   {...другой код...}
 
   if bLoadedFont then
   begin
     sAppDir := extractfilepath(Application.ExeName);
     sFontRes := sAppDir + 'MYFONT.TTF' + #0;
     RemoveFontResource(@sFontRes[1]);
     SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
   end;
 
   {...другой код...}
 end; {FormDestroy}
 

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


 {1998-01-16 Функция загрузки и выгрузки шрифта.}
 
 function LoadFont(sFontFileName: string; bLoadIt: boolean): boolean;
 var
   sFont, sAppDir, sFontRes: string;
 begin
   result := TRUE;
 
   if bLoadIt then
   begin
     {Загрузка шрифта.}
     if FileExists(sFontFileName) then
     begin
       sFontRes := sFontFileName + #0;
       if AddFontResource(@sFontRes[1]) = 0 then
         result := FALSE
       else
         SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
     end;
   end
   else
   begin
     {Выгрузка шрифта.}
     sFontRes := sFontFileName + #0;
     result := RemoveFontResource(@sFontRes[1]);
     SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
   end;
 end; {LoadFont}
 




Как использовать протокол about

- Вы никогда не задумывались, что кнопка Обновить в Internet Explorer может быть весьма полезной при виртуальном распитии спиртных напитков?

Протокол "about:" позволяет Вам просмотреть HTML строку:


 procedure TForm1.LoadHTMLString(sHTML: String);
 var
   Flags, TargetFrameName, PostData, Headers: OleVariant;
 begin
   WebBrowser1.Navigate('about:' + sHTML, Flags,
   TargetFrameName, PostData, Headers)
 end;
 




Как можно использовать протокол res

- Что такое Интернет во Львове?
- Что-то вроде секса в кладовке. Вроде и кайф, но темно, душно и неудобно.

Протокол "res:" позволяет просмотреть HTML файл, сохранённый как ресурс. Более подробная информация доступна на Microsoft


 procedure TForm1.LoadHTMLResource;
 var
   Flags, TargetFrameName, PostData, Headers: OleVariant;
 begin
   WebBrowser1.Navigate('res://' + Application.ExeName + '/myhtml',
                            Flags, TargetFrameName, PostData, Headers);
 end;
 

Создайте файл ресурса (*.rc) со следующими строками и откомпилируйте его при помощи brcc32.exe:


 MYHTML 23 ".\html\myhtml.htm"
 MOREHTML 23 ".\html\morehtml.htm"
 

Отредактируйте файл проекта, чтобы он выглядел примерно так:


 {$R *.RES}
 {$R HTML.RES} //где html.rc будет скомпилирован в html.res
 




Работа с Sender



 unit TestInputForm;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, DdhInpuB;
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit;
     Label1: TLabel;
     DdhInputButton1: TDdhInputButton;
     DdhInputButton2: TDdhInputButton;
     DdhInputButton3: TDdhInputButton;
     procedure DdhInputButtonClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.DdhInputButtonClick(Sender: TObject);
 begin
   ShowMessage ('You''ve clicked the ' +
     (Sender as TButton).Name + ','#13 +
     'having the caption ' +
     (Sender as TButton).Caption);
 end;
 
 end.

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




Как использовать Список Задач (Tasklist)

Автор: Daniel Kinnaer

Приходит как-то программер со школы. Жена ему говорит:
- Дорогой, тебе чайник поставить?
- Да за#бали меня уже эти чайники!!!


 procedure TForm1.Button1Click(Sender: TObject);
 {Размещаем имена модулей запущенных/минимизированных задач в ListBox    }
 var
   pTask: pTaskEntry; {требуется Uses ToolHelp}
   Task: bool;
   Pstr: array[0..79] of Char;
   Str: string[80];
   byt_j: byte;
 begin
   ListBox1.Clear;
   GetMem(pTask, SizeOf(TTaskEntry)); {Резервируем память для TaskEntry}
   pTask^.dwSize := SizeOf(TTaskEntry);
 
   byt_j := 0; {Устанавливаем счетчик для количества задач}
   Task := TaskFirst(pTask); {Ищем первую задачу}
   while task do
   begin
     inc(byt_j); {счетчик количества различных задач}
     Str := StrPas(pTask^.szModule); {Преобразуем PStr в паскалевскую строку}
     Listbox1.Items.Add(str); {Сохраняем паскалевскую строку в ListBox}
     task := taskNext(pTask); {Ищем следующую возможную задачу}
   end;
   Label1.Caption := IntToStr(byt_j) + ' задач найдено'; {Показываем счетчик}
 end;
 




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

Автор: Jim Poe

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

...я все еще ищу *крутой* способ отрисовки содержимого окна редактирования IDE, и уже добрался до списка дескрипторов окон. Я так понял, что для этого нужно использовать инструментальный интерфейс (Tools Interface), только c помощью него, да? Ну и как этим чудом воспользоваться?

Приведенный ниже код может использоваться для включения заголовка исходного кода, представляющего собой шапку с информацией об авторских правах, авторе, версии и пр. при добавлении нового модуля или формы к вашему проекту. TIAddInNotifier - класс, реализованный в ToolIntf и позволяющий "захватывать" такие события, как открытие файлов, их закрытие, открытие и закрытие проекта и др. Я перекрыл процедуру FileNotification для захвата событий AddedToProject и RemovedFromProject. В обработчике события AddedToProject вы можете получить доступ к новому модулю проекта, особенно это касается процедуры InsertHeader. Я создал наследника класса TIEditorInterface, расположенного в файле EditIntf.pas, и создал собственную процедуру InsertHeader.

VCSNotifier создается в другом модуле и здесь не показан. Приведенный ниже код является частью моей программы, осуществляющей контроль версий dll. При создании код "живет" до тех пор, пока работает Delphi. При получении кода AddedToProject, я проверяю наличие файла (должен быть новым), и что он является .pas-файлом. Затем я создаю VCSEditorInterface, мой унаследованный интерфейс, и использую мою процедуру InsertHeader.

В самой процедуре InsertHeader я создаю экземпляр TIEditReader для чтения нового модуля и TIEditWriter для его изменения.


 unit VCSNtfy;
 
 interface
 
 uses SysUtils, Dialogs, Controls, ToolIntf, EditIntf;
 
 type
 
   TIVCSNotifier = class(TIAddInNotifier)
   public
     procedure FileNotification(NotifyCode: TFileNotification; const FileName:
       string; var Cancel: Boolean); override;
   end;
 
   TIVCSEditorInterface = class(TIEditorInterface)
   public
     procedure InsertHeader;
   end;
 
 var
 
   VCSNotifier: TIVCSNotifier;
   VCSModuleInterface: TIModuleInterface;
   VCSEditorInterface: TIVCSEditorInterface;
 
 implementation
 
 uses FITIntf, FITStr, Classes;
 
 { *************************   Начало VCSNotifier  **************************** }
 
 procedure TIVCSNotifier.FileNotification(NotifyCode: TFileNotification; const
 
   FileName: string; var Cancel: Boolean);
 var
 
   TmpFileName: string;
 
 begin
 
   case NotifyCode of
     fnRemovedFromProject: VCSProject.Remove(LowerCase(ExtractFileName(
         FileName)));
     fnAddedToProject:
       begin
         if (not FileExists(FileName)) and
           (ExtractFileExt(FileName) = '.pas') then
         begin
           { новый файл с исходным кодом }
           VCSModuleInterface := ToolServices.GetModuleInterface(FileName);
           if VCSModuleInterface <> nil then
           begin
             VCSEditorInterface := TIVCSEditorInterface(
               VCSModuleInterface.GetEditorInterface);
             VCSEditorInterface.InsertHeader;
             VCSEditorInterface.Free;
           end;
           VCSModuleInterface.Free;
         end;
 
         TmpFileName := LowerCase(ExtractFileName(FileName));
         if VCSProject.RecycleExists(TmpFileName) then
         begin
           if MessageDlg('Вы хотите извлечь текущие ' +
             ' записи из таблицы Recycle' +
             #13 + #10 + '           ' +
             VCSProject.ProjectName + '/' +
             TmpFileName + '?', mtConfirmation,
             [mbYes, mbNo], 0) = mrYes then
           begin
             VCSProject.Recycle(TmpFileName);
           end;
         end;
       end;
   end;
 end;
 
 { *************************    Конец TIVCSNotifier   *************************** }
 
 { *********************   Начало TIVCSEditorInterface  ************************ }
 
 procedure TIVCSEditorInterface.InsertHeader;
 var
 
   Module, TmpFileName, UnitName, InsertText, Tmp: string;
   Reader: TIEditReader;
   Writer: TIEditWriter;
   APos: Integer;
   F: TextFile;
 begin
 
   TmpFileName := ExtractFileName(FileName);
   UnitName := SwapStr(TmpFileName, '.pas', '');
 
   SetLength(Module, 255);
   Reader := CreateReader;
   try
     Reader.GetText(0, PChar(Module), Length(Module));
   finally
     Reader.Free;
   end;
 
   APos := Pos('unit ' + UnitName, Module);
   if APos > 0 then
   begin
     try
       InsertText := '';
       AssignFile(F, VCSConfig.HeaderFileLocation);
       Reset(F);
       while not EOF(F) do
       begin
         Readln(F, Tmp);
         InsertText := InsertText + #13 + #10 + Tmp;
       end;
       CloseFile(F);
 
       InsertText := InsertText + #13 + #10;
 
       Writer := CreateWriter;
       try
         Writer.CopyTo(APos - 1);
         Writer.Insert(PChar(InsertText));
       finally
         Writer.Free;
       end;
     except
       on E: EStreamError do
         MessageDlg('Не могу создать шапку', mtInformation, [mbOK], 0);
     end;
   end;
 
 end;
 { *********************   Конец TIVCSModuleInterface  ************************** }
 end.
 




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

Автор: Mike Scott

Вы просили пример кода использования TParser. Хорошо, вот несколько процедур для модуля Parser для создания документации Delphi-компонент напрямую из исходного кода.

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


 { TDelphiUnitParser }
 
 function TDelphiUnitParser.CheckSectionBreak: Boolean;
 begin
   with Parser do
   begin
     Result := (Token = toSymbol) and
       (Compare('Var') or
       Compare('Const') or
       Compare('Type') or
       Compare('Implementation') or
       Compare('Procedure') or
       Compare('Function'));
   end;
 end;
 
 procedure TDelphiUnitParser.ParseParameterList;
 begin
   with Parser do
   begin
     { пропускаем '(' }
     NextToken;
     while Token <> ')' do
       NextToken;
     NextToken;
   end;
 end;
 
 procedure TDelphiUnitParser.ParseRecord;
 begin
   with Parser do
   begin
     { пропускаем 'record' }
     NextToken;
     while (Token <> toSymbol) or not Compare('End') do
     begin
       if Token = 'Record' then
         ParseRecord
       else
         NextToken;
     end;
   end;
 end;
 
 procedure TDelphiUnitParser.ParseDeclaration;
 begin
   with Parser do
   begin
     while Token <> ';' do
     begin
       if Token = '(' then
         ParseParameterList
       else if (Token = toSymbol) and Compare('Record') then
         ParseRecord
       else
         NextToken;
     end;
   end;
 end;
 
 procedure TDelphiUnitParser.ParseConst;
 var
   AString: string;
   AStart: PChar;
   EndOfConsts: Boolean;
 begin
   with Parser do
   begin
     NextToken;
     repeat
       if Token <> toSymbol then
         ErrorStr('Неопознанный идентификатор');
       AString := TokenString;
       AStart := FSourcePtr;
       NextToken;
       if not (Token in ['=', ':']) then
         ErrorStr('''='' or '':''
           ожидалось' ) ;
 
           ParseDeclaration;
           FindToken(';');
     until CheckSectionBreak;
   end;
 end;
 




Как использовать клавишу-акселератор в TTabSheets

Press any key to continue or any other key to exit

Можно перехватить сообщение CM_DIALOGCHAR


 type
   TForm1 = class(TForm)
     PageControl1: TPageControl;
     TabSheet1: TTabSheet;
     TabSheet2: TTabSheet;
     TabSheet3: TTabSheet;
   private
     {Private declarations}
     procedure CMDialogChar(var Msg:TCMDialogChar);
     message CM_DIALOGCHAR;
   public
     {Public declarations}
   end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.CMDialogChar(var Msg:TCMDialogChar);
 var
   i: integer;
 begin
   with PageControl1 do
   begin
     if Enabled then
       for i := 0 to PageControl1.PageCount - 1 do
         if ((IsAccel(Msg.CharCode, Pages[i].Caption)) and
         (Pages[i].TabVisible)) then
         begin
           Msg.Result:=1;
           ActivePage := Pages[i];
           exit;
         end;
   end;
   inherited;
 end;
 




Работа с Winsock на Delphi

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

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

Заголовки всех процедур и функций, находящихся в этой dll-ке можно найти в Delphi5\source\rtl\win\winsock.pas.

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

1. function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; Входящий параметр wVersionRequired - наивысшая версия сокетов Windows, которую можно использовать. Исходящий параметр WSData - указатель на структуру данных WSAData. В случае успешного завершения функция возвращает значение ноль, в противном случае код ошибки. Эта функция должна быть ОБЯЗАТЕЛЬНО вызвана один раз, перед началом работы с сокетами.

2. function inet_addr(cp: PChar): u_long; Входящий параметр cp - нуль терминальная строка. Если нет ошибок, функция возвращает стандартный IP адрес для использования по протоколу TCP\IP. В случае ошибки возвращаемое значение - INADDR_NONE.

3. function htons(hostshort: u_short): u_short; Входящий параметр hostshort - число (16 битное). Функция возвращает 16 битный номер в специальном формате, который можно использовать в протоколе TCP\IP.

4. function socket(af, Struct, protocol: Integer): TSocket; Входящий параметр af - спецификация семейства сокетов, может принимать значение AF_INET, AF_IPX и др. struct - спецификация типа нового сокета (принимает значение SOCK_STREAM или SOCK_DGRAM). protocol - специфический протокол, который будет использоваться сокетом (если не хочешь ничего специфического - пиши 0). Если функция выполнена без ошибок, она возвращает дескриптор на новый сокет, если ошибки есть возвращается INVALID_SOCKET. Код ошибки можно узнать, вызвав функцию WSAGetLastError.

5. function connect(s: TSocket; var name: TSockAddr; namelen: Integer): Integer; Входящий параметр s - дескриптор, идентифицырующий сокет (это значение возвращает функция socket). name - имя с которым будет связан сокет после коннекта, namelen - длинна этого имени (легко можно получить, используя функцию sizeof). В случае успешного коннекта функция возвращает значение ноль. Если коннект не удался, возвращаемое значение - SOCKET_ERROR (код ошибки можно получить, используя функцию WSAGetLastError).

6. function WSACleanup: Integer; Если выполнена успешно - возвращает ноль и прекращает использования сокетов Windows. Если есть ошибка во время выполнения возвращает код ошибки.

Это далеко не все функции, находящиеся в winsock.dll. Еще раз повторю, что полный их список можно найти в файле winsock.pas, а описание можно посмотреть в Win32 API Reference - Windows Sockets 2 Reference. Надеюсь, что Вы поняли все вышенаписанное и знакомы с основами функционирования сокетов, т.е. понимаете, что такое сокет. Для закрепления полученных знаний, как обычно, напишим маленькую программку.. Все знают, что такое Socks сервер и для чего он нужен.. Если у Вас провал в памяти, я напомню: Socks прокси работают по Socks протоколу, который не зависит от высокоуровневых протоколов (http, ftp, telnet и.т.д.) и поэтому может использоваться для передачи данных по любому протоколу "высокого уровня". После всего выше изложенного будет вполне закономерно, что для тренировки мы напишем простой консольный сканер диапазонов IP адресов на открытый 1080 порт, который является стандартным портом Socks серверов.


 program scan;
 
 {$APPTYPE CONSOLE}
 
 { Для использования winsock необходимо описать этот модуль в uses. }
 uses
   sysutils,winsock;
 
 { дефолтовый порт Socks прокси. Сюда можно вписать любой порт,
 превратив наш сканнер, к примеру, в httpd (80 порт) сканнер. }
 const
   port = 1080;
 
 { Здесь объявляем переменные }
 var
   D:WSAData;
   S:TSocket;
   A:TSockAddr;
   m1,m2,mask,val:String;
   i:Integer;
 begin
   { Если наш сканер запущен без параметров, выводим некоторую информацию.. }
   if paramcount < 1 then
   begin
     writeln('Socks Scanner by har0n, har0n@gmx.net');
     writeln('Example: scan.exe 127.0.0 1-255');
     writeln('http://www.security.net.tf');
   exit;
 end
 else
 { Если сканер запущен с параметрами, в переменную mask заносим 1-ый параметр,
 в val 2-ой параметр }
 begin
   mask:=paramstr(1);
   val:=paramstr(2);
   { Определяем диапазон сканирования}
   m1:= copy(val,1,pos('-',val)-1);
   m2:= copy(val,pos('-',val)+1,length(val));
   writeln('- Scanning begin: '+mask+'.'+m1+' - '+mask+'.'+m2+' -');
   writeln;
   { Если WSAStartup() возвращает не нулевое значение, выводим сообщение об ошибке
   и выходим из программы}
 if WSAStartup($101,D)<>0 then
 begin
   writeln('error..');
   exit;
 end;
 { Начинаем процесс сканирования }
 for i:= strtoint(m1) to strtoint(m2) do
 begin
   { Определяем тип семейства сокетов, и IP адрес для сканирования }
   A.sin_family:=AF_INET;
   A.sin_addr.S_addr:=inet_addr(pchar(mask+'.'+inttostr(i)));
   { Создаем сокет }
   S:=socket(AF_INET,SOCK_STREAM,0);
   { Если возвращено значение INVALID_SOCKET, выводим сообщение об ошибке }
   if S=INVALID_SOCKET then
     writeln('socket error');
   { Определяем порт (задается константой) }
   A.sin_port:=htons(port);
   { Пытаемся подконнектиться, если удачно - выводим сообщение, что порт открыт,
   в другом случае - сообщение о том, что порт закрыт (или недоступен) }
   if connect(S,A,sizeof(A))=0 then
     writeln(mask+'.'+inttostr(i)+' port '+inttostr(port)+' opened') else
   writeln(mask+'.'+inttostr(i)+' port '+inttostr(port)+' closed');
 end;
 { Завершаем работу с сокетами }
 WSACleanup;
 writeln;
 writeln('- Scanning is completed -');
 end;
 end.
 

Запускать сканер будем так: scan.exe 127.0.0 1-255, при этом будут проверены IP адреса с 127.0.0.1 по 127.0.0.255. Я компилировал исходник на Delphi 5 update pack 1, Windows 2000 SP2, но, думаю, и под другими версиями Delphi и Windows проблем не возникнет. Ну все, удачи!




Как использовать встроенные в Windows иконки в своём приложении


Сперва необходимо узнать, константы, которые соответствуют определённым иконкам. Все они определены в API unit (windows.pas) в Delphi:

  • IDI_HAND
  • IDI_EXCLAMATION
  • IDI_QUESTION

Следующий пример рисует иконку вопроса на панели:


 var
   DC: HDC;
   Icon: HICON;
 begin
   DC := GetWindowDC(Panel1.Handle);
   Icon := LoadIcon(0, IDI_QUESTION);
   DrawIcon(DC, 5, 5, Icon);
   ReleaseDC(Panel1.Handle, DC);
 end;
 




Использование и создание DLL в Delphi

У жены программиста спросили:
- А как он за тобой ухаживал?
Жена, после минутного раздумья:
- Ну-у, компьютер показал...

Введение

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

Области применения DLL

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

Отдельные библиотеки
Содержат полезные для программистов дополнительные функции. Например, функции для работы со строками, или же - сложные библиотеки для преобразования изображений.
Хранилища ресурсов
В DLL можно хранить не только программы и функции, но и всевозможные ресурсы - иконки, рисунки, строковые массивы, меню, и т.д.
Библиотеки поддержки
В качестве примера можно привести библиотеки таких известных пакетов, как: DirectX, ICQAPI (API для ICQ), OpenGL и т.д.
Части программы
Например, в DLL можно хранить окна программы (формы), и т.п.
Плагины (Plugins)
Вот где настоящий простор для мыслей программиста! Плагины - дополнения к программе, расширяющие ее возможности. Например, в этой статье мы рассмотрим теорию создания плагина для собственной программы.
Разделяемый ресурс
DLL (Dynamic Link Library) может быть использована сразу несколькими программами или процессами (т.н. sharing - разделяемый ресурс)

Краткое описание функций и приемов для работы с DLL

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

1 способ. Привязка DLL к программе.

Это наиболее простой и легкий метод для использования функций, импортируемых из DLL. Однако (и на это следует обратить внимание) этот способ имеет очень весомый недостаток - если библиотека, которую использует программа, не будет найдена, то программа просто не запустится, выдавая ошибку и сообщая о том, что ресурс DLL не найден. А поиск библиотеки будет вестись: в текущем каталоге, в каталоге программы, в каталоге WINDOWS\SYSTEM, и т.д. Итак, для начала - общая форма этого приема:


 implementation
 ...
 
 function FunctionName(Par1: Par1Type; Par2: Par2Type; ...): ReturnType;
 stdcall; external 'DLLNAME.DLL' name 'FunctionName' index FuncIndex;
 
 // или (если не функция, а процедура):
 
 procedure ProcedureName(Par1: Par1Type; Par2: Par2Type; ...);
 stdcall; external 'DLLNAME.DLL' name 'ProcedureName' index ProcIndex;
 

Здесь:

FunctionName (либо ProcedureName)
имя функции (или процедуры), которое будет использоваться в Вашей программе;
Par1, Par2, ...
имена параметров функции или процедуры;
Par1Type, Par2Type, ...
типы параметров функции или процедуры (например, Integer);
ReturnType
тип возвращаемого значения (только для функции);
stdcall
директива, которая должна точно совпадать с используемой в самой DLL;
external 'DLLNAME.DLL'
директива, указывающая имя внешней DLL, из которой будет импортирована данная функция или процедура (в данном случае - DLLNAME.DLL);
name 'FunctionName' ('ProcedureName')
директива, указывающая точное имя функции в самой DLL. Это необязательная директива, которая позволяет использовать в программе функцию, имеющую название, отличное от истинного (которое она имеет в библиотеке);
index FunctionIndex (ProcedureIndex)
директива, указывающая порядковый номер функции или процедуры в DLL. Это также необязательная директива.

2 способ. Динамическая загрузка DLL

Это гораздо более сложный, но и более элегантный метод. Он лишен недостатка первого метода. Единственное, что неприятно - объем кода, необходимого для осуществления этого приема, причем сложность в том, что функция, импортируемая из DLL достуна лишь тогда, когда эта DLL загружена и находится в памяти... С примером можно ознакомиться ниже, а пока - краткое описание используемых этим методом функций WinAPI:

LoadLibrary(LibFileName: PChar)
загрузка указанной библиотеки LibFileName в память. При успешном завершении функция возвращает дескриптор (THandle) DLL в памяти.
GetProcAddress(Module: THandle; ProcName: PChar)
считывает адpес экспоpтиpованной библиотечной функции. При успешном завершении функция возвращает дескриптор (TFarProc) функции в загруженной DLL.
FreeLibrary(LibModule: THandle)
делает недействительным LibModule и освобождает связанную с ним память. Следует заметить, что после вызова этой процедуры функции данной библиотеки больше недоступны.

Практика и примеры

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

Пример 1. Привязка DLL к программе


 {... Здесь идет заголовок файла и определение
 формы TForm1 и ее экземпляра Form1}
 
 implementation
 
 {Определяем внешнюю библиотечную функцию}
 
 function GetSimpleText(LangRus: Boolean): PChar;
 stdcall; external 'MYDLL.DLL';
 
 procedure Button1Click(Sender: TObject);
 begin
   {И используем ее}
   ShowMessage(StrPas(GetSimpleText(True)));
   ShowMessage(StrPas(GetSimpleText(False)));
   {ShowMessage - показывает диалоговое окно с указанной надписью;
   StrPas - преобразует строку PChar в string}
 end;
 

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

Пример 2. Динамическая загрузка DLL


 {... Здесь идет заголовок файла и определение
 формы TForm1 и ее экземпляра Form1}
 
 var
   Form1: TForm1;
   GetSimpleText: function(LangRus: Boolean): PChar;
   LibHandle: THandle;
 
 procedure Button1Click(Sender: TObject);
 begin
   {"Чистим" адрес функции от "грязи"}
   @GetSimpleText := nil;
   {Пытаемся загрузить библиотеку}
   LibHandle := LoadLibrary('MYDLL.DLL');
   {Если все OK}
   if LibHandle >= 32 then
   begin
     {...то пытаемся получить адрес функции в библиотеке}
     @GetSimpleText := GetProcAddress(LibHandle,'GetSimpleText');
     {Если и здесь все OK}
     if @GetSimpleText <> nil then
       {...то вызываем эту функцию и показываем результат}
       ShowMessage(StrPas(GetSimpleText(True)));
   end;
   {И не забываем освободить память и выгрузить DLL}
   FreeLibrary(LibHandle);
 end;
 

Примечание:

Следует воздерживаться от использования типа string в библиотечных функциях, т.к. при его использовании существуют проблемы с "разделением памяти". Подробней об этом можно прочитать (правда, на английском) в тексте пустого проекта DLL, который создает Delphi (File -> New -> DLL). Так что лучше используйте PChar, а затем при необходимости конвертируйте его в string функцией StrPas.

Ну а теперь разберем непосредственно саму библиотеку DLL:

Пример 3. Исходник проекта MYDLL.DPR


 library mydll;
 
 uses
   SysUtils, Classes;
 
 {Определяем функцию как stdcall}
 function GetSimpleText(LangRus: Boolean): PChar; stdcall;
 begin
   {В зависимости от LangRus возвращаем русскую (True) либо английскую (False) фразу}
   if LangRus then
     Result := PChar('Здравствуй, мир!')
   else
     Result := PChar('Hello, world!');
 end;
 
 {Директива exports указывает, какие функции будут экспортированы этой DLL}
 exports GetSimpleText;
 
 begin
 end.
 

Размещение в DLL ресурсов и форм

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

Для этого нужно создать новую DLL и добавить в нее новую форму (File -> New -> DLL, а затем - File -> New Form). Далее, если форма представляет собой диалоговое окно (модальную форму (bsDialog)), то добавляем в DLL следующую функцию (допустим, форма называется Form1, а ее класс - TForm1):

Пример 4. Размещение формы в DLL


 function ShowMyDialog(Msg: PChar): Boolean; stdcall;
 
 ...
 exports ShowMyDialog;
 
 function ShowMyDialog(Msg: PChar): Boolean;
 begin
   {Создаем экземпляр Form1 формы TForm1}
   Form1 := TForm1.Create(Application);
   {В Label1 выводим Msg}
   Form1.Label1.Caption := StrPas(Msg);
   {Возвращаем True только если нажата OK (ModalResult = mrOk)}
   Result := (Form1.ShowModal = mrOk);
   {Освобождаем память}
   Form1.Free;
 end;
 

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

Создание плагинов

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

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

Эпилог

В этой статье отображены основные стороны использования и создания библиотек DLL в Borland Delphi. Если у Вас есть вопросы - скидывайте их мне на E-mail: snick@mailru.com




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


Содержание

  • Понятие DLL
  • Создание DLL в Delphi (экспорт)
  • Использование DLL в Delphi (импорт)
  • DLL, использующие объекты VCL для работы с данными
  • Исключительные ситуации в DLL
  • Понятие DLL

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

Программа1 Программа2 : : MyFunc(:) MyFunc(:) : : код функции MyFunc код функции MyFunc код других функций код других функций

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

Но, чем же отличаются Dynamic Link Library (DLL) от обычных приложений? Для понимания этого требуется уточнить понятия задачи (task), экземпляра (копии) приложения (instance) и модуля (module).

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

DLL - библиотека также является модулем. Она находится в памяти в единственном экземпляре и содержит сегмент кода и ресурсы, а также сегмент данных (см. рис. 4).

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

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

Часто, в виде DLL создаются отдельные наборы функций, объединенные по тем или иным логическим признакам, аналогично тому, как концептуально происходит планирование модулей ( в смысле unit ) в Pascal. Отличие заключается в том, что функции из модулей Pascal компонуются статически - на этапе линковки, а функции из DLL компонуются динамически, то есть в run-time.

Создание DLL в Delphi (экспорт)

Для программирования DLL Delphi предоставляет ряд ключевых слов и правил синтаксиса. Главное - DLL в Delphi такой же проект как и программа.

Рассмотрим шаблон DLL:


 library MyDll;
 uses
   <используемые модули>
 
   <объявления и описания функций>
 exports
   <экспортируемые функции>
 begin
   <инициализационная часть>
 end.
 

Имя файла проекта для такого шаблона должно быть MYDLL.DPR.

К сожалению, в IDE Delphi автоматически генерируется только проект программы, поэтому Вам придется проект DLL готовить вручную. В Delphi 2.0 это неудобство устранено.

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

Экспортирование функций (и процедур ) может производится несколькими способами:

  • по номеру (индексу)
  • по имени

В зависимости от этого используется различный синтаксис:


 {экспорт по индексу}
 procedure ExportByOrdinal; export;
 begin
   ...
 end;
 
 exports
   ExportByOrdinal index 10;
 
 {экспорт по имени}
 procedure ExportByName; export;
 begin
   ...
 end;
 
 { имя для экспорта может не совпадать с именем функции ! }
 exports
   ExportByName name 'MYEXPORTPROC';
 

Так как в Windows существует понятие "резидентных функций" DLL, то есть тех функций, которые находятся в памяти на протяжении всего времени существования DLL в памяти, в Delphi имеются средства для организации и такого рода экспорта:


 exports
   ExportByName name 'MYEXPORTPROC' resident;
 

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

Если же Вы будете экспортировать функции следующим образом:


 exports
 MyExportFunc1,
 MyExportFunc2,
 ... ;
 

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

Использование DLL в Delphi (импорт)

Для организации импорта, т.е. доступа к функциям, экспортируемым из DLL, так же как и для их экспорта, Delphi предоставляет стандартные средства.

Для показанных выше примеров, в Вашей программе следует объявить функции, импортируемые из DLL таким образом:


 { импорт по специфицированному имени }
 procedure ImportByName;external 'MYDLL' name 'MYEXPORTPROC';
 { импорт по индексу }
 procedure ImportByOrdinal; external 'MYDLL' index 10;
 { импорт по оригинальному имени }
 procedure MyExportFunc1; external 'MYDLL';
 

Этот способ называется статическим импортом.

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

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


 uses
   WinTypes, WinProcs, ... ;
 
 type
   TMyProc = procedure ;
 
 var
   Handle: THandle;
   MyImportProc: TMyProc;
 
 begin
   Handle := LoadLibrary('MYDLL');
   if Handle >= 32 then { if <=32 - error ! }
   begin
     @MyImportProc := GetProcAddress(Handle, 'MYEXPORTPROC');
     if MyImportProc <> nil then
       ... {using imported procedure}
   end;
   FreeLibrary(Handle);
 end;
 

Синтаксические диаграммы объявлений экспорта/импорта, подмена точки выхода из DLL, и другие примеры, Вы можете найти в OnLine Help Delphi, Object Pascal Language Guide, входящему в Borland RAD Pack for Delphi, и, например, в книге "Teach Yourself Delphi in 21 Days".

Если не говорить о генерируемом компилятором коде (сейчас он более оптимизирован), то все правила синтаксиса остались те же , что и в Borland Pascal 7.0

DLL, использующие объекты VCL для работы с данными

При создании своей динамической библиотеки Вы можете использовать вызовы функций из других DLL. Пример такой DLL есть в поставке Delphi (X:\DELPHI\DEMOS\BD\BDEDLL). В эту DLL помещена форма, отображающая данные из таблицы и использующая для доступа к ней объекты VCL (TTable, TDBGrid, TSession), которые, в свою очередь, вызывают функции BDE. Как следует из комментариев к этому примеру, для такой DLL имеется ограничение: ее не могут одновременно использовать несколько задач. Это вызвано тем, что объект Session, который создается автоматически при подключении модуля DB, инициализируется для модуля, а не для задачи. Если попытаться загрузить эту DLL вторично из другого приложения, то возникнет ошибка. Для предотвращения одновременной загрузки DLL несколькими задачами нужно осуществить некоторые действия. В примере - это процедура проверки того, используется ли DLL в данный момент другой задачей.

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

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

Код в DLL:


 function MyFunc: string;
 begin
   try
     {собственно код функции}
   except
     on EResult: Exception do
       Result:=Format(DllErrorViewingTable, [EResult.message])
     else
       Result := Format(DllErrorViewingTable, ['Unknown error']);
   end;
 end;
 

Код в программе:


 StrResult := MyFunc;
 if StrResult <> '' then
   raise Exception.Create(StrResult);
 




Список зависимых файлов

Используйте утилиту tdump, включенную в поставку delphi:

  tdump -eiNAM xyz.exe >tempfile
Эта команда просканирует файл xyz.exe c параметром MODULE NAME TABLE (таблица имен модулей) и запишет результат в Файла tempfile.

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

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




UUE кодирование

Автор: Sergei Dubarev

Для того, чтобы ОНО заработало, необходимо создать проект в составе:

  1. Форма (form) - 1 шт.
  2. Поле ввода (edit) - 2 шт., используются события OnDblClick.
  3. Кнопка (button) - 1 шт., используется событие OnClick.
  4. Диалог открытия файла (Open Dialog) - 1 шт.
  5. Диалог сохранения файла (Save Dialog) - 1 шт.
Имена файлов будут вводится либо вручную, либо из диалога (double-click на поле ввода edit), причем в edit1.text должно лежать имя входного файла, в edit2.text - выходного. По нажатии кнопки пойдет процесс, который завершится сообщением "DONE."

Всего хорошего.

P. S. Функция toanysys обнаружена в книге "Для чего нужны и как работают персональные ЭВМ" от 1990 г. Там она присутствует в виде программы на BASIC'e.

P.P.S. Для стимулирования фантазии читателей "Советов..." высылаю так же мессагу из эхи, на основе которой я сваял свое чудо.

Файл Unit1.pas


 //UUE кодирование
 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   ExtDlgs, StdCtrls;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     Edit1: TEdit;
     Edit2: TEdit;
     OpenDialog1: TOpenDialog;
     SaveDialog1: TSaveDialog;
     procedure Edit1DblClick(Sender: TObject);
     procedure Edit2DblClick(Sender: TObject);
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 const
 
   ssz = (High(Cardinal) - $F) div sizeof(byte);
   //эта константа используется при выделении памяти
 
   p: string = '0123456789ABCDEF';
   //эта константа используется функцией toanysys
 
   //выбор входного файла
 
 procedure TForm1.Edit1DblClick(Sender: TObject);
 begin
 
   if opendialog1.execute then
     edit1.text := opendialog1.filename;
 end;
 
 //выбор выходного (UUE) файла
 
 procedure TForm1.Edit2DblClick(Sender: TObject);
 begin
 
   if savedialog1.execute then
     edit2.text := savedialog1.filename;
 end;
 
 //выделение подстроки
 
 function mid(s: string; fromc, toc: byte): string;
 var
   s1: string;
 
   i: byte;
 begin
 
   s1 := '';
   for i := fromc to toc do
     s1 := s1 + s[i];
   mid := s1;
 end;
 
 //перевод числа (a) из десятичной системы в другую
 //с основанием (r)
 
 function toanysys(a, r: byte): string;
 var
   s,
 
   k: string;
   n,
     m,
     i: byte;
 begin
 
   s := '';
   m := 1;
   while m <> 0 do
   begin
     m := a div r;
     n := a - m * r + 1;
     k := p[n];
     s := k + s;
     a := m;
   end;
   //добавляет незначащие нули
   for i := 1 to 8 - length(s) do
     s := '0' + s;
   toanysys := s;
 end;
 
 //перевод 6-разрядного числа из двоичной системы в десятичную
 //двоичное число подставляется в виде строки символов
 
 function frombin(s: string): byte;
 var
   i,
 
   e,
     b: byte;
 begin
 
   b := 0;
   for i := 1 to 6 do
   begin
     e := 1 shl (6 - i);
     if s[i] = '1' then
       b := b + e;
   end;
   frombin := b;
 end;
 
 //непосредственно кодирование
 type
   tcoola = array[1..1] of byte;
   pcoola = ^tcoola;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   inf: file of byte;
 
   ouf: textfile;
   uue: pcoola;
   b: array[1..4] of byte;
   bin,
     t: string;
   szf,
     oum,
     szl,
     szh,
     sxl,
     sxh,
     i,
     j: longint;
 begin
 
 {$I-}
   assignfile(inf, edit1.text); //входной файл
   reset(inf);
   szf := filesize(inf); //
   szh := (szf * 8) div 6; //
   if szf * 8 - szh * 6 = 0 then
     szl := 0
   else
     szl := 1; //
   getmem(uue, szh + szl); //выделение памяти
   oum := 1;
   while not (eof(inf)) do
   begin
     b[1] := 0;
     b[2] := 0;
     b[3] := 0;
     b[4] := 0;
     //чтение должно быть сделано посложнее,
     //дабы избежать "read beyond end of file"
     read(inf, b[1], b[2], b[3]);
     //читаем 3 байта из входного файла
     //и формируем "двоичную" строку
     bin := toanysys(b[1], 2) +
       toanysys(b[2], 2) +
       toanysys(b[3], 2);
     //разбиваем строку на куски по 6 бит и добавляем 32
     t := mid(bin, 19, 24);
     b[4] := frombin(t) + 32;
     t := mid(bin, 13, 18);
     b[3] := frombin(t) + 32;
     t := mid(bin, 07, 12);
     b[2] := frombin(t) + 32;
     t := mid(bin, 01, 06);
     b[1] := frombin(t) + 32;
     //запихиваем полученнные байты во временный массив
     uue[oum] := b[1];
     oum := oum + 1;
     uue[oum] := b[2];
     oum := oum + 1;
     uue[oum] := b[3];
     oum := oum + 1;
     uue[oum] := b[4];
     oum := oum + 1;
   end;
   //входной файл больше не нужен - закрываем его
   closefile(inf);
   //формируем выходной файл
   assignfile(ouf, edit2.text); //выходной файл
   rewrite(ouf);
   oum := 1;
   sxh := (szh + szl) div 60; //число строк в UUE файле
   sxl := (szh + szl) - sxh * 60;
   //заголовок UUE-файла
   writeln(ouf, 'begin 644 ' + extractfilename(edit1.text));
   //записываем строки в файл
   for i := 1 to sxh do
   begin
     write(ouf, 'M');
     // 'M' значит, что в строке 60 символов
     for j := 1 to 60 do
     begin
       write(ouf, chr(uue[oum]));
       oum := oum + 1;
     end;
     writeln(ouf);
   end;
   //записываем последнюю строку, которая
   //обычно короче 60 символов
   sxh := (sxl * 6) div 8;
   write(ouf, chr(sxh + 32));
   for i := 1 to sxl do
   begin
     write(ouf, chr(uue[oum]));
     oum := oum + 1;
   end;
   // "добиваем" строку незначащими символами
   for i := sxl + 1 to 60 do
     write(ouf, '`');
   //записываем последние строки файла
   writeln(ouf);
   writeln(ouf, '`');
   writeln(ouf, 'end');
   closefile(ouf);
   freemem(uue, szh + szl); //освобождаем память
   showmessage('DONE.'); //Готово. Забирайте!
 end;
 
 end.
 

 1) Читаем из исходного хфайла 3 байта.
 2) Разбиваем полyченные 24 бита (8x3=24) на 4 части, т.е. по 6 бит.
 3) Добавляем к каждой части число 32 (десятичн.)
 
 Пpимеp: Имеем тpи числа 234 12 76. Побитово бyдет так -
 
 11101010 00001100 01001100 pазбиваем и полyчаем -
 
  111010  100000  110001  001100 добавляем 32 -
 +100000 +100000 +100000 +100000
  ------  ------  ------  ------
 1011010 1000000 1010001  101100 или в бyквах -
    Z       @       Q       ,
 
 Вот собственно и все. В UUE файле в пеpвой позиции стоит кол-во закодиpованных
 символов + 32. Т.е. вся стpока содеpжит 61 символ. 1 символ идет на кол-во.
 Остается 60 символов _кода_. Если подсчитать, то мы yвидим, что для полyчения
 60
 символов кода необходимо 45 исходных символов. Для полной стpоки в начале стоит
 
 бyква "M", а ее ASCII код = 77. 45+32=77.
 



Проверка дат


 function ValidDate(const S: String): Boolean;
 BEGIN
   Result := True;
   try
     StrToDate(S);
   except
     ON EConvertError DO
       Result := False;
   end;
 END
 




Пример переменного количества параметров


 program VarPar;
 
 { Простая программа, демонстрирующая пример использования переменного
 
 числа параметров заданного типа в Delphi.
 
 Создано в марте 1995, автор Hallvard Vassbotn
 hallvard@falcon.no
 }
 
 uses WinCrt, SysUtils;
 
 { предопределения в System:
 const
 
 vtInteger  = 0;
 vtBoolean  = 1;
 vtChar     = 2;
 vtExtended = 3;
 vtString   = 4;
 vtPointer  = 5;
 vtPChar    = 6;
 vtObject   = 7;
 vtClass    = 8;
 
 type
 TVarRec = record
 case Integer of
 vtInteger:  (VInteger: Longint; VType: Byte);
 vtBoolean:  (VBoolean: Boolean);
 vtChar:     (VChar: Char);
 vtExtended: (VExtended: PExtended);
 vtString:   (VString: PString);
 vtPointer:  (VPointer: Pointer);
 vtPChar:    (VPChar: PChar);
 vtObject:   (VObject: TObject);
 vtClass:    (VClass: TClass);
 end;
 }
 
 const
 
   TypeNames: array[vtInteger..vtClass] of PChar =
   ('Integer', 'Boolean', 'Char', 'Extended', 'String',
     'Pointer', 'PChar', 'Object', 'Class');
 
   {
   Согласно on-line документации (поиск по слову TVarRec), массив параметров
   array of const интерпретируется компилятором подобно массиву array of TVarRec.
   Данный пример будет работать подобно тому, как если бы вы изменили
   объявление TestMultiPar на:
 
   procedure TestMultiPar(const Args: array of TVarRec);
 
   Вы можете сделать реализацию обычного "очистителя" (без объявления
   переменных), но интерфейс был бы менее понятным пользователям данного
   модуля.
 
   Компилятор видит параметры и формирует массив непосредственно в
   стеке. Для каждого элемента массива также устанавливается поле
   VType с одной из предопределенных констант vtXXXX. Фактически
   значение всегда передается в виде четыре байта информации. Для
   типов Boolean и Char полезную информацию содержит только первый
   байт.
 
   Теперь вы можете писать все те же хорошие программы, но вдобавок
   поддерживающие переменное количество параметров с проверкой типов!
   }
 
 function PtrToHex(P: pointer): string;
 begin
 
   Result := IntToHex(Seg(P^), 4) + ':' + IntToHex(Ofs(P^), 4);
 end;
 
 procedure TestMultiPar(const Args: array of const);
 var
 
   ArgsTyped: array[0..$FFF0 div sizeof(TVarRec)] of TVarRec absolute Args;
   i: integer;
 begin
 
   for i := Low(Args) to High(Args) do
     with ArgsTyped[i] do
     begin
       Write('Args[', i, '] : ', TypeNames[VType], ' = ');
       case VType of
         vtInteger: writeln(VInteger);
         vtBoolean: writeln(VBoolean);
         vtChar: writeln(VChar);
         vtExtended: writeln(VExtended^: 0: 4);
         vtString: writeln(VString^);
         vtPointer: writeln(PtrToHex(VPointer));
         vtPChar: writeln(VPChar);
         vtObject: writeln(PtrToHex(Pointer(VObject)));
         vtClass: writeln(PtrToHex(Pointer(VClass)));
       end;
     end;
 end;
 
 var
 
   MyObj: TObject;
 begin
 
   Writeln('Проверка выполнения функции с переменным количеством параметров и проверкой типов:');
   MyObj := TObject.Create;
   TestMultiPar([123, 45.67, PChar('ASCIIZ'), 'Здравствуй, мир!', true, 'X',
     @ShortDayNames, TObject, MyObj]);
   MyObj.Free;
 
   { Для того, чтобы обеспечить предварительную проверку типа при передаче параметров,
   попробуйте следующее: }
   writeln(Format('%d', ['привет']));
   { Переданный параметр не является ожидаемым типом. Строка формата '%d'
   говорит о том, что параметр должен быть целой величиной, но вместо этого мы передаем
   строку. Во время выполнения это вызовет исключительную ситуацию, и если вы не организовали
   ловушку для объектов исключения, то Delphi выведет вам строку с описанием ошибки.
   Использование функции C-типа sprintf в этом случае может привести к непредсказуемым
   последствиям (читай: крах системы, GP и все что угодно) }
 end.
 




Переменное количество параметров любого типа

Автор: Neil

Вы можете определить список параметров процедуры как "Foo : ARRAY of const" и использовать почти ЛЮБОЙ тип параметра. Вот пример. Разместите на форме компоненты Memo и Button и добавьте строку "procedure Display(X : array of const);" в определения класса формы после комментария { Private Declarations }. Создайте функцию типа этой:


 procedure TForm1.Display(X: array of const);
 var
   I: Integer;
 begin
   Memo1.Clear;
   for I := 0 to High(X) do
     with TVarRec(X[I]) do
       with Memo1.Lines do
         case VType of
           vtInteger: Add('Integer:'#9 + IntToStr(VInteger));
           vtBoolean: if VBoolean then
               Add('Boolean:'#9'True'
             else
               Add('Boolean:'#9'False');
           vtChar: Add('Char:'#9 + VChar);
           vtExtended: Add('Float:'#9 + FloatToStr(VExtended^));
           vtString: Add('String:'#9 + VString^);
           vtPointer: Add('Pointer:'#9 + Format('%p', [VPointer]));
           vtPChar: Add('PChar:'#9 + StrPas(VPChar));
           vtObject: Add('Object:'#9 + VObject.ClassName);
           vtClass: Add('Class:'#9 + VClass.ClassName);
         end;
 end;
 

Теперь в обработчике события кнопки OnClick вызываем процедуру Display и передаем ей "что попало". Числа, строки, PChar-ы, объекты! Например:


 Display([42, 1.234, 'A', 'Васек Трубачев', Form1, TButton]);
 

Практичестки это программа с переменным числом параметров. Но самом деле параметр один, но он является массивом, содержащим переменное количество параметров различного типа. Потрясающе!




Пример переменной записи

Автор: Peter Below

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

Файл выглядит примерно так:

TFH.......<First record type, первый тип записи>
TBH.......<Second record type, второй тип записи>
TAB........<Third record type, третий тип записи>
TAA........<Fourth record type, четвертый тип записи>

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


 type
   TDataTag = array[1..3] of Char;
   TDataTags = array[0..NumOfTags - 1] of TDataTag;
   TDataRec = packed record
     tagfield: TDataTag;
     case integer of
       0: (поля для тэга TFH);
       1: (поля для тэга TBH);
       2: ..
       ....
   end;
   TMultiRec = packed record
     case Boolean of
       false: (строка: array[0..1024] of Char);
       { должно установать строку максимально возможной длины }
       true: (data: TDataRec);
   end;
 
 const
   DataTags: TDataTags = ('TFH', 'TBH', ....);
 var
   rec: TMultirec;
 
   ReadLn(datafile, rec.line);
   case IndexFromDataTag(rec.data.tagfield) of
     0: ...
       1: ...
   end;
 

IndexFromDataTag должен искать передаваемый тэг поля в массиве DataTags. Определите все поля в TDataRec как Array [1..someUpperBound] of Char.




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

Более подробно ищите в хелпе Delphi по словам "Variant" и "TVarData"...


 function ToString(Value: Variant): String;
 begin
   case TVarData(Value).VType of
     varSmallInt,
     varInteger   : Result := IntToStr(Value);
     varSingle,
     varDouble,
     varCurrency  : Result := FloatToStr(Value);
     varDate      : Result := FormatDateTime('dd/mm/yyyy', Value);
     varBoolean   : if Value then Result := 'T' else Result := 'F';
     varString    : Result := Value;
     else            Result := '';
   end;
 end;
 

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


 ShowMessage(ToString(10.87));
 ShowMessage(ToString(10));
 

или


 var
   V1 : Double;
   V2 : Integer;
   V3 : TDateTime;
   V4 : Boolean;
 
 begin
   ...
 
   ShowMessage(ToString(V1));  // Double â String
   ShowMessage(ToString(V2));  // Integer â String
   ShowMessage(ToString(V3));  // DateTime â String
   ShowMessage(ToString(V4));  // Boolean â String
 end;
 

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


 varCurrency  : Result := CurrToStrF(Value ,ffFixed,CurrencyDecimals);
 

и


 varDate: Result := DateToStr(Value);
 




Классовые и статические переменные общего доступа

Здесь кроется небольшая хитрость: получение эквивалентной функциональности с помощью классового метода. Просто объявите NodeCount как регулярную типизированную константу в секции implementation вашего файла.


 type
   TNode = class
   public
     NodeCount: Integer = 0; {ЭТО НЕ ДОПУСКАЕТСЯ}
     constructor Create;
     class function GetNodeCount: word;
     {
     другой необходимый код
     }
   end;
 
 implementation
 
 const
   NodeCount: word = 0;
   TNode.Create;
 begin
   inherited Create;
   Inc(NodeCount);
 end;
 
 function TNode.GetNodeCount: word;
 begin
   result := NodeCount;
 end;
 

Итак, теперь ваш код может выглядеть так, как вы хотели:


 SampleNode := TNode.Create;
 x := SampleNode.GetNodeCount;
 

следующая строка также корректна:


 x := TNode.GetNodeCount;
 




Передача переменных форме

Автор: Ed Jordan

...поможете мне создать функцию, с помощью которой я передам переменные в TFormClass? Проблема в том, что MyDlg.Execute() не захотела компилироваться, поскольку, как сообщил мне компилятор, я не могу использовать MyDlg (определенный как: TForm).

Эта функция может выглядеть примерно так:


 function ExecuteDialog( FormClass: TFormClass; var Data ): Boolean;
 

Я могу вам дать еще один совет: сделать все ваши формы наследниками одного класса, в котором объявлены виртуальные методы SetData и GetData.


 { ----------------------- }
 unit ExecFrms;
 interface
 uses Forms, Controls;
 type
   TExecForm = class(TForm)
   public
     procedure GetData(var Data); virtual; abstract;
     procedure SetData(var Data); virtual; abstract;
   end;
   TExecFormClass = class of TExecForm;
 
 function ExecuteDialog(FormClass: TExecFormClass;
   var Data): Boolean;
 
 implementation
 
 function ExecuteDialog(FormClass: TExecFormClass;
   var Data): Boolean;
 begin
   with FormClass.Create(Application) do
   try
     SetData(Data);
     Result := ShowModal = mrOK;
     if Result then
       GetData(Data);
   finally
     Release;
   end;
 end;
 
 end.
 { ----------------------- }
 

Как вы можете видеть, я поместил функцию ExecuteDialog в тот же самый модуль.

После того как Delphi создаст форму, вы должны в модуле формы сделать четыре вещи:

  1. вручную измените предка формы, с TForm на TExecForm;
  2. добавьте ExecFrms в список используемых модулей;
  3. добавьте тип записи для хранения данных, необходимых диалогу; и
  4. перекрыть методы SetData и GetData.

 { ----------------------- }
 unit MyDlgs;
 interface
 uses WinTypes, WinProcs, Classes, Graphics, Forms,
   Controls, Buttons, StdCtrls, Spin, ExtCtrls,
   ExecFrms;
 
 type
   { Запись для данных, необходимых модальной форме... }
   TMyDlgData = record
     FormCaption: string;
     FormWidth: Integer;
   end;
 
   TMyDlg = class(TExecForm)
     OKBtn: TBitBtn;
     CancelBtn: TBitBtn;
     HelpBtn: TBitBtn;
     Bevel1: TBevel;
     Edit1: TEdit;
     SpinEdit1: TSpinEdit;
   public
     procedure SetData(var Data); override;
     procedure GetData(var Data); override;
   end;
 
 var
   MyDlg: TMyDlg;
 
 implementation
 
 {$R *.DFM}
 
 procedure TMyDlg.SetData(var Data);
 begin
   with TMyDlgData(Data) do
   begin
     Edit1.Text := FormCaption;
     SpinEdit1.Value := FormWidth;
   end;
 end;
 
 procedure TMyDlg.GetData(var Data);
 begin
   with TMyDlgData(Data) do
   begin
     FormCaption := Edit1.Text;
     FormWidth := SpinEdit1.Value;
   end;
 end;
 
 end.
 { ----------------------- }
 

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


 { Добавьте ExecFrms и MyDlgs в список USES вызывающего модуля. }
 
 procedure TForm1.GetNewCaptionAndWidthBtnClick(Sender: TObject);
 var
   Data: TMyDlgData;
 begin
   Data.FormCaption := Caption;
   Data.FormWidth := Width;
   if ExecuteDialog(TMyDlg, Data) then
   begin
     Caption := Data.FormCaption;
     Width := Data.FormWidth;
   end;
 end;
 

Не поверите: данный код работает еще со времён Turbo Vision!




Как преобразовать строку в дату

Функция StrToDate преобразует только числа, поэтому, если у Вас месяцы в виде имён, то прийдётся использовать VarToDateTime.


 var
   D1, D2, D3 : TDateTime;
 begin
   D1 := VarToDateTime('December 6, 1969');
   D2 := VarToDateTime('6-Apr-1998');
   D3 := VarToDateTime('1998-Apr-6');
   ShowMessage(DateToStr(D1)+' '+DateToStr(D2)+' '+DateToStr(D3));
 end;
 




Как сообщить какую-то глобальную переменную всем окнам программы (даже скрытым)

Автор: Олег Кулабухов

Решением для такой задачи является рассылка пользовательского сообщения всем окнам массива Screen.Forms


 {Code for Unit1}
 
 const
   UM_MyGlobalMessage = WM_USER + 1;
 
 type
   TForm1 = class(TForm)
     Label1: TLabel;
     Button1: TButton;
     procedure FormShow(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     { Private declarations }
   private
     procedure UMMyGlobalMessage(var AMessage: TMessage); message
       UM_MyGlobalMessage;
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 uses Unit2;
 
 procedure TForm1.FormShow(Sender: TObject);
 begin
   Form2.Show;
 end;
 
 procedure TForm1.UMMyGlobalMessage(var AMessage: TMessage);
 begin
   Label1.Left := AMessage.WParam;
   Label1.Top := AMessage.LParam;
   Form1.Caption := 'Got It!';
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   f: integer;
 begin
   for f := 0 to Screen.FormCount - 1 do
     Screen.Forms[f].Perform(UM_MyGlobalMessage, 42, 42);
 end;
 
 {Code for Unit2}
 
 const
   UM_MyGlobalMessage = WM_USER + 1;
 
 type
   TForm2 = class(TForm)
     Label1: TLabel;
   private
     { Private declarations }
     procedure UMMyGlobalMessage(var AMessage: TMessage); message
       UM_MyGlobalMessage;
   public
     { Public declarations }
   end;
 
 var
   Form2: TForm2;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm2.UMMyGlobalMessage(var AMessage: TMessage);
 begin
   Label1.Left := AMessage.WParam;
   Label1.Top := AMessage.LParam;
   Form2.Caption := 'Got It!';
 end;
 




VBX в приложениях DELPHI - как распространять

Чтобы использовать любые элементы управления VBX с компилированным Delphi EXE-файлом, вам необходимо распространить BIVBX11.DLL (расположен в каталоге \WINDOWS\SYSTEM - Borland при установке копирует его туда).




Использование контекстного меню с VBX

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

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

Как мне перехватить это?

Например, так:


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

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




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

Автор: Nomadic

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

Старо как мир, и нет ничего военного:


 procedure RefreshQuery(Query: TQuery; F: boolean);
 var
   B: TBookMark;
 begin
   with Query do
     if Query.Active then
     begin
       B := GetBookMark;
       try
         Close;
         Unprepare;
         {Если не поставить этого, то если используется select
         SP, то иногда последующая операция вешает сервер.
         Кто скажет почему?!}
         Active := True;
         if F then
         begin
           try
             GotoBookMark(B)
           except
             on EDatabaseError do
               First;
           end
         end
         else
           First;
       finally
         FreeBookmark(B);
       end;
     end;
 end;
 

Уфф! Кажется, лyчше yже не сделать. :)

dbtables можно опционально пpопатчить (см. в конце), чтобы иметь такой вот pyлезный Detail query.

Update for dbtables.pas

New interface function DoRefreshQuery can Refresh TQuery component in master-detail scheme and alone.

TQuery.RefreshParams should be updated


 function GetFieldNamesStr(DataSet: TDataSet): string;
 var
   I: Integer;
 begin
   Result := '';
   with DataSet do
     for I := 0 to FieldCount - 1 do
     begin
       Result := Result + Fields[I].FieldName + ';';
     end;
 end;
 
 procedure DoRefreshQuery(Query: TQuery; KeyFields: string; BookMarkSearch:
   Boolean);
 var
   Fields: TList;
   KeyValues: Variant;
   KeyNames: string;
   Bmk: TBookmark;
   I: Integer;
   BookmarkFound: Boolean;
   CanLocate: Boolean;
 begin
   Fields := TList.Create;
   if KeyFields = '' then
     KeyFields := GetFieldNamesStr(Query);
   try
     Query.GetFieldList(Fields, KeyFields);
     for I := Fields.Count - 1 downto 0 do
       with TField(Fields[I]) do
         if Calculated or Lookup then
           Fields.Delete(I);
     CanLocate := Fields.Count > 0;
     if CanLocate then
     begin
       if Fields.Count = 1 then
         KeyValues := TField(Fields[0]).Value
       else
       begin
         KeyValues := VarArrayCreate([0, Fields.Count - 1], varVariant);
         KeyValues[0] := TField(Fields[0]).Value;
       end;
       KeyNames := TField(Fields[0]).FieldName;
       for I := 1 to Fields.Count - 1 do
       begin
         KeyNames := KeyNames + ';' + TField(Fields[I]).FieldName;
         KeyValues[I] := TField(Fields[I]).Value;
       end;
     end;
   finally
     Fields.Free;
   end;
   with Query do
   begin
     Bmk := nil;
     DisableControls;
     try
       BookmarkFound := False;
       if BookMarkSearch then
         Bmk := GetBookmark;
       Close;
       Open;
       if Assigned(Bmk) then
       try
         GotoBookMark(Bmk);
         BookmarkFound := True;
       except
       end;
       if not BookmarkFound and CanLocate then
         Locate(KeyNames, KeyValues, []);
     finally
       EnableControls;
       Screen.Cursor := crDefault;
       FreeBookmark(Bmk);
     end;
   end;
 end;
 
 procedure TQuery.RefreshParams;
 var
   DataSet: TDataSet;
 begin
   DisableControls;
   try
     if FDataLink.DataSource <> nil then
     begin
       DataSet := FDataLink.DataSource.DataSet;
       if DataSet <> nil then
         if DataSet.Active and (DataSet.State <> dsSetKey) then
           DoRefreshQuery(Self, GetFieldNamesStr(Self), False);
     end;
   finally
     EnableControls;
   end;
 end;
 




Основы 3D математики - Векторные и матричные преобразования

Векторы

Вектор - направленный отрезок, имеющий направление и длину. Векторы обозначаются так: a = (x,y,z), например, b = (0,1,-2). Еще одно представление вектора : AB = (x,y,z).


 AB = (x,y,z) = (bx-ax,by-ay,bz-az),
 

где A и B - 2 точки, A(ax,ay,az) и B(bx,by,bz), A - начало вектора, B - конец вектора.

Длина вектора

Длина вектора, |a|, считается так:


 |a| = sqrt(ax2+ay2+az2).
 

Сложение векторов.


 a + b = c;
 a + b = (ax + bx, ay + by, az + bz).
 

т. е. как результат мы получаем вектор.

Вычитание векторов.


 c - a = b;
 c - a = (cx - ax, cy - ay, cz - az).
 

как результат - также мы получаем вектор.

Cкалярное произведение векторов.(dot)

Скалярное произведение 2х векторов - произведение длин 2х векторов на cos угла между ними. Скалярное произведение векторов - это длина проекции вектора a на вектор b.


 a . b = |a| |b| cos ?;
 

или


 a . b = axbx + ayby + azbz;
 

Следствие: ? - угол между двумя векторами: cos ? = a . b / (|a| |b|);

Проекция одного вектора на другой.

Для того, чтобы вычислить проекцию вектора b на вектор а требуется просто произвести скалярное умножение этих векторов, а затем получить произведение получившегося результата на вектор b. Обозначим искомый вектор как c. тогда:


 c = (a . b) b;
 

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

Умножение вектора на вектор.(cross)

Умножая вектор a на вектор b, мы получим вектор, перпендикулярный плоскости, которую определяют вектора a и b.


 a x b = ( aybz - byaz , azbx - bzax , axby - bxay );
 

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

Матрицы

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

скалярное произведение векторов:


 [ a ] [ d ]
 [ b ] * [ f ] = a*d + b*f + c*g
 [ c ] [ g ]
 

Векторное произведение:


 [ a ] [ d ] [ b*f - c*e ]
 AxB = [ b ] x [ e ] = [ c*d - a*f ]
 [ c ] [ f ] [ a*e - b*d ]
 

Сложение матриц:


 [ 1 2 3 ] [ 10 11 12 ] [ 1+10 2+11 3+12 ]
 [ 4 5 6 ] + [ 13 14 15 ] = [ 4+13 5+14 6+15 ]
 [ 7 8 9 ] [ 16 17 18 ] [ 7+16 8+17 9+18 ]
 

Умножение матриц:


 [ 1 2 3 ] [ 10 11 12 ] [ 1*10+2*13+3*16 1*11+2*14+3*17 1*12+2*15+3*18 ]
 [ 4 5 6 ] * [ 13 14 15 ] = [ 4*10+5*13+6*16 4*11+5*14+6*17 4*12+5*15+6*18 ]
 [ 7 8 9 ] [ 16 17 18 ] [ 7*10+8*13+9*16 7*11+8*14+9*17 7*12+8*15+9*18 ]
 

Очень важным является тот факт, что (A*B)*С = A*(B*C)

Векторные и матричные преобразования

Параллельный перенос:

Переносим точку (x,y,z) на вектор (dx,dy,dz), в результате получим точку с координатами (x+dx, y+dy, z+dz);

Поворот:

Поворачиваем точку (x,y) на угол ? :


 x' = x cos ? - y*sin ?
 y' = x sin ? + y*cos ?
 

для трехмерного случая - аналогично для каждой плоскости.

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

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

матрица параллельного переноса:


 [ 1 0 0 0 ]
 [ 0 1 0 0 ]
 [ 0 0 1 0 ]
 [ x y z 1 ]
 

матрица растяжения/сжатия:


 [ z 0 0 0 ]
 [ 0 y 0 0 ]
 [ 0 0 x 0 ]
 [ 0 0 0 1 ]
 

матрица поворота вокруг оси x:


 [ 0 0 0 0 ]
 [ 0 cos ? sin ? 0 ]
 [ 0 -sin ? cos ? 0 ]
 [ 0 0 0 1 ]
 

матрица поворота вокруг оси y:


 [ cos ? 0 -sin ? 0 ]
 [ 0 1 0 0 ]
 [ sin ? 0 cos ? 0 ]
 [ 0 0 0 1 ]
 

матрица поворота вокруг оси z:


 [ cos ? sin ? 0 0 ]
 [-sin ? cos ? 0 0 ]
 [ 0 0 1 0 ]
 [ 0 0 0 1 ]
 

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

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


 (A*B)*C = A*(B*C)
 

для матриц.. а нам требуется провести такие преобразования: a*A*B*C*D, где - а-точка-вектор, над которым требуется произвести действия, а A,B,C,D - матрицы переноса и поворотов. Мы вполне можем не последовательно умножать точку-вектор a на матрицы переносов, а сначала перемножить эти матрицы, а затем просто умножать получившуюся матрицу на каждую точку, которую требуется сместить - перемножение 4х матриц, а затем умножение 1 вектора на 1 матрицу на каждую точку по сравнению с подвержением каждой точки векторным преобразованиям - весьма и весьма значительное сокращение производимых операций.




Как вытащить VersionInfo из свойств проекта


 function CurrentFileInfo(NameApp: string): string;
 var
   dump: DWORD;
   size: integer;
   buffer: PChar;
   VersionPointer, TransBuffer: PChar;
   Temp: integer;
   CalcLangCharSet: string;
 begin
   size := GetFileVersionInfoSize(PChar(NameApp), dump);
   buffer := StrAlloc(size+1);
   try
     GetFileVersionInfo(PChar(NameApp), 0, size, buffer);
 
     VerQueryValue(buffer, '\VarFileInfo\Translation', pointer(TransBuffer),
     dump);
     if dump >= 4 then
     begin
       temp:=0;
       StrLCopy(@temp, TransBuffer, 2);
       CalcLangCharSet:=IntToHex(temp, 4);
       StrLCopy(@temp, TransBuffer+2, 2);
       CalcLangCharSet := CalcLangCharSet+IntToHex(temp, 4);
     end;
 
     VerQueryValue(buffer, pchar('\StringFileInfo\'+CalcLangCharSet+
     '\'+'FileVersion'), pointer(VersionPointer), dump);
     if (dump > 1) then
     begin
       SetLength(Result, dump);
       StrLCopy(Pchar(Result), VersionPointer, dump);
     end
     else
       Result := '0.0.0.0';
   finally
     StrDispose(Buffer);
   end;
 end;
 




Информация о версии (Version Info) в Delphi EXE


 unit rpVersionInfo; //версия 1.0 3/8/98 записана и проверена в Delphi 3.
 (*Автор Rick Peterson, данный компонент распространяется свободно
 
 и освобожден от платы за использование. В случае изменения
 авторского кода просьба прислать измененный код. Сообщайте пожалуйста
 обо всех найденных ошибках. Адрес для писем - rickpet@airmail.net. *)
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   TypInfo;
 
 type
 {$M+}
   (* Видели директиву $M+??? Это заставляет Delphi включать в код RTTI-информацию для
 
   перечислимых типов. В основном допускает работу с перечислимыми типами как
   со строками с помощью GetEnumName *)
   TVersionType = (vtCompanyName, vtFileDescription, vtFileVersion,
     vtInternalName,
     vtLegalCopyright, vtLegalTradeMark, vtOriginalFileName,
     vtProductName, vtProductVersion, vtComments);
 {$M-}
 
   TrpVersionInfo = class(TComponent)
     (* Данный компонент позволяет получать информацию о версии вашего приложения
 
     во время его выполенния *)
   private
     FVersionInfo: array[0..ord(high(TVersionType))] of string;
   protected
     function GetCompanyName: string;
     function GetFileDescription: string;
     function GetFileVersion: string;
     function GetInternalName: string;
     function GetLegalCopyright: string;
     function GetLegalTradeMark: string;
     function GetOriginalFileName: string;
     function GetProductName: string;
     function GetProductVersion: string;
     function GetComments: string;
     function GetVersionInfo(VersionType: TVersionType): string; virtual;
     procedure SetVersionInfo; virtual;
   public
     constructor Create(AOwner: TComponent); override;
   published
     (* Использовать это очень просто - Label1.Caption := VersionInfo1.FileVersion
 
     Примечание: Все свойства - только для чтения, поэтому они недоступны в
     Инспекторе Объектов *)
     property CompanyName: string read GetCompanyName;
     property FileDescription: string read GetFileDescription;
     property FileVersion: string read GetFileVersion;
     property InternalName: string read GetInternalName;
     property LegalCopyright: string read GetLegalCopyright;
     property LegalTradeMark: string read GetLegalTradeMark;
     property OriginalFileName: string read GetOriginalFileName;
     property ProductName: string read GetProductName;
     property ProductVersion: string read GetProductVersion;
     property Comments: string read GetComments;
   end;
 
 procedure Register;
 
 implementation
 
 constructor TrpVersionInfo.Create(AOwner: TComponent);
 begin
 
   inherited Create(AOwner);
   SetVersionInfo;
 end;
 
 function TrpVersionInfo.GetCompanyName: string;
 begin
 
   result := GeTVersionInfo(vtCompanyName);
 end;
 
 function TrpVersionInfo.GetFileDescription: string;
 begin
 
   result := GeTVersionInfo(vtFileDescription);
 end;
 
 function TrpVersionInfo.GetFileVersion: string;
 begin
 
   result := GeTVersionInfo(vtFileVersion);
 end;
 
 function TrpVersionInfo.GetInternalName: string;
 begin
 
   result := GeTVersionInfo(vtInternalName);
 end;
 
 function TrpVersionInfo.GetLegalCopyright: string;
 begin
 
   result := GeTVersionInfo(vtLegalCopyright);
 end;
 
 function TrpVersionInfo.GetLegalTradeMark: string;
 begin
 
   result := GeTVersionInfo(vtLegalTradeMark);
 end;
 
 function TrpVersionInfo.GetOriginalFileName: string;
 begin
   result := GeTVersionInfo(vtOriginalFileName);
 end;
 
 function TrpVersionInfo.GetProductName: string;
 begin
   result := GeTVersionInfo(vtProductName);
 end;
 
 function TrpVersionInfo.GetProductVersion: string;
 begin
   result := GeTVersionInfo(vtProductVersion);
 end;
 
 function TrpVersionInfo.GetComments: string;
 begin
   result := GeTVersionInfo(vtComments);
 end;
 
 function TrpVersionInfo.GeTVersionInfo(VersionType: TVersionType): string;
 begin
   result := FVersionInfo[ord(VersionType)];
 end;
 
 procedure TrpVersionInfo.SeTVersionInfo;
 var
   sAppName, sVersionType: string;
   iAppSize, iLenOfValue, i: integer;
   pcBuf, pcValue: PChar;
 begin
   sAppName := Application.ExeName;
   iAppSize := GetFileVersionInfoSize(PChar(sAppName), iAppSize);
   if iAppSize > 0 then
   begin
     pcBuf := AllocMem(iAppSize);
     GetFileVersionInfo(PChar(sAppName), 0, iAppSize, pcBuf);
     for i := 0 to Ord(High(TVersionType)) do
     begin
       sVersionType := GetEnumName(TypeInfo(TVersionType), i);
       sVersionType := Copy(sVersionType, 3, length(sVersionType));
       if VerQueryValue(pcBuf, PChar('StringFileInfo\040904E4\' +
         sVersionType), Pointer(pcValue), iLenOfValue) then
         FVersionInfo[i] := pcValue;
     end;
     FreeMem(pcBuf, iAppSize);
   end;
 end;
 
 procedure Register;
 begin
   RegisterComponents('FreeWare', [TrpVersionInfo]);
 end;
 
 end.
 




Вертикальный текст


 var
   Hfont: Thandle;
   logfont: TLogFont;
   font: Thandle;
   count: integer;
 begin
   LogFont.lfheight := 30;
   logfont.lfwidth := 10;
   logfont.lfweight := 900;
   LogFont.lfEscapement := -200;
   logfont.lfcharset := 1;
   logfont.lfoutprecision := out_tt_precis;
   logfont.lfquality := draft_quality;
   logfont.lfpitchandfamily := FF_Modern;
   font := createfontindirect(logfont);
   Selectobject(Form1.canvas.handle, font);
   SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
   SetBKmode(Form1.canvas.handle, transparent);
   {textout(form1.canvas.handle,10,10,'Повернутый',7);}
   for count := 1 to 100 do
   begin
     canvas.textout(Random(form1.width), Random(form1.height), 'Повернутый');
     SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255),
       Random(255)));
   end;
   deleteobject(font);
 end;
 




Функции VER.DLL

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


 procedure TAboutBox.FormCreate(Sender: TObject);
 var
   VIHandle: LongInt;
   VSize: LongInt;
   VData: Pointer;
   VVers: Pointer;
   Len: Word;
   FileName: string;
 
 const
   { Предустановленный набор символов U.S., если я правильно помню }
   Prefix = '\StringFileInfo\040904E4\';
 
   function GetVerValue(Value: string): string;
   var
     ItemName: string;
   begin
     ItemName := Prefix + Value + chr(0);
     Result := '';
     if VerQueryValue(VData, @ItemName[1], VVers, Len) then
       if Len > 0 then
       begin
         if Len > 255 then
           Len := 255; { "Обрезаем" любые длинные строки }
         Move(VVers^, Result[1], Len);
         Result[0] := Chr(Len);
       end;
   end;
 
 begin
   FileName := Application.EXEName + chr(0);
   VSize := GetFileVersionInfoSize(@FileName[1], VIHandle);
   if VIHandle <> 0 then
   begin
     GetMem(VData, VSize);
     try
       if GetFileVersionInfo(@FileName[1], VIHandle, VSize, VData) then
       begin
         { В этом месте мы получаем значения из блока StringFileInfo,
         но точно также мы могли бы взять значения из корневого блока,
         используя VerQueryValue }
 
         ProductName.Caption := GetVerValue('ProductName');
         Version.Caption := GetVerValue('ProductVersion');
         Copyright.Caption := GetVerValue('LegalCopyright');
         Comments.Caption := GetVerValue('FileDescription');
       end;
     finally
       FreeMem(VData, VSize);
     end;
   end;
 end;
 




Коды виртуальных клавиш

Надпись на мониторе: Для продолжения нажмите все клавиши сразу.


 vk_LButton   = $01;
 vk_RButton   = $02;
 vk_Cancel    = $03;
 vk_MButton   = $04;   { генерятся только системой вместе с L & RBUTTON }
 vk_Back      = $08;
 vk_Tab       = $09;
 vk_Clear     = $0C;
 vk_Return    = $0D;
 vk_Shift     = $10;
 vk_Control   = $11;
 vk_Menu      = $12;
 vk_Pause     = $13;
 vk_Capital   = $14;
 vk_Escape    = $1B;
 vk_Space     = $20;
 vk_Prior     = $21;
 vk_Next      = $22;
 
 
 vk_End       = $23;
 vk_Home      = $24;
 vk_Left      = $25;
 vk_Up        = $26;
 vk_Right     = $27;
 vk_Down      = $28;
 vk_Select    = $29;
 vk_Print     = $2A;
 vk_Execute   = $2B;
 vk_SnapShot  = $2C;
 { vk_Copy      = $2C не используется клавиатурой }
 
 vk_Insert    = $2D;
 vk_Delete    = $2E;
 vk_Help      = $2F;
 { vk_A - vk_Z такие же, как и их ASCII-эквиваленты: 'A' - 'Z' }
 { vk_0 - vk_9 такие же, как и их ASCII-эквиваленты: '0' - '9' }
 
 
 vk_NumPad0   = $60;
 vk_NumPad1   = $61;
 vk_NumPad2   = $62;
 vk_NumPad3   = $63;
 vk_NumPad4   = $64;
 vk_NumPad5   = $65;
 vk_NumPad6   = $66;
 vk_NumPad7   = $67;
 vk_NumPad8   = $68;
 vk_NumPad9   = $69;
 vk_Multiply  = $6A;
 vk_Add       = $6B;
 vk_Separator = $6C;
 vk_Subtract  = $6D;
 vk_Decimal   = $6E;
 vk_Divide    = $6F;
 vk_F1        = $70;
 vk_F2        = $71;
 vk_F3        = $72;
 vk_F4        = $73;
 vk_F5        = $74;
 
 
 vk_F6        = $75;
 vk_F7        = $76;
 vk_F8        = $77;
 vk_F9        = $78;
 vk_F10       = $79;
 vk_F11       = $7A;
 vk_F12       = $7B;
 vk_F13       = $7C;
 vk_F14       = $7D;
 vk_F15       = $7E;
 vk_F16       = $7F;
 vk_F17       = $80;
 vk_F18       = $81;
 vk_F19       = $82;
 vk_F20       = $83;
 vk_F21       = $84;
 vk_F22       = $85;
 vk_F23       = $86;
 vk_F24       = $87;
 vk_NumLock   = $90;
 vk_Scroll    = $91;
 




Virtual ListView с контекстным меню

Два программера разговаривают:
- Вася - ты каких любишь...?
- Нуу - которые 800х600...
- А я 1024х768 - они покрупней - обхватишь, так, прижмёшь.... - здорово (мечтательно, закрыв глаза и пуская, слюни).

В Delphi5/Demos есть пример Virtual ListView. программка чем-то напоминает explorer, но без контекстного меню. контекстное меню приделывается так:


 procedure TForm1.PopupMenu1Popup(Sender: TObject);
 var
   ContextMenu : IContextMenu;
   menu : HMENU;
 begin
   FIShellFolder.GetUIObjectOf(Handle, 1,
   ShellItem(ListView.Selected.index).ID,
   IID_IContextMenu, nil, ContextMenu);
   menu := CreatePopupMenu();
   ContextMenu.QueryContextMenu(menu, 0, 1, $7FFF, CMF_EXPLORE);
   TrackPopupMenu(menu,
   TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD,
   Mouse.CursorPos.x, Mouse.CursorPos.y, 0, Handle, nil);
   DestroyMenu(menu);
 end;
 




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



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



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


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