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

ВИДЕОКУРС ВЗЛОМ
выпущен 2 июля!


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

БОЛЬШОЙ FAQ ПО DELPHI



DirectX (Игровой SDK) 1-2

Автор: Стас Бакулин

Сидит как то программер, налаживает свою пятилетнюю работу, облoжился справочниками, доками, FAQ-ами.....неделю сидит - ни фига не получается. Мужик уже похудел весь, зарос щетиной... Входит в комнату его мама и говорит ему (с горечью в голосе):
- Hу... все играешь?

Модель компонентных объектов (СОМ)

Перед углублением и изнурительные подробности DirectDraw сначала несколько слов о модели компонентных объектов - кратко СОМ. Delphi использует объектно-ориентированный язык программирования Object Pascal. Дизайнеры Delphi решили сделать родные Delphi объекты полностью совместимыми с СОМ и OLE. Это большая новость для нас, потому что DirectDraw использует интерфейс СОМ и поэтому из Delphi получить к нему доступ достаточно просто.

Объекты СОМ подробно освещены в разделе Delphi. Но для того, чтобы сэкономить ваше время, предоставлю краткий обзор. В Delphi вы работаете с объектом СОМ практически так же, как и с другим объектом. Объекты СОМ выглядят по сути как обычные объекты Delphi. Они имеют методы, которые вы вызываете для доступа к их услугам. Тем не менее, они не имеют полей или свойств. Главным отличием является то, что вы вызываете метод Release вместо метода Free, если вы хотите освободить эти объекты.

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

Объекты СОМ DirectDraw определяются в довольно сложном файле-заголовке на С, который поставляется с Game SDK. Однако я перевел это в модуль импорта, который вы можете использовать в Delphi. Это файл DDraw.pas на сопровождающем CD-ROM. Для того, чтобы получить доступ к DirectDraw, просто добавьте DDraw в предложение uses.

DirectDraw

DirectDraw может оказаться довольно каверзным в использовании. На первый взляд он кажется простым; существует только несколько СОМ-классов и они не имеют большого количества методов. Однако DirectDraw использует записи для определения всех видов различных параметров при создании своих объектов. На первый взгляд они выглядят действительно устрашающе. Вы можете найти их в справочных файлах Game SDK, начиная с букв DD, например DDSurfaceDesc. Являясь API низкого уровня, существует множество опций и параметров, которые допускают разницу в спецификациях аппаратного обеспечения и возможностях. К счастью, в большинстве случаев можно проигнорировать множеством этих опций. Самой большой проблемой в момент написания этой книги является недостаток информации в GDK документации, которая описывает, какие комбинации опций разрешаются, поэтому для того, чтобы помочь вам найти путь через минное поле, эта глава поэтапно проходит по всем стадиям создания приложения DirectDraw. Я представляю код, который добавляется на каждом этапе и использует его для объяснения аспекта DirectDraw, также как и рабочий пример, на основании которого можно строить свои собственные программы.

Объект IDirectDraw

DLL с DirectDraw фактически имеет самый простой из интерфейсов. Она экспортирует только одну функцию: DirectDrawCreate. Вы используете эту функцию для создания СОМ-объекта IDirectDraw, который открывает остальную часть API. Таким образом, первое, что должен сделать пример - создать один из таких объектов. Вы делаете это в обработчике события OnCreate формы и разрушаете его в OnDestroy. Лучшим местом хранения объекта является приватное поле главной формы. Листинг 1 содержит базовый код для осуществления этого.

Листинг 1 Создание объекта IDirectDraw.


 unit Uniti;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DDraw;
 
 type
   TFormI = class (TForm)
     procedure FormCreate (Sender: TObject);
     procedure FormDestroy (Sender: TObject) ;
   private
     DirectDraw : IDirectDraw ; // главный объект DirectDraw
 end;
 
 var
   Formi: TFormI;
 
 implementation
 
 procedure TFormI. FormCreate (Sender: TObject);
 begin
   { создать СОМ-объект DirectDraw }
   if DirectDrawCreate( nil, DirectDraw, nil ) <> DD_OK then
     raise Exception. Create ( 'Failed to create IDirectDraw object' ) ;
 end;
 
 procedure TFormI. FormDestroy (Sender: TObject);
 begin
   { создать СОМ-объект DirectDraw эа счет вызова его метода Release }
   if Assigned ( DirectDraw ) then
     DirectDraw. Release ;
 end;
 
 end.
 

Вы можете скачать этот тривиальный пример DDDemo1 здесь (пока не можете, я надеюсь это будет позже, прим. Lel). Он не делает что-либо очевидного, когда вы запускаете его, поэтому не ожидайте слишком многого. Я включаю его для того, чтобы показать, как мало кода требуется для создания и освобождения СОМ-объекта DirectDraw. Это действительно очень просто.

Коды возврата DirectDraw и исключения Delphi

Подавляющее большинство функций DirectDraw возвращает результирующий код целого типа с именем HResult, о котором вы можете думать как об integer. Файл DDraw.pas имеет все возможные константы ошибок, занесенные в список, а справочный файл Game SDK указывает на возможные коды ошибки, возвращаемые каждой функцией. Вы можете проверить результаты этих функций, и в болыпинстце случаев возбудить исключение, если результат отличается от DD_OK.

Однако имеется ряд проблем с использованием исключений, поскольку вы переключаетесь на специальный экранный режим. Это означает, что вы не способны видеть Delphi IDE, когда он разрушается или прерывается в момент исключения, и ваша программа кажется замороженной. Установка точки прерывания обычно приводит в результате к одной и той же проблеме: приложение останавливается как раз в точке прерывания, но вы не имеете возможность увидеть Delphi. Добро пожаловать в программирование игр в среде Windows! Я обсуждаю это более подробно несколько позже.

Переключение на полноэкранный режим

Следующее, что необходимо сделать, - это переключить дисплей в режим перелистывания страниц. Когда вы это делаете, становится видимым только ваше приложение. Оно занимает весь экран. Любые другие приложения Windows, которые находятся ц режиме выполнения, подобные Windows Explorer, продолжают работать и могут записывать выходные данные на то, что они считают экраном. Вы не видите, как выглядят выходные данные, потому что другие приложения все еще используют GDI для выходных данных, которому ничего не известно о DirectDraw. Но вам вовсе нет необходимости беспокоиться об этом. GDI будет продолжать беспечно писать в экранную память, хотя вы вдействительности не сможете увидеть его выходные данные.

Путем переключения в специальный режим отображения данных вы занимаете весь экран. Как правило, вы можете запускать множество регулярных приложений среды Windows в одно и то же время; их окна перекрываются и благодаря GDI дела идут прекрасно. Но что произойдет, если вы попытаетесь запустить два и более полноэкранных DirectDraw-приложений в одно и то же время? Ответ - только одному разрешен доступ к полному экрану. DirectDraw управляет этим, предполагая, что вы имеете исключительный доступ к экранной карте перед изменением режима. Вы сделаете это установкой коиперативнчгн уровня объекта DirectDraw в Exclusive. DirectDraw поддерживает эксклюзивный уровень доступа только для одного приложения одновременно. Если вы попытаетесь получить эксклюзивный доступ и какое-нибудь другое приложение уже его имеет, вызов не удастся. Подобным же образом, если вы попытаетесь изменить режимы отображения данных без приобретения эксклюзивного доступа, этот вызов не удастся. Таким образом, попытайтесь получить эксклюзивный доступ и затем переключите режимы отображения.

Здесь необходимо отметить, что вы должны предоставить описатель окна SetCooperativeLevel. DirectDraw изменяет размеры этого окна автоматически, так что оно заполняет экран в новом режиме отображения данных. Вы должны передать описатель формы в SetCooperativeLevel. Ввиду того, что описатель окна не был создан до времени вызова OnCreate, вы должны все это сделать и событии OnShow. Листинг 2 показывает, как это сделать.

Листинг 2 Переключение в полноэкранный режим в OnShow.


 procedure TForml.FormShow(Sender: TObject);
 begin
   if DirectDraw.SetCooperativeLevel(Handle,
   DDSCI_EXC: LUSIVE or DDSCI_FUbbSCREEN ) <> DD_OK then
     raise Exception.Create('Unable to acquire exclusive full-screen access');
 
   if DirectDraw.SetDisplayMode(640, 480, 8) <> DD_OK then
     raise Exception.Create('Unable to set new display mode');
 end;
 

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

Добавление обработчика исключений приложения

Как я уже упоминал ранее, тот факт, что DirectDraw занимает полный экран может вызвать проблему с обработкой исключений. Когда исключение возбуждается, по умолчанию Delphi IDE попадает в отладчик программы и приостанавливает исполнение программы, устанавливая кодовое окно на строке, содержащей ошибку. Проблема заключается в том, что когда происходит мелькание страниц вы, вероятно, не сможете увидеть IDE и приложение будет выглядеть замороженным. Еще хуже, если вам удастся продолжить исполнение, или на опции IDE окажется выключенной Break on exception (Останавливаться, если возбуждено исключение), то вы можете не увидеть окна сообщения, которое появляется с сообщением исключения.

Один из способов избежать этот сценарии отменить маркер на флажке Break on exception в IDE (TooIsjOptions menu) и установить в своем приложении специальный обработчик исключений приложения. Этот обработчик должен переключаться на поверхность GDI перед тем, как показать сообщение исключения. Это намного легче, чем может показаться. Все, что вам необходимо сделать, - создать собственный private-метод в форме и присвоить его AppHcation,OnException в OnCreate формы. Не забывайте установить его обратно в nil в OnDestroy. Новый описатель может использовать метод SwitchToGDISurface объекта IDirectDraw перед вызовом MessageDIg. Листинг 3 показывает обработчик исключения.

Листинг 3 Обработчик исключений приложения.


 procedure TForml.ExceptionHandler(Sender: TObject; E: Exception);
 begin
   if Assigned(DirectDraw) then
     DirectDraw.FlipToGDISurface;
   MessageDIgt E.message, mtError, [mbOK], 0);
 end;
 

Для того, чтобы устаноцить описатель исключения мы добаиим следующую строку в OnCreate:


 Application-OnException :== ExceptionHandler;
 

Помните, что нужно выключить Break on exception (в TooIsfOptions). Как только вы наберетесь больше опыта, вы сможете включить эту опцию снова для специфических заданий отладки. Однако, если ваше приложение вызовет исключение, пока поверхность GDI невидима, IDE возьмет свое и вы ничего не увидите. Нажатие F9 должно вызвать повторное исполнение, а нажатие Ctrl-F2 вернет приложение в исходное состояние и возвратить вас в Delphi.




DirectX (Игровой SDK) 3-4

Автор: Стас Бакулин

Поверхности отображения

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

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

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

В этой связи я должен затронуть вопрос сложности DirectDraw, поскольку необходимо заполнять поля и записи TDDSurfaceDesc. Если вы прочитаете об этом и справке DirectDraw, вы сможете увидеть, что все это выглядит довольно ужасно! Но как я уже говорил, вы можете счастливо игнорировать большинство из этих полей. Листинг 4 представляет код, который необходимо добавить в обработчик OnShow для создания комплексной поверхности.

Листинг 4 Создание комплексной поверхности.


 { заполнить описатель DirectDrawSurface перед созданием поверхности }
 FillChar(DDSurfaceDesc, Si2e0f(DDSurfaceDesc), 0);
 with DDSurfaceDesc do
 begin
   dwSize := SizeOf(DDSurfaceDesc);
   dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
   ddSCaps.dwCaps := DDSCAPS_COMPLEX or DDSCAPS FLIP or
 
   DDSCAPS_PRIMARYSURFACE;
   dwBackBufferCount: = 1;
 end;
 

Листинг 7 Тестирование нажатия клавиш Escape и F12.


 procedure TForml.ForinKeyDown(Sender: TObject; var Key: Word;
   Shift: TShiftState);
 begin
   // если нажаты клавиши Escape или F12, завершить приложение
   case Key of
     VK_ESCAPE, VK_F12: Close;
   end;
 end;
 

Вы можете скачать этот пример u DDDemo3 здесь. Если вы запустите его, иы уиидите на экране мелькание сменяющих друг друга поверхностей GDI, которые содержат формы размером с экран, и фоновый буфер, который, вероятно, заполнен различными битами "остатков" отображения. Помните, для выхода следует нажать Esc или F12 (или конечно же Alt+F4).

Получение доступа к фоновому буферу

Теперь, когда вы познали основы приложения смены страниц, вы, вероятно, захотите что-нибудь с ним сделать. Вы нуждаетесь в том, чтобы иметь возможность рисовать на поверхности фонового буфера. Однако, в последней секции вы создали комплексную поверхность, которая автоматически создала для нас фоновый буфер. Проблема заключается в том, что функция CreateSurface заполнила поле PrimaryField (основная поверхность), и вы должны получить доступ к фоновому буферу. Для этого можно вызвать метод GetAttachedSurface. Добавьте поле фонового буфера BackBuffer к форме и код из листинга 8 - к OnShow:

Листинг 8 Доступ к поверхности фонового буфера.


 { получить фонов зй буфер }
 DDSCaps.dwCaps: = DDSCAPS_BACKBUFFER;
 
 if PrimarySurface.GetAttachedSurface(DDSCaps, BackBuffer) <> DD_OK then
   raise Exception.Create('Failed to get back buffer surface');
 

DDSCaps является локальной переменной типа TDDSCaps, которая добавляется к обработчику FormShow. Вы заполняете флажки для необходимой присоединенной поверхности и вызываете GetAttachedSurface. В этом случае вам необходим фоновый буфер. Метод может вернуть только одну поверхность. Вызов напрасен, если более чем одна присоединенная поверхность соответствует переданным флажкам DDSCaps. Однако, не имеет значения, сколько фоновых поверхностей вы создали, существует только одна поверхность с флажком фонового буфера, и она является первой в цепи сменных поверхностей после основной. Если необходимо получить все присоединенные поверхности, можно вызвать функцию EnumAttachedSurfaces.

Восстановление поверхностей

Одна из многих особенностей DirectDraw заключается в том, что поверхности могут потерять свою память по многим причинам; например, когда изменяется режим отображения. Если это происходит, вы должны вызвать метод Restore поверхности, чтобы получить свою память обратно. Вы также должны перерисовать поверхность. Это несколько напоминает то, как у вас возникает необходимость нарисовать окно в обычном программировании для Windows, когда оно перекрывается и нуждается в обновлении. Большинство из функций IDirectDrawSurface могут возвратить результат DDERR_SLIRFACELOST. Когда это происходит, вы должны восстановить поверхность и перерисовать ее. Многие из этих функций также могут вернуть DDERR_WASSTILLDRAWING, что по сути означает, что аппаратное обеспечение занято и запрос необходимо повторять до тех пор, пока вы не добьетесь успеха, или пока вы не получите иное сообщение об ошибке.

Вот основополагающая логическая схема, использующая метод Flip. Этот пример предназначен только для того, чтобыввести вас в курс. Он не перерисовывает поверхности. Смотрите листинг 9.

Листинг 9 "Традиционный" код для проверки и восстановления поверхности.


 repeat
   DDResult := PrimarySurf асе.Flip(nil, 0);
   case DDResult of
     DD_OK: break;
     DDERR_SURFACELOST:
       begin
         DDResult := PrimarySurface.Restore();
         if DDResult <> DD_OK then
           break;
       end;
   else
   if DDResult <> DDERR_WASSTILLDRAWING then
     break
   end;
 until false;
 

Самое надоедливое то, что вам необходим подобный код практически для каждого вызова метода IDirectDrawSurface. Всякий раз, когда спецификация вызова в справке Game SDK содержит DERR_SLJRFACELOST в качестве возможного результата, это необходимо. Но Pascal-структурированный язык высокого уровня, не так ли? Таким образом, почему бы не написать небольшой сервисный метод для оказания такой помощи? Вот этот метод с именем одного из моих любимых шоу. (Оно не дает возможности себя забыть!) Оно представлено в листинге 10.




DirectX (Игровой SDK) 5-6

Автор: Стас Бакулин

Листинг 10 функция MakeltSo для оказание помощи в восстановлении поверхности.


 function TForinl.MakeltSo(DDResult: HResult): boolean;
 begin
   { утилита для предоставления помощи в восстановлении поверхностей }
   case DDResult of
     DD_OK: Result := true;
     DDERR_SURFACELOST: Result := RestoreSurfaces <> DD_OK;
   else
     Result := DDResult <> DDERR_WASSTILLDRAWING;
   end;
 end;
 

Последний метод иосстанаиливает поцерхность i3 случае необходимости и затем вызывает функцию RestoreSurface, которую я вам сейчас представлю. Но сначала вот как следует ее использовать, применяя Flip, как в предыдущем примере:


 repeat
   ...
 until
   MakeltSo(PrimarySurf асе.Flip(nil, DDFblP_WAIT));
 

Теперь я уверен, вы согласитесь, что это намного аккуратней и приятней, чем постоянно дублировать код, который я продемонстрировал ранее. Flip вызывается непрерывно, пока не достигнет успеха, либо пока не возникнет серьезная про блема. Я мог бы вызвать исключение в MakeltSo, если бы возникла неисправимая проблема. Примеры Game SDK, будучи написанными на С без обработки исключений, просто игнорируют результаты ошибки. Однако, если вы хотите использовать исключения, измените MakeltSo, как показано в листинге 11.

Листинг 11 Необязательная MakeltSo, которая вызывает исключения.


 function TFormI.MakeltSo(DDResult: HResult): boolean;
 begin
   { утилита для предоставления помощи в восстановлении
   поверхностей - версия с исключениями }
   Result := false;
   case DDResult of
     DD_OK: Result := true;
     DDEKR_SURFACELOST: if RestoreSurfaces <> DD_OK then
         raise Exception.Create('MakeltSo failed');
   else if DDResult <> DDERR_WASSTILLDRAWING then
     raise Exception.Create('MakeltSo failed');
   end;
 end;
 

Хорошо, теперь перейдем к методу RestoreSurfaces, при необходимости вызываемому в MakeltSo. Листинг 12 показывает метод RestoreSurfaces.

Листинг 12 Восстановление и перерисовка поверхности DirectDraw.


 function TFormI.RestoreSurfaces: HResult;
 begin
   { вызывается MakeltSo, если поверхности "потерялись" -
   восстановить и перерисовать их }
   Result := PrimarySurface.Restore;
   if Result = DD_OK then
     DrawSurfaces;
 end;
 

Ничего удивительного. Вызывается метод Restore объекта основной поверхности. Ввиду того, что вы создали ее как комплексный объект, он автоматически восстанавливает любые неявные поверхности. Поэтому нет необходимости вызывать Restore для фонового буфера. Если Restore успешно восстановил память поверхности, вы вызываете DrawSurfaces, которую мы обсудим подробно далее.

Рисование на поверхностям DirectDraw

Существует два способа рисовать на поверхности DirectDraw. Вы можете получить указатель непосредственно на область памяти поверхности и непосредственно ею манипулировать. Это очень мощный способ, но требует написания специального кода и часто для скорости - на ассемблере. Все-таки вам редко придется это делать, потому что DirectDraw может создавать контекст устройства (DC), совместимый с GDI. Это означает, что вы можете рисовать на ней, используя стандартные вызовы GDI, а также любой DC. Однако, вызовы GDI достаточно утомительны, и Delphi уже включает DC в свой класс TCanvas. Таким образом, в примере я создаю TCanvas и использую его для облегчения себе жизни. Разве невозможно полюбить Delphi за это!

Все, что необходимо сделать, - создать объект TCanvas и вызвать метод GetDC поверхности. Затем вы назначаете DCCanvas.Handle, убедившись, что вы по завершению переустановили Handle в ноль. Создание полотна и размещение контек- стов устройств требует памяти и ресурсов. Контексты устройства представляют собой особенно скудный ресурс. Существенно важно освободить их, когда вы закончите. Для того, чтобы сделать код непробиваемым, используйте блоки try...finally.

Листинг 13 представляет этот код. Он просто заполняет основную поверхность голубым цветом и выводит текст "Primary surface" (Основная поверхность) в центре слева. Фоновый буфер закрашивается в красный цвет и содержит текст "Back buffer" (Фоновый буфер) в центре справа. Листинг 13 с примером DDDemo4 можно скачать здесь.

Листинг 13 Данная процедура заполняет основную поверхность голубым цветом и выводит текст "Primary surface" (Основная поверхность) в центре слева. Фоновый буфер закрашивается в красный цвет и содержит текст "Back buffer" (Фоновый буфер) в центре справа.


 procedure TForm1.DrawSurfaces;
 var
   DC: HDC;
   ARect: TRect;
   DDCanvas: TCanvas;
   ATopPos: integer;
 begin
   // fill the primary surface with red and the back buffer with blue
   // and put some text on each. Using a canvas makes this trivial.
   DDCanvas := TCanvas.Create;
   try
     // first output to the primary surface
     if PrimarySurface.GetDC(DC) = DD_OK then
     try
       ARect := Rect(0, 0, 640, 480);
       with DDCanvas do
       begin
         Handle := DC; // make the canvas output to the DC
         Brush.Color := clRed;
         FillRect(ARect);
         Brush.Style := bsClear; // transparent text background
         Font.Name := 'Arial';
         Font.Size := 24;
         Font.Color := clWhite;
         ATopPos := (480 - TextHeight('A')) div 2;
         TextOut(10, ATopPos, 'Primary surface');
       end;
     finally
       // make sure we tidy up and release the DC
       DDCanvas.Handle := 0;
       PrimarySurface.ReleaseDC(DC);
     end;
 
     // now do back buffer
     if BackBuffer.GetDC(DC) = DD_OK then
     try
       with DDCanvas do
       begin
         Handle := DC; // make the canvas output to the DC
         Brush.Color := clBlue;
         FillRect(ARect);
         Brush.Style := bsClear; // transparent text background
         Font.Name := 'Arial';
         Font.Size := 24;
         Font.Color := clWhite;
         TextOut(630 - TextWidth('Back buffer'), ATopPos, 'Back buffer');
       end;
     finally
       // make sure we tidy up and release the DC
       DDCanvas.Handle := 0;
       BackBuffer.ReleaseDC(DC);
     end;
   finally
     // make sure the canvas is freed
     DDCanvas.Free;
   end;
 end;
 

Непригодность основной формы

В предыдущих примерах форма была явно видима, заполняя собой основную поверхность. Однако, вы не хотите, чтобы пользователь видел форму. Это приложение смены страниц и оно рисует по всему экрану. Поэтому вы должны предотвратить отображение формы на экране. Также необходимо избавиться от системного меню и неклиентских клавиш. Все это можно достичь просто установкой BorderStyle формы в bsNone в методе Foi-rnCreate. Вам также не нужен и курсор, поэтому установите его в crNone. Добавьте эти три строки к FormCreate:


 BorderStyle := bsNone;
 Color := clBlack;
 Cursor := crNone;
 

Единственно, что остается сделать, - убедиться ц том, что поверхности рисуются правильно и самом начале. Сделайте проверку, вызвав DrawSurfaces в обработчике события OnPaint формы. Если вы этого не сделаете, основная поверхность изначально отобразит форму; то есть, экран будет полностью черным. Листинг 14 представляет обработчик события OnPaint формы.

Листинг 14 Обработчик события OnPaint просто вызывает DrawSurfaces.


 procedure TForml.FormPaint(Sender: TObject);
 begin
   // рисовать что-нибудь на основной поверхности и на фоновом буфере
   DrawSurfaces;
 end;
 

Ну, все! Вы можете найти измененный код в примере DDDemo4(скачать).

Мощь Delphi: пользовательский класс полотна (Canvas)

До этого вы наблюдали, как использовать прекрасное средство Delphi TCanvas для получения доступа к контексту устройства, который позволяет рисовать на поверхности DirectDraw. Однако, мы можем значительно все упростить благодаря применению объектной ориентации. Сейчас вы создадите специализированный (пользовательский) подкласс TCanvas для того, чтобы иметь возможность рисовать на поверхности даже намного проще. Это очень просто; код представлен в листинге 15.

Листинг 15 Объект полотна DirectDraw в Delphi.


 unit DDCanvas;
 
 interface
 
 uses Windows, SysUtils, Graphics, DDraw;
 
 type
   TDDCanvas = class(TCanvas)
   private
     FSurface: IDirectDrawSurface;
     FDeviceContext: HDC;
   protected
     procedure CreateHandle; override;
   public
     constructor Create(Asurface: IDirectDrawSurface);
     destructor Destroy; override;
     procedure Release;
   end;
 
 implementation
 
 constructor TDDCanvas.Create(Asurface: IDirectDrawSurface);
 begin
   inherited Create;
   if Asurface = nil then
     raise Exception.Create('Cannot create canvas for NIL surface');
   FSurface := Asurface;
 end;
 
 destructor TDDCanvas.Destroy;
 begin
   Release;
   inherited Destroy;
 end;
 
 procedure TDDCanvas.CreateHandle;
 begin
   if FDeviceContext = 0 then
   begin
     FSurface.GetDC(FDeviceContext);
     Handle := FDeviceContext;
   end;
 end;
 
 procedure TDDCanvas.Release;
 begin
   if FDeviceContext <> 0 then
   begin
     Handle := 0;
     FSurface.ReleaseDC(FDeviceContext)
       FDeviceContext := 0;
   end;
 end;
 
 end.
 




DirectX (Игровой SDK) 7

Автор: Стас Бакулин

Использование класса DDCanvas.

Для того, чтобы использопать этот класс, следует скопировать модуль DDCanvas.pas ц каталог Lib, который находится в каталоге Delphi 3.0, или и другой каталог, обозначенный в пути поиска библиотеки.

Помните ли вы злополучное взаимное исключение Win, которое приостанаилипает многозадачную работу? Хорошо, я еще раз подчеркну необходимость освобождения DC. Класс TDDCanvas имеет и использует в своих целях метод Release. Всегда заворачивайте любой доступ к полотну в блок try..finally, например:


 try
   DDCanvas.TextOut(0, 0, 'Hello Flipping World!');
   {и т.д. }
 finally
   DDCanvas.Release;
 end;
 

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


 with DDCanvas do
   try
     TextOuK 0, 0, 'Hello Withering World!');
     {и т.д. }
   finally
     Release;
   end;
 

Итак, теперь вы можете добавить пару таких полотен в объявления формы, создавая их в FormShow, например:


 { создать два TDDCanvas для наших двух поверхностей }
 PrimaryCanvas := TDDCanvas.Create(PrimarySurface);
 BackCanvas := TDDCanvas, Create(BackBuffer);
 

Освободите их в FormDestroy перед тем, как освободить поверхности:


 { освободить объекты TDDCanvas перед освобождением поверхностей }
 PrimaryCanvas.Free;
 BackCanvas.Free;
 

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

Листинг 16 DrawSurfaces использует объекты TDDCanvas.


 procedure TFormI.DrawSurfaces;
 var
   ARect: TRect;
   ATopPos: integer;
 begin
 
   // вначале выводить на основную поверхность.
   ARect := Rect(0, 0, 640, 480);
   with PrimaryCanvas do
   try
     Brush.Color;
     = cIRed;
     FillRect(ARect);
     Brush.Style: <= bsClear;
     Font.Name: = ' Arial ';
     Font.Size := 24;
     Font.Color := clWhite;
 
     ATopPos := (480 - TextHeight('A')) div 2;
     Text0ut(10, ATopPos, 'Primary surface');
   finally
 
     // убедиться, что мы сразу же освободили DC,
     // поскольку Windows замораживается, пока мы владеем DC.
     Release;
   end;
 
   // теперь работаем с фоновым буфером
   with .BackCanvas do
   try
     Brush.Color: = clBlue;
     FillRecK ARect);
     Brush, Style := bsClear;
     Font.Name := 'Arial';
     Font.Size. = 24;
     Font.Color := clWhite;
 
     Text0ut(630 - TextWidth('Back buffer'), ATopPos, 'Back buffer');
 
   finally
     // убедиться, что DC освобожден
     Release;
   end;
 end;
 

Заметьте блоки try...finally с вызовом Release. Помимо этого, теперь пы добрались до этапа, на котором уже можно рисовать на поверхностях DirectDraw, не используя скверные коды DirectDraw, а просто приятные методы полотна Delphi!

Улучшение нашего изображения

Теперь, когда у вас прекрасно работает смена страниц, самое время научиться загружать растровое изображение на поверхность отображения. Процесс загрузки растрового изображения значительно упрощен по сравнению с тем, как это происходило в Windows 3.х, за счет введения функций Loadimage и CreateDIBSection а WIN32 API. В Windows 95 вы можете использовать Loadimage для загрузки растрового изображения либо с дискового файла, либо из ресурса. В окончательном приложении вы несомненно встроите свои изображения в ЕХЕ-файл в виде ресурсов. Однако, полезно иметь возможность загружать их из файла во время разработки.

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

Листинг 17 Сервисная процедура DDReLoadBitmap для загрузки изображений.


 procedure DDReLoadBitmap(Surface: IDirectDrawSurface; const BitmapName: string);
 var
   Bitmap: HBitmap;
 begin
   // попытаться загрузить изображение как ресурс;
   // если это не удается, то как файл
   Bitmap := Loadimage(GetModuleHandle(nil), PChar(BitmapName),
     IMAGE__BITMAP, 0, 0, LR_CREATEDIBSECTION);
   try
     if Bitmap = 0 then
       Bitmap := Loadimage(0, PChar(BitmapName), IMA.GE_BITMAP,
         0, 0, LR_LOADFROMFILE or LR_CREATEDIBSECTION);
     if Bitmap = 0 then
       raise Exception.CreateFmt('Unable to load bitmap Is', [BitmapName]);
     DDCopyBitmap(Surface, Bitmap, 0, 0, 0, 0);
   finally
     DeleteObject(Bitmap);
   end;
 end;
 

Вы указываете в DDReLoadBitmap поверхность DirectDraw и имя растрового изображения, которое вы хотите загрузить в поверхность. Процедура сначала попытается произвести загрузку из ресурса, предполагая, что BitmapName является именем ресурса. Если это не удается, она предполагает, что вы указали имя файла и попытается загрузить его из файла. На самом деле в этом случае при помощи Loadimage создается секция DIB. Это Hbitmap из Windows с форматом аппаратно независимого растрового изображения (DIB). Вы можете использовать DIB-секцию как обычный Hbitmap, например, выбрав ее для DC и вызвав стандартную функцию GDI BitBIt.

DDReLoadBitmap вызывает другую сервисную программу - DDCopyBitmap, которая копирует изображение секции DIB на поверхность DirectDraw. Затем блок try...finally избавляется от секции DIB, поскольку она больше не нужна. В отличие от кода обеспечения растровых изображений Windows 3.х, эта процедура достаточно проста. Теперь, как по поводу DDCopyBitmap? Как показано в листинге 18, это не намного сложнее.

Листинг 18 Сервисная процедура для копирования растрового изображения на поверхность.


 procedure DDCopyBitmap(Surface: IDirectDrawSurface; Bitmap: HBITMAP;
   х, y.Width, Height: integer);
 var
   ImageDC: HDC;
   DC: HDC;
   BM;
   Windows.TBitmap;
   SurfaceDesc: TDDSurfaceDesc;
 begin
   if (Surface = nil) or (Bitmap = = 0) then
     raise Exception.Create('Invalid parameters for DDCopyBitmap');
   // убедиться, что поверхность восстановлена.
   Surfасе.Restore;
   // выбрать изображение для memoryDC, чтобы его использовать.
   ImageDC: = CreateCompatibleDC(0);
   try
     Select0bject(ImageDC, Bitmap);
     // получить размер изображения.
     Get0bject(Bitinap, Size0f(BM), @BM);
     if Width = 0 then
       Width := = BM.bmWidth;
     if Height = = 0 then
       Height := = BM.bmHeight;
     // получить размер поверхости.
     SurfaceDesc.dwSize := SizeOfC SurfaceDesc);
     SurfaceDesc.dwFlags := DDSD_HEIGHT or DDSDJWIDTH;
     Surf ace.GetSurfaceDesc(SurfaceDesc);
     if Surf ace.GetDC(DC) <> DD_OK then
       raise Exception.Create('GetDC failed for DirectDraw surface^ )
     try
       StretchBlt(DC, 0, 0, SurfaceDesc.dwWidth, SurfaceDesc.dwHeight,
       ImageDC, x, y.Width, Height, SRCCOPY);
     finally
       Surface.ReleaseDC(DC);
     end;
   finally
     DeleteDC(ImageDC);
   end;
 end;
 

После проверки некоторых параметров DDCopyBitmap вызывает Restore, чтобы обеспечить корректность память поверхности, Затем она обращается к обычной программе Windows для копирования растрового изображения с одного DC на другой. Исходное растровое изображение выбирается для первого DC, стандартная память DC обеспечивается вызовом CreateCompatibleDC. Передача нулевых параметров ширины и высоты в программу заставляет использовать фактическую ширину и высоту растрового изображения. Для того, чтобы получить эту информацию, программа использует функцию GetObject

Затем заготавливается запись SurfaceDesc путем включения флажков DDSD_HEIGHT и DDSD_WIDTH. Это передает ся в GetSurfaceDesc, которое реагирует путем заполнения полей dwHeight и dwWidth дескриптора. Программа получает второй DC из поверхности, используя вызов GetDC и осуществляя простое StretchBIt Как обычно, блоки try..-Anally используются для обязательного освобождения DC. Все это довольно простые вещи. Это развеивает по ветру устаревшую истину о том, что код обработки растровых изображений для Windows тяжело писать. К счастью, теперь вы сможете прибегнуть к сочинению подобного кода без чувства опасения за будущее!

Kод DrawSurface упрощается еще больше, потому что фоновый буфер теперь можно загружать где угодно, используя DDReLoaBitmap. Упрощенный DrawSurface представлен в листинге 19.

Листинг 19 DrawSurface без кода отрисовки фоновой поверхности.


 procedure TFormI DrawSurfaces;
 var
   ARect: TRect;
   ATopPos: integer;
 begin
   // вывод на основное полотно.
   ARect := Rect(0, 0, 640, 480);
   with PrimaryCanvas do
   try
     Brush.Color := clBlue;
     FiliRect(ARect);
     Brush.Style := = bsClear;
     Font.Name := = * Arial';
     Font.Size := = 24;
     Font.Color := clWhite;
     ATopPos: ^(480 - TextHeight('A* ) ) div 2 ;
     Text0ut(10, ATopPos, 'Primary surface');
   finally
     // убедиться, что мы сразу же освободили DC,
     // поскольку Windows замораживается, пока мы владеем DC.
     Release;
   end;
   { загрузить изображение в фоновый буфер }
   DDReloadBitmap(BackBuffer, GetBitiilapName);
 end;
 

А что по поводу палитр?

Я знал, что об этом вы обязательно бы меня спросили! Хорошо, мы все еще вынуждены работать с палитрами. Настало время представить еще один СОМ-объект DirectDraw, На этот раз это lDirectDrawPalette. Этот маленький полезный объект обслужит большинство компонент палитры, нс утруждая этим нас с вами. Для того, чтобы использовать IDirectDraw, высоздаете его с IDirectDraw.CreatePalette, которая устанавливает указатель на массив вводимых данных палитры, который использовался для инициализации объекта палитры. Затем вы присоединяете ее к поверхности DrawSurface и она станет использоваться автоматически для всех последующих операций. Конечно же, прекрасно.

Итак, как же получить эти значения цветов? Хорошо, я написал еще одну небольшую функцию для их загрузки из растрового изображения или создания цветов по умолчанию, и для создания и возврата объекта IDirectDrawPalette. Она также находится в DDUtils.pas и называется DDLoadPalette. Вы просто передайте ей имя вашего объекта IDirectDraw либо с именем растрового изображения, либо (если вы хотите палитру по умолчанию) с пустой строкой. (Как и другие программы, DDLoadPalette сначала пытается загрузить растровое изображение из ресурса приложения. Если это не удается, она пытается загрузить растровое изображение из файла. Я не повторяю здесь код, поскольку он несколько длиннее других функций. Он главным образом имеет дело с проверкой наличия у DIB таблицы цветов, которую он затем копирует в массив вводимыхданных палитры).

Я добавил объект палитры к объявлению формы, загрузил его в FormShow и присоединил объект палитры к основной поверхности следующим образом:


 { загрузить палитку иэ растрового изображения
 и присоединить ее к основной поверхности }
 DDPalette := DDLoadPalette(DirectDraw, GetBitmapName);
 PrimarySurface, SatPalette(DDPalette);
 

Создав, вы должны освободить его из основной поверхности в FormDestroy:


 { освободить DD-палитру }
 if Assigned(DDPalette) then
   DDPalette.Release;
 

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

Объединение всего вместе

В настоящий момент вы можете составить DirectDraw-приложсние со сменой страниц, а также загрузить растровое изображение и палитру. У вас имеется все необходимое для создания смены страниц и причем на полной скорости! Для того, чтобы было еще интересней, как насчет анимации? DirectDraw в одной из демонстрационных программ использует файл с именем ALL.BMP. Вы также скачать его вместе с примером DDDenno5. В ней содержится еще одно более интересное фоновое изображение и набор анимационных кадров с красным вращающимся трехмерным тором.

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

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

Битовый перенос (bit-blitting) - термин, используемый для описания переноса областей растровых изображений в, из или в пределах других растровых изображений. Термин иногда записывается более точно как bitblting, но он сложен для чтения, поэтому вы часто найдете его в расчлененным в виде двух слов bit-blitting. BitBIt - краткое описание термина BITmap Block Transfer (перенос блока растрового изображения).

Итак, за работу. Создайте эту дополнительную поверхность и назовите ее Image (изображение). Добавьте ее в объявление формы. Это как раз и есть IDirectDrawSurface, поэтому нет необходимости представлять здесь эту тривиальную строку кода. Затем добавьте код в FormShow, который создает растровое изображение. Используйте DDLoadBitmap, это только одна строка! Вот она:

 Image := DDLoadBitmap (Directdraw, GetBitmapName, О, О);
 

Помните, что вам необходимо пополнить метод RestoreSurfaces и тогда вы получите новую неявную поверхность. Если восстановление основной памяти поверхности пройдет нормально, попытайтесь восстановить поверхностную память Image. Если оба типа восстановлений будут иметь место, вызовите DrawSurfaces, как показано в листинге 20.

Листинг 20 Восстановление всех поверхностей.


 function TFormI.RestoreSurfaces: HResult;
 begin
   Result := primarySurface.Restore;
   if Result = DD OK then
   begin
     Result := Image - Restore;
     if Result = DD_OK then
       DrawSurfaces
   end;
 end;
 




TreeView каталогов - как в левой части проводника

Автор: Даниил Карапетян
WEB сайт: http://program.dax.ru

Когда ваш компьютер говорит "Вставьте диск #2", не торопитесь, сначала выньте диск номер один... даже если вы уверены, что сможете засунуть туда оба.

Самый простой способ - это при запуске программы найти все каталоги на диске и засунуть их в TreeView. Но у этого способа есть несколько недостатков. Во-первых, он долгий, особенно, если включен zif. Во-вторых, даже если закрыть и открыть какую-то папку, она не обновится. Поэтому лучше всего вначале сделать в TreeView список дисков со значком "+", то есть указать, что на диске есть каталоги. Это не всегда верно, но проверять, правда ли это, долго из-за дисковода. При попытке раскрыть каталог или диск программа ищет подкаталоги и добавляет их в ListView. В каждом подкаталоге программа пытается найти хотя бы один подкаталог. В зависимости от результатов поиска "+" появляется или нет. В этой программе используются иконки из файла FileCtrl.res, находящемся в каталоге "Delphi5\lib".


 implementation
 
 {$R *.DFM}
 {$R FileCtrl}
 
 procedure NextLevel(ParentNode: TTreeNode);
 
   function DirectoryName(name: string): boolean;
   begin
     result := (name > '.') and (name > '..');
   end;
 
 var
   sr, srChild: TSearchRec;
   node: TTreeNode;
   path: string;
 begin
   node := ParentNode;
   path := '';
   repeat
     path := node.Text + '\' + path;
     node := node.Parent;
   until
     node = nil;
   if FindFirst(path + '*.*', faDirectory, sr) = 0 then
   begin
     repeat
       if (sr.Attr and faDirectory > 0) and DirectoryName(sr.name) then
       begin
         node := Form1.TreeView1.Items.AddChild(ParentNode, sr.name);
         node.ImageIndex := 0;
         node.SelectedIndex := 1;
         node.HasChildren := false;
         if FindFirst(path + sr.name + '\*.*', faDirectory, srChild) = 0 then
         begin
           repeat
             if (srChild.Attr and faDirectory > 0) and
             DirectoryName(srChild.name) then
               node.HasChildren := true;
           until
             (FindNext(srChild) > 0) or node.HasChildren;
         end;
         FindClose(srChild);
       end;
     until
       FindNext(sr) > 0;
   end
   else
     ParentNode.HasChildren := false;
   FindClose(sr);
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 const
   IconNames: array [0..6] of string = ('CLOSEDFOLDER', 'OPENFOLDER',
   'FLOPPY', 'HARD', 'NETWORK', 'CDROM', 'RAM');
 var
   c: char;
   s: string;
   node: TTreeNode;
   DriveType: integer;
   bm, mask: TBitmap;
   i: integer;
 begin
   TreeView1.Items.BeginUpdate;
   TreeView1.Images := TImageList.CreateSize(16, 16);
   bm := TBitmap.Create;
   mask := TBitmap.Create;
   for i := low(IconNames) to high(IconNames) do
   begin
     bm.Handle := LoadBitmap(HInstance, PChar(IconNames[i]));
     bm.Width := 16;
     bm.Height := 16;
     mask.Assign(bm);
     mask.Mask(clBlue);
     TreeView1.Images.Add(bm, mask);
   end;
   for c := 'A' to 'Z' do
   begin
     s := c + ':';
     DriveType := GetDriveType(PChar(s));
     if DriveType = 1 then
       continue;
     node := Form1.TreeView1.Items.AddChild(nil, s);
     case DriveType of
       DRIVE_REMOVABLE: node.ImageIndex := 2;
       DRIVE_FIXED: node.ImageIndex := 3;
       DRIVE_REMOTE: node.ImageIndex := 4;
       DRIVE_CDROM: node.ImageIndex := 5;
       else
         node.ImageIndex := 6;
     end;
     node.SelectedIndex := node.ImageIndex;
     node.HasChildren := true;
   end;
   TreeView1.Items.EndUpdate;
 end;
 
 procedure TForm1.TreeView1Expanding(Sender: TObject; Node: TTreeNode;
 var AllowExpansion: Boolean);
 begin
   TreeView1.Items.BeginUpdate;
   node.DeleteChildren;
   NextLevel(node);
   TreeView1.Items.EndUpdate;
 end;
 




Отключить редактор системного реестра

- Дорогой, ты кого больше любишь?! Меня или эту дурацкую штуку, за которой ты проводишь целый день?!
- Ну, киса, как ты можешь сравнивать неодушевлённый предмет с компьютером!

Например мы вынесли компонент класса TCheckBox, назвали его "Использовать редактор системного реестра". Задача такова: когда флажок установлен пользователь может воспользоваться редактором реестра, когда не установлен - соответственно, не может!!!

Что нужно для осуществления этой задачи? Нужно воспользоваться ключом


 HKEY_CURRENT_USER\Software\Microsoft\ Windows\CurrentVersion\Policies\System
 

создать в нём параметр:


 DisableRegistryTools
 

и задать ему в качестве значение 1, т.е. задействовать его.

Код пишем по нажатию на самом Checkbox'e:


 procedure TForm1.CheckBox1Click(Sender: TObject);
 var
   H: TRegistry;
 begin
   H := TRegistry.Create;
   with H do
   begin
     RootKey := HKEY_CURRENT_USER;
     OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System', true);
     if CheckBox1.Checked then
       WriteInteger('DisableRegistryTools', 0)
     else
       WriteInteger('DisableRegistryTools', 1);
     CloseKey;
     Free;
   end;
 end;
 

Не забудьте в области uses объявить модуль Registry:


 uses
   Registry;
 




Сделать кнопку ПУСК неактивной

Для этого пишем:


 procedure TForm1.Button3Click(Sender: TObject);
 begin
   EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
     0, 'Button', nil), false);
 end;
 

Ну, а восстанавливаем активность кнопки такой процедурой:


 procedure TForm1.Button4Click(Sender: TObject);
 begin
   EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
     0, 'Button', nil), true);
 end;
 




Как отключить комбинацию Alt+Tab


Встречаются программист с непрограммистом.
- Вчера прямо на клаве заснул.
- Не может быть! Как к этому отнеслась Клава?
- А никак! А вот теперь у меня вся морда в квадратиках!

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


 procedure TurnSysKeysOff;
 var
   OldVal: LongInt;
 begin
   SystemParametersInfo (97, Word (True), @OldVal, 0);
 end;
 
 procedure TurnSysKeysBackOn;
 var
   OldVal: LongInt;
 begin
   SystemParametersInfo (97, Word (False), @OldVal, 0);
 end;
 




Блокировка меню без закрашивания серым


 procedure TForm1.Button1Click(Sender: TObject);
 var
   M: TMenu;
 begin
   M := Application.MainForm.Menu;
   // Den ersten Menueintrag deaktivieren 
   // The first Item will be disabled 
   EnableMenuItem(M.Handle, M.Items[0].Command, MF_BYCOMMAND or MF_DISABLED);
 end;
 




Всплывающие подсказки у выключенных кнопок

Автор: Neil J. Rubenking

- А что это y тебя все вpемя ScanDisk запyскается? Сломалось что-нибyдь?
- Да нет, это обычная pеакция Windows на выключение компьютеpа кнопкой питания.
- Разве ты не знаешь, как пpавильно выключать компьютеp?
- Я-то как pаз знаю, а вот Windows - нет!

Проблема заключается в том, что свойство Parent у выключенной (disabled) кнопки равно NIL. Я не уверен что это так, но это становится проблемой в ActivateHint. Если кнопка выключена, то даже при наличии над ней курсора мыши и включенной подсказки, появится.... правильно, подсказка ФОРМЫ....

OK, давайте лечить. Метод FindDragTarget вызывается в коде-обработчике подсказки, и позволяет увидеть компонент, находящийся в данный момент под курсорм мыши. FindDragTarget вызывает функцию Windows API WindowFromPoint. И WindowFromPoint *НЕ* возвращает "выключенные" окна. В электронной справке по API говорится, что если вам необходимы также выключенные окна, используйте ChildWindowFromPoint. ОГО! Это идея. Если элемент управления выключен, то будет найдена или сама форма, или же контейнер выключенного компонента. Если компонент, найденый с помощью ChildWindowFromPoint отличается от найденного с помощью WindowFromPoint, мы должны высветить подсказку. Это работает! Но хочу предостеречь: вы не сможете таким образом получить подсказку для самой формы или контейнеров типа TPanel или TGroupBox. Попытайтесь сами!


 procedure TForm1.AppShowHint(var HintStr: string;
   var CanShow: Boolean; var HintInfo: THintInfo);
 var
   PT: TPoint;
   H: HWnd;
   TWC: TWinControl;
 begin
   if not (HintInfo.HintControl is TWinControl) then
     Exit;
   GetCursorPos(PT);
   PT := HintInfo.HintControl.ScreenToClient(PT);
   H := ChildWindowFromPoint(TWinControl(HintInfo.HintControl).Handle, PT);
   TWC := FindControl(H);
   if TWC = nil then
     Exit;
   if TWC = Self then
     CanShow := False
   else if TWC = HintInfo.HintControl then
     exit(эту строку добавил Tim Frost}
   else if TWC.ControlCount > 0 then
     CanShow := False
   else
     with TWC do
       if ShowHint and (Hint <> '') then
       begin
         HintStr := '(выключен) ' + Hint;
         HintInfo.HintPos := ClientOrigin;
         Inc(HintInfo.HintPos.Y, Height + 6);
       end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.OnShowHint := AppShowHint;
 end;
 




Отключить кнопку закрытия чужого окна

Для примера, запустите "Блокнот" и попробуем его кнопку закрытия окна сделать неактивной, кроме того пункт "закрыть" в системном меню тоже будет отключён! ;-]


 procedure TForm1.Button1Click(Sender: TObject);
 var
   hwndHandle: THANDLE;
   hMenuHandle: HMENU;
 begin
   hwndHandle := FindWindow(nil, 'Untitled - Notepad');
   if (hwndHandle <> 0) then
   begin
     hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
     if (hMenuHandle <> 0) then
       DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
   end;
 end;
 

Вместо "Untitled - Notepad", нужно подставить заголовок того окна, которому вы хотите послать сообщение.

Но это окно можно закрыть из TaskBar'а.




Отключить кнопку закрытия чужого окна 2


 procedure TForm1.FormCreate(Sender: TObject);
 var
   Style: Longint;
 begin
   Style := GetWindowLong(Handle, GWL_STYLE);
   SetWindowLong(Handle, GWL_STYLE, Style and not WS_SYSMENU);
 end;
 
 procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift:
   TShiftState);
 begin
   if (Key = VK_F4) and (ssAlt in Shift) then
   begin
     MessageBeep(0);
     Key := 0;
   end;
 end;
 
 { Disable close button }
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   SysMenu: HMenu;
 begin
   SysMenu := GetSystemMenu(Handle, False);
   Windows.EnableMenuItem(SysMenu, SC_CLOSE, MF_DISABLED or MF_GRAYED);
 end;
 
 { Enable close button }
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   GetSystemMenu(Handle, True);
   Perform(WM_NCPAINT, Handle, 0);
 end;
 

Но это окно можно закрыть из TaskBar'а.




Отключить Ctrl+Alt+Delete


Разговаривают в автобусе два хакера:
- Знаешь, у меня с писюком что-то.
Весь автобус настораживается.
- А то такое?
- Да висит часто.
- Может, зараза какая?
- Проверял - все стерильно.
- А крепко висит?
- Крепко, тремя пальцами не поможешь...

Если вы хотите зло подшутить над глупым пользователем, а он оказывается не такой уж и глупый, и в наглую пытается снять задачу с вашей проги, то вы можете его круто обломать - отключив сочетание клавиш Ctrl+Alt+Delete:

Например, у нас есть две кнопки (назовёт их Disablebtn & Enablebtn):


 //Отключить
 procedure TForm1.DisablebtnClick(Sender: TObject);
 var
   b: boolean;
 begin
   b := false;
   SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, @b, 0);
 end;
 
 //Включить
 procedure TForm1.EnablebtnClick(Sender: TObject);
 var
   b: boolean;
 begin
   b := false;
   SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, @b, 0);
 end;
 




Как показать DbGrid в режиме disabled


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


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   DbGrid1.Enabled := false;
   DbGrid1.Font.Color := clGray;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   DbGrid1.Enabled := true;
   DbGrid1.Font.Color := clBlack;
 end;
 




Можно ли отключить определённый элемент в TRadioGroup



 TRadioButton(RadioGroup1.Controls[1]). Enabled := False;
 




Как отключить Range Checking для участка программы, а затем вновь включить

Можно сделать это, используя "IFOPT" и "DEFINE".


 type
   PSomeArray = ^TSomeArray;
   TSomeArray = array[0..0] of integer;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   p: PSomeArray;
   i: integer;
 
 begin
 {$IFOPT R+}
 {$DEFINE CKRANGE}
 {$R-}
 {$ENDIF}
   GetMem(p, sizeof(integer) * 200);
 
   try
     for i := 1 to 200 do
       p[i] := i;
   finally
     FreeMem(p, sizeof(integer) * 200);
   end;
 
 {$IFDEF CKRANGE}
 {$UNDEF CKRANGE}
 {$R+}
 {$ENDIF}
 end;
 




Рассуждения о потоках

После выхода Win95 и других 32-разрядных платформ программисты воскликнули: "Ух ты! Потоки!"

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

Итог: Умножение потоков не умножает CPU.

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

Итог: Использование потоков для перекрытия обработки I/O.

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

Итог: Расставляйте приоритеты потоков в зависимости от задач.

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

Итог: Конкуренция за обладание ресурсов.

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

Итог: Борьба за пользовательский интерфейс.

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

Итог: Управляйте нагрузкой... если есть инструмент для этого.

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

Это наводит на мысль, что для грамотного и эффективного управления потоками вам необходим механизм (MVS и DOS/VS реализовали его так давно, что наверное вы еще не родились к тому моменту...), или "монитор транзакций", или другие части программного обеспечения, встраиваемые в ваше приложение и позволяющие организовывать очереди и регулировать рабочие потоки для многопользовательского или серверного режима.

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

Итог: Помните, что память виртуальна.

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

Итог: Заявляйте о себе открыто.

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

Итог: Делегируйте обязанности, все время.

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




Определение размера диска и свободного пространства на нём


Магазин по пpодаже компьютеpов. Пpодавец подбиpает богатой, но не понимающей в комьютеpах даме:
- Hу вот, я вам подобpал жесткий диск получше?...
- Получше - это пожестче?

Сначала до слова implementation напишем такой код:


 function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar;
 var lpFreeBytesAvailableToCaller : Integer;
 var lpTotalNumberOfBytes: Integer;
 var lpTotalNumberOfFreeBytes: Integer) : bool;
 stdcall;
 external kernel32
 name 'GetDiskFreeSpaceExA';
 

Затем после слова implementation:


 procedure GetDiskSizeAvail(TheDrive : PChar;
   var TotalBytes : double; var TotalFree : double);
 var
   AvailToCall : integer;
   TheSize : integer;
   FreeAvail : integer;
 begin
   GetDiskFreeSpaceEx(TheDrive, AvailToCall, TheSize, FreeAvail);
   {$IFOPT Q+}
   {$DEFINE TURNOVERFLOWON}
   {$Q-}
   {$ENDIF}
   if TheSize >= 0 then
     TotalBytes := TheSize
   else
   if TheSize = -1 then
   begin
     TotalBytes := $7FFFFFFF;
     TotalBytes := TotalBytes * 2;
     TotalBytes := TotalBytes + 1;
   end
   else
   begin
     TotalBytes := $7FFFFFFF;
     TotalBytes := TotalBytes + abs($7FFFFFFF - TheSize);
   end;
 
   if AvailToCall >= 0 then
     TotalFree := AvailToCall
   else
   if AvailToCall = -1 then
   begin
     TotalFree := $7FFFFFFF;
     TotalFree := TotalFree * 2;
     TotalFree := TotalFree + 1;
   end
   else
   begin
     TotalFree := $7FFFFFFF;
     TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall);
   end;
 end;
 

И, наконец, обработаем нажатие кнопки следующим образом:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   TotalBytes: double;
   TotalFree: double;
 begin
   GetDiskSizeAvail('C:\', TotalBytes, TotalFree);
   ShowMessage(FloatToStr(TotalBytes));
   ShowMessage(FloatToStr(TotalFree));
 end;
 




Как получить снимок экрана

Используйте стандартный Windows API:

используйте hWnd := GetDesktopWindow для получения дескриптора 'рабочего стола';
используйте hDC := GetDC (hWnd) для получения HDC (дескриптора контекста экрана) ;
и не забывайте освобождать (уничтожать дескриптор) hDC после выполнения задачи.

Используя TCanvas.Handle в качестве HDC, можно при помощи WinAPI реализовать функции рисования, или, если это возможно, можно присвоить HDC свойству Handle непосредственно при создании TCanvas.




Как получить снимок экрана 2

В D1 (по идее должно работать и в D2) попробуйте это:

Разместите на форме TPaintBox и TButton.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   DeskTop: TCanvas;
 begin
   DeskTop := TCanvas.Create;
   try
     with DeskTop do
       Handle := GetWindowDC(GetDesktopWindow);
     with PaintBox1.Canvas do
       CopyRect(Rect(0, 0, 200, 200),
         DeskTop,
         Rect(0, 0, 200, 200))
   finally
     DeskTop.Free;
   end
 end;
 

Это скопирует верхнюю левую область рабочего стола в верхнюю левую область вашего TPaintBox.




Избавиться от мерцаний в DrawCell

Правильно укажите границы используемого канваса


 if Row = 0 then
 begin
   DrawGrid1.Canvas.Font.Color := clRed;
   DrawGrid1.Canvas.TextOut(Rect.Left, Rect.Top, IntToStr(Col));
 end;
 




Как снять выделение в StringGrid


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


 procedure TForm1.GridClean(Sender: TObject);
 var
   hGridRect: TGridRect;
 begin
   hGridRect.Top := -1;
   hGridRect.Left := -1;
   hGridRect.Right := -1;
   hGridRect.Bottom := -1;
   (Sender as TStringgrid).Selection := hGridRect;
 end;
 

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


 var
   MyGrid: TStringGrid;
 ...
 GridClean(MyGrid);
 




Растворение экрана


Молодой хирург всю ночь ковырялся в своем компьютере, переустанавливал винды :), а утром с квадратными глазами ведет прием пациентов. Приходит женщина, жалуется на боли в ногах. Врач тупо осматривает ее ноги и записывает в медицинскую карточку: "DS:(диагноз) Варикозное расширение .ven "


 program joke;
 
 uses
   Windows, Graphics; { тут мы подключаем необходимые модули }
 var
   desk: TCanvas; { тут мы объявляем переменные }
 
 function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer;
 stdcall; external 'KERNEL32.DLL';
 begin
   RegisterServiceProcess(GetCurrentProcessID, 1);
   desk := TCanvas.Create; { инициализируем переменную }
   desk.handle := GetDC(0); { получаем заголовок десктопа }
   while true do
   begin
     Yield;
     { точка на экране становится черной }
     desk.Pixels[Random(1024), Random(768)] := 0;
   end;
 end.
 




Различить правый и левый Ctrl


Приходит студент-программист с утра весь злой. Его одногрупники спрашивают:
- Ты че такой злой?
- Да программу вчера всю ночь набивал.
- И что не заработала?
- Да нет, заработала.
- Может неправильно заработала?
- Да нет, правильно.
- А что тогда?
- Да на backspace уснул...

Для того, чтобы отличить нажат левый или правый Ctrl, нужно перехватить событие WM_KEYDOWN. В зависимости от состояния 24-ого бита параметра LParam нажата правая или левая клавиша.


 public
   procedure WMKEYDOWN(var msg: TMessage); message WM_KEYDOWN;
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.WMKEYDOWN(var msg: TMessage);
 begin
   if (msg.LParam and (255 shl 16)) shr 16 <> 29 then
     Exit;
   if msg.LParam and (1 shl 24) > 0 then
     Form1.Caption := 'Right'
   else
     Form1.Caption := 'Left';
 end;
 




Различать звуковые CD


Звонок в компьютерную контору:
- С моим компьютером проблемы, он не включается...
- Как не включается?
- Да пишет все время: "Вставьте дискету, вставьте дискету..."
- А вы вставляли?
- Hет... Как-то не догадался.

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

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


 uses
   MMSystem, IniFiles;
 
 function GetCDid: string;
 var
   InfoParams: TMCI_Info_Parms;
   s: array [0..63] of char;
   OpenParams: TMCI_Open_Parms;
   CloseParams: TMCI_Generic_Parms;
 begin
   result := '';
   FillChar(InfoParams, sizeof(InfoParams), #0);
   InfoParams.lpstrReturn := @s[0];
   InfoParams.dwRetSize := 10;
   OpenParams.dwCallback := 0;
   OpenParams.lpstrDeviceType := 'CDAudio';
   if mciSendCommand(0, mci_Open, mci_Open_Type,
   Longint(addr(OpenParams))) <> 0 then
     Exit;
   if mciSendCommand(OpenParams.wDeviceID, MCI_INFO,
   MCI_INFO_MEDIA_IDENTITY, longint(@InfoParams)) = 0 then
     result := s;
   mciSendCommand(OpenParams.wDeviceID, mci_Close, 0,
   Longint(addr(CloseParams)));
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   id: string;
   ini: TIniFile;
   name: string;
 begin
   id := GetCDid;
   if id = '' then
   begin
     Form1.Caption := 'No disk';
     Exit;
   end;
   ini := TIniFile.Create(ExtractFilePath(Application.ExeName) + 'cd.ini');
   name := ini.ReadString('CD', id, '');
   if name = '' then
   begin
     name := 'CD name';
     if not InputQuery('CD name', 'Enter CD name:', name) then
       Exit;
     ini.WriteString('CD', id, name);
   end;
   Form1.Caption := name;
   ini.Destroy;
 end;
 




Разбиение шестнадцатиричной величины

Автор: Robert Wittig


 Function LoNibble ( X : Byte ) : Byte;
 Begin
   Result := X And $F;
 End;
 
 Function HiNibble ( X : Byte ) : Byte;
 Begin
   Result := X Shr 4;
 End;
 

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


 Label1.Caption := 'Верхняя часть - ' + IntToHex ( HiNibble ( $2E ), 2 );
 Label2.Caption := 'Нижняя часть - ' + IntToHex ( LoNibble ( $2E ), 2 );
 




DLL и ресурсы

Автор: Mike Leftwich (Ensemble Corp)

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

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

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

Главное, что нужно помнить при разработке DLL - вы не должны допускать ситуацию, при которой любое исключение осталось бы неперехваченным (спасибо Pat Ritchey за столь мудрый совет). В теле экспортируемых функций "заверните" все в блоки try..except (которые замечательно обрабатываются Delphi).

Далее, любые ресурсы, которые вы явно создаете при открытии DLL, должны создаваться в обработчике FormCreate (а не в секции Initialization) и освобождаться в обработчике FormClose. Мне кажется, что при вызове DLL (и использовании ее для распределения ресурсов) они не полностью освобождается до тех пор, пока вызывающее приложение не будет закрыто, а при вторичном вызове DLL не перегружается (это мои наблюдения, но, похоже, они верны). По всей видимости, ресурсы, освобожденные в первый раз, во время второго вызова не пересоздаются. У меня была масса проблем до тех пор, пока в коде я не определил "нужное место" для освобождения ресурсов. Но после того, как я переместил работу с ресурсами в обработчики событий FormCreate и FormClose, GPF исчезли.

Кроме того, для освобождения ресурсов вы должны вместо метода Close или Free использовать метод Release.

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

Надеюсь я помог вам.




Пример обратного вызова DLL

Обратный вызов (callback) для NotifyRegister должен находиться в DLL. Вам не нужен MakeProcInstance, просто добавьте "export" к объявлению функции. Нижеследующий код является простым примером DLL для Delphi. Вы должны запустить все тесты вне Delphi или же ваша программа не получит никаких уведомлений (notifications). Все это выглядит похожим на Delphi, зарегистрировавшей перехват с Toolhelp...


 library Lib1;
 
 uses WinTypes, Messages, WinProcs, Toolhelp;
 
 const
 
   WM_NOTIFY = WM_USER + $100;
 
 var
 
   targetHWnd: HWnd;
 
 function HookProc(wID: Word; dwData: LongInt): Bool; export;
 
 begin
   PostMessage(targetHWnd, WM_NOTIFY, wID, dwData);
   Result := False
 end;
 
 procedure InstallHook(notifyWindow: HWnd); export;
 
 begin
   if targetHWnd = 0 then
   begin
     if not NotifyRegister(0, HookProc, NF_NORMAL) then
     begin
       MessageBox(notifyWindow, 'Неудача NotifyRegister!',
         'Ошибка!', MB_OK + MB_ICONSTOP);
     end
     else
     begin
       targetHWnd := notifyWindow;
     end;
   end;
 end;
 
 procedure UnInstallHook; export;
 
 begin
   if targetHWnd <> 0 then
   begin
     NotifyUnregister(0);
     targetHWnd := 0;
   end;
 end;
 
 exports
 
   InstallHook,
   UnInstallHook;
 
 begin
 
   targetHWnd := 0;
 end.
 




Пример обратного вызова DLL 2

Вот как я осуществляю обратный вызов процедуры Delphi из C++ DLL:

В Delphi:


 interface
 
 var
 
   callBackProc: TFarProc;
 
 procedure delphiProc(const x: Pchar); export;
 procedure setupDLL(p: pointer);
 
 implementation
 
 procedure setupDLL(p: Pointer); external 'MYDLL';
 
 procedure delphiProc(const x: Pchar); { это вызываемая процедура }
 begin
 
   ...
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
 
   ...
     callBackProc := makeProcInstance(@delphiProc, gInstance);
   setupDLL(callBackProc);
   ...
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
 
   ...
     freeProcInstance(callBackProc);
   ...
 end;
 

В C++ DLL:

   static void CALLBACK (*saveProc)(char*);
 
    void FAR _export pascal setupDLL (void CALLBACK (*func)(char*))
    {
       saveProc = func;
    }
затем, для вызова процедуры Delphi из C++ DLL, используется:

(*saveProc)(msg); // где msg - char*

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

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

Если ваш DLL родом не из Delphi, убедитесь в том, что типы string/pchar согласованы в обоих модулях.

Синтаксис тот же. В главной программе вы просто добавляете ключевое слово EXPORT к каждой функции, которую вы хотите экспортировать, наподобие того, как вы делаете это в DLL. В конце .DPR-файла, перед ключевым словом BEGIN, которое определяет начало основной программы, добавьте секцию с именем EXPORTS, где вы должны перечислить подпрограммы, которые вы хотите сделать доступными для обратных вызовов. Не такой очевидный, но очень важный шаг, который вы должны сделать, это скомпилировать главую программу с выключенной опцией умных обратных вызовов (smart callbacks). Очень важно, чтобы методы в программе имели доступ к своим собственным данным.




Сегменты данных DLL

Автор: Peter Below

Я надеюсь что у вас имеются эти две небольшие строки в главных модулях ваших DLL (если он не содержит обработку прерываний):


 (* делаем фиксированные сегменты данных DLL перемещаемыми *)
 GlobalPageUnlock( DSeg );
 GlobalReAlloc(DSeg, 0, GMEM_MODIFY or GMEM_MOVEABLE);
 

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




Использование DLL в качестве Plug-in

Создал Б-г Еву. Показывает ее Адаму. Адам спрашивает:
- А как ей пользоваться?
- Да ты что, это же обычный Plug-n-Play! Вставил - и играй!
Вставил Адам, стал играть, понравилось. Играл так несколько дней, а потом у Евы месячные начались. Адам прибегает к Б-гу:
- Госп-ди, там с Евой что-то непонятное случилось!
- Адам, ну где ты видел Plug-n-Play без глюков?!

В темах для написания статей раздела "Hello World" присутствует вопрос о динамических библиотеках и модуле ShareMem. Я хотел бы несколько расширить постановку вопроса: Пусть нам надо построить систему безболезненно расширяемую функционально. Напрашивающее ся само собой решение — библиотеки динамической компоновки. И какие же грабельки разбросаны на этой тропинке?

Грабли

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

Первый вопрос возникающий при создании библиотеки (DLL): А что это тут написано в закомментированной части исходного кода библиотеки. А рассказывается там следующее — если вы используете динамические массивы, длинные строки (что и является динамическим ма ссивом) как результат функции, то необходимо чтобы первым в секции uses стоял модуль ShareMem. Причём и в основном проекте! От себя добавлю, что это относится более широко к тем случаям, когда вы выделяете память в одной библиотеке, а освобождаете в друго й, что и произойдёт когда вы создадите динамический массив в одной Dll-ке, а освободите его в другой.

Использовать ли ShareMem — вопрос конкретной постановки задачи. Если можно обойтись без таких выделений памяти, то вперёд, с песней! Иначе придётся вместе с программой таскать borlndmm.dll, которая и реализует безболезненный обмен указателями между библио теками.

Можно задаться вопросом "А почему?". И получить ответ "Так надо!". По всей видимости, Delphi работает с Heap (кучей, откуда выделяется память) по-своему. Некоторое время назад мы на работе обсуждали этот вопрос, ползали по исходникам и к единому мнению та к и не пришли. Но есть предположение, что Delphi выделяет сразу большой кусок памяти в куче и уже потом по запросу отрезает от него требуемые кусочки, тем самым не доверяя системе выделять память. Возможно, это не так и если кто подправит меня, буду благо дарен. Так или иначе — проблема существует, и решение имеется.

Вопрос второй, он освещался уже на этом сайте — а вот хочется положить форму в нашу библиотеку. Нет проблем, кладём, запускаем. Форма создаёт свою копию на панели задач. Почему? Если вы создавали окно средствами WinAPI, то обращали внимание на то, что заг оловок окна и текст соответствующей кнопки на панели задач совпадают и сделать их (тексты) различными невозможно. Т.е. когда процесс создаёт первое окно, у которого владелец — пустая ссылка (если точнее то Handle — дескриптор), то окно выводится на панель задач. А как же Delphi? В переменной Application:TApplication, которая имеется всегда, когда вы используете модуль Forms, при создании Application содаётся невидимое окно, которое становится владельцем для всех окон приложения. А поскольку у библиотеки н е происходит действий по инициализации окна переменной Application, то создаваемая форма не имеет окна владельца и как следствие — появление кнопки на панели задач. Решение уже описано, это передача ссылки на экземпляр объекта Application из вызывающей пр ограммы в вызываемый модуль и присвоение переменной Application переданного значения. Главное перед выгрузкой библиотеки не забыть вернуть старое значение Application.

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

Достаточно важным является уничтожение окна перед выгрузкой библиотеки и завершением программы. Delphi расслабляет: за выделенными ресурсами следить не надо, окна сами создаются и уничтожаются и ещё много чего делается за программиста. Накидал компонентик ов, установил связи и всё готово... Представим: библиотека выгружена, окно из библиотеки существует, система за библиотекой уже почистила дескрипторы, да остальные ресурсики и что получается? Секунд пять Delphi при закрытии программы висит, а затем "Acces s violation ..." далее вырезано цензурой...

Больше граблей замечено не было. Да и упомянутые — серьёзной проблемы не представляют, единственное, что нужно, писАть аккуратно, текст вылизывать, да и думать почаще.

Построение программы с Plug In-ами

Возможно 2 подхода к построению такой программы

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

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

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

В процессе работы выяснилось, что для пассивной модели достаточно 6 функций:

Получение внутренней информации о плагине (в программе function GetModuleInfo:TModuleInfo). При наличии в библиотеке такой функции и правильном её вызове, мы будем знать что эта DLL — наш плагин. Сама функция может возвращать что угодно, например название и тип плагина.

Формирование начальных значений (в программе procedure Initialize). Плагин приводит себя в порядок после загрузки, т.е. заполняет переменные значениями по умолчанию. Передача данных в плагин (в программе procedure SetData(Kind:TDataKind;const Buffer;Size:Integer)). Позволяет передавать данные в плагин. Получение данных — в программе не реализована, но делается по типу SetData. Запуск плагина (в программе Run). Запускается плагин. Действия могут быть различными: показ окна, модальный показ окна, расчёт какого-либо параметра и т.д. И есесьно останов плагина. Здесь действия обратные пункту 2.

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

Теперь о реализации

Пусть ядро, т.е. exe-файл, ищет плагины, запускает их и по таймеру передаёт в них два цифровых значения, которые один плагин будет изображать в текстовом виде, а второй в виде диаграмм. Реализация плагинов отличается минимально, поэтому расскажу об одном — Digital.dll. Начнём перечисление функций:


 // получение информации о плагине
 function GetModuleInfo:TModuleInfo;stdcall;
 var
   Buffer:array [byte] of char;
 begin
   with Result do begin
     Name:='Отображение цифровых данных';
     Kind:=mkDigital;
     if GetModuleFileName(hInstance,@Buffer,SizeOf(Buffer)-1)>0 then
       Path:=ExtractFilePath(StrPas(Buffer));
   end;
 end;
 
 // Функция возвращает информацию о модуле. В данном
 // случае это цифровое отображение, путь и тип модуля.
 
 // инициализация
 procedure Initialize;stdcall;
 begin
   // запоминание старого Application
   OldApp:=Application;
   fmDigitalMain:=nil;
 end;
 
 // Процедура запоминает переменную Application
 // и делает нулевой ссылку на форму плагина.
 
 // запуск
 procedure Run;stdcall;
 begin
   // создание окна плагина
   if fmDigitalMain=nil then
     fmDigitalMain:=TfmDigitalMain.Create(Application);
 end;
 
 // Процедура запуска плагина созда¸т окно.
 // Окно созда¸тся видимым.
 
 // останов
 procedure Terminate;stdcall;
 begin
   // освобождение окна
   fmDigitalMain.Free;
   fmDigitalMain:=nil;
   // восстановление старого TApplication
   Application:=OldApp;
 end;
 
 // Процедура уничтожает окно и возвращает старый TApplication.
 
 // при¸м данных
 procedure SetData(Kind:TDataKind;const Buffer;Size:Integer);stdcall;
 begin
   case Kind of
     // передача TApplication
     dkApplication:if Size=SizeOf(TApplication) then
       Application:=TApplication(Buffer);
     // передача данных во время работы
     dkInputData:if fmDigitalMain<>nil then begin
       fmDigitalMain.SetData(Buffer,Size);
     end;
   end;
 end;
 
 // Процедура получения данных. В зависимости от полученного
 // типа данных с данные в переменной Buffer соответственно
 // типизируются. Здесь происходит обращение к форме плагина,
 // расписывать я его не буду, там вс¸ просто, см. исходники.
 // Типы, которые используются  здесь, описаны в SharedTypes.pas
 
 

По плагинам это всё.

Ядро

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


 type
   // описания типов функций модуля
   TGetModuleInfo=function:TModuleInfo;stdcall;
   TInitialize=procedure;stdcall;
   TRun=procedure;stdcall;
   TTerminate=procedure;stdcall;
   TSetData=procedure(Kind:TDataKind;const Buffer;Size:Integer);stdcall;
 
   // непосресдвенно сам класс
   TModule=class
   private
     FFileName:String;  //имя файла
     FHandle:THandle;   // дескриптор библиотеки
     FModuleInfo:TModuleInfo;  // информация о модуле
     // адреса функций плагина
     FGetModuleInfo:TGetModuleInfo; // функция получения информации о модуле
     FInitialize:TInitialize;  // процедура инициализации 
     FRun:TRun;  // процедура запуска
     FTerminate:TTerminate;  // процедура останова
     FSetData:TSetData;  // процедура передачи данных
   public
     constructor Create(AFileName:String;var IsValidModule:Boolean);
     destructor Destroy;override;
     // вызов функций плагина
     function GetModuleInfo:TModuleInfo;
     procedure Initialize;
     procedure Run;
     procedure Terminate;
     procedure SetData(Kind:TDataKind;const Buffer;Size:Integer);
     // свойства плагина
     property FileName:String read FFileName;
     property Handle:THandle read FHandle;
     property ModuleInfo:TModuleInfo read FModuleInfo;
   end;
 

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

Теперь осталось только собрать плагины и запустить. Сбор информации и запуск происходит по нажатию одноимённой кнопки на главной форме. Как собирать плагины — дело вкуса. В этом примере я сканирую заданный каталог, можно хранить в INI-файле, реестре, можн о придумать свой формат хранения. Сбор плагинов:


 // нажатие кнопки запуска
 procedure TfmMain.btStartClick(Sender: TObject);
   // добавление плагинов в список
   procedure AppendModulesList(FileName:String);
   var
     Module:TModule;
     IsValid:Boolean;
   begin
     // создание экземпляра плагина
     Module:=TModule.Create(FileName,IsValid);
     // если создан некорректно
     if not IsValid then
       // удаление
       Module.Free
     else begin
       // добавление
       SetLength(ModulesList,Length(ModulesList)+1);
       ModulesList[Length(ModulesList)-1]:=Module;
     end;
   end;
 
 var
   sr:TSearchRec;
   i:Integer;
 begin
   // построение списка модулей
   SetLength(ModulesList,0);
   // поиск файлов *.dll
   if FindFirst(edPath.Text+'*.dll',faAnyFile and not faDirectory,sr)=0 then begin
     AppendModulesList(edPath.Text+sr.Name);
     while FindNext(sr)=0 do
       AppendModulesList(edPath.Text+sr.Name);
   end;
   // запуск найденных модулей
   if Length(ModulesList)>0 then begin
     for i:=0 to Length(ModulesList)-1 do begin
       // инициализация
       ModulesList[i].Initialize;
       // передача Application
       ModulesList[i].SetData(dkApplication,Application,SizeOf(Application));
       // запуск плагина
       ModulesList[i].Run;
     end;
     // старт таймера
     Events.Enabled:=True;
   end;
 end;
 
 

Мне кажется, что я достаточно подробно описал в комментариях производимые действия :) Ну и последнее — засылка данных по таймеру:


 procedure TfmMain.EventsTimer(Sender: TObject);
 var
   Values:array [0..1] of Word;
   i:Integer;
 begin
   // формирование случайных значений
   Values[0]:=Random($ffff);
   Values[1]:=Random($ffff);
   // передача данных
   if Length(ModulesList)>0 then
     for i:=0 to Length(ModulesList)-1 do begin
       ModulesList[i].SetData(dkInputData,Values,SizeOf(Values));
     end;
 end;
 

Желательно не забывать об освобождении модулей. Это уже в самом конце (см. исходные тексты).




Можно ли определить полный путь и имя файла запущенной DLL из самой DLL

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


 uses Windows;
 
 procedure ShowDllPath stdcall;
 var
   TheFileName: array[0..MAX_PATH] of char;
 begin
   FillChar(TheFileName, sizeof(TheFileName), #0);
   GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName));
   MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok);
 end;
 




DLL - убийственная утилита

Программа МсLаud.ехе вызвала неустранимую ошибку в модуле kukushkа.dll при обращении к системному таймеру: Stасk Оvеrflоw. Кukushkа.dll будет закрыта. При повторном появлении ошибки обратитесь к разработчику МсLаud.ехе.

Вот маленький метод, взятый мною из небольшого проекта, созданного мною для удаления DLL из памяти. На форме присутствует одно поле редактирования TEdit с именем EditDLLName, кнопки Ok и Close. Следующий код выполняется при нажатии на кнопке Ok:


 procedure TForm1.OkBtnClick(Sender: TObject);
 var
   hDLL: THandle;
   aName: array[0..10] of char;
   FoundDLL: Boolean;
 begin
   if EditDLLName.Text = '' then
   begin
     MessageDlg('Сначала вы должны ввести имя выгружаемой DLL!', mtInformation,
       [mbOk], 0);
     exit;
   end;
   StrPCopy(aName, EditDLLName.Text);
   FoundDLL := false;
   repeat
     hDLL := GetModuleHandle(aName);
     if hDLL = 0 then
       break;
     FoundDLL := true;
     FreeLibrary(hDLL);
   until false;
   if FoundDLL then
     MessageDlg('Успешно!', mtInformation, [mbOk], 0)
   else
     MessageDlg('DLL не найдена!', mtInformation, [mbOk], 0);
   EditDLLName.Text := '';
 end;
 




Как создать DLL только с ресурсами

- Что общего между ЭВМ и половым членом?
- Оба имеют два устойчивых состояния - либо стоит, либо висит.

Создайте и откомпилируйте пустой проект DLL, который содержит ссылку на файл ресурсов .res, который содержит Ваши ресурсы.


 library ResTest;
 uses
   SysUtils;
 
 {$R MYRES.RES}
 
 begin
 end.
 

Для использования такой DLL, просто загрузите dll и ресурсы, которые Вы будете использовать:


 {$IFDEF WIN32}
 const
   BadDllLoad = 0;
 {$ELSE}
 const
   BadDllLoad = 32;
 {$ENDIF}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   h: THandle;
   Icon: THandle;
 begin
   h := LoadLibrary('RESTEST.DLL');
 
   if h <= BadDllLoad then
     ShowMessage('Bad Dll Load')
   else
   begin
     Icon := LoadIcon(h, 'ICON_1');
     DrawIcon(Form1.Canvas.Handle, 10, 10, Icon);
     FreeLibrary(h);
   end;
 end;
 




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

- Если встать между двумя программистами и загадать желание, то оно обязательно сбудется!
- Но желание будет глючить!

Делаешь текстовый файл с ресурсами, типа

--my.rc--
 STRINGTABLE
 {
 00001, "My String #1"
 00002, "My String #2"
 }
Далее компилируешь его:
brcc32 my.rc
У тебя получится my.res.

Делаешь DLL:

--my.dpr--


 library my;
 
 {$R my.res}
 
 begin
 
 end.
 

Компилируешь Дельфиским компилятором:

dcc32 my.dpr

Получаешь, наконец-то свою my.dll

Теперь о том, как использовать.

В своей программе:


 var
   h: THandle;
   S: array [0..255] of Char;
 begin
   h := LoadLibrary('MY.DLL');
   if h <= 0 then
     ShowMessage('Bad Dll Load')
   else
   begin
     SetLength(S, 512);
     LoadString(h, 1, @S, 255);
     FreeLibrary(h);
   end;
 end;
 




Описание протокола DNS (Domain Name System)

Ругательство программистов: Web твою мать!!!

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

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

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

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

Мне неизвестна ни одна машина с доменным именем из одного сегмента; очень редко используются доменные имена из двух сегментов; имена из трех и четырех сегментов составляют подавляющую долю всех имен Internet; имена из пяти сегментов встречаются довольно редко, а из шести и более мне неизвестны.

Допустим, клиент запросил адрес "www.организация.город.страна". Поиск информации по доменному имени происходит следующим образом:

  1. Клиент спрашивает своего сервера.
  2. Если тот является сервером данной зоны, то ответит, на чем все заканчивается.
  3. Сервер спрашивает корневой сервер.
  4. Тот не может ответить, потому что не знает; зато знает, какой сервер отвечают за зону "страна".
  5. Сервер зоны "страна" тоже не может ответить, но знает, что нужно спросить сервер зоны "город.страна".
  6. Тот в свою очередь отсылает запрос серверу зоны "организация.город.страна", который сообщит нужную информацию.

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

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

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

Хочу обратить особое внимание на сходство, различие и взаимодействие систем DNS и IP-маршрутизации. Как и IP-маршрутизация, DNS работает по принципу делегирования полномочий, но выделение доменных имен совершенно не зависит от выделения IP-адресов. Для примера рассмотрим домен freebsd.org. Это - домен организации, занимающейся распространением операционной системы FreeBSD Unix. FTP-сервер, содержащий дистрибутив операционной системы и множества утилит для нее, имеет копии в нескольких десятках стран. Имена серверов выглядят так:

ftp.freebsd.org
первичный сервер в США
ftp.страна.freebsd.org
основной сервер в стране
ftpчисло.страна.freebsd.org
дополнительный сервер в стране

Так например на 11 февраля 1998 года

  • ftp.ru.freebsd.org соответствует ftp.ru
  • ftp2.ru.freebsd.org соответствует ftp.gamma.ru
  • ftp3.ru.freebsd.org соответствует ftp.chg.ru

Таким образом, машины, находящиеся в России оказались произвольно (по воле DNS-мастера из университета Bercley) включенными в домен freebsd.org; однако, они также состоят в своих зонах. Система DNS позволяет любому DNS-мастеру включить любой сервер в свою зону, хотя это включение никого ни к чему не обязывает.

Однако, некоторым сервисам этого недостаточно - так E-mail требует, чтобы машина, принимающая письмо, признала своим адрес, указанный в качестве пункта назначения. Протокол HTTP 1.1 (в 1.0 этого не было) требует, чтобы в HTTP-запросе указывался не путь к файлу, отсчитанный от корня сервера (хотя такие запросы тоже признаются), но и имя сервера; при этом сам сервер знает, какие имена - его, а остальные обрезает и обслуживает в соответствии с HTTP 1.0.

Делегирование зоны ...in-addr.arpa дается только от провайдера вместе с IP-адресами. Собственно, это связано с предназначением ReverceDNS - сообщать доменное имя по IP-адресу. Наверняка мастер зоны freebsd.org держит Reverce-зону для IP-номеров, выделенных университету Bercley; но все эти серверы (кроме сервера, расположенного в университете) не входят в эту Reverce-зону, а значит, ему неподконтрольны.

Одна из проблем состит в том, что Reverce-зону можно выделить только на сеть класса A, B или C (на 16777216, 65536 или 256 адресов) и никак иначе. Можно получить правА на несколько зон одного или разных классов, но что делать тем, кому выделили меньше 256 адресов? А ведь в условиях исчерпания адресного пространства не редкость выделения пула уже на 16 адресов!

DNS-услуги Internet-провайдера

Как правило, провайдер предоставляет клиенту целый комплекс услуг. В число оказываемых DNS-услуг входят:

  • делегирование зоны ...in-addr.arpa клиентам, имеющим пул адресов, кратный 256.
  • регистрация доменного имени клиента у держателя той зоны, в которой клиент хочет зарегистрироваться;
  • поддержание вторичного сервера прямой и обратной DNS-зон клиента;
  • поддержание первичного сервера этих зон, если клиент по какой-либо причине не поддерживает их сам (особенно это относится к случаю виртуальных зон и к случаю выделения малого пула адресов);

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

Политика и стратегия назначения имен

Имена зон условно можно разделить на "организационные" и "географические". В высшей зоне зарегестрированы следующие "организационные" зоны:

com
commercial (коммерческие)
edu
educational (образовательные)
gov
goverment (правительственные)
mil
military (военные)
net
network (организации, обеспечивающие работу сети)
org
organization (некоммерческие организации)

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

Каждая страна (государство) имеет свой географический домен из двух букв:

ae
United Arab Emirates (Объединенные Арабские Эмираты)
au
Australia (Австралия)
be
Belgium (Бельгия)
br
Brazil (Бразилия)
by
Belarus (Белоруссия)
ca
Canada (Канада)
ch
Switzerland (Швейцария)
cz
Czech Republic (Чехия)
de
Germany (Германия)
dk
Denmark
do
Dominican Republic (Доминиканская республика)
ee
Estonia (Эстония)
eo
???
es
Spain (Испания)
fi
Finland (Финляндия)
fr
France (Франция)
hu
Hungary (Венгрия)
il
Israel (Израиль)
in
India (Индия)
iz
???
jp
Japan (Япония)
kg
Kyrgyzstan (Кыргызстан)
kr
South Korea (Южная Корея)
kz
Kazakhstan (Казахстан)
lt
Lithuania (Литва)
lv
Latvia (Латвия)
mx
Mexico (Мексика)
nl
Netherlands (Нидерланды)
no
Norway (Норвегия)
nz
New Zealand (Новая Зеландия)
pl
Poland (Польша)
ro
Romania (Румыния)
ru
Russia (Россия)
si
Slovenia (Словения)
sk
Slovak Republic (Словакия)
su
Soviet Union (Советский Союз - поддерживается, но не распределяется)
ua
Ukraine (Украина)
uk
United Kingdom (Соединенное Королевство ВеликоБритания / Англия)
yu
Yugoslavia (Югославия)
za
South Africa (Южная Африка)

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

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

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

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

Имена "функциональные" вытекают из функций, выполняемых машиной:

www
HTTP (WWW) сервер
ftp
FTP сервер
ns, nss, dns
DNS (Name) сервер
mail
Mail сервер
relay
Mail Exchanger
*proxy
соответствующий Proxy сервер

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




Как преобразовать DOC в RTF при помощи OLE

Создайте новое приложение и пометите на него: кнопку с именем Button3, объект RitchText с именем WordEditor и компонент OpenDialog. Теперь посмотрим, как пролистывать все файлы *.doc и загружать их в объект RitchText.

ЗАМЕЧАНИЕ: Format:=6 указывает Word-у на необходимость сохранять файл как RTF. Расширения недостаточно.

Другие форматы файлов:

 Format      File
 Argument    Format
 --------    ------
 
    0        Нормальный (формат Word)
    1        Шаблон документа
    2        Только текст (extended characters saved in ANSI character set)
    3        Текст+Переносы (plain text with line breaks; extended
             characters saved in ANSI character set)
    4        Только текст (PC-8) (extended characters saved in IBM PC
             character set)
    5        Текст+Переносы (PC-8) (text with line breaks; extended
             characters saved in IBM PC character set)
    6        Формат Rich-text (RTF)
 

 procedure TImport_Form.ToolButton3Click(Sender: TObject);
 var
   WordApp: Variant;
 begin
   if OpenDialog1.Execute then
   begin
     Edit1.Text := ExtractFileName(OpenDialog1.FileName);
     StatusBar1.SimpleText := OpenDialog1.FileName;
     WordApp := CreateOleObject('Word.Basic');
     if not VarIsEmpty(WordApp) then
     begin
       WordApp.FileOpen(OpenDialog1.FileName);
       WordApp.FileSaveAs(Name := 'c:\temp_bb.rtf', Format := 6);
       WordApp.AppClose;
       WordApp := Unassigned;
       WordEditor.Lines.LoadFromFile('c:\temp_bb.rtf');
     end
     else
       ShowMessage('Could not start MS Word');
   end;
 end;
 




Как избежать использования неактуальных указателей

Автор: David S. Becker

Программер просит у друга денег в долг:
- Одолжи 250$ до получки, ну или для ровного счета 256?

Я создал простой модуль и разработал несколько простых методов, помогающих избежать использования неактуальных (в оригинале было "stale" - черствый, несвежий) указателей. Я настоятельно рекомендую добавить во все модули, содержащие указатели или объектные переменные секцию инициализации ('initialization') и установить все указатели (объектные переменные это те же реальные указатели) в nil. Что это даст: прежде чем хотя бы один указатель будет использован, он обязательно будет проверен, освобожден и установлен в nil. Затем, после освобождения указателей, просто установите их в nil. Мой модуль содержит функцию Nilify() для установки указателей в nil, а также специальные версии методов Free, Dispose, и FreeMem (названные NilXXX) для проверки значения nil перед освобождением памяти, и установления указателя в nil сразу после того, как он был освобожден. Я также включил специальную версию Assigned(), названную IsNil(), которая вместо переменного (var) параметра получает константу, которую вы можете затем использовать в своих свойствах, и т.п.

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


 unit Pointers;
 
 {
 
 Автор: David S. Becker (dsb@plaza.ds.adp.com)
 Дата: 1/27/97
 Авторские права: Нет
 Дистрибутивные права: Свободные, неограниченное использование, в случае любых изменений кода
 с вашей стороны или наличия каких-либо замечаний или предложений пришлите их пожалуйста мне.
 
 Данный модуль создавался для помощи в управлении указателями и объектами. Так как
 компилятор не инициализирует указатели и объекты в nil и не сбрасывает
 их в nil при освобождении, существует вероятность применения неактуального
 указателя. По этой причине я рекомендую добавление секции 'initialization'
 во все модули и вызове Nilify() для всех указателей/объектов в данном модуле.
 Это позволит быть уверенным, что все указатели/объекты стартуют как nil.
 Кроме того, вместо стандартных аналогов, вы можете использовать NilFree
 (для объектов), NilDispose (для указателей, создаваемых с помощью New),
 и NilFreeMem (для указателей, создаваемых с помощью GetMem). Эти процедуры
 безопасны при вызове nil-вых указателей/объектов, так как перед выполнением
 любых действий они проверяют их на nil. После освобождения распределенной
 указателем/объектом памяти они сбрасываются в nil. Строгое соблюдение функций
 модуля значительно снижает риск использования неактуального указателя.
 (Конечно, вы еще можете получить неактуальные указатели из VCL, т.к.
 они, естественно, не используют данные функции.)
 }
 
 {==============================================================================}
 interface
 
 {------------------------------------------------------------------------------}
 { Проверка указателя на nil }
 { ПРИМЕЧАНИЕ: Данная функция отличается от Assigned() тем, что Assigned() }
 { требует переменную, а IsNil() нет.                                      }
 function IsNil(const p: Pointer): Boolean;
 { Устанавливает указатель в nil }
 procedure Nilify(var p);
 { Освобождает не-nil объект и устанавливает его в nil }
 procedure NilFree(o: TObject);
 { Освобождает не-nil указатель, созданный с помощью New и устанавливает его в nil }
 procedure NilDispose(var p: Pointer);
 { Освобождает не-nil указатель и устанавливает его в nil }
 procedure NilFreeMem(var p: Pointer; size: Word);
 
 {==============================================================================}
 implementation
 
 {------------------------------------------------------------------------------}
 
 function IsNil(const p: Pointer): Boolean;
 begin
 
   Result := (p = nil);
 end;
 
 {------------------------------------------------------------------------------}
 
 procedure Nilify(var p);
 begin
 
   Pointer(p) := nil;
 end;
 
 {------------------------------------------------------------------------------}
 
 procedure NilFree(o: TObject);
 begin
 
   if not IsNil(o) then
   begin
     o.Free;
     Nilify(o);
   end;
 end;
 
 {------------------------------------------------------------------------------}
 
 procedure NilDispose(var p: Pointer);
 begin
 
   if not IsNil(p) then
   begin
     Dispose(p);
     Nilify(p);
   end;
 end;
 
 {------------------------------------------------------------------------------}
 
 procedure NilFreeMem(var p: Pointer; size: Word);
 begin
 
   if not IsNil(p) then
   begin
     FreeMem(p, size);
     Nilify(p);
   end;
 end;
 
 end.
 




Как получить дескриптор окна Windows, содержащего DOS программу

Hiroshima-45... Chernobyl-86... Windows-95...

В следуещем примере используется функция Windows API FindWindow(). Обратите внимание, что WndClass консольного окна отличаются для Windows 95 и Window NT и заголовок окна может содержать полный путь под Windows NT.

Пример:


  procedure TForm1.Button1Click(Sender: TObject); 
  var 
    info : TOSVersionInfo; 
    ClassName : string; 
    Title : stringbegin 
   {Проверяем -  Win95 или NT.} 
    info.dwOSVersionInfoSize := sizeof(info); 
    GetVersionEx(info); 
    if (info.dwPlatformId = VER_PLATFORM_WIN32_NT) then begin 
      ClassName := 'ConsoleWindowClass'; 
      Title := 'Command Prompt'; 
    end else begin 
      ClassName := 'tty'; 
      Title := 'MS-DOS Prompt'; 
    end; 
    ShowMessage(IntToStr(FindWindow(PChar(ClassName), PChar(Title)))); 
  end;
 




Выключение питания ATX коpпуса из-под DOS

Автор: Колесников Сергей Александрович

Вам пора завязывать с компьютером, если ложась спать и закрыв глаза, вы ждете надписи "Теперь можно выключить питание".


         mov ax,5301h
         sub bx,bx
         int 15h
         jb stop
         mov ax,530eh
         sub bx,bx
         int 15h
         jb stop
         mov ax,5307h
         mov bx,0001h
         mov cx,0003h
         int 15h
   stop: int 20h
 

или


 mov ax,5301h
     sub bx,bx
     int 15h
     jc @@finish
     mov ax,530Eh
     sub bx,bx
     mov cx,102h
     int 15h
     jc @@finish
     mov ax,5307h
     mov bx,1
     mov cx,3
     int 15h
 @@finish:
     int 20h
 
 




DOS команды

...Ну! И кто открывал бутылку об F8 ?!

rundll32 shell32.dll,Control_RunDLL
Выводит панель управления

rundll32 shell32.dll,OpenAs_ RunDLL
Выводит окошко «Открыть с помощью...»

rundll32 shell32.dll,ShellAboutA Info-Box
Показать окно «About Windows»

rundll32 shell32.dll,Control_RunDLL desk.cpl
Открыть свойства экрана

rundll32 user,cascadechildwindows
Сортировка окон каскадом

rundll32 user,tilechildwindows
Сортировка окон вниз

rundll32 user,repaintscreen
Обновить рабочий стол

rundll32 shell,shellexecute Explorer
Запустить проводник Windows

rundll32 keyboard,disable
Вырубить клавиатуру

rundll32 mouse,disable
Вырубить мышь

rundll32 user,swapmousebutton
Поменять местами кнопки мыши

rundll32 user,setcursorpos
Сместить курсор крысы в левый верхний угол

rundll32 user,wnetconnectdialog
Вызвать окно «Подключение сетевого диска»

rundll32 user,wnetdisconnectdialog
Вызвать окно «Отключение сетевого диска»

rundll32 user,disableoemlayer
Спровоцировать сбой

rundll32 diskcopy,DiskCopyRunDll
Показать окно «Copy Disk»

rundll32 maui.dll,RnaWizard
Вывод окна «Установка связи», с ключом «/1» - без окна

rundll32 shell32,SHFormatDrive
Вызвать окно «Форматирование диск 3,5(А)»

rundll32 shell32,SHExitWindowsEx-1
Перегрузить explorer

rundll32 shell32,SHExitWindowsEx 1
Выключение компьютера

rundll32 shell32,SHExitWindowsEx 0
Завершить работу текущего пользователя

rundll32 shell32,SHExitWindowsEx 2
Windows-98-PC boot

rundll32 krnl386.exe,exitkernel
Выход из Windows без любых вопросов

rundll maui.dll,RnaDial”MyConnect”
Вызвать окно «Установка связи» с соединением «MyConnect»

rundll32 msprint2.dll,RUNDLL_PrintTestPage
Выбрать в появившемся окне принтер и послать на него тест

rundll32 user,setcaretblinktime
Установить новую частоту мигания курсора

rundll32 user,setdoubleclicktime
Установить новую скорость двойного нажатия

rundll32 sysdm.cpl,InstallDevice_Rundll
Установить non-Plug&Play оборудование



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

Чайник y хакеpа спpашивает, что такое UNIX, Windows'95, OS/2 и DOS?
- Hy пpедставь себе аэpопоpт. Hа взлетной полосе стоит навоpоченный кpасивый самолет. Пассажиpы в него заходят - там ковpы везде, все класно. Запyскают двигатели - и самолет медленно объезжает вокpyг аэpопоpта, после чего пассажиpы выходят. Вот это полyось. Hа дpyгой полосе стоит еще один самолет - тоже весь из себя, внyтpи ковpы. Садяться в него пассажиpы, самолет pазгоняется, взлетает, и тyт же pазваливается на кyски - это Windows. А в стоpоне на поле стоит стаpый, помятый, гpязный кyкypyзник - пассажиpы подходят, кладyт вещи, потом толкают самолет, pазгоняют его и сами запpыгивают - потом с тpyдом летят - это DOS.
- А что такое UNIX?
- Ну я же тебе говорил: - Представь себе аэропорт...

При использовании DOS DBF файлов можно сделать небольшую программку (или процедурку), которая произведет перекодировку между форматами. что-то типа:


 function update_dos(s:string):string;
 var c:STRING;
     I:INTEGeR;
     l:byte;
     dd:char;
 begin
  i:=1;
  c:='';
  while i< length(s)+1 do
  begin
    l:=ord(s[i]);
    inc(i);
    if (l>=128) and (l<=192)then l:=l+64 else
    if (l>=224) and (l<240) then l:=l+16 else
    if l=241 then l:=184 else
    if l=240 then l:=168;
    dd:=chr(l);
    c:=c+dd;
  end;
 update_dos:=c;
 end;
 
 function update_win(s:string):string;
 var c:STRING;
     I:INTEGeR;
     l:byte;
     dd:char;
 begin
  i:=1;
  c:='';
  while i< length(s)+1 do
  begin
    l:=ord(s[i]);
    inc(i);
    if (l>=192) and (l<240)then l:=l-64 else
    if (l>=240) and (l<256) then l:=l-16 else
    if l=184 then l:=241 else
    if l=168 then l:=240;
    dd:=chr(l);
    c:=c+dd;
  end;
 update_win:=c;
 end;
 

это и туда и обратно, у меня работает на старых DBF. Осталось только вызвать в нужный момент.




Получение переменных окружения DOS

Автор: Dr. Bob

- Служба технической подержки, здравствуйте!
- У меня не запускается компьютер. Ваш высокоскоростной интернет сломал его.
- Что вы имеете ввиду?
- Я говорю вам, он не запускается.
- Он работал, когда наш специалист был у Вас.
- Да, он перестал работать после того, как я его накрыла.
- Накрыли?
- Я накрыла его пластиковой пленкой, чтобы туда не пропадали кошачьи волосы. У меня много кошек. Не плохая идея, на правда ли?

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

Функция GetEnvironmentVariable возвращает значения переменных среды опрашиваемого процесса. Величина также возвращается в виде строки с завершающим нулем.




Получение переменных окружения DOS 2


 unit TDosEnv;
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs;
 
 type
   TDosEnvironment = class(TComponent)
   public
     { Public объявления класса }
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
 
   private
     { Объявления Private-полей }
     FDosEnvList: TStringList;
     procedure DoNothing(const Value: TStringList);
 
   protected
     { Объявления Protected-методов }
     dummy: Word;
     function GetDosEnvCount: Word;
 
   public
     { Public interface объявления }
     function GetDosEnvStr(const Name: string): string;
     { Данная функция является измененной версией функции GetEnvVar,
     присутствующей в поставляемом с Delphi модуле WinDos. Она
     использует паскалевские строки вместо строк с терминирующим нулем.
     }
 
   published
     { Published design объявления }
     property DosEnvCount: Word read GetDosEnvCount write dummy;
     property DosEnvList: TStringList read FDosEnvList write DoNothing;
   end;
 
 procedure Register;
 
 implementation
 
 constructor TDosEnvironment.Create(AOwner: TComponent);
 var
   P: PChar;
   i: Integer;
 begin
   inherited Create(AOwner);
   FDosEnvList := TStringList.Create;
   P := GetDosEnvironment; { Win API }
   i := 0;
   while P^ <> #0 do
   begin
     Inc(i);
     FDosEnvList.Add(StrPas(P));
     Inc(P, StrLen(P) + 1) { Быстрый переход к следующей переменной }
   end
 end {Create};
 
 destructor TDosEnvironment.Destroy;
 begin
   FDosEnvList.Free;
   FDosEnvList := nil;
   inherited Destroy
 end {Destroy};
 
 procedure TDosEnvironment.DoNothing(const Value: TStringList);
 begin
   MessageDlg('TDosEnvironment.DosEnvList только для чтения!', mtInformation,
     [mbOk], 0)
 
 end {DoNothing};
 
 function TDosEnvironment.GetDosEnvCount: Word;
 { Возвращает количество переменных окружения.
 }
 begin
   if Assigned(FDosEnvList) then {!!}
     Result := FDosEnvList.Count
   else
     Result := 0;
 end {GetDosEnvCount};
 
 function TDosEnvironment.GetDosEnvStr(const Name: string): string;
 { Данная функция является измененной версией функции GetEnvVar,
 присутствующей в поставляемом с Delphi модуле WinDos. Она
 использует паскалевские строки вместо строк с терминирующим нулем.
 }
 var
   i: Integer;
   Tmp: string;
   Len: Byte absolute Name;
 begin
   i := 0;
   Result := '';
   if Assigned(FDosEnvList) then {!!}
     while i < FDosEnvList.Count do
     begin
       Tmp := FDosEnvList[i];
       Inc(i);
       if Pos(Name, Tmp) = 1 then
       begin
         Delete(Tmp, 1, Len);
         if Tmp[1] = '=' then
         begin
           Delete(Tmp, 1, 1);
           Result := Tmp;
           i := FDosEnvList.Count { конец while-цикла }
         end
       end
     end
 end {GetDosEnvStr};
 
 procedure Register;
 begin
   RegisterComponents('Dr.Bob', [TDosEnvironment]);
 end {Register};
 
 end.
 




Считывать строки из текстового DOS файла

Автор: Dimka Maslov

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


 procedure ReadDosTextFile(FileName: string; List: TStrings);
 var
  S: string;
  i: integer;
 begin
  List.BeginUpdate;
  try
   List.LoadFromFile(FileName);
   for i:=0 to List.Count - 1 do begin
    S:=List[i];
    OemToChar(PChar(S), PChar(S));
    List[i]:=S;
   end;
  finally
   List.EndUpdate;
  end;
 end;
 
 procedure WriteDosTextFile(FileName: string; List: TStrings);
 var
  S: string;
  I: integer;
  L: TStringList;
 begin
  L:=TStringList.Create;
  try
   L.Assign(List);
   for i:=0 to L.Count - 1 do begin
    S:=L[i];
    CharToOem(PChar(S), PChar(S));
    L[i]:=S;
   end;
   L.SaveToFile(FileName);
  finally
   L.Free;
  end;
 end;
 




Как сделать имитацию ввода с клавиатуры для программы выполняющейся в DOS-окне

Автор: Nomadic

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


 const
 
   ExtendedKeys: set of Byte = [ // incomplete list
   VK_INSERT, VK_DELETE, VK_HOME, VK_END, VK_PRIOR, VK_NEXT,
     VK_LEFT, VK_UP, VK_RIGHT, VK_DOWN, VK_NUMLOCK
     ];
 
 procedure SimulateKeyDown(Key: byte);
 var
 
   flags: DWORD;
 begin
 
   if Key in ExtendedKeys then
     flags := KEYEVENTF_EXTENDEDKEY
   else
     flags := 0;
   keybd_event(Key, MapVirtualKey(Key, 0), flags, 0);
 end;
 
 procedure SimulateKeyUp(Key: byte);
 var
 
   flags: DWORD;
 begin
 
   if Key in ExtendedKeys then
     flags := KEYEVENTF_EXTENDEDKEY
   else
     flags := 0;
   keybd_event(Key, MapVirtualKey(Key, 0), KEYEVENTF_KEYUP or flags, 0);
 end;
 
 procedure SimulateKeystroke(Key: byte);
 var
 
   flags: DWORD;
   scancode: BYTE;
 begin
 
   if Key in ExtendedKeys then
     flags := KEYEVENTF_EXTENDEDKEY
   else
     flags := 0;
   scancode := MapVirtualKey(Key, 0);
   keybd_event(Key,
     scancode,
     flags,
     0);
   keybd_event(Key,
     scancode,
     KEYEVENTF_KEYUP or flags,
     0);
 end;
 




Как скачать любой URL используя стандартные настройки сети


- Почему русские не выдвигаются в правительство Норвегии?
- А вы хотите, чтобы у вас был е-майл premier-ministr@gov.no?

Начиная с Internet Explorer 3, Microsoft поддерживает очень полезные API, Wininet. Эти функции позволяют использовать все возможности IE, такие как настройки прокси, кэширование файлов и т.д.

Ниже приведён пример использования этих функций для скачивания файла с нужного URL. Это может быть любой доступный URL, ftp://, http://, gopher://, и т.д.

Более подробную информацию об этих функция можно посмотреть в MSDN - Win32 Internet API Functions.


 function DownloadFile(const Url: string): string;
 var
   NetHandle: HINTERNET;
   UrlHandle: HINTERNET;
   Buffer: array[0..1024] of char;
   BytesRead: cardinal;
 begin
   Result := '';
   NetHandle := InternetOpen('Delphi 5.x', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
 
   if Assigned(NetHandle) then
   begin
 
     UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);
 
     { UrlHandle правильный? Начинаем загрузку }
     if Assigned(UrlHandle) then
     begin
       FillChar(Buffer, SizeOf(Buffer), 0);
       repeat
         Result := Result + Buffer;
         FillChar(Buffer, SizeOf(Buffer), 0);
         InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
       until
         BytesRead = 0;
       InternetCloseHandle(UrlHandle);
     end
     else
     begin
       { UrlHandle неправильный. Генерируем исключительную ситуацию. }
       raise Exception.CreateFmt('Cannot open URL %s', [Url]);
     end;
 
     InternetCloseHandle(NetHandle);
   end
   else
     { NetHandle недопустимый. Генерируем исключительную ситуацию }
     raise Exception.Create('Unable to initialize Wininet');
 end;
 
 //-------------------------------------------------
 
 implementation
 
 uses
   SysUtils,Windows,ShlObj;
 
 function NetShareAdd(ServerName:PChar; //указатель на имя компьютера, например '\\Server'#0, если свой, то можно nil
   Level:Word; //уровень структуры Share_info, здесь 50
   PShareInfo:PChar; //указатель на структуру Share_Info
   ParmErr:DWord) //указатель на ???
   :dword;stdcall;external 'svrapi.dll';//svrapi для Win9X, NetApi32 для NT
 
 function NetShareDel(ServerName:PChar;
   NetName:PChar;
   Reserved:DWord):dword;stdcall;external 'svrapi.dll';
 
 type
   _share_info_50 = record //структура Share уровня 50
   NetName: array [1..13] of char; //Как будет называться диск в сети
   SType: byte; //тип =0 (STYPE_DISKTREE) - шарить диски
   Flags: word; //флаги $0191,$0192,$0193....(доступ из сети)
   Remark: PChar; //указатель на комментарий, видимый из сети
   Path: PChar; //указатель на имя ресурса, например 'c:\'#0
   RW_Password: array [1..9] of char; //пароль для полного доступа, если не нужен =#0
   RO_Password: array [1..9] of char; //пароль для доступа на чтение, если не нужен =#0
 end;
 
 //----------------------------
 
 function SetShareOnDisk(HostName,LocalPath:string; NetName:TNetName;Remark:string;
   Access:word;RO_Passw,RW_Passw:TPassw):boolean; var ShareInfo:_Share_Info_50;
 begin
   Result:=false;
   StrPCopy(@ShareInfo.NetName,NetName);
   ShareInfo.SType:=0;
   ShareInfo.Flags:=Access;
   ShareInfo.Remark:=PChar(Remark);
   ShareInfo.Path:=PChar(LocalPath);
   StrPCopy(@ShareInfo.RO_Password,RO_Passw);
   StrPCopy(@ShareInfo.RW_Password,RW_Passw);
   ShareResult:=NetShareAdd(PChar(HostName), 50,@ShareInfo,$0000002a); //вызываем Share
   if ShareResult <> 0 then //расшарить неудалось
     Exit;
   SHChangeNotify(SHCNE_NETSHARE,SHCNF_PATH,PChar(LocalPath),nil); //сказать шеллу об изменениях
   Result:=true;
 end;
 
 //----------------------------
 
 function RemoveShareFromDisk(HostName, NetName, LocalPath: string): boolean;
 begin
   Result:=false;
   ShareResult:=NetShareDel(PChar(HostName),PChar(NetName),0); //удалить шару
   if ShareResult <> 0 then
     Exit;
   SHChangeNotify(SHCNE_NETUNSHARE, SHCNF_PATH,PChar(LocalPath),nil); //сказать шеллу об изменениях
   Result:=true;
 end;
 
 end.
 




Закачать файл из Интернета

Сколько пользуюсь интернетом - никак не могу понять: я вхожу в интернет или я выхожу в интернет?


 uses
   URLMon, ShellApi;
 
 function DownloadFile(SourceFile, DestFile: string): Boolean;
 begin
   try
     Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, nil) = 0;
   except
     Result := False;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
   // URL Location 
   SourceFile = 'http://www.google.com/intl/de/images/home_title.gif';
   // Where to save the file 
   DestFile = 'c:\temp\google-image.gif';
 begin
   if DownloadFile(SourceFile, DestFile) then
   begin
     ShowMessage('Download succesful!');
     // Show downloaded image in your browser 
     ShellExecute(Application.Handle, PChar('open'), PChar(DestFile),
       PChar(''), nil, SW_NORMAL)
   end
   else
     ShowMessage('Error while downloading ' + SourceFile)
 end;
 
 // Minimum availability: Internet Explorer 3.0 
 // Minimum operating systems Windows NT 4.0, Windows 95 
 
 {********************************************************}
 
 {2.}
 
 
 uses
   Wininet;
 
 function DownloadURL(const aUrl: string): Boolean;
 var
   hSession: HINTERNET;
   hService: HINTERNET;
   lpBuffer: array[0..1024 + 1] of Char;
   dwBytesRead: DWORD;
 begin
   Result := False;
   // hSession := InternetOpen( 'MyApp', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0); 
   hSession := InternetOpen('MyApp', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
   try
     if Assigned(hSession) then
     begin
       hService := InternetOpenUrl(hSession, PChar(aUrl), nil, 0, 0, 0);
       if Assigned(hService) then
         try
           while True do
           begin
             dwBytesRead := 1024;
             InternetReadFile(hService, @lpBuffer, 1024, dwBytesRead);
             if dwBytesRead = 0 then break;
             lpBuffer[dwBytesRead] := #0;
             Form1.Memo1.Lines.Add(lpBuffer);
           end;
           Result := True;
         finally
           InternetCloseHandle(hService);
         end;
     end;
   finally
     InternetCloseHandle(hSession);
   end;
 end;
 




Качаем с докачкой

В Японии скончался старейший пингвин в мире.
Linux объявил 3-х дневный траур...


 // ПРЕДИСЛОВИЕ:
 
 {
 Копаясь как-то в исходниках модулей третьей Delphi, я наткнулся на файл,
 который назывался WinInet.pas. Имея врожденное любопытство, я заглянул
 в него и нашел там очень много интересных вещей. О некоторых из них я
 попытаюсь рассказать в данной статье, в частности, как, используя этот
 модуль, организовать докачку файлов при обрыве связи. В модуле WinInet.pas
 содержатся описания прототипов функций и некоторых типов входящих в т.н.
 Microsoft Windows Internet Extensions, описания которых я не нашел в
 справочной системе (хотя может плохо искал) :-(. Поэтому пришлось идти
 почти вслепую.
 }
 
 // ТЕОРИЯ:
 
 {
 Для начала рассмотрим все функции, константы и типы, которые мы будем
 использовать:
 }
 
 // 1) HINTERNET, вот как он описан:
 
  type
    HINTERNET = Pointer;
    PHINTERNET = ^HINTERNET;
 
 // При детальном рассмотрении, это обычный указатель.
 // 2) функции InternetOpen и InternetCloseHandle:
 
   function InternetOpen(lpszAgent: PChar; dwAccessType: DWORD;
     lpszProxy, lpszProxyBypass: PChar; dwFlags: DWORD): HINTERNET; stdcall;
 
 {
     где:
     lpszAgent      <-|Имя программы, с помощью которой мы соединяемся,
                      |может принимать любые значения
     dwAccessType   <-|Каким макаром соединяться с и-нетом
                      |принимаемые значения:
                      | PRE_CONFIG_INTERNET_ACCESS -как в системном реестре
                      | LOCAL_INTERNET_ACCESS      -напрямую
                      | GATEWAY_INTERNET_ACCESS    -через GateWay
                      | CERN_PROXY_INTERNET_ACCESS -через проксю
     lpszProxy      <-|Имя прокси сервера (ставим в nil)
     lpszProxyBypass<-|Не уверен, но смахивает на имена хостов, для которых не
                      |использовать проксю (ставим в nil)
     dwFlags        <-|Принимаеемые значения:
                      | INTERNET_FLAG_ASYNC  -этот запрос асинхронный (если есть
                      |                       поддержка), но мы поставим 0
 
 }
 
 // возвращает пресловутый HINTERNET, который будет требоваться при вызове
 // всех остальных функций. С вызова этой функции начинается вся наша работа
 // с интернетом, а с вызова второй заканчивается.
 
   function InternetCloseHandle(hInet: HINTERNET): BOOL; stdcall;
 
 // где: nInet ранее созданый указатель.
 // 3) функция InternetOpenUrl:
 
   function InternetOpenUrl(hInet: HINTERNET; lpszUrl: PChar;
                lpszHeaders: PChar; dwHeadersLength: DWORD; dwFlags: DWORD;
                dwContext: DWORD): HINTERNET; stdcall;
 
 {
  где:
    hInet          <-|Ранее созданый указатель
    lpszUrl        <-|Сам УРЛ
    lpszHeaders    <-|Дополнительные строки в НТТР запрос
    dwHeadersLength<-|Длинна предыдущего
    dwFlags        <-|Принимаемые значения:
                     | INTERNET_FLAG_RAW_DATA -принимать как RAW данные
                     | INTERNET_FLAG_EXISTING_CONNECT -не создавать для
                     |                                 объекта нового соединения
                     |                                 (поставим в 0)
    dwContext      <-|пока не знаю, ставим в 0
 }
 
 // Функция возвращает HINTERNET, указывающий на конкретный файл (далее он в
 // параметрах функций будет называться hFile).
 
 // 4) функция InternetReadFile:
 
   function InternetReadFile(hFile: HINTERNET; lpBuffer: Pointer;
     dwNumberOfBytesToRead: DWORD; var lpdwNumberOfBytesRead: DWORD): BOOL; stdcall;
 
 {
  где:
     hFile                <-|Указатель, созданый предыдущей функцией
     lpBuffer             <-|Указатель на буфер куда читать
     dwNumberOfBytesToRead<-|Сколько максимум читать (можно сказать размер
                            | буфера, хотя не факт)
     lpdwNumberOfBytesRead<-|Сколько реально прочитано байт
 }
 
 // Этой функой мы будем читать файл из и-нета.
 // 5) функция InternetSetFilePointer:
 
   function InternetSetFilePointer(hFile: HINTERNET;
              lDistanceToMove: Longint; pReserved: Pointer;
              dwMoveMethod, dwContext: DWORD): DWORD; stdcall;
 {
  где:
    hFile          <-|Указатель созданый функцией InternetOpenUrl
    lDistanceToMove<-|На сколько байт смещать указатель
    pReserved      <-|??
    dwMoveMethod   <-|Как смещать (=0)
    dwContext      <-|??
 }
 
 // Собственно, эта функция и поможет нам организовать докачку. Она смещает
 // указатель в файле, после чего передача файла начнется с этого места.
 
 // В принципе этих данных уже достаточно для наших целей, но есть еще одна
 // полезная функция, которая пригодится нам:
 
  function InternetQueryDataAvailable(hFile: HINTERNET; var lpdwNumberOfBytesAvailable: DWORD;
                                      dwFlags, dwContext: DWORD): BOOL; stdcall;
 {
   где:
    hFile                     <-|Указатель, созданный функцией InternetOpenUrl
    lpdwNumberOfBytesAvailable<-|Сколько осталось байт
    dwFlags                   <-|??
    dwContext                 <-|??
 }
 
 // Как вы уже догадались, с помощью этой функции можно узнать сколько
 // осталось байт скачать (или размер файла, если вызвать ее сразу после
 // InternetOpenUrl).
 
 //Ну, собственно, и все по теории.
 
 // ПРАКТИКА:
 

Условия задачи:

  1. Скачиваемый файл сохраняется как c:\123.tmp
  2. При очередном старте скачки идет проверка на наличие оного файла на винте, если он есть, считаем что надо докачивать. Размер этого файла является признаком того, с какого места надо качать.

    Требуемые материалы:

    • Форма (TForm)-1 шт.
    • Кнопки (TButton)-2 шт.
    • Строка ввода (TEdit)-1 шт.
    • Progress bar для красоты (TProgressBar)-1 шт.
    • Метки (TLabel)-по необходимости.

Далее идет полный листинг модуля:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   wininet,
   StdCtrls, ComCtrls;
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit; //<-строка для УРЛа
     Label1: TLabel;
     Button1: TButton; //<-кнопка Start
     Button2: TButton; //<-кнопка Stop
     ProgressBar1: TProgressBar; //<-декорация
     procedure Button1Click(Sender: TObject); //<-|процедура начала скачки
     procedure Button2Click(Sender: TObject); //<-|принудительный обрыв
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
   stop: boolean; //<-|вспомогательная переменная отв. за
   //  |остановку скачки
 implementation
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   hInet, //<-переменная сод. указатель на сессию
   hURL: HINTERNET; //<-указатель на URL
   fSize, //<-размер файла
   ReadLen, //<-количество реально прочитанных байт
   RestartPos: DWORD; //<-|позиция с которой начинается
   //  |докачка
   fBuf: array[1..1024] of byte; //<-буфер куда качаем
   f: file; //<-файл куда качаем
   Header: string; //<-|дополнительная переменная в HTTP
   //  |заголовок
 begin
   RestartPos := 0; //<- |инициализация
   fSize := 0; //<- |переменных
   Button1.Enabled := false;
   Button2.Enabled := true;
   //Если на винте есть файл то считаем, что нужно докачивать
   if FileExists('c:\123.tmp') then
   begin
     AssignFile(f, 'c:\123.tmp');
     Reset(f, 1);
     RestartPos := FileSize(F);
     Seek(F, FileSize(F));
   end
   else
   begin
     //иначе с начала
     AssignFile(f, 'c:\123.tmp');
     ReWrite(f, 1);
   end;
   //открываем сессию
   hInet := InternetOpen('Mozilla',
     PRE_CONFIG_INTERNET_ACCESS,
     nil,
     nil,
     0);
   //Пишем дополнительную строку для заголовка
   Header := 'Accept: */*';
   //открываем URL
   hURL := InternetOpenURL(hInet,
     PChar(Edit1.Text),
     pchar(Header),
     StrLen(pchar(Header)),
     0,
     0);
   //устанавливаем позицию в файле для докачки
   if RestartPos > 0 then
     InternetSetFilePointer(hURL,
       RestartPos,
       nil,
       0,
       0);
   //смотрим ск-ко надо скачать
   InternetQueryDataAvailable(hURL, fSize, 0, 0);
   if RestartPos > 0 then
   begin
     ProgressBar1.Min := 0;
     ProgressBar1.Max := fSize + RestartPos;
     ProgressBar1.Position := RestartPos;
   end
   else
   begin
     ProgressBar1.Min := 0;
     ProgressBar1.Max := fSize + RestartPos;
   end;
   //качаем до тех пор пока реально прочитаное число байт не
   //будет равно нулю или не стор
   while (ReadLen <> 0) and (stop = false) do
   begin
     //читаем в буфер
     InternetReadFile(hURL, @fBuf, SizeOf(fBuf), ReadLen);
     //смотрим ск-ко осталось докачать
     InternetQueryDataAvailable(hURL, fSize, 0, 0);
     ProgressBar1.Position := ProgressBar1.Max - fSize;
     BlockWrite(f, fBuf, ReadLen); //<-пишем в файл
     Application.ProcessMessages;
   end;
   stop := false;
   Button1.Enabled := true;
   Button2.Enabled := false;
   InternetCloseHandle(hURL); //<-|закрываем
   InternetCloseHandle(hInet); //<-|сесcии
   CloseFile(f); //<-|и файл
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   stop := false; //<-прервать скачку
   Button2.Enabled := false; //<-кнопка останова скачки
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   stop := true; //<-сообщаем о необходимости прерывания скачки
 end;
 
 end.
 




Drag and Drop из TScrollBox

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


 procedure TForm1.GenericMouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   TImage(Sender).BeginDrag(False);
   {что-то другое, что вы хотели бы сделать}
 end;
 
 {....}
 
 UmpteenthDynImage := TImage.Create(dummyImage);
 UmpteenthDynImage.MouseDown := TForm1.GenericMouseDown;
 

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




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



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



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


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