DirectX для начинающих. Считывание и запись

Привет всем, кто интересуется программированием под DirectX на языке Object Pascal!

Как и обещал, я продолжаю искать новый материал по DirectX, переводить его на язык Object Pascal и представлять всеобщему вниманию. Недавно у меня появилась идея снятия скриншотов с экрана DirectDraw-программы и записи изображения в простой bmp-файл - некоторые игры позволяют это делать, и я решил последовать их примеру. Потом я наткнулся на другой интересный материал - речь шла о загрузке изображения из bmp-файла без использования функции LoadImage(). Поэтому тема статьи всецело посвящена работе с bmp-файлами на "низком уровне". Замечу, что это немного сложные вещи, но мы ведь сложностей не боимся, правда? Иначе непонятно, зачем тогда заниматься изучением DirectX вообще.

Замечания

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

Немного изменилась реализация модуля ddutils.pas - теперь функция CreateSurface() не требует адрес главного интерфейса IDirectDraw, а создаёт и уничтожает локальный интерфейс. Возможно, более практично с точки зрения Pascal-программирования было бы объявить глобальный для модуля ddutils.pas интерфейс IDirectDraw, а для создания и удаления интерфейса воспользоваться секциями initialization и finalization модуля.

Также немного изменился стиль написания программ, теперь он совсем грешит С-подобным кодом :-)

FASTFILE1



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

С помощью функции LoadImage() загружался растр и нам сообщался идентификатор загруженного растра в виде переменной типа HBITMAP;
Функцией SelectObject() в контекст-источник выбирался созданный растр;
Методом IDirectDrawSurface7.GetDC() создавался GDI-совместимый дескриптор контекста-приёмника и осуществлялась блокировка поверхности;
Функцией GDI BitBlt() содержимое контекста-источника копировалось на контекст-приёмник.
Методом IDirectDrawSurface7.ReleseDC() удалялся созданный контекст и осуществлялась разблокировка поверхности.
В чём недостатки такого подхода? В универсальности. Не скажу, что функция LoadImage() очень медленная, но и очень быстрой она не является. Во всяком случае, программисты, писавшие её, не ставили своей задачей обеспечить максимальную скорость загрузки. Посмотрите справку по этой функции (файл win32sdk.hlp) - обилие параметров и констант, задаваемых при вызове, наводят на мысль о том, что она довольно "тяжеловесна". В частности, сказано, что с её помощью можно загружать не только растры из bmp-файлов разных форматов (в их число входят монохромные, 16- и 256-цветные палитровые файлы, а также беспалитровые 24-битные файлы), но и файлы иконок Windows и даже файлы, содержащие изображения курсоров.

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

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



Хранящийся на диске файл DIB, обычно с расширением .bmp, как видно, начинается со структуры BITMAPFILEHEADER, позволяющей начать работу с файлом. Вот как эта структура описана в файле windows.pas:

tagBITMAPFILEHEADER= packed record
  bfType: Word;      // Тип файла. Должен содержать 'BM' ($4d42)
  bfSize: DWORD;     // Размер файла в байтах
  bfReserved1: Word; // Зарезервировано, должен быть нуль
  bfReserved2: Word; // Зарезервировано, должен быть нуль
  bfOffBits: DWORD;  // Смещение от начала файла до гафических данных
end;
BITMAPFILEHEADER = tagBITMAPFILEHEADER;

Следом за структурой BITMAPFILEHEADER следует стуктура BITMAPINFO:

tagBITMAPINFO = packed record
  bmiHeader: TBitmapInfoHeader; // Структура BITMAPINFOHEADER
  bmiColors: array[0..0] of TRGBQuad; // RGB-триплекс
end;
BITMAPINFO = tagBITMAPINFO;

Фактически, стуктура BITMAPINFO включает в себя ещё одну структуру - BITMAPINFOHEADER:

tagBITMAPINFOHEADER = packed record
  biSize: DWORD; // Размер самой структуры в байтах
  biWidth: Longint; // Ширина растра в пикселях
  biHeight: Longint; // Высота растра в пикселях
  biPlanes: Word; // Количество плоскостей (всегда 1)
  biBitCount: Word; // Количество бит на 1 пиксель
  biCompression: DWORD; // Тип сжатия (BI_RGB - без сжатия)
  biSizeImage: DWORD; // Размер изображения в байтах (обычно 0)
  biXPelsPerMeter: Longint; // А эти данные
  biYPelsPerMeter: Longint; // нам вообще
  biClrUsed: DWORD; // никогда не
  biClrImportant: DWORD; // понадобятся :)
end;
BITMAPINFOHEADER = tagBITMAPINFOHEADER;

Эта структура для нас наиболее интересна, так как опираясь на её данные, и будет производиться загрузка растра. Несмотря на обилие полей, нам понадобятся только некоторые - это biWidth, biHeight и ещё поле biBitCount - для проверки, является ли файл 24-битным.

После этих структур начинаются графические данные. В 24-битном файле каждый пиксель кодируется 3 байтами - на каждую составляющую R, G, B - по одному байту. Значение каждой составляющей может варьироваться от 0 до 255.

Откройте файл проекта и найдите функцию LoadData(). Она вызывает другую функцию - LoadBitMap(). Я разместил её в файле ddutils.pas, вот её прототип

function LoadBitMap(name: pchar; pbi: PBITMAPINFO): pointer;

Первым параметром передаётся имя загружаемого файла, вторым - адрес структуры BITMAPINFO, структура понадобится после вызова функции LoadBitMap().

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

Вот как, например, открывается файл:

hFile := CreateFile(name, GENERIC_READ, FILE_SHARE_READ, nil,
  OPEN_EXISTING, 0, 0);
if hFile = INVALID_HANDLE_VALUE then
  exit;

Переменная hFile - это дескриптор открытого файла. Проверить, открыт ли он в самом деле можно, сравнив дескриптор с константой INVALID_HANDLE_VALUE. Далее считывается структура BITMAPFILEHEADER:

ReadFile( hFile, bfh, sizeof( BITMAPFILEHEADER ), dwBytesRead, nil );

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

Далее считывается структура BITMAPINFOHEADER:

ReadFile( hFile, bi, sizeof( BITMAPINFOHEADER ), dwBytesRead, nil );

Думаю, надо объяснить, почему здесь мы читаем только данные структуры BITMAPINFOHEADER, и не считываем массив bmiColors. Дело в том, что этот массив в структуре BITMAPINFO, там, куда мы её передадим позже, всё равно не используется. Однако он входит в состав общих графических данных, поэтому мы считаем его вместе с ними, а в структуре bi массив bmiColors оставим пустым.

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

// Определяем размер DIB
dwDIBSize := GetFileSize( hFile, nil ) - sizeof( BITMAPFILEHEADER ) - sizeof( BITMAPINFOHEADER );

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

// Выделяем участок памяти
result := pbyte(GlobalAllocPtr( GMEM_MOVEABLE, dwDIBSize ));

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

// Читаем данные DIB
ReadFile(hFile, result^, dwDIBSize, dwBytesRead, nil);
// Закрываем файл
CloseHandle(hFile);

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

Итак, функция LoadBitMap() загрузила в оперативную память битовые данные, формирующие изображение и вернула указатель на них как результат функции. Вернёмся теперь обратно к функции LoadData(). Первый шаг сделан - произведена максимально быстрая загрузка данных из файла (я не вижу способа, как можно ещё как-нибудь ускорить этот процесс). Теперь надо сделать второй шаг. В чём он состоит? Для ускорения загруки в играх и других программах все графические данные объединяются в один или несколько больших файлов. Такую реализацию, например, можно увидеть в игре Donuts из DirectX SDK 7-8. Такое объединение очень полезно при условии, что файл на жестком диске нефрагментирован. Данный метод, безусловно, уменьшает время загрузки, но как будет видно далее, добавляет лишних хлопот программисту.

Я подготовил простой bmp-файл, в котором хранится изображение для фона и десять "кадров", которые будут последовательно сменять друг друга. Как же загрузить эти данные на поверхности DirectDraw? Есть два пути:

Воспользоваться методами Lock() и Unlock() интерфейса IDirectDrawSurface7, и осуществлять прямое копирование данных функцией CopyMemory(). Это решение оптимально по скоростным характеристикам, но уж очень сложное: необходимо учитывать абсолютно все нюансы формата поверхности, на которую копируются данные - а их очень много, ведь формат меняется в зависимости от глубины цвета текущего видеорежима - 8, 16, 24, 32 бит. К тому же, выигрыш в этом случае может оказаться совсем небольшим.
Использовать функцию GDI StretchDIBits(). Она предназначена для копирования в контекст данных, расположеных не в другом контексте, а находящихся просто в указаннном участке памяти. Может сложиться впечатление, что эта функция достаточно медленна - из-за угрожающей приставки "Stretch". Однако если будут копироваться участки битов, одинаковые по высоте и ширине, то в этом случае функция, думается, должна работать быстрее.
Я решил использовать второй способ. Итак, первым делом создадим поверхность для фона:

CreateSurface( g_pWallpaper, 640, 480 );

После этого получим контекст для поверхности и осуществим копирование функцией StretchDIBits(). В файле справки о методе IDirectDrawSurface7.GetDC() сказано, что он является надмножеством над методом IDirectDrawSurface7.Lock() - т. е. осуществляет те же операции, которые мы бы проделали при прямом копировании данных. Различие в том, что здесь DirectDraw учитывает особенности формата поверхности при создании контекста-приёмника. Думаю, нет необходимости дублировать эти операции - выигрыш в скорости может оказаться весьма сомнительным, т.к. код в библиотеке DirectDraw и без того максимально быстр.

if g_pWallpaper.GetDC(DC) = DD_OK then
begin
  // Копируем битовый массив в контекст
  StretchDIBits(DC,
    0, 0, 640, 480,
    0, 64, 640, 480,
    pBits, bi,
    0, SRCCOPY);
  g_pWallpaper.ReleaseDC(DC);
end;

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

Далее 10 раз осуществляется копирование в отдельные поверхности массива g_pMovie. Опять же, необходимо учитывать, что строки растра перевёрнуты. После этого необходимо освободить участок системной памяти, где хранится битовый массив:

// Освободили битовый массив!
pBits := nil;

Вот и всё, можно приступать к отрисовке экрана.

Вообще такая схема объединения всех данных в один большой или несколько больших файлов оправдана в крупных программах и играх - там, где набор различных изображений достигает сотен штук. На этапе черновой разработки целесообразно загружать растры из отдельных файлов, а в конце, перед релизом программы, в процессе доводки и оптимизации, объединить всё в один большой файл. При этом придётся немного поработать в графическом редакторе, разместив отдельные растры оптимальным способом, не оставляя "пустых" мест. Также целесообразно подготовить массив типа TRect, которыи будет описывать область каждой картинки в этом растре, и пользоваться им в функции загрузки.

FASTFILE2

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

Чтобы не копировать каждый раз содержимое нового участка памяти на отдельную поверхность DirectDraw функцией StretchDIBits(), я решил все данные из памяти скопировать на одну большую поверхность DirectDraw, а потом копировать её содержимое по участкам на другие поверхности методом IDirectDrawSurface7.BltFast(). Казалось бы, такое двойное копирование - из памяти на общую поверхность, а потом с этой поверхности на отдельные поверхности - довольно долгий процесс. Однако если память видеокарты достаточно большая (32-64 Мб), можно позволить программе разместить все созданные поверхности в памяти видеокарты, и тогда копирование методом IDirectDrawSurface7.BltFast() будет происходить очень быстро. При большом объёме графических данных этот способ предпочтителен. К тому же данные на общей поверхности DirectDraw хранятся в нормальном, а не перевёрнутом виде, что облегчает программисту перенос.

Этот способ и демонстрирует данный проект. Всё остальное осталось без изменений.

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

Например:

g_pBackBuffer.BltFast( x, y, g_pMovie[ frame ], nil, DDBLTFAST_WAIT );

Однако можно третьим параметром указать общую data-поверхность, а четвертым - не nil, а область на этой поверхности:

g_pBackBuffer.BltFast( x, y, g_pDataSurface, arrayRect[ FRAME_01 ], DDBLTFAST_WAIT );

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

PRINTSCREEN

Заманчиво, когда в программе имеется возможность делать "снимки" экрана и сразу записывать их в файл. Этот пример ничем не отличается от предыдущих, за исключением того, что при нажатии на клавишу "Пробел" делается запись содержимого экрана в файл screen.bmp. Функция, которая проделывает эту работу, находится в файле pscreen.pas. Рассмотрим её.

Первым делом создаётся новый файл или открывается для перезаписи старый:

// созда?м файл с заданным именем, в него будет производиться запись
hFile := CreateFile(szFileName, GENERIC_WRITE, FILE_SHARE_READ, nil,
  CREATE_ALWAYS, 0, 0);
if hFile = INVALID_HANDLE_VALUE then
begin
  CloseHandle(hFile);
  exit;
end;

// Затем нам необходимо получить данные о поверхности(здесь в функцию передан
// дополнительный буфер):

// подготавливаем структуру TDDSURFACEDESC2
ZeroMemory(@ddsd2, sizeof(TDDSURFACEDESC2));
ddsd2.dwSize := sizeof(TDDSURFACEDESC2);

// получаем формат поверхности
pSurface.GetSurfaceDesc(ddsd2);
dwWidth := ddsd2.dwWidth;
dwHeight := ddsd2.dwHeight;
dwBPP := ddsd2.ddpfPixelFormat.dwRGBBitCount;

// Структура ddsd2 используется дополнительно в методе
// Lock()поверхности.Заблокировав поверхность, можно обратится к е? содержимому
// для чтения данных:

// блокируем поверхность DirectDraw
if (FAILED(pSurface.Lock(nil, ddsd2, DDLOCK_WAIT, 0))) then
  exit;


Затем необходимо выделить достаточное количество памяти под массив пикселей. Число три в конце выражения - это потому, что вывод будет осуществляться в 24-битный файл:

pPixels := pbyte(GlobalAllocPtr( GMEM_MOVEABLE, dwWidth * dwHeight * 3 ));

Затем начинается главное. Т. к. формат пикселя поверхности в каждом из графических режимов различается, необходимо предусмотреть все особенности размещения данных. Бессмысленно подробно описывать все операции - они запутанны и сложны. Мне понадобилось некоторое количество времени, чтобы правильно перевести все операции с указателями с языка C++ в контекст Object Pascal. Операции с указателями на этом языке получаются довольно путаными, малейшая оплошность приводит к тому, что обычно в файл записывается не тот участок памяти (получается мешанина из пикселей), или запись вообще не происходит. Обратите внимание на такую строку:

pixel := PDWORD(DWORD(ddsd2.lpSurface) + i * 4 + j * ddsd2.lPitch)^;

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

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

// закрываем файл
CloseHandle(hFile);
pPixels := nil;

Функция получилась громоздкой, согласен. Однако иного способа не существует - во всём виноват формат поверхности. Кстати, я не учёл режим в 256 цветов - опять же по причине анахронизма.

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


Автор: Виктор Кода

Взято из

DirectX и Delphi

DirectX и Delphi

Перед тем как приступить я хотел бы сделать пару оговорок. Во-первых для использования DirectX в Delphi необходим файл с заголовками, где объявлены имена функций DirectX API либо какой-нибудь компонент, позволяющий обращаться к интерфейсу DirectX через свои методы. В момент написания сего опуса я использую компонент DelphiX (автор - Hiroyuki Hori), распространяемый бесплатно - http://www.yks.ne.jp/~hori/DelphiX-e.html. (если у вас есть что-нибудь получше и Вы поделитесь со мной - я буду очень признателен.)
И еще один адрес, по которому можно скачать компонент DelphiX : http://www.torry.ru/vcl/packs/hhdelphix.zip

По возможности я буду писать и названия методов DelphiX и названия соответствующих интерфейсов Directx API ? чтоб вам легче было ориентироваться в DirectX SDK. Во-вторых при всем своем гипертрофированном самомнении я не могу назвать себя экспертом в области DirectX ? так что не судите чересчур строго. Я надеюсь сие творение хоть как то сможет помочь делающим первые шаги в DirectX ? если Вы круче меня ? буду признателен за помощь и указание на ошибки (коих увы наверняка сделал немало (честное слово не нарочно :-) ) Оговорка без номера ? я пишу эти строки в те времена когда последней версией DirectX является DirectX 6.

Ну что ж приступим пожалуй.

Как известно DirectX предназначен в основном для программирования игр под Windows 9x. Тем не менее можно придумать еще не мало ему применений (рано или поздно грядет таки эра повсеместного трехмерного пользовательского интерфейса). DirectX состоит из следующих компонентов:

·

DirectDraw®

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

·

DirectSound®

- как видно из названия позволяет выводить звук, используя все что можно выжать из Вашей звуковой карты (ну почти все)
 

·

DirectMusic™

- музыка. В отличие от DirectSound работает не с оцифрованным звуком (WAV) а с музыкальными командами, посылаемыми звуковой карте.
 

·

DirectPlay®

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

·

Direct3D®

(мой любимый J) ? содержит высокоуровневый интерфейс Retained Mode позволяющий легко выводить 3-хмерные графические обьекты, и низкоуровневый интерфейс Immediate Mode предоставляющий полный конроль над рендерингом. (если кто-нибудь знает как будет рендеринг по-русски ? мой адрес в конце статьи)
 

·

DirectInput®

- поддержка устройств ввода. Пока джойстик, мышь, клавиатура и т.д. ? впрочем можете быть уверены ? если появится еще что ? за Microsoft не заржавеет.
 

·

DirectSetup

? предназначен для установки DirectX.
 

·

AutoPlay

? самый обычный AutoPlay ? позволяет запускать какую-нибудь программу (инсталяшку или саму игру) при установке CD-диска в дисковод. Вообще-то описание AutoPlay относится к Win 32 SDK и просто повторяется в DirectX SDK (думаю Microsoft включила его в DirectX SDK просто чтоб оно было под рукой у разработчика)
 

Кое что о Direct3DRM®. (Reatined Mode)

Система координат
В Direct3D она соответствует так называемому правилу "левой руки". Суть правила в том, что если Вы растопырите пальцы левой руки так, что указательный палец будет направлен к экрану, большой к потолку, а средний параллельно столу туда, где обычно лежит мышиный коврик, то большому пальцу будет соответствовать координата Y, среднему ? X, указательному Z. Говоря короче координата Z направлена как бы вглубь экрана (я во всяком случае нахожусь по эту его сторону :-)), координата Y ? вверх, координата X ? вправо (все рисунки из SDK). Возможно Вам это покажется непривычным. А что Вы тогда скажите на это ? в DirectX цвета задаются тремя составляющими R,G,B, каждая из которых ? число с плавающей точкой в диапазоне [0-1]. Например белый цвет ? (1,1,1), серенький (0.5,0.5,0.5), красный (1,0,0) ну и т.д.



Все трехмерные объекты задаются в виде набора (mesh) многоугольников (граней ? faces). Каждый многоугольник должен быть выпуклым. Вообще-то лучше всего использовать треугольники ? более сложные многоугольники все равно будут разбиты на треугольники (на это уйдет столь драгоценно процессорное время). Грани (faces) состоят из вершин (vertex).



Грань становится видимой если она повернута так, что образующие ее вершины идут по часовой стрелке с точки зрения наблюдателя. Отсюда вывод ? если Ваша грань почему-то не видна ? переставьте вершины так, чтоб они были по часовой стрелке. Кроме того имеются другие объекты ? источники света (прямой свет - directional light и рассеянный свет ? ambient light), т.н. камера, текстуры, которые могут быть "натянуты" на грани и прочая, прочая… Наборы объектов составляют т.н. frames (затрудняюсь дать этому русское название). В Вашей программе всегда будет хоть один главный frame, называемый сцена (scene), не имющий фрейма-родителя, остальные фреймы принадлежат ему или друг другу. Я не буду долго разговаривать о том, как инициализировать все это хозяйство, для Дельфи-программиста достаточно разместить на форме компонент TDXDraw из библиотеки DelphiX.

Перейдем однако к делу. Запустите-ка Дельфи и откройте мою (честно говоря не совсем мою ? большую часть кода написал Hiroyuki Hori ? однако не будем заострять на этом внимание :-)) учебную программку - Sample3D.
Найдите метод


TMainForm.DXDrawInitializeSurface.

Этот метод запускается при инициализации компонента TDXDraw. Обратите внимание, что DXDraw инкапсулирует D3D, D3D2, D3Ddevice, D3DDevice2, D3DRM, D3DRM2, D3DRMDevice, D3DRMDevice2, DDraw ? ни что иное как соответствующие интерфейсы DirectX. (только в названиях интерфейсов Microsoft вместо первой буквы D слово IDirect). Инициализация компонента очень подходящее место, чтоб выбрать кое какие режимы (что и делается в программке). Обратите внимание на DXDraw.D3DRMDevice2.SetRenderMode(D3DRMRENDERMODE_BLENDEDTRANSPARENCY or D3DRMRENDERMODE_SORTEDTRANSPARENCY); - Эти два флага установлены вот для чего ? если у нас два треугольника находятся один под другим и оба видны (т.е. вершины у них по часовой) нужно их сперва отсортировать по координате Z чтоб понять кто кого загораживает. Включает такую сортировку флаг, названный скромненько эдак, по Microsots-ки: D3DRMRENDERMODE_SORTEDTRANSPARENCY. Однако как говаривал К. Прутков ? смотри в корень. Корнем же у нас является метод


TMainForm.DXDrawInitialize(Sender: TObject);

Здесь сначала создаются два фрейма ? Mesh и Light, для нашего видимого объектика и для лампочки, его освещающей.


MeshFrame.SetRotation(DXDraw.Scene, 0.0, 10.0, 0.0, 0.05);

(первые три цифры ? координаты вектора вращения, последний параметр ? угол полворота) . Тонкое (не очень правда :-)) отличие между методами SetRotation и AddRotation в том, что AddRotation поворачивает объект только один раз, а SetRotation ? заставляет его поворачиваться на указанный угол при каждом следующей итерации (with every render tick) Потом создается т.н. MeshBuilder ? специальный объект, инкапсулирующий методы для добавления к нему граней. Этот обьект может быть загружен из файла (и естественно сохранен в файл). По традиции файлы имеют расширение X. (насколько мне извесно эта традиция возникла еще до появления сериала X-Files :-)) В самом же деле ? в конце 20 века задавать координаты каждого треугольника вручную… Можно заставит сделать это кого то еще ? а потом просто загрузить готовый файл :-). Ну а если серьезно в DirectX SDK входит специальная утилита - conv3ds. {conv3ds converts 3ds models produced by Autodesk 3D Studio and other modelling packages into X Files. }

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


MeshBuilder.Scale(3, 3, 3); - Увеличиваем в три раза по всем координатам.

Наконец MeshFrame.AddVisual(MeshBuilder); - наш MeshBuilder готов, присоединяем его как визуальный объект к видимому объекту Mesh.


DXDraw.Scene.SetSceneBackgroundRGB(0,0.7,0.7); -

Как понятно из названия метода цвет фона. (Видите ? я не врал RGB-цвет действительно задается числами с плавающей точкой :-)) Интересные дела творятся в методе TMainForm.DXTimerTimer. (небольшая тонкость ? это не обычный таймер, а DXTimer из библиотеки DelphiX)


DXDraw.Viewport.ForceUpdate(0, 0, DXDraw.SurfaceWidth, 
  DXDraw.SurfaceHeight); 

указываем область, которую нужно обновить (не мудрствуя лукаво ? весь DXDraw.Surface)

DXDraw.Scene.Move(1.0); 

- применяем все трехмерные преобразования, добавленные методами вроде AddRotation и SetRotation к нашей сцене. (вот где собака то порылась… :-) вычисления новых координат точек начнутся не сразу после метода AddRotation а только здесь)
DXDraw.Render ? Рендерим (ну как же это по русски то? :-))
DXDraw.Flip ? выводим результат рендеринга на экран (аминь :-));

(в этом методе помещены также несколько строк, выводящих на экран число кадров в секунду и информацию о поддержке Direct3D аппаратурой или программно ? пригодится при отладке) Метод FormKeyDown.

Здесь проверяется код нажатой клавиши ? если Alt+Enter ? переходим из оконного в полноэкранный режим (клево, правда? :-)) и наоборот. Напоследок пара слов о DXDrawClick.

Просто выводим FileOpenDialog ? Вы можете поэкспериментировать с x-файлами. Пока все. Вот уж не думал, что это будет так трудно. Надеюсь хоть кто-то дочитал до этого места.

Пишите: aziz@telebot.net, error@softhome.net


Автор: Азиз (JINX)

Взято из

DirectX и Delphi - введение

DirectX и Delphi - введение

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

blitting - blit сокращение от "bit block transfer" пересылка блоков данных из одной области видеопамяти в другую.
flip ? переключение между буферами видеопамяти
Surface ? "поверхность" ? область видеопамяти
Второе ? разговор идет о использовании DirectDraw в Delphi. Для того, чтобы воспользоваться DirectX вообще и DirectDraw в частности, нужно, чтобы во-первых DirectX был установлен на компьютере (скачать его можно у Microsoft например, впрочем я не думаю, что для читателя будет проблемой его найти), во-вторых нужны файлы заголовков DirectX ? их существует немало, я по-прежднему считаю компонент DelphiX от Hiroyuki Hori ? превосходным , кроме того, существует официально поддерживаемые Borland'ом заголовки DirectX, составленные в рамках проекта "JEDI" ? скачать их можно с (http://www.delphi-jedi.org/DelphiGraphics/).
Третье ? неплохо если Вы имеете некоторое общее представление о работе видеоадаптера (ну очень общее ? тонкости не нужны) и еще более общее о COM-технологии (всего-то нужно знать что такое COM- Interface, впрочем и это не обязательно).


DirectDraw ? интерфейс DirectX, предназначенный, по существу, для управления видеопамятью.
Прелесть однако заключается в том, что с DirectDraw доступ к видеопамяти становится не зависимым от типа используемой видеоплаты (ну или почти не зависимым). DirectDraw обращается к апаратуре посредством hardware abstraction layer (HAL) ? (уровня абстагирования от аппаратуры). Кроме того с помощью hardware emulation layer (HEL) (уровня эмуляции аппаратуры) те возможности, которые не реализованы в данной видеокарте эмулируются программно (к сожалению тут есть пара исключений). Благодаря такому подходу жизнь программиста становится легче и веселее ? если, например, видеокарта поддерживает hardware blitting ? DirectDraw использует эту возможность через HAL ? если нет ? эмулирует через HEL (естественно эмуляция всегда медленнее). На рисунке из SDK показаны отношения между DirectDraw, GDI, HAL и HEL.



Как видно из рисунка DirectDraw находится вне GUI. DirectDraw может предоставлять области памяти, с которыми он работает в виде контекста устройства (device context, привычный для Windows-программиста), что позволяет использовать функции GDI для работы с ним (например, выводить текст с помощью функции TextOut)


DirectDraw можно использовать как при рисовании в окне Windows так и при работе в полноэкранном режиме. Я пока буду говорить только о полноэкранном режиме (с эксклюзивным уровнем кооперации).
Видео режимы.

Режим определяет размер видимой области экрана в пикселах и число бит, требуемых для представления одного пиксела ("глубина цвета ") (практически все мониторы поддерживают например режим 640ґ480ґ8). Чем больше ширина и высота экрана в пикселах, и чем больше бит требуется для представления одного пиксела, тем больше видеопамяти требуется для режима.

Кроме того видеорежимы бывают палитровыми (palettized) и безпалитровыми (non-palettized). В палитровых режимах "глубина цвета" означает число элементов палитры для данного режима, например 8-битовый палитровый режим означает, что используется палитра, размером 256 элементов. В безпалитровом режиме "глубина цвета" означает число бит для представления цвета (8 бит ? 256 цветов, 16 бит ? 65535 цветов и т.д.)
Чтобы выяснить какие режимы поддерживает ваша видеокарта можно использовать интефейс IDirectDraw4::EnumDisplayModes.
Пример:

выясним все поддерживаемые видеорежимы {используем DirectX headers от JEDI}

functionMyEnumFunction(const lpDDSurfaceDesc: TDDSurfaceDesc; lpContext:
  Pointer): HResult; stdcall
var
  SMode: string;
begin
  SMode := IntToStr(lpDDSurfaceDesc.dwWidth) + ' X ';
  SMode := SMode + IntToStr(lpDDSurfaceDesc.dwHeight) + ' X ';
  SMode := SMode + IntToStr(lpDDSurfaceDesc.ddpfPixelFormat.dwRGBBitCount);
  Form1.ListBox1.Items.Append(SMode);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  DD: IDirectDraw;
  hr: HRESULT;
begin
  hr := DirectDrawCreate(nil, DD, nil);
  if (hr = DD_OK) then
  begin
    ListBox1.Clear;
    DD.EnumDisplayModes(0, nil, nil, MyEnumFunction);
  end;
end;

{то же используя компонент DelphiX} 

procedure TForm1.Button1Click(Sender: TObject);
var
  i: integer;
  SMode: string;
begin
  ListBox1.Clear;
  for i := 0 to DXDraw1.Display.Count - 1 do
  begin
    SMode := IntToStr(DXDraw1.Display.Modes[i].Width) + ' X ';
    SMode := SMode + IntToStr(DXDraw1.Display.Modes[i].Height) + ' X ';
    SMode := SMode + IntToStr(DXDraw1.Display.Modes[i].BitCount);
    ListBox1.Items.Append(SMode);
  end;
end;

Чувствуете почему я так люблю Hiroyuki Hori с его компонентом DelphiX? :-) Действительно проще ? но, увы, документация у DelphiX очень скудная (и по большей части на японском). Вообще говоря, наверное полезно изучить "классический" способ работы с DirectDraw от JEDI ? потом легче пользоваться и DelphiX.

Установить видеорежим можно методом IDirectDraw4::SetDisplayMode.
Установим видеорежим 640x480x8 {используем DirectX headers от JEDI}

procedure TForm1.Button1Click(Sender: TObject);
var
  DD: IDirectDraw;
  DD4: IDirectDraw4;
  hr: HRESULT;
begin
  hr := DirectDrawCreate(nil, DD, nil);
  if (hr = DD_OK) then
  begin
    DD.QueryInterface(IID_IDirectDraw4, DD4);
    DD4.SetCooperativeLevel(Self.Handle, DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN);
    DD4.SetDisplayMode(640, 480, 8, 0, 0);
    //DD4.RestoreDisplayMode;
  end;
end;

{то же используя компонент DelphiX} 

procedure TForm1.Button1Click(Sender: TObject);
begin
  DXDraw1.Display.Width := 640;
  DXDraw1.Display.Height := 480;
  DXDraw1.Display.BitCount := 8;
  DXDraw1.Options := DXDraw1.Options + [doFullScreen];
  DXDraw1.Initialize;
end;

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

Кстати пример с JEDI-заголовками хорош тем, что демонстрирует создание объекта IDirectDraw получение ссылки на интерфейс IDirectDraw4 вызовом метода QueryInterface из IDirectDraw (IDirectDraw без номера ? базовый (и самый старый) интерфейс DirectDraw; IDirectDraw4 ? интерфейс из DirectX 6). Вообще объект IDirectDraw ? это самая, что ни на есть, сердцевина DirectDraw ? он представляет собой некую абстракцию над видеоадаптером ? с помощью его методов создаются все остальные объекты DirectDraw (Surface'ы, палитры и т.д.). В принципе можно создавать больше одного объекта IDirectDraw ? если у Вас больше одного видеоадаптера и несколько мониторов ? в таком случае Вы ровно во столько раз круче меня, на сколько число Ваших видеоадаптеров больше 1-го :-) (для знатоков COM-технологии ? для этого при создании объекта DirectDraw нужно передать GUID другого дисплея). Если же монитор у Вас один Вы можете создавать несколько объектов DirectDraw ? все они будут управлять одним и тем же видеоадаптером ? но мы этот случай рассматривать не будем.

В случае же если Вы используете Hori'вский компонент DelphiX ? мучения с инициализацией и деинициализацией сводятся к нулю ? достаточно просто разместить на форме компонент DXDraw ? он сам позаботится о мелочах жизни, вроде create и release. :-)

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

Поговорим теперь о Surface'ах. (моя попытка найти хороший русский эквивалент этому слову, не увенчалась успехом). Surface (объект DirectDrawSurface) ? в буквальном переводе поверхность, представляет собой линейный участок в видеопамяти. (впрочем можно создавать Surface'ы и в системной памяти ? но мы на этом не станем задерживаться) По умолчанию Surface создается так, чтобы получить максимальное быстродействие ? в видеопамяти, если ее не хватает ? в нелокальной видеопамяти (для плат AGP) а если и ее не хватает то в системной памяти (этот случай самый медленный). Объект DirectDrawSurface кроме указателя на область видеопамяти содержит несколько очень полезных методов (и зверски скоростных) для быстрого переноса квадратика видеоизображения из одного участка Surface'а в другой (blitting), для быстрой смены одного Surface' а на экране другим ? fliping, для работы с палитрами и спрайтами и др.

Ну как удалось мне вас заинтересовать? Ну тогда давайте разберемся ? как эти самые замечательные Surface'ы создавать. Перво-наперво скажем что у каждого Surface'а должен быть размер - ширина и высота. Кроме того Surface'ы устроены так, что между началом одной строчки и другой расстояние не всегда равное ширине. Скажем мы создали Surface 640X480X8 ? казалось бы между первой строчкой и второй ровно 640 байт ? ан нет. Может 640 байт а может и больше (это завист от того парня, который писал драйвер Вашего видеоадаптера). Расстояние между строчками в байтах называется Pitch ? переводится как шаг. Почему этот самый Pitch не всегда равен ширине видно из рисунка:



Видите ? справа от нашего Front-bufera может быть какой-то кэш, если Вы вздумаете писать напрямую в видеопамять ? писать туда (в кэш) строго не рекомендуется (за последствия никто не ручается). Кроме того Pitch, в отличие от ширины измеряется в байтах а не в пикселах.

Раз уж заговорили, про Front-bufer'ы ? скажем уж и про то, что один Surface, называемый PrimarySurface, является главным - это тот самый Surface, который был виден на экране в момент когда мы начали создавать эти самые Surface'ы.

Surface'ы могут быть обьединены в так называемые flip-цепочки. Когда происходит flip между Surface'ами ? тот Surface, что сейчас на экране, заменяется следующим в цепочке, на следующем flip'е ? этот ? следующим и т.д. ? если дошли до последнего в цепочке ? то он заменяется на первый. Ну в обычной жизни цепочка может состоять из всего двух Surface' ов ? при каждом они просто flip'е сменяют друг друга. Обратите внимание ? при flip'е смена Surface'ов происходит не в результате пересылки всего их содержимого, а просто в результате изменения указателей на области видеопамяти в видеоадаптере ? поэтому flip выполняется очень быстро. (Исключение может быть только в случае если Вы создали столько Surface'ов, что они не поместились в видеопамяти ? тогда за дело возьмется HEL ? бедняге придется все это эмулировать и скорость будет ? не ахти). C помощью flip можно создавать анимацию, выводим какую-то картинку, затем в BackBuffer'e ? чуть-чуть меняем эту картинку, вызываем flip, чуть-чуть меняем картинку в BackBuffer'e, вызываем flip и т.д. в цикле.
Вот пример создания Flip-цепочки из двух Surface'ов, обьектов IDirectDrawSurface4.

(Ссылки на два созданных Surface'а сохраняются в переменных FPrimarySurface и FbackSurface)
(этот пример взят из моей демо-программульки, которую Вы может скачать здесь 169K)
{используются JEDI ? заголовки DirectX}

uses ... DDraw;
var
  hr: HRESULT;
  SurfaceDesc: TDDSurfaceDesc2;
  DDSCaps: TDDSCAPS2;
  DD: IDirectDraw;
begin
  ///  ...начнем, помолясь
  hr := DirectDrawCreate(nil, DD, nil); ///создали DirectDraw
  if (hr = DD_OK) then
  begin
    // Получим интерфейс IDirectDraw4
    DD.QueryInterface(IID_IDirectDraw4, FDirectDraw);
    // интерфейс DirecDraw1 нам больше не нужен
    DD := nil;
    // Установим эксклюзивный уровень кооперации и полноэкранный режим
    hr := FDirectDraw.SetCooperativeLevel(Handle, DDSCL_EXCLUSIVE or
      DDSCL_FULLSCREEN);
    if (hr = DD_OK) then
    begin
      hr := FDirectDraw.SetDisplayMode(640, 480, 8, 0, 0);
        ///переключаем видеорежим на 640X480X8
      if (hr = DD_OK) then
      begin
        // Создаем главный surface с одним back buffer'ом
        FillChar(SurfaceDesc, SizeOf(SurfaceDesc), 0);
        SurfaceDesc.dwSize := SizeOf(SurfaceDesc);
        ///говорим что нам нужны back buffer'ы
        SurfaceDesc.dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
        ////говорим что создаем первый Surface
        SurfaceDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE
          or DDSCAPS_FLIP //// во Flip-цепочке
        or DDSCAPS_COMPLEX; //// а вообще будут и дополнительные Surface'ы
        //// число этих самых дополнительных - 1
        SurfaceDesc.dwBackBufferCount := 1;
        ///все готово, создаем Surface'ы и запоминаем главный в FPrimarySurface
        hr := FDirectDraw.CreateSurface(SurfaceDesc, FPrimarySurface, nil);
        if (hr = DD_OK) then
        begin
          // А теперь получим указатель на back buffer (создали-то два Surface'a сразу)
          ddscaps.dwCaps := DDSCAPS_BACKBUFFER;
          ///получили и запомнили в FBackSurface
          hr := FPrimarySurface.GetAttachedSurface(ddscaps, FBackSurface);
          if (hr = DD_OK) then
          begin
            {Все нормально - Surface'ы созданны - выходим}
            exit;
          end;
        end;
      end;
    end;
  end;
  {где-то была ошибка - сообщаем об этом неприятном факте}
  MessageBox(Self.Handle, PChar('Не удалось инициализировать DirectDraw! ' +
    ErrorString(Hr)), 'ERROR', MB_OK);
  Close();
end;

Создали Surface'ы. Теперь было бы интересно что-нибудь на них нарисовать. Интересно также попробовать писать прямо в видеопамять.
Получить указатель на область видеопамяти Surface'а можно вызвав метод Lock ? он вернет указатель в структуре типа TDDSURFACEDESC2, которую получает в качестве параметра.

С фантазией у меня всегда было не очень ? поэтому просто заполню всю область Surface'ов одним цветом, записав в видеопамять одно и тоже значение.

var
  i, j: integer;
  AdresVideo: PByteArray;
  SurfaceDesc: TDDSURFACEDESC2;
  HR: HResult;
begin
  // Пишем прямо в видеопамять
  FillChar(SurfaceDesc, SizeOf(SurfaceDesc), 0);
  SurfaceDesc.dwSize := SizeOf(SurfaceDesc);
  HR := FPrimarySurface.Lock(nil, SurfaceDesc, {DDLOCK_WAIT or}
    DDLOCK_SURFACEMEMORYPTR, 0);
  if (HR = DD_OK) then
  begin
    AdresVideo := SurfaceDesc.lpSurface;
    for i := 0 to SurfaceDesc.dwHeight - 1 do
    begin
      for j := 0 to SurfaceDesc.dwWidth - 1 do
      begin
        AdresVideo[j + i * SurfaceDesc.lPitch] := $FF;
      end;
    end;
    FPrimarySurface.Unlock(nil);
  end;
end;


Обратите внимание - какой я аккуратный ? перехожу между строчками, учитывая Pitch. Да кстати ? я просто демонстрирую как обратится к каждому байту видеопамяти Surface'a на самом деле если нужно закрасить весь Surface одним цветом то заносить значения в каждый байт слишком медленно ? для этого можно воспользоваться методом IDirectDrawSurface4.Blt, передав ему флаг DDBLT_COLORFILL. Кроме того можно выводить на Surface и привычными функциями GDI ? TextOut'ом например:

var
  DC: HDC;
begin
  if (FPrimarySurface.GetDC(DC) = DD_OK) then
  begin
    {Выводим текст на 1-й surface, используя GDI-фуекцию TextOut}
    SetBkColor(DC, RGB(255, 255, 255));
    SetTextColor(DC, RGB(255, 0, 0));
    TextOut(DC, 10, 20, ' Проба пера', Length(' Проба пера'));
    FPrimarySurface.ReleaseDC(DC);
  end;
end;

Небольшое лирическое отступление ? между вызовами LOCK и UNLOCK, а также между GetDC и ReleaseDC выполнение всех других программ останавливается (в том числе и отладчика). Отсюда выводы ? первое ? не стоит делать что-то слишком долго между этими вызовами, второе, отладить программу пошагово между этими вызовами ? невозможно (если только Вы не вооружились Kernel-debuger'ом).

Теперь попробуем flip'ануть наши Surface'ы. Переключимся на другой Surface

hr := FPrimarySurface.Flip(nil, 0);

Метод Flip может отказаться flip'овать и вернуть, среди прочих, такие коды ошибок:
DDERR_NOEXCLUSIVEMODE ? этот код возврата означает, что наша программа потеряла эксклюзивный режим. Произойти такое может, если мы flip'уем в цикле по таймеру, а пользователь зачем-то ушел из нашей программы, свернув ее или нажав Alt-TAB. В таком случае, чтобы зря не тратить процессорные циклы, лучше подождать его возвращения, вызывая функцию Sleep(0) или WaitMessage.
DDERR_SURFACELOST ? потеря Surface'ов пользователь уходил, но вернулся, Surface'ы нужно забрать назад, вызвав IDirectDraw4.RestoreAllSurfaces, содержимое их придется восстановить.
Все вышесказанное касается классического стиля использования DirectDraw в стиле С от JEDI. Поклонники же Hori'вского набора DelphiX могут поэкспериментировать c Surface'ами используя TDXDraw.DDraw.SurfaceCount, TDXDraw.DDraw.Surfaces, TDXDraw.Flip ? вместе с набором компонент распространяются отличные примеры.

Я очень рад, что Вы дочитали до этого места (если Вы просто пролистали в конец, не читая, сделайте вид, что это не так, порадуйте меня, старика) :-).
На этом пока все. Если Вы заинтересовались ? скачайте демо-программку и поэкспериментируйте.
Пишите мне ? aziz@telebot.com или error@softhome.net ? с удовольствием приму Ваши пожелания и предложения (особенно если предложите какую-нибудь работу) :-).


Автор: Азиз (JINX)

Взято из

DirectX (Игровой SDK)

DirectX (Игровой SDK)

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

Взято из

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

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

Перед углублением и изнурительные подробности 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) 2

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

Теперь вы готовы создавать поверхности отображения. В 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) 3

Листинг 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) 4

Использование класса 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;

Директивы компилляции

Директивы компилляции

Cодержание раздела:

Директивы вызова процедур

Директивы вызова процедур

Может кто объяснит подробнее особенности применения директив вызовов процедур: register, pascal, cdecl, stdcall, safecall. В чём отличия, когда и какие надо применять, какие преимущества и недостатки?

Разница в способе передачи параметров в функцию и возврата параметров из функции.
stdcall - юзается (вроде) а винапях. Передача аргументов справа налево. Стек очищает вызываемая процедура. Возвращает разультат в EAX (помойму)
pascal - юзалось в вин16апи. Передача в аргументов слева направо. Стек очищает вызываемая. В паскале результат возвращался в al, ax или в dx:ax. Как в Дельфи - не помню, вероятно а EAX.
register - передача всего через регистры процессора. Как именно - зависит от компилятора.
cdecl - не помню. Вроде тоже, что и stdcall, только стек чистит вызывающая процедура

Автор ответа: FdX
Взято с Vingrad.ru



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

Автор ответа: Dapo
Взято с Vingrad.ru


Эти директивы скорее относятся к способу(ам) реализации вызовов процедур и передачи (приему от) параметров на конкретном машинном языке при компиляции с языков высокого уровня.
Так, например в DOS СИ использовали свои виды реализаций(обычно называемые C-call), а Паскаль - свой. В win32 также различаются реализации для этих языков, но постепенно происходит заимствование фрагментов реализаций друг у друга и их симбиозы (stdcall).
Если ты пишешь только на одном языке и не подключаешь внешних библиотек, созданных другим компилятором (в другом формате), то тебе, в принципе, все равно, какая реализация используется - компилятор сам примет верное решение и согласует вызовы подпрограмм в своем стиле. Исключение, пожалуй, составляет лишь опция "registers" - по смыслу это означает приоритетное использование регистров процессора для передачи(получения) данных процедуре. Как правило, это ускоряет вызов процедуры и возврат из нее: может быть использования для повышения быстродействия. Однако это обычно делают установкой глобального флага проекта в момент создания Файнал Релиз, применяя это сразу ко всем подпрограммам.
Однако если тебе необходимо подключить внешнюю библиотеку (например, написанный на СИ dll, вызывающий в свою очередь апи sql-сервера), то будет необходимо учесть способ передачи параметров именно этой библиотеке.
Или при явном вызове win api из кода также нужно учесть способ их вызова (stdcall)...


Автор ответа: Chingachguk
Взято с Vingrad.ru




Статья P. Below на
Calling conventions influence two things:
- how parameters are passed to a function/procedure (=routines)
- how the call stack is cleaned up when the call returns
Delphi routines can use the calling conventions pascal (the
Delphi 1 default), register (the default for Delphi 2-5), cdecl
(the default used by C/C++ compilers), stdcall (the default used
by the Windows API). There is a fifth one: safecall, which
is only used in the context of interface methods. A good
explanation for what it entails can be found in issue 51
(Nov. 99) of The Delphi Magazine, i will not go into it
further here. Lets go through the first four in detail, using a
couple of test functions with the same parameter list but
different calling conventions. For clearity we compile with
stack frames on, so each routine will start with the prologue
push ebp
mov ebp, esp
The stack layouts given below are for the mov line. Each test
function is called with the same parameter values so one can
use the CPU windows stack pane to study the resulting stack
layout.

1. Pascal calling convention

Function Test1( i: Integer; b: Boolean; d: Double ): Integer;
Pascal;
Pascal calling convention passes parameters on the stack and
pushes them from left to right in the parameter list. Each
parameter occupies a multiple of 4 bytes. The resulting stack
layout is
ebp + 20 value of i, 4 bytes
ebp + 16 value of b, 4 bytes, only lowbyte significant
ebp + 08 value of d, 8 bytes
ebp + 04 return address, 4 bytes
ebp + 00 old ebp value
The parameters are cleared off the stack by the called function
using a
ret $10
instruction ($10 = 16 is the total size of the parameters on
stack).

2. Register calling convention
Function Test2( i: Integer; b: Boolean; d: Double ): Integer;
Register;
Register calling convention passes parameters in registers
eax, edx, ecx and on the stack and processes them from left to
right in the parameter list. There are rules to decide what
goes into registers and what goes on the stack, as detailed
in the Object Pascal Language guide. The resulting stack layout
is
ebp + 08 value of d, 8 bytes
ebp + 04 return address, 4 bytes
ebp + 00 old ebp value
The value of i is passed in eax, the value of b in edx.
The parameters are cleared off the stack by the called function
using a
ret $8
instruction ($8 = 8 is the total size of the parameters on
stack).

3. cdecl calling convention
Function Test3( i: Integer; b: Boolean; d: Double ): Integer;
cdecl;
Cdecl calling convention passes parameters on the stack and
pushes them from right to left in the parameter list. Each
parameter occupies a multiple of 4 bytes. The resulting stack
layout is
ebp + 16 value of d, 8 bytes
ebp + 12 value of b, 4 bytes, only lowbyte significant
ebp + 08 value of i, 4 bytes
ebp + 04 return address, 4 bytes
ebp + 00 old ebp value
The parameters are cleared off the stack by the calling
function, so the function ends with a
ret 0
and after the call instruction we find a
add esp, $10
instruction ($10 = 16 is the total size of the parameters on
stack).

4. Stdcall calling convention
Function Test4( i: Integer; b: Boolean; d: Double ): Integer;
stdcall;
Sdtcall calling convention passes parameters on the stack and
pushes them from right to left in the parameter list. Each
parameter occupies a multiple of 4 bytes. The resulting stack
layout is
ebp + 16 value of d, 8 bytes
ebp + 12 value of b, 4 bytes, only lowbyte significant
ebp + 08 value of i, 4 bytes
ebp + 04 return address, 4 bytes
ebp + 00 old ebp value
The parameters are cleared off the stack by the called function
using a
ret $10
instruction ($10 = 16 is the total size of the parameters on
stack).
When writing DLLs that are only be meant to be used from Delphi
programs you will usually use the register calling convention,
since it is the most efficient one. But this really ties the
DLL to Delphi, no program compiled in another language (with
the exception of BC++ Builder perhaps) will be able to use the
DLL unless it uses assembler to call the functions, since the
Register calling convention (like MS VC _fastcall) is
compiler-specific.
When writing DLLs that should be usable by other programs
regardless of language you use the stdcall calling convention
for exported routines. Any language that can call Windows API
routines will be able to call routines from such a DLL, as long
as you stay away from Delphi-specific data types, like String,
Boolean, objects, real48.
Pascal calling convention is Win16 heritage, it was the default
for the Win16 API but is no longer used on Win32.
A topic loosely tied to calling conventions is name decoration
for exported names in DLLs. Delphi (5 at least) does not
decorate names, regardless of calling convention used. The name
appears in the exported names table exactly as you cite it in
the exports clause of the DLL, case and all. Case is
significant for exported functions in Win32!
Other compilers may decorate names. Unless told to do otherwise
a C compiler will prefix all cdecl functions with an underbar
and will decorate stdcall functions in the format _name@x,
where x is the total parameter size, e.g. _Test3@16. C++ is
even worse, unless functions are declared as extern "C" it will
export names in a decorated format that encodes parameter size
and type, in a compiler-specific fashion. For routines exported
with Pascal calling convention the names may be all uppercase,
but as said above you will not usually encouter this convention
on Win32.
Due to these naming issues it is often appropriate to sic TDUMP
on an unknown DLL you want to interface to, to figure out the
actual names of the exported functions. These can then be given
in a name clause for the external statement if they are
decorated.

Demo DLL:

library DemoDLL;
uses Windows;

function Test1(i: Integer; b: Boolean; d: Double): Integer; pascal;
begin
  Result := Round(i * Ord(b) * d);
end;

function Test2(i: Integer; b: Boolean; d: Double): Integer; register;
begin
  Result := Round(i * Ord(b) * d);
end;

function Test3(i: Integer; b: Boolean; d: Double): Integer; cdecl;
begin
  Result := Round(i * Ord(b) * d);
end;

function Test4(i: Integer; b: Boolean; d: Double): Integer; stdcall;
begin
  Result := Round(i * Ord(b) * d);
end;

exports
  Test1 index 1,
  Test2 index 2,
  Test3 index 3,
  Test4 index 4;

begin
end.

// Example call from test project:
implementation
{$R *.DFM}

function Test1(i: Integer; b: Boolean; d: Double): Integer; pascal; external 'DEMODLL.DLL' Index 1;

function Test2(i: Integer; b: Boolean; d: Double): Integer; register; external 'DEMODLL.DLL' Index 2;

function Test3(i: Integer; b: Boolean; d: Double): Integer; cdecl; external 'DEMODLL.DLL' Index 3;

function Test4(i: Integer; b: Boolean; d: Double): Integer; stdcall; external 'DEMODLL.DLL' Index 4;

procedure TForm1.Button1Click(Sender: TObject);
var i: Integer;
begin
  i := Test1(16, True, 1.0);
  i := Test2(16, True, 1.0);
  i := Test3(16, True, 1.0);
  i := Test4(16, True, 1.0);
end;

Set breakpoints on the lines and step into the routines with the
CPU window open to see the stack layout.

Взято с Vingrad.ru

Диски

Диски

Cодержание раздела:

DLL!

DLL!

Ура. До нас и за нас все уже стандатизировали. Давайте этим воспользуемся и напишим теперь наш модуль в постандарту. Напишим dll.

library CalcDll;

uses SysUtils, Classes;

type
MyCalc=class  
fx,fy:integer;  
public
procedure SetOperands(x,y:integer);  
function Sum:integer;  
function Diff:integer;  
end;

var Calc:MyCalc;

procedure MyCalc.SetOperands(x,y:integer);
begin
fx:=x; fy:=y;  
end;

function MyCalc.Sum:integer;
begin
result:=fx+fy;  
end;

function MyCalc.Diff:integer;
begin
result:=fx-fy;  
end;

procedure SetOperands(x,y:integer);
begin
Calc.SetOperands(x,y);  
end;

function Sum:integer;
begin
result:=Calc.Sum;  
end;

function Diff:integer;
begin
result:=Calc.Diff;  
end;

procedure CreateObject;
begin
Calc:=MyCalc.Create;  
end;

procedure ReleaseObject;
begin
Calc.Free;  
end;

exports //Вот эта секция и указывает компилятору что записать в таблицу экспорта
SetOperands,  
Sum,  
Diff,  
CreateObject,  
ReleaseObject;  
begin
end.


Напишим программку - протестировать наш модуль.

unit tstcl;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;  
Button2: TButton;  
procedure FormCreate(Sender: TObject);  
procedure FormDestroy(Sender: TObject);  
procedure Button1Click(Sender: TObject);  
procedure Button2Click(Sender: TObject);  
end;

var Form1: TForm1;
_Mod:Integer; //индефикатор модуля  
SetOpers:procedure(x,y:integer); //Это все указатели на функции,  
diff,sum:function:integer; //которые мы собираемся получить  
CreateObj,ReleaseObj:procedure; //из нашего модуля  

implementation
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
//загружаем наш модуль в память  
_Mod:=LoadLibrary('CalcDll.dll');   
 
//получаем адреса функций по именам   
CreateObj:=GetProcAddress(_Mod,'CreateObject');  
ReleaseObj:=GetProcAddress(_Mod,'ReleaseObject');  
sum:=GetProcAddress(_Mod,'Sum');  
diff:=GetProcAddress(_Mod,'Diff');  
SetOpers:=GetProcAddress(_Mod,'SetOperands');  
 
CreateObj; //вызываем функцию по адресу  
SetOpers(13,10); //вызываем функцию по адресу  
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
ReleaseObj; //опять вызываем функцию по адресу  
FreeLibrary(_Mod); //выгружаем модуль из памяти  
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(diff)); //вычисляем разницу  
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(IntToStr(sum)); //вычисляем сумму  
end;

end.

Классно! Теперь каждый программирующий в системе Windows на любом языке может использовать наш калькулятор! Что? Разочарованны? Такое ощущение что COM тут и не пахнет?

Правильно, ибо про СОМ я пока ничего и не сказал, но

Продолжение следует!

Добавление колонки в StringGrid

Добавление колонки в StringGrid

Procedure GridAddColumn(StrGrid: TStringGrid; NewColumn: Integer); 
Var Column: Integer; 
begin 
  StrGrid.ColCount := StrGrid.ColCount+1; 
  For Column := StrGrid.ColCount-1 downto NewColumn do 
    StrGrid.Cols[Column].Assign(StrGrid.Cols[Column-1]); 
  StrGrid.Cols[NewColumn-1].Text := ''; 
end; 


procedure AddColumn(SG : TStringGrid; AtColNumber : integer; 
                    ColWidth : integer = 0); 
var Column : integer; 
    Wdth : integer; 
begin 
  AtColNumber := abs(AtColNumber); 
  SG.ColCount := SG.ColCount + 1; 
  if abs(ColWidth) = 0 then 
     Wdth := SG.DefaultColWidth 
  else 
     Wdth := ColWidth; 

  if AtColNumber <= SG.ColCount then begin 
    for Column := SG.ColCount - 1 downto AtColNumber + 1 do begin 
      SG.Cols[Column].Assign(SG.Cols[Column - 1]); 
      SG.Colwidths[Column] := SG.Colwidths[Column - 1]; 
    end; 

    SG.Cols[AtColNumber].Text := ''; 
    SG.Colwidths[AtColNumber] := Wdth; 
  end;   
end; 

Взято с Исходников.ru

Добавление ODBC-драйверов в Delphi

Добавление ODBC-драйверов в Delphi

Минимальные требования, необходимые для установки драйвера ODBC в Delphi 3.0, заключаются в наличие следующих компонентов:


Microsoft ODBC Manger
        Windows 95 или NT
        Delphi версии Developer или Client/Server
        Поставляемый производителем драйвер ODBC (уже установленный в вашей системе)
При использовании Delphi 3.0 есть два общих метода добавления ODBC драйверов к BDE. Первым шагом при использовании любого из методов является установка постовляемого производителем драйвера ODBC в вашу систему. После этого достаточно сложного шага остальные шаги будут не такими сложными. В левой панели менеджера BDE расположен список драйверов и источников данных, которые прежде были ориентированы на использование с приложениями BDE.
Метод A:

Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.)

Теперь в главном меню выберите пункт Object|ODBC administrator. (будет показан спискок установленных в настоящий момент драйверов.)

Нажмите Add, выберите ODBC драйвер, для которого вы хотели бы создать источник данных, и нажмите на OK.

Затем заполните необходимую для вашего драйвера информацию. (Минимальная конфигурация требует заполнения поля Data Source Name. Вам необходимо будет заполнить по крайней мере еще одно поле, описывающее месторасположение данных. В случае таблиц Paradox и dBase это будет поле "Path" (путь), или поле "Server" (сервер) в случае конфигурирования драйвера ODBC для Interbase ODBC. Если вы используете Interbase, вы должны указать путь к файлу .GDB, если вы пользуетесь файлами Paradox или dBASE, вы должны определить месторасположение каталога с таблицами, и, наконец, если вы используете Oracle, вы указать строку, расположенную в вашем файле TNSNAMES.ORA. После того как вы это сделаете, можно считать, что виртуальный драйвер вами создан, и вы можете получить доступ к вашим файлам с базами данных через созданный вами источник данных.)
Метод B:
Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.)

Щелкните на закладке database, затем правой кнопкой мыши на левой панели.

Щелкните в контекстном меню на пункте New, выберите тип ODBC драйвера, который вы хотите добавить, и нажмите на кнопку OK.

Снова щелкните правой кнопкой на панели database, и в появившемся контекстном меню выберите Apply.

Теперь на панели definition вы должны выбрать правильный ODBC DSN (Data Source Name, имя источника данных) и нажать apply.
Оба этих метода заканчиваются способностью Delphi с помощью TDataset перехватывать живые данные.
Вы, возможно, обратили внимание на новые опции в меню Object|Options, эти опции позволяют вам выбирать для просмотра различные режимы конфигурации. Желательно в панели View в группе Select Configuration Modes включить (отметить галочками) все выключатели. При всех включенных checkbox-ах вы получите в свое распоряжение расширенный список всех драйверов и псевдонимов, доступных вам для использования. Если галочка напротив 'virtual' отсутствует, вы не сможете увидеть драйверы, добавленные через менеджер MS ODBC, а увидете драйверы, установленный только с помощью BDE (в соответствии с методом 2).

Взято из

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

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

Автор: Tom Stickle

var
pszAliasName: PChar;  { Имя псевдонима }
  pszDriverType: PChar; { Тип драйвера для псевдонима }
  pszParams: PChar;     { Дополнительные параметры }
  bPersist: Bool;       { Постоянный или временный псевдоним }
  dbiRes: Integer;      { Возвращаемый код }
begin
  pszAliasName := strAlloc(25);
  pszDriverType := strAlloc(25);
  pszParams := strAlloc(100);

  try
    bPersist := True;
    strPcopy(pszAliasName, 'Lance');
    strPcopy(pszDriverType, 'PARADOX');
    strPcopy(pszParams, 'PATH:' + 'c:\Paradox\');

    dbiRes := DbiAddAlias(nil, pszAliasName, pszDriverType, pszParams,
      bPersist);

  finally
    strDispose(pszAliasName);
    strDispose(pszDriverType);
    strDispose(pszParams);
  end;
end;

Взято из

Добавляем дополнительную кнопку в заголовок формы

Добавляем дополнительную кнопку в заголовок формы

Автор: Vimil Saju

Чтобы добавить дополнительную кнопку, нам прийдётся создать обработчики для следующих событий:
WM_NCPAINT;//вызывается, когда перерисовывается не клиентская область формы
WM_NCACTIVATE; вызывается, когда заголовок формы становится активныи
WM_NCLBUTTONDOWN; вызывается, когда кнопка мыши нажимается на не клиентской области
WM_NCMOUSEMOVE; вызывается, когда курсор мыши передвигается по не клиентской области
WM_MOUSEMOVE;вызывается, когда курсор мыши передвигается по клиентской области
WM_LBUTTONUP; вызывается, когда кнопка мыши отпушена в клиентской области
WM_NCLBUTTONUP; вызывается, когда кнопка мыши отпушена в не клиентской области
WM_NCLBUTTONDBLCLK; вызывается при двойном щелчке мышкой в не клиентской области

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

h1(Thandle) : хэндл контекста устройства всего окна, включая не клиентскую область.
pressed(boolean): индикатор, показывающий, нажата кнопка или нет.
focuslost(boolean): индикатор, показывающий, находится ли фокус на кнопке или нет.
rec(Trect): размер кнопки.

type
  TForm1 = class(TForm) 
    procedure FormPaint(Sender: TObject); 
    procedure FormResize(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
  private 
    { Private declarations } 
  public 
    procedure WMNCPAINT(var msg:tmessage);message WM_NCPAINT; 
    procedure WMNCACTIVATE(var msg:tmessage);message WM_NCACTIVATE; 
    procedure WMNCMOUSEDOWN(var msg:tmessage);message WM_NCLBUTTONDOWN; 
    procedure WMNCMOUSEMOVE(var msg:tmessage);message WM_NCMOUSEMOVE; 
    procedure WMMOVE(var msg:tmessage);message WM_MOUSEMOVE; 
    procedure WMLBUTTONUP(var msg:tmessage);message WM_LBUTTONUP; 
    procedure WMNCMOUSEUP(var msg:tmessage);message WM_NCLBUTTONUP; 
    procedure WNCLBUTTONDBLCLICK(var msg:tmessage);message WM_NCLBUTTONDBLCLK; 
  end; 

var 
  Form1: TForm1; 
  h1:thandle; 
  pressed:boolean; 
  focuslost:boolean; 
  rec:trect; 
implementation 

{$R *.DFM} 

procedure tform1.WMLBUTTONUP(var msg:tmessage); 
begin 
pressed:=false;   
invalidaterect(form1.handle,@rec,true);   
inherited;   
end; 

procedure tform1.WMMOVE(var msg:tmessage); 
var tmp:boolean 
begin 
tmp:=focuslost;   
focuslost:=true;   
if tmp<>focuslost then   
  invalidaterect(form1.handle,@rec,true);   
inherited;   
end; 

procedure tform1.WMNCMOUSEMOVE(var msg:tmessage); 
var 
pt1:tpoint;   
tmp:boolean;   
begin 
tmp:=focuslost;   
pt1.x:=msg.LParamLo-form1.left;   
pt1.y:=msg.LParamHi-form1.top;   
if not(ptinrect(rec,pt1)) then   
  focuslost:=true   
else   
  focuslost:=false;   
if tmp<>focuslost then   
  invalidaterect(form1.handle,@rec,true);   
end; 

procedure tform1.WNCLBUTTONDBLCLICK(var msg:tmessage); 
var pt1:tpoint;   
begin 
pt1.x:=msg.LParamLo-form1.left;   
pt1.y:=msg.LParamHi-form1.top;   
if not(ptinrect(rec,pt1)) then   
  inherited; 
end; 

procedure tform1.WMNCMOUSEUP(var msg:tmessage); 
  var pt1:tpoint; 
begin 
pt1.x:=msg.LParamLo-form1.left;   
pt1.y:=msg.LParamHi-form1.top;   
if (ptinrect(rec,pt1)) and (focuslost=false) then   
  begin   
   pressed:=false;   
   {   
     enter your code here when the button is clicked     
   }   
   invalidaterect(form1.handle,@rec,true);   
  end   
else   
  begin   
   pressed:=false;   
   focuslost:=true;   
   inherited;   
  end;   
end; 

procedure tform1.WMNCMOUSEDOWN(var msg:tmessage); 
var pt1:tpoint;   
begin 
pt1.x:=msg.LParamLo-form1.left;   
pt1.y:=msg.LParamHi-form1.top;   
if ptinrect(rec,pt1) then   
  begin   
   pressed:=true;   
   invalidaterect(form1.handle,@rec,true);   
  end   
else   
  begin   
   form1.paint;   
   inherited;   
  end;   
end; 

procedure tform1.WMNCACTIVATE(var msg:tmessage); 
begin 
invalidaterect(form1.handle,@rec,true);   
inherited;   
end; 

procedure tform1.WMNCPAINT(var msg:tmessage); 

begin 
invalidaterect(form1.handle,@rec,true);   
inherited;   
end; 


procedure TForm1.FormPaint(Sender: TObject); 
begin 
h1:=getwindowdc(form1.handle);   
rec.left:=form1.width-75;   
rec.top:=6;   
rec.right:=form1.width-60;   
rec.bottom:=20;   
selectobject(h1,getstockobject(ltgray_BRUSH));   
rectangle(h1,rec.left,rec.top,rec.right,rec.bottom);   
if (pressed=false) or (focuslost=true) then   
  drawedge(h1,rec,EDGE_RAISED,BF_RECT)   
else if (pressed=true) and (focuslost=false) then   
  drawedge(h1,rec,EDGE_SUNKEN,BF_RECT);   
releasedc(form1.handle,h1);   
end; 

procedure TForm1.FormResize(Sender: TObject); 
begin 
form1.paint;   
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
rec.left:=0;   
rec.top:=0;   
rec.bottom:=0;   
rec.right:=0;   
end; 

Комментарии специалистов:

Дата: 25 Августа 2000г.
Автор: NeNashev nashev@mail.ru

InvalidateRect на событие Resize ничего не даёт. Но даже без него
кнопка всё равно моргает при Resize формы... Надо ещё где-то убрать

Для рисования кнопок на заголовке окна лучше пользоваться
DrawFrameControl а не DrawEdge... Так и с не серыми настройками
интерфейса всё правильно будет. Да и проще так.

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

Сравнивать логическое значение с логической константой чтоб получить
логическое значение глупо, так как логическое значение у Вас уже есть.
тоесь вместо
if (pressed=true) and (focuslost=false)
лучше писать
if Pressed and not FocusLost

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


В общем Ваша процедура FormPaint может выглядеть так:

procedure TMainForm.FormPaint(Sender: TObject);
var h1:THandle;  
begin
h1:=GetWindowDC(MainForm.Handle);  
rec:=Rect(MainForm.Width-75,6,MainForm.Width-60,20);  
if Pressed and not FocusLost then   
  DrawFrameControl(h1, rec, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_PUSHED)  
else   
  DrawFrameControl(h1, rec, DFC_BUTTON, DFCS_BUTTONPUSH);  
ReleaseDC(MainForm.Handle,h1);  
end;

Но вообще-то рисовать эту кнопку надо только при WM_NCPAINT, а не
всегда... И вычислять координаты по другому... Вдруг размер элементов
заголовка у юзера в системе не стандартный? А это просто настраивается...


Взято с Исходников.ru


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



unit Main;
interface
uses
  Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TForm1 = class(TForm)
    procedure FormResize(Sender: TObject);
  private
    CaptionBtn : TRect;
    procedure DrawCaptButton;
    procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;
    procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;
    procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;
    procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;
    procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
const
  htCaptionBtn = htSizeLast + 1;
{$R *.DFM}

procedure TForm1.DrawCaptButton;
var
  xFrame,  yFrame,  xSize,  ySize  : Integer;
  R : TRect;
begin
  //Dimensions of Sizeable Frame
  xFrame := GetSystemMetrics(SM_CXFRAME);
  yFrame := GetSystemMetrics(SM_CYFRAME);

  //Dimensions of Caption Buttons
  xSize  := GetSystemMetrics(SM_CXSIZE);
  ySize  := GetSystemMetrics(SM_CYSIZE);

  //Define the placement of the new caption button
  CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,
                       yFrame + 2, xSize - 2, ySize - 4);

  //Get the handle to canvas using Form's device context
  Canvas.Handle := GetWindowDC(Self.Handle);

  Canvas.Font.Name := 'Symbol';
  Canvas.Font.Color := clBlue;
  Canvas.Font.Style := [fsBold];
  Canvas.Pen.Color := clYellow;
  Canvas.Brush.Color := clBtnFace;

  try
    DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);
    //Define a smaller drawing rectangle within the button
    R := Bounds(Width - xFrame - 4 * xSize + 2,
                       yFrame + 3, xSize - 6, ySize - 7);
    with CaptionBtn do
      Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');
  finally
    ReleaseDC(Self.Handle, Canvas.Handle);
    Canvas.Handle := 0;
  end;
end;

procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMSetText(var Msg : TWMSetText);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);
begin
  inherited;
  with Msg do
    if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then
      Result := htCaptionBtn;
end;

procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);
begin
  inherited;
  if (Msg.HitTest = htCaptionBtn) then
    ShowMessage('You hit the button on the caption bar');
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  //Force a redraw of caption bar if form is resized
  Perform(WM_NCACTIVATE, Word(Active), 0);
end;

end.

Источник:

 


Автор: Tercio Ferdinando Gaudencio Filho

Приведённый здесь код создаёт кнопку в заголовке окна, создаёт MenuItem в системном меню и создаёт подсказку(Hint) в кнопке. Поместите код в Ваш Unit и замените "FrmMainForm" на Ваше имя формы, а так же некоторые кусочки кода, ткст подсказки и т.д.

Совместимость: Delphi 3.x (или выше)

... 

  private 
    { Private declarations } 
    procedure WMNCPAINT          (var msg: Tmessage); message WM_NCPAINT; 
    procedure WMNCACTIVATE       (var msg: Tmessage); message WM_NCACTIVATE; 
    procedure WMNCMOUSEDOWN      (var msg: Tmessage); message WM_NCLBUTTONDOWN; 
    procedure WMNCMOUSEMOVE      (var Msg: TMessage); message WM_NCMOUSEMOVE; 
    procedure WMMOUSEMOVE        (var Msg: TMessage); message WM_MOUSEMOVE; 
    procedure WMLBUTTONUP        (var msg: Tmessage); message WM_LBUTTONUP; 
    procedure WNCLBUTTONDBLCLICK (var msg: Tmessage); message WM_NCLBUTTONDBLCLK; 
    procedure WMNCRBUTTONDOWN    (var msg: Tmessage); message WM_NCRBUTTONDOWN; 
    procedure WMNCHITTEST        (var msg: Tmessage); message WM_NCHITTEST; 
    procedure WMSYSCOMMAND       (var msg: Tmessage); message WM_SYSCOMMAND; 

... 

var 
... 
  Pressed         : Boolean; 
  FocusLost       : Boolean; 
  Rec             : TRect; 
  NovoMenuHandle  : THandle; 
  PT1             : TPoint; 
  FHintshow       : Boolean; 
  FHint           : THintWindow; 
  FHintText       : String; 
  FHintWidth      : Integer; 

... 

//------------------------------------------------------------------------------ 

procedure TFrmMainForm.WMSYSCOMMAND(var Msg: TMessage); 
begin 
  if Msg.WParam=LongInt(NovoMenuHandle) then 
    //********************************************* 
    //Кнопка была нажата! Добавьте сюда Вашу функцию 
    //********************************************* 
  inherited; 
end; 

//------------------------------------------------------------------------------ 

procedure TFrmMainForm.WMNCHITTEST(var Msg: TMessage); 
var 
  Tmp : Boolean; 
begin 
  if Pressed then 
  begin 
    Tmp:=FocusLost; 
    PT1.X := Msg.LParamLo - FrmMainForm.Left; 
    PT1.Y := Msg.LParamHi - FrmMainForm.Top ; 
    if PTInRect(Rec, PT1) then 
      FocusLost := False 
    else 
      FocusLost := True; 
    if FocusLost <> Tmp then 
      InvalidateRect(FrmMainForm.Handle, @Rec, True); 
  end; 
  inherited; 
end; 

//------------------------------------------------------------------------------ 

procedure TFrmMainForm.WMLBUTTONUP(var Msg: TMessage); 
var 
  Tmp : Boolean; 
begin 
  ReleaseCapture; 
  Tmp     := Pressed; 
  Pressed := False; 
  if Tmp and PTInRect(Rec, PT1) then 
  begin 
    InvalidateRect(FrmMainForm.Handle, @Rec, True); 
    FHintShow := False; 
    FHint.ReleaseHandle; 
    //********************************************* 
    //Кнопка была нажата! Добавьте сюда Вашу функцию 
    //********************************************* 
  end 
  else 
    inherited; 
end; 

//------------------------------------------------------------------------------ 

procedure TFrmMainForm.WNCLBUTTONDBLCLICK(var Msg: TMessage); 
begin 
  PT1.X := Msg.LParamLo - FrmMainForm.Left; 
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ; 
  if not PTInRect(Rec, PT1) then 
    inherited; 
end; 

//------------------------------------------------------------------------------ 

procedure TFrmMainForm.WMNCRBUTTONDOWN(var Msg: TMessage); 
begin 
  PT1.X := Msg.LParamLo - FrmMainForm.Left; 
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ; 
  if not PTInRect(Rec, PT1) then 
    inherited; 
end; 

//------------------------------------------------------------------------------ 

procedure TFrmMainForm.WMNCMOUSEDOWN(var Msg: TMessage); 
begin 
  PT1.X := Msg.LParamLo - FrmMainForm.Left; 
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ; 
  FHintShow := False; 
  if PTInRect(Rec, PT1) then 
  begin 
   Pressed   := True; 
   FocusLost := False; 
   InvalidateRect(FrmMainForm.Handle, @Rec, True); 
   SetCapture(TWinControl(FrmMainForm).Handle); 
  end 
  else 
  begin 
   FrmMainForm.Paint; 
   inherited; 
  end; 
end; 

//------------------------------------------------------------------------------ 

//That function Create a Hint 
procedure TFrmMainForm.WMNCMOUSEMOVE(var Msg: TMessage); 
begin 
  PT1.X := Msg.LParamLo - FrmMainForm.Left; 
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ; 
  if PTInRect(Rec, PT1) then 
  begin 
    FHintWidth  := FHint.Canvas.TextWidth(FHintText); 
    if (FHintShow = False) and (Length(Trim(FHintText)) <> 0) then 
      FHint.ActivateHint( 
        Rect( 
          Mouse.CursorPos.X, 
          Mouse.CursorPos.Y + 20, 
          Mouse.CursorPos.X + FHintWidth + 10, 
          Mouse.CursorPos.Y + 35 
          ), 
        FHintText 
      ); 
      FHintShow := True; 
  end 
  else 
  begin 
    FHintShow := False; 
    FHint.ReleaseHandle; 
  end; 
end; 

//------------------------------------------------------------------------------ 

procedure TFrmMainForm.WMMOUSEMOVE(var Msg: TMessage); 
begin 
  FHintShow := False; 
  FHint.ReleaseHandle; 
end; 

//------------------------------------------------------------------------------ 

procedure TFrmMainForm.WMNCACTIVATE(var Msg: TMessage); 
begin 
  InvalidateRect(FrmMainForm.Handle, @Rec, True); 
  inherited; 
end; 

//------------------------------------------------------------------------------ 

procedure TFrmMainForm.WMNCPAINT(var Msg: TMessage); 
begin 
  InvalidateRect(FrmMainForm.Handle, @Rec, True); 
  inherited; 
end; 

//------------------------------------------------------------------------------ 

procedure TFrmMainForm.FormPaint(Sender:TObject); 
var 
  Border3D_Y, Border_Thickness, Btn_Width, 
  Button_Width, Button_Height  : Integer; 
  MyCanvas                      : TCanvas; 
begin 
  MyCanvas        := TCanvas.Create; 
  MyCanvas.Handle := GetWindowDC(FrmMainForm.Handle); 
  Border3D_Y      := GetSystemMetrics(SM_CYEDGE); 
  Border_Thickness:= GetSystemMetrics(SM_CYSIZEFRAME); 
  Button_Width    := GetSystemMetrics(SM_CXSIZE); 
  Button_Height   := GetSystemMetrics(SM_CYSIZE); 

  //Создаём квадратную кнопку, но если Вы захотите создать кнопку другого размера, то
  //измените эту переменную на Вашу ширину. 
  Btn_Width  := Border3D_Y  + Border_Thickness + Button_Height - (2 * Border3D_Y) - 1; 

  Rec.Left   := FrmMainForm.Width - (3 * Button_Width + Btn_Width); 
  Rec.Right  := FrmMainForm.Width - (3 * Button_Width + 03); 
  Rec.Top    := Border3D_Y  + Border_Thickness - 1; 
  Rec.Bottom := Rec.Top     + Button_Height - (2 * Border3D_Y); 
  FillRect(MyCanvas.Handle,Rec,HBRUSH(COLOR_BTNFACE+1)); 
  If not Pressed or Focuslost Then 
    DrawEdge(MyCanvas.Handle, Rec, EDGE_RAISED, BF_SOFT or BF_RECT) 
  Else If Pressed and Not Focuslost Then 
    DrawEdge(MyCanvas.Handle, Rec, EDGE_SUNKEN, BF_SOFT or BF_RECT); 

  //It draw a the application icon to the button. Easy to change. 
  DrawIconEX(MyCanvas.Handle, Rec.Left+4, Rec.Top+3, Application.Icon, 8, 8, 0, 0, DI_NORMAL); 

  MyCanvas.Free; 
end; 

... 

procedure TFrmMainForm.FormCreate(Sender: TObject); 

... 

  InsertMenu(GetSystemMenu(Handle,False), 4, MF_BYPOSITION+MF_STRING, NovoMenuHandle,pchar('TEXT OF THE MENU')); 
  Rec             := Rect(0,0,0,0); 
  FHintText       := 'Put the text of your Hint HERE'; 
  FHint           := THintWindow.Create(Self); 
  FHint.Color     := clInfoBk;  //Вы можете изменить бэкграунд подсказки

... 

Взято с Исходников.ru

Добавляем файлы в Recent Documents list?

Добавляем файлы в Recent Documents list?

Предположим Вам захотелось, чтобы Ваше программа сама умела добавлять файлы "recent documents list" (для тех, кто в танке - это такая менюшка, которая появляется при нажатии на кнопку Пуск(Start) и наведении мышкой на "Документы" (Documents). Сама функция API-шная, так что применять её можно в любом компиляторе.
Добавляем следующий код в интерфейсную часть формы:

const 
SHARD_PIDL = 1; 
SHARD_PATH = 2; 

procedure SHAddToRecentDocs(Flags: Word; pfname: Pointer); stdcall; external 'shell32.dll' name'SHAddToRecentDocs'; 

А так выглядит вызов этой функции:

SHAddTorecentDocs(SHARD_PATH,pchar('C:\mydir\myprogram.exe')); 

файл 'myprogram.exe' будет добавлен в recent documents list

Взято с Исходников.ru

Добавляем компонент в стандартный Message dialog.

Добавляем компонент в стандартный Message dialog.

Автор: Terrance Hui

Пример показывает стандартное диалоговое окно, которое обычно используется для подтверждения дальнейших действий в любой программе с галочкой "Don't show this message again."

Используем функцию CreateMessageDialog и добавляем любой компонент до того как будет вызвана ShowModal.

procedure TForm1.Button1Click(Sender: TObject); 
Var 
  AMsgDialog: TForm; 
  ACheckBox: TCheckBox; 
begin 
  AMsgDialog := CreateMessageDialog('This is a test message.', mtWarning, [mbYes, mbNo]); 
  ACheckBox := TCheckBox.Create(AMsgDialog); 
  with AMsgDialog do 
  try 
    Caption := 'Dialog Title' ; 
    Height := 169; 

    With ACheckBox do 
    begin 
      Parent := AMsgDialog; 
      Caption := 'Do not show me again.'; 
      top := 121; 
      Left := 8; 
    end; 

    Case ShowModal of 
      ID_YES: ;//здесь Ваш код после того как диалог будет закрыт 
      ID_NO:  ; 
    end; 
    If ACheckBox.Checked then 
    begin 
      //... 
    end; 
  finally 
    ACheckBox.Free; 
    Free; 
  end; 
end; 

Так же Вы можете изменить диалог по Вашему усмотрению.

Взято с Исходников.ru

Добавляем пункты в системное меню Windows

Добавляем пункты в системное меню Windows

Автор: MAD Rodrguez

Вы, наверное, задавались вопросом, почему системное меню постоянно одно и тоже ? Пример показывает, как добавить туда такие пункты как "About" или "Information", или что-нибудь ещё.

Нам понадобится две вещи, первая это Item ID, который может быть любым целым числом. Второе это Описание(Caption) для нашего пункта меню. Нам понадобится также процедура, которая будет принимать сообщения Window для определения нажатия на наш пункт меню.

Unit OhYeah; 

Interface 

Uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus; 

Type 
   TForm1 = Class (TForm) 
     Procedure FormCreate (Sender : TObject); 
     Private {Private declarations} 
     Public  {Public declarations} 
     Procedure WinMsg (Var Msg : TMsg; Var Handled : Boolean); 
     Procedure DoWhatEever; 
  End; 

Var Form1 : TForm1; 

Implementation 
{$R *.DFM} 

Const ItemID = 99; // ID номер для пункта меню. Может быть любым 

Procedure Tform1.WinMsg (Var Msg : TMsg; Var Handled : Boolean); 
Begin 
     If Msg.Message = WM_SYSCOMMAND Then 
        If Msg.WParam = ItemID Then DoWhatEver; 
End; 

Procedure TForm1.FormCreate (Sender : TObject); 
Begin 
     Application.OnMessage := WinMsg; 
     AppendMenu (GetSystemMenu (Form1.Handle, False), MF_SEPARATOR, 0, ''); 
     AppendMenu (GetSystemMenu (Form1.Handle, False), MF_BYPOSITION, ItemID, '&My menu'); 
     AppendMenu (GetSystemMenu (Application.Handle, False), MF_SEPARATOR, 0, ''); 
     AppendMenu (GetSystemMenu (Application.Handle, False), MF_BYPOSITION, ItemID,'&My menu minimized'); 
End; 

Procedure TForm1.DoWhatEver; 
Begin 
  Exit;    // Вы можете добавить здесь всё, что угодно 
End; 

End.



Взято с Исходников.ru

Does Delphi have an equivalent for the VB function DoEvents?

Does Delphi have an equivalent for the VB function DoEvents?

Application.ProcessMessages

Does Delphi have an equivalent to the Visual Basic SendKeys function?

Does Delphi have an equivalent to the Visual Basic SendKeys function?

The following example demonstrates procedures that provide the
capibility of sending keystrokes to any window control capable of
receiving keyboard input. You may use this technique to toggle
the num lock, caps lock, and scroll lock keys under Windows NT.
This same technique works for toggling caps lock and scroll lock
keys under Windows 95, but it will not work for num lock.

Note that there are four procedures provided: SimulateKeyDown(),
SimulateKeyUp(), SimulateKeystroke(), and SendKeys(), to allow greater
control in your ability to send keystrokes.

The SimulateKeyDown(), SimulateKeyUp(), and SimulateKeystroke()
procedures expect a virtural key code (like VK_F1).
The SimulateKeystroke() procedure accepts an extra parameter that is
useful when simulating the PrintScreen key. When extra is set to zero,
the entire screen will be captured to the windows clipboard. When
extra is set to one, only the active window will be captured.

The four button click methods demonstrate the use of these functions:
ButtonClick1 - Toggles the cap lock.
ButtonClick2 - Captures the entire screen to the clipboard.
ButtonClick3 - Capture the active window to the clipboard.
ButtonClick4 - Set the focus to an edit control and sends it a string.

Example:

procedure SimulateKeyDown(Key : byte);
begin
  keybd_event(Key, 0, 0, 0);
end;

procedure SimulateKeyUp(Key : byte);
begin
  keybd_event(Key, 0, KEYEVENTF_KEYUP, 0);
end;

procedure SimulateKeystroke(Key : byte;
                            extra : DWORD);
begin
  keybd_event(Key,
              extra,
              0,
              0);
  keybd_event(Key,
              extra,
              KEYEVENTF_KEYUP,
              0);
end;

procedure SendKeys(s : string);
var
  i : integer;
  flag : bool;
  w : word;
begin
 {Get the state of the caps lock key}
  flag := not GetKeyState(VK_CAPITAL) and 1 = 0;
 {If the caps lock key is on then turn it off}
  if flag then
    SimulateKeystroke(VK_CAPITAL, 0);
  for i := 1 to Length(s) do begin
    w := VkKeyScan(s[i]);
   {If there is not an error in the key translation}
    if ((HiByte(w)  $FF) and
        (LoByte(w)  $FF)) then begin
     {If the key requires the shift key down - hold it down}
      if HiByte(w) and 1 = 1 then
        SimulateKeyDown(VK_SHIFT);
     {Send the VK_KEY}
      SimulateKeystroke(LoByte(w), 0);
     {If the key required the shift key down - release it}
      if HiByte(w) and 1 = 1 then
        SimulateKeyUp(VK_SHIFT);
    end;
  end;
 {if the caps lock key was on at start, turn it back on}
  if flag then
    SimulateKeystroke(VK_CAPITAL, 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 {Toggle the cap lock}
  SimulateKeystroke(VK_CAPITAL, 0);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
 {Capture the entire screen to the clipboard}
 {by simulating pressing the PrintScreen key}
  SimulateKeystroke(VK_SNAPSHOT, 0);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
 {Capture the active window to the clipboard}
 {by simulating pressing the PrintScreen key}
  SimulateKeystroke(VK_SNAPSHOT, 1);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
 {Set the focus to a window (edit control) and send it a string}
  Application.ProcessMessages;
  Edit1.SetFocus;
  SendKeys('Delphi Is RAD!');
end;

Does Kylix support ODBC?

Does Kylix support ODBC?

You can connect using an ODBC driver via dbExpress in Kylix. There is an ODBC dbExpress gateway driver on the Kylix companion CD.

Does Kylix support Postgres?

Does Kylix support Postgres?

The Kylix 2 dbExpress PostgreSQL/RedHat database driver is available for download from the

You can also use ODBC

Докачка файлов по сети ( NetBios )

Докачка файлов по сети ( NetBios )

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

procedure TForm1.Button1Click(Sender: TObject);
var
  Stream,
    Stream1: TFileStream;
  Temp: array[0..$FFFF] of Byte;
  Access: Integer;
  FileNames, Filenames1: string;
begin
  with TOpenDialog.Create(Form1) do
    begin
      Execute;
      FileNames:=FileName;
      Free;
    end;
  if Filenames='' then Exit;
  with TSaveDialog.Create(Form1) do
    begin
      Execute;
      FileNames1:=FileName;
      Free;
    end;
  if Filenames1='' then Exit;
  Access:=fmOpenReadWrite;
  ZeroMemory(@Temp, sizeof(Temp));
  Stream:=TFileStream.Create(FileNames, fmOpenRead);
  if not FileExists(Filenames1) then Access:=fmCreate;
  Stream1:=TFileStream.Create(Filenames1, Access);

  Gauge1.MaxValue:=Stream.Size;
  Stream.Position:=Stream1.Size;
  Stream1.Position:=Stream1.Size;
  Label1.Caption:=IntToStr(Stream1.Position);
  Label2.Caption:=IntToStr(Stream.Size);
  Gauge1.Progress:=Stream.Position;
  while Stream.Size<>Stream1.Size do
    begin
      if (Stream.Size-Stream1.Position)<sizeof(Temp) then
        begin
          Stream1.CopyFrom(Stream, Stream.Size-Stream1.Position);
        end
      else
        Stream1.CopyFrom(Stream, sizeof(Temp));
      Gauge1.Progress:=Stream.Position;
      Label1.Caption:=IntToStr(Stream.Position);
      Label2.Caption:=IntToStr(Stream.Size);
      Form1.Update;
      Application.ProcessMessages;
    end;
  Stream.Free;
  Stream1.Free;
end;


Взято с Vingrad.ru

Документация по Corba

Документация по Corba

Взято с Vingrad.ru

Дополнительная литература

Дополнительная литература

Word2000 для разработчика (я сам разбирался по ней, хорошая книжка)
Excel2000 для разработчика (тоже)
В книгах подробно описано как и макросы запускать как управлять объектами Office много примеров (правда на VB for App, но все легко переносится)

Автор ответа: PILOTIK
Взято с Vingrad.ru

Дополнительные константы цветов

Дополнительные константы цветов

unitUnitColorConstants;
{-----------------------------------------------------------------

    Unit Name: UnitColorConstants
    Version: 2.0
    Author: Stewart Moss
    Creation Date: Jan 31 2002 11:54 pm
    Modification Date: Feb 21 2002
    Dependancies:

    Description:

-- This code is copyright (Jan 31 2002) by Stewart Moss
-- All rights Reserved.
-----------------------------------------------------------------}

interface

uses Graphics;

const
  clNicePaleGreen = TColor($CCFFCC);
  clPaleRed = TColor($CCCCFF);
  clNicePurple = TColor($00E1E100);
  clKhaki = TColor($ADAE80);
  clMonkeyGreen = TColor($00C0DCC0);
  clSkyBlue = TColor($00F1CAA6);
  clMedGray = TColor($00A4A0A0);
  clCream = TColor($00EFFBFF);

  clChocolate = TColor($17335C);
  clDarkBrown = TColor($5C3340);
  clDarkSlateGrey = TColor($4F4F2F);
  clDarkTan = TColor($4F6997);
  clDarkWood = TColor($425E85);
  clLightWood = TColor($A6C2E9);
  clMediumWood = TColor($6480A6);
  clNewTan = TColor($9EC7EB);
  clSemiSweetChocolate = TColor($26426B);
  clSienna = TColor($236B8E);
  clWheat = TColor($BFD8D8);
  clBrass = TColor($42A6B5);
  clBronze = TColor($53788C);
  clBronzeII = TColor($3D7DA6);
  clCoolCopper = TColor($1987D9);
  clCopper = TColor($3373B8);
  clQuartz = TColor($F3D9D9);
  clFieldSpar = TColor($7592D1);
  clGoldenrod = TColor($70DBDB);
  clMediumGoldenrod = TColor($AEEAEA);
  clBrightGold = TColor($19D9D9);
  clGold = TColor($327FCD);
  clOldGold = TColor($3BB5CF);
  clCoral = TColor($007FFF);
  clFirebrick = TColor($23238E);
  clIndianRed = TColor($2F2F4E);
  clMandarianOrange = TColor($3378E4);
  clMediumVioletRed = TColor($9370DB);
  clNeonPink = TColor($C76EFF);
  clOrangeRed = TColor($0024FF);
  clScarlet = TColor($17178C);
  clSpicyPink = TColor($AE1CFF);
  clThistle = TColor($D8BFD8);
  clVioletRed = TColor($9932CC);
  clDarkOliveGreen = TColor($2F4F4F);
  clForestGreen = TColor($238E23);
  clHunterGreen = TColor($215E21);
  clMediumForestGreen = TColor($238E6B);
  clMediumSeaGreen = TColor($426F42);
  clMediumSpringGreen = TColor($00FF7F);
  clPaleGreen = TColor($8FBC8F);
  clSeaGreen = TColor($688E23);
  clSpringGreen = TColor($7FFF00);
  clYellowGreen = TColor($32CC99);
  clAquamarine = TColor($93DB70);
  clCadetBlue = TColor($9F9F5F);
  clCornFlowerBlue = TColor($6F4242);
  clDarkTurquoise = TColor($DB9370);
  clLightBlue = TColor($D9D9C0);
  clLightSteelBlue = TColor($BD8F8F);
  clMediumAquamarine = TColor($99CD32);
  clMediumBlue = TColor($CD3232);
  clMediumTurquoise = TColor($DBDB70);
  clMidnightBlue = TColor($4F2F2F);
  clNeonBlue = TColor($FF4D4D);
  clNewMidnightBlue = TColor($9C0000);
  clRichBlue = TColor($AB5959);
  clSlateBlue = TColor($FF7F00);
  clSteelBlue = TColor($8E6B23);
  clSummerSky = TColor($DEB038);
  clTurquoise = TColor($EAEAAD);
  clBlueViolet = TColor($9F5F9F);
  clOrchid = TColor($DB70DB);
  clDarkPurple = TColor($781F87);
  clViolet = TColor($4F2F4F);
  clDarkOrchid = TColor($CD3299);
  clMediumSlateBlue = TColor($007FFF);
  clDarkSlateBlue = TColor($8E236B);
  clMediumOrchid = TColor($DB7093);

implementation

end.

Взято с

Delphi Knowledge Base

Доступ к базам данных

Доступ к базам данных

Теперь, после работы руками, попробуем разобрать несколько менее призёмлённых вещей. Для начала следует упомянуть что Вы наверное уже прочуствовали что такое таблица. Теперь немного остановимся на базе данных. Базу данных можно очень упрощённо представить как несколько разных таблиц. Они могут быть связаны между собой, а могут и нет. Как физически хранятся таблицы? В трёх видах:

1) Каждая таблица это отдельный файл. Так работают наиболее древние базы данных, например Парадокс (который мы пока используем в примерах), Dbase, FoxPro. Все файлы таблиц лежат в отдельном каталоге на диске. Этот каталог и называется базой данных.
2) Все таблицы хранятся в одном файле ? например MS Access ? именно этот файл и называется базой данных
3)Таблицы хранятся на специальном сервере ? например MS SQL Server, Oracle. В данном случае нас вообще не интересует как сервер хранит эти таблицы ? для нас прямой доступ к ним закрыт, мы можем лишь послать запрос на сервер и получить ответ.

Несмотря на значительную разницу в организации, работа с разными базами данных очень сходная (во всяком случае до углубления в дебри). В целом, Вам нет смысла копаться в реальных форматах файлов, нет смысла искать что в файле biolife.db означает 10й байт. Может показаться что всю работу над этим файлом делает компонент TTable в нашем примере. Но это не так! Я наверное удивлю многих если скажу, что компонент TTable реально является только интерфейсом, для лёгкого доступа к данным из Дельфи. Оказывается, что всю работу над таблицей делает специальный драйвер базы данных (или его ещё называют провайдер). Итак упрощённая схема общения с таблицей из программы выглядит примерно следующим образом(для нашего примера):

База Данных <-> Драйвер Базы Данных <-> TTable <-> наш код или др. компоненты

Итак драйвер БД «знает» тонкости и детали строения файла таблицы, или знает конкретные форматы запроса к серверу на «входе», а на выходе имеет некий универсальный «интерфейс» (Я имею ввиду широкое понятие слова «интерфейс», вне контекста с COM) к которому и подключается TTable. Естественно что каждая база данных, и даже каждая версия базы данных имеет свой уникальный формат, свои уникальные особенности, поэтому драйвер для каждой разновидности баз данных тоже уникальный и обычно создаётся производителем баз данных. Интерфейс на «выходе» тоже должен быть стандартизованным ? тогда работа с разными базами данных будет значительно облегчена, конечно до истиной переносимости кода далеко (хотя для простейших програм можно легко перенести код для работы с другой базой данных) ? сказываются очень большие различия в архитектуре баз данных, которые просто невозможно свести 100% к одинаковому интерфейсу, но в любом случае знакомство с одной базой данных позволяет с лёгкостью разобраться с другой... Как всегда существует несколько стандартов таких «выходных интерфейсов». Наиболее широкораспространены следующие «стандарты» или системы доступа к базам данных:

1)BDE ? Borland Database Engine (или по-старому IDAPI). Мы как раз работали в наших примерах именно через эту систему. Эта система является «родной» для Дельфи и отличается весьма высокой производительностью при работе с локальными базами данных. С серверными базами данных её производительность гораздо скромнее. Она же является «родной» для Парадокса, что обусловливает очень высокую производительность и удобство работы связки Delphi-BDE-Paradox (конечно для небольших систем с малым количеством пользователей). BDE имеет в своём составе драйвера практически ко всем более или менее известным базам данных в среде Windows. Позже мы подробнее остановимся на настройке BDE.
2)ODBC ? продукт был создан Microsoft как конкурент BDE. На большинстве баз данных он показывает меньшую производительность чем BDE, из Дельфи с ним работать не так удобно, но он так же имеет в своём составе драйвера практически ко всем более или менее известным базам данных в среде Windows. Его настройки можно найти в «Панели Управления» Windows. Есть бесплатная библиотека компонентов для работы с ODBC с исходными кодами, её можно взять с моего сайта: . Для программиста на Дельфи представляет очень ограниченный интерес ? большинство возможностей реализовано в BDE, причём BDE со многими базами работает быстрее и Дельфи имеет собственные компоненты для BDE.
3)DAO ? это очень старая система для доступа к MS Access и MS Excel (она так же поддерживает ещё несколько баз данных), отличается высокой производительностью и богатым набором функций для работы именно с MS Access и MS Excel. Вообще не поддерживает работу с серверными базами данных. DAO можно использовать для работы с MS Access и MS Excel когда критична производительность приложений и/или требуется всё богатство возможностей доступа к MS Access и MS Excel. Есть бесплатная библиотека компонентов для работы с DAO с исходными кодами, её можно взять с моего сайта: .
4)ADO (ActiveX Data Object) ? новая система от MS ориентированная прежде всего на работу с серверными базами данных. Довольно удобна в использовании, Дельфи начиная с 4й версии в модификации Enterprise/Professional имеет линейку собственных компонентов для работы через ADO. Позднее мы рассмотрим работу с ADO компонентами.

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

Доступ к данным

Доступ к данным

Each function listed below accesses data in a table, such as retrieving data from a specified BLOB field or from the record buffer.



DbiAppendRecord:
Appends a record to the end of the table associated with the given cursor.

DbiDeleteRecord:
Deletes the current record of the given cursor.

DbiFreeBlob:
Closes the BLOB handle located within the specified record buffer.

DbiGetBlob:
Retrieves data from the specified BLOB field.

DbiGetBlobHeading:
Retrieves information about a BLOB field from the BLOB heading in the record buffer.

DbiGetBlobSize:
Retrieves the size of the specified BLOB field in bytes.

DbiGetField:
Retrieves the data contents of the requested field from the record buffer.

DbiGetFieldDescs:
Retrieves a list of descriptors for all the fields in the table associated with the cursor.

DbiGetFieldTypeDesc:
Retrieves a description of the specified field type.

DbiInitRecord:
Initializes the record buffer to a blank record according to the data types of the fields.

DbiInsertRecord:
Inserts a new record into the table associated with the given cursor.

DbiModifyRecord:
Modifies the current record of table associated with the cursor with the data supplied.

DbiOpenBlob:
Prepares the cursor's record buffer to access a BLOB field.

DbiPutBlob:
Writes data into an open BLOB field.

DbiPutField:
Writes the field value to the correct location in the supplied record buffer.

DbiReadBlock:
Reads a specified number of records (starting from the next position of the cursor) into a buffer.

DbiSaveChanges:
Forces all updated records associated with the cursor to disk.

DbiSetFieldMap:
Sets a field map of the table associated with the given cursor.

DbiTruncateBlob:
Shortens the size of the contents of a BLOB field, or deletes the contents of a BLOB field
from the record, by shortening it to zero.

DbiUndeleteRecord:
Undeletes a dBASE record that has been marked for deletion (a "soft" delete).

DbiVerifyField:
Verifies that the data specified is a valid data type for the field specified, and that all validity
checks in place for the field are satisfied. It can also be used to check if a field is blank.

DbiWriteBlock:
Writes a block of records to the table associated with the cursor.

Взято с

Delphi Knowledge Base

Доступ к объекту Oracle

Доступ к объекту Oracle

Для этого можно воспользоваться компонентами от AllRoundAutomations Direct Oracle Access. Если кому надо могу поделиться. При помощи этих компонент можно не только производить простые запросы/вставки, но и выполнять DDL-скрипты, и иметь доступ к объектам Oracle 8, примет смотри ниже...



var
Address: TOracleObject;
begin
  Query.SQL.Text := 'select Name, Address from Persons';
  Query.Execute;
  while not Query.Eof do
  begin
    Address := Query.ObjField('Address');
    if not Address.IsNull then
      ShowMessage(Query.Field('Name') + ' lives in ' + Address.GetAttr('City'));
    Query.Next;
  end;
end;

Взято из

Доступ к Oracle через ADO

Доступ к Oracle через ADO

Для доступа к данных хранящимся в Oracle лучше всего использовать не компоненты ADO а компоненты билиотека DAO (Data Access Oracle) с ними так же просто разобраться как и со стандартными компонентами, к тому же они работают на прямую с Oracle, без каких-либо посредников (например BDE, или тот же ODBC), и заточены соответственно под него. Линк точный дать не могу, но найти их будет не трудно (воспользуйся поисковой системой)...

Но если все же решил использовать ADO вот тебе строка:
1) способ если использовать "MS OLE DB Provaider for Oracle" - это провайдер мелкомягких
Provider=MSDAORA.1;Password=USER123;User ID=USER;Data Source=MyDataSourse;
Persist Security Info=False
2) способ если использовать "Oracle Provaider for Ole DB" - это провайдер от Oracle
Provider=OraOLEDB.Oracle.1;Persist Security Info=False;User ID=USER;Data Source=MyDataSourse

Автор ответа: Pegas
Взято с Vingrad.ru

Доступ к страницам Tabbednotebook

Доступ к страницам Tabbednotebook

При добавлении компонентов во время выполнения программы, вам необходимо присвоить для каждого компонента свойству parent (контейнер) _страницу_ компонента notebook, а не сам notebook.

Вы можете сделать это следующим образом (пример дан для кнопки):



MyButton:= TButton.Create( Form1 );  {как обычно...}
...
...
MyButton.Parent := TTabPage( TabbedNotebook1.Pages.Objects[n] );
{ <== где 'n' - индекс желаемой страницы ==> }

 


Свойство notebook 'Pages' имеет тип StringList и содержит список заголовков и объектов 'TTabPage'.

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

При добавлении компонента на страницу TabbedNotebook во время выполнения приложения, указатель на желаемую страницу для свойства Parent нового компонента должен быть назначен перед тем, как он будет реально показан. Способ получить доступ ко всем страницам TTabbedNotebook во время выполнения программы - с помощью свойства-массива Objects свойства TabbedNotebook Pages. Другими словами, страничные компоненты хранятся как объекты, присоединенные к имени страницы в списке строк свойства Pages. В следующим коде показано создание кнопки на второй странице компонента TabbedNotebook1:



var
NewButton : TButton;
begin
NewButton := TButton.Create(Self);
NewButton.Parent := TWinControl(TabbedNotebook1.Pages.Objects[1])
...

 


Вот как страница TNotebook может быть использована в качестве родителя для вновь создаваемого на ней компонента:



NewButton.Parent := TWinControl(Notebook1.Pages.Objects[1])




Вот как страница (закладка) TTabSet может быть использована в качестве родителя для вновь создаваемого на ней компонента:



NewButton.Parent := TWinControl(TabSet1.Tabs.Objects[1])

Взято с

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

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

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

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

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


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


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

function TForm1.ChkPath: Boolean;
var
  s: array[0..100] of char;
begin
  if DirectoryExists(Edit1.Text) then
    begin
      DataBase1.DatabaseName := 'TempDB';
      DataBase1.DriverName := 'Standard';
      DataBase1.LoginPrompt := false;
      DataBase1.Connected := False;
      DataBase1.Params.Add('Path=' + Edit1.Text);
      DataBase1.Connected := TRUE;
      Result := TRUE;
    end
  else
    begin
      StrPCopy(s, 'Каталог : ' + Edit1.text + ' не найден');
      Application.MessageBox(s, 'Ошибка!', MB_ICONSTOP);
      Result := FALSE;
    end;
end;

{ Примечание: Не забудьте добавить объявление
  функции в секцию public формы. }





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


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

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



unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, DB, StdCtrls, FileCtrl,

{$IFDEF WIN32}
  BDE;
{$ELSE}
  DbiProcs, DbiTypes, DbiErrs;
{$ENDIF }

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    Database1: TDatabase;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    function ChkPath: Boolean;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.ChkPath: Boolean;
var
  s: array[0..100] of char;
begin
  if DirectoryExists(Edit1.Text) then
    begin
      DataBase1.DatabaseName := 'TempDB';
      DataBase1.DriverName := 'Standard';
      DataBase1.LoginPrompt := false;
      DataBase1.Connected := False;
      DataBase1.Params.Add('Path=' + Edit1.Text);
      DataBase1.Connected := TRUE;
      Result := TRUE;
    end
  else
    begin
      StrPCopy(s, 'Каталог : ' + Edit1.text + ' не найден');
      Application.MessageBox(s, 'Ошибка!', MB_ICONSTOP);
      Result := FALSE;
    end;
end;

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

end.

Взято из

Другие базы данных

Другие базы данных

Cодержание раздела:

Другие компоненты

Другие компоненты

Cодержание раздела:

Duplicate resource error

Duplicate resource error

When I try to add a resource to my project's .res file, I get a
"Duplicate Resource" error when linking. The resource I have
added is a unique resource. How can I successfully add the
resource to my project?


The projects resource file is generated by the IDE wizard,
and is not intended to be modified. To add additional resources
to your project, create a separate resource file with a unique
name that does not conflict with either the project or any of
the unit names. Then to add the resource file to Delphi, simply
add the following line to any unit file in the project:

{$R MyRes.Res}

(where MyRes.Res is the name of the resource file).

To add the resource to Borland's C++ Builder, add the resource
from the project manager.

ENoResultSet Error creating cursor handle

ENoResultSet Error creating cursor handle

Почему не работает Query.Open(Query.ExecSQL)?
Что значит "ENoResultSet Error creating cursor handle"?

1.Query.Open возвращает результат запроса в виде курсора(Cursor).

Когда мы выполняем запрос «select * from table1» мы получаем
Набор данных (Cursor). Можете представит курсор как виртуальную таблицу, со строками и столбцами, определенными в запросе. В этом случае надо использовать Query.Open или Query.Active:=true;

2.Query.ExecSQL выполняет инструкции запроса и курсор не создается.

Если в запросах используются инструкции не создающие набор данных (курсор) ? СREATE TABLE, INSERT, DELETE, UPDATE , SELECT INTO и т.д. то нужно вызывать метод ExecSQL.

Автор: BAS

EOleSysError - как бороться?

EOleSysError - как бороться?

Перед тем как Дельфи сможет использовать любые ActiveX/COM (в том числе и ADO компоненты) должна быть выполнена строка Application.Initialize - которая инициализирует использование COM. Если пишется DLL или консольное приложение, которые не имеют объекта Application, то надо просто добавить в Uses ещё один модуль: "oleauto"

Автор:

Vit

Взято из

Error -10 when trying to install Kylix

Error -10 when trying to install Kylix

The Error -10 is a generic install error. The usual cause of this is due to a previous version of Kylix that wasn't uninstalled completely. You will need to check the RPM database to see if there are still components from Kylix installed. This can be done with command rpm -qa | grep kylix. For each of the resulting packages (if there are none, then Kylix is completely uninstalled), use rpm -e PackageName to remove them. Then, try reinstalling Kylix.

If you have Kylix completely uninstalled (the rpm -qa | grep kylix command returns nothing), and after choosing "Begin Install" from the installation, the installer aborts with an error code -10, then the problem may be do with the your locale settings. Typing the command "locale" may show LC_NUMERIC="de_DE" (the German locale, in this case). Some versions of RPM (mostly newer ones) respect this setting and will use a comma as the decimal separator. This causes a problem for the Kylix installer. The installer needs a period as the decimal separator. The workaround is to reset the LC_NUMERIC environment like this:


    export LC_NUMERIC="en_US"
   
Once installation is finished, you can reset this value by setting it to the original locale. This problem can occur for any locale which does not use a period as the decimal separator.

It's possible that a previous version of Kylix was not uninstalled completely or that there is a problem with the RPM. [{more info}]. There are a couple ways to work around this. The first is to install as a user other than root. If you would rather not do this you can use the "-m" option on the setup script. So you would enter: ./setup.sh -m from a vterm. This tells the script to not use the RPM.

Примечание от Vit: обычно ошибка возникает при попытке установить Kylix от имени root и разрешается простой установкой Kylix от имени обычного пользователя.

Error: Interface not supported

Error: Interface not supported

I receive an "Interface is not supported" error when trying to use an interface.

Verify that STDVCL32.DLL and your type library are registered. If casting an interface, you must be using DCOM and the type library must be registered on the client.

Error permission denied when trying to run Kylix

Error permission denied when trying to run Kylix

If you installed as root and accepted the defaults then Kylix was installed under the /root directory. By default the permissions for this directory are 700 so only the root user can access this directory tree for read, write or execute. If users besides root are to use Kylix it must be installed in a directory all will have access to. See the file INSTALL that comes with Kylix for more information.

Error reading symbol file

Error reading symbol file

This usually occurs when you move a project to another drive or
directory. Simply deleting the project's .DSM and .DSK files should
remedy the situation.

Error: RPC Server is unavailable

Error: RPC Server is unavailable

The error is usually caused because the server can't be located. Make sure you can ping the server machine using the string you typed into the ComputerName property of the TRemoteServer. You might also want to try using an IP address instead in case there is some problem with your DNS configuration or the hosts file. Try setting the "Default Authentication Level" to (Run DCOMCNFG on the server to do this.) Lastly, check the Microsoft Developer's Network on the Web for the latest information on this Microsoft transport. The MSDN can be located at the time of the writing at www.microsoft.com/msdn.

Escape код PASSTHROUGH

Escape код PASSTHROUGH

Кто - нибудь знает почему некоторые видеодрайверы не осуществляют транзитную пересылку данных(passthrough)в Escape функции?
Как узнать, поддерживает ли драйвер принтера код PASSTROUGH? Dos - приложения и в Windows 95 используют эту функцию с командой "copy file > lpt1" для передачи текста в буфер принтера.

Хотя Delphi модуль TPrinter облегчает доступ к принтеру, есть случаи, когда вам необходимо спуститься до транспортного уровня общения системы с принтером и передать специфические для устройства управляющие коды.Под 16 - битной операционной системой Windows это было так же легко, как открыть порт принтера, но сейчас, к примеру, под Windows NT, непосредственный доступ к аппаратному обеспечению невозможен.Одно из решений проблемы состоит в использовании Windows кода "PASSTHROUGH" для посылки кода непосредственно в принтер.Тем не менее, для использования кода "PASSTHROUGH" необходимо, чтобы это поддерживалось самим драйвером принтера.К сожалению, далеко не все принтеры поддерживают данную характеристику.

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

Приведенный ниже пример не привязан к каким - либо специфическим моделям принтеров.Вам необходимо лишь знать правильную последовательность передачи escape кодов на управляемый вами принтер.Имейте в виду, что вы все еще должны вызывать методы BeginDoc и EndDoc объекта TPrinter.При вызове метода BeginDoc драйвер принтера инициализирует принтер как объект управления, EndDoc - деинициализацирует и извлекает бумагу.При escape вызове принтер может установить текущий режим метрики экрана, если он поддерживает внутреннее масштабирование.Технически вы ничего не должны делать, что могло бы вызвать обнуление памяти принтера или удаление из него бумаги с помощью escape кодов.Другими словами, попытайтесь оставить принтер в том же состоянии, в котором он остался после окончания печати.В основном это касается технически совершенных принтеров, поддерживающих режим Postscript, в стандартных же моделях(TTY)все это не столь существенно, и вы свободны в своих действиях, включая удаление страницы из принтера.

Пример кода:

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

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

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

unitEsc1;

interface

uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
  end;

var

  Form1: TForm1;

implementation

{ добавляем модуль printers }
uses

  Printers;

{$R *.DFM}

{ описываем структуру "PASSTHROUGH" }
type TPrnBuffRec = record

    BuffLength: word;
    Buffer: array[0..255] of char;
  end;

procedure TForm1.Button1Click(Sender: TObject);
var

  Buff: TPrnBuffRec;
  TestInt: integer;
  s: string;
begin

{ Тестируем на предмет поддержки escape кода "PASSTHROUGH" }

  TestInt := PASSTHROUGH;
  if Escape(Printer.Handle,
    QUERYESCSUPPORT,
    sizeof(TestInt),
    @TestInt,
    nil) > 0 then
    begin

{ Начинаем вывод на печать }
      Printer.BeginDoc;

{ Создаем строку для транзитной пересылки }
      s := ' Текстовая строка ';

{ Копируем строчку в буфер }
      StrPCopy(Buff.Buffer, s);

{ Устанавливаем размер буфера }
      Buff.BuffLength := StrLen(Buff.Buffer);

{ Даем команду на транзитную пересылку буфера }
      Escape(Printer.Canvas.Handle,
        PASSTHROUGH,
        0,
        @Buff,
        nil);

{ Заканчиваем вывод на печать }
      Printer.EndDoc;
    end;
end;

end.

Взято из

Советов по Delphi от

Сборник Kuliba

Еще шаг в направлении COM

Еще шаг в направлении COM

Сделаем еще шаг в направлении Component Object Module (COM).Даже сейчас у экспортируется довольно много функций. Соответсвенно и в программе нам надо сделать несколько ступений - создать переменную-указатель, присвоить ей значение адреса нужной функции при помощи GetProcAddress, и только потом вызвать саму функцию. Причем все эти функции у нас сами по себе и никак не связанны с самим объектом, который мы используем. А неплохо бы сделать так, чтобы можно было работать с ними как с объектом, что нибудь типа:
Сalc.SetOperands(13,10);
i:=Calc.Sum;

Так давайте так и сделаем! Правда мы ограничены экспортом только функций, но мы сделаем так:

Добавим в dll такую запись

type
ICalc=record  
SetOpers:procedure (x,y:integer);  
Sum:function:integer;  
Diff:function:integer;  
Release:procedure;  
end;  

и процедуру:

procedure GetInterface(var Calc:ICalc);
begin
CreateObject;  
Calc.Sum:=Sum;  
Calc.Diff:=Diff;  
Calc.SetOpers:=SetOperands;  
Calc.Release:=ReleaseObject;  
end;

и будем экспортировать только ее:

exports
GetInterface; 

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

Переделаем наш тестер.

В описание типов добавим:

type
ICalc=record  
SetOpers:procedure (x,y:integer);  
Sum:function:integer;  
Diff:function:integer;  
Release:procedure;  
end;  

изменим секцию var.

var
Form1: TForm1;  
_Mod:Integer;  
GetInterface:procedure (var x:ICalc);  
Calc:ICalc;  

и процедуры где мы используем наш объект.

procedure TForm1.FormCreate(Sender: TObject);
begin
_Mod:=LoadLibrary('CalcDll.dll');  
GetInterface:=GetProcAddress(_Mod,'GetInterface');  
GetInterface(Calc);  
Calc.SetOpers(13,10);  
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
Calc.Release;  
FreeLibrary(_Mod);  
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(Calc.diff));  
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(IntToStr(Calc.Sum));  
end;

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

Ещё примеры экспертов

Ещё примеры экспертов

This article introduces you to the world of Delphi Experts. Delphi Experts are DLLs, that will be loaded during the startup sequence of Delphi. This article first appeared on Delphi-PRAXiShttp://www.delphipraxis.net/viewtopic.php?t=5300 in German.

NOTE: The techniques shown in this article are valid starting with Delphi 3 or 4 and since Delphi 7 they are deprecated, however, still fully suported by the Delphi IDE.

Installation of a Delphi-IDE-Expert

Every Delphi-Expert has to be registered in the Windows-Registry. For each Delphi-Version installed on a machine, as well as for each user using the machine, the Delphi-Expert has to be registered separately.

In the Registry the Delphi-Expert has to be registered under the folowing key:

HKCU\Software\Borland\Delphi\X.0\Experts

, where the X has to be replaced by the appropriate Delphi-Version supported. It may happen that the Experts key is not installed, in such case you are required to create it.

Underneath the Experts key you have to create a string value for the Delphi-Expert. The name must be unique. The value must point to the Delphi-Expert DLL, including both complete path and file name of the Delphi-Expert. Next time Delphi starts, the Expert will be loaded automatically.

The interface of the Delphi-Expert

In order for the Delphi Expert to interact with the Delphi-IDE ist has to export a function with the name ExpertEntryPoint, using the following parameters:

function

InitExpert(ToolServices: TIToolServices; RegisterProc:
  TExpertRegisterProc; var Terminate: TExpertTerminateProc): Boolean; export;
  stdcall;

The first parameter ToolServices offers all "documented" interfaces to the Delphi-IDE. The second parameter RegisterProc is used to load the expert into the Delphi-IDE. The last parameter Teminate is used to notify the Expert-DLL when it is about to be unloaded by the Delphi-IDE.

The InitExpert method returns True, if the Expert has loaded successfully, otherwise it can eiter return False or raises an exception to unload the DLL from the Delphi-IDE (see code sample for solution).

The PlugIn class TIExpert

Any Delphi-Expert must be derived from the class TIExpert, which is declared in the unit ExptIntf. This class defines some abstract methods, which must be implemented by each PlugIn: GetName, GetAuthor, GetComment, GetPage, GetGlyph (different for Windows and Linux), GetStyle, GetState, GetIDString, GetMenuText and Execute. The purpose of each method is explained in the source code below.

The simplest Delphi-Expert

This Delphi-Expert want do much good, however, it shows you the basic way of getting the job done. It will show an entry in the Help menu (default behavior). Once the user clicks the menu item the method Execute from the Expert will be called. The following points must be respected in order to get the expert working:

·The method GetState must return [esEnabled]
·The method GetStyle must return esStandard  
·The method GetMenuText returns the text to be shown in the Help menu  
·The method Execute defines the expert action upon activation  

The Library Source Code (DelphiPlugI.dpr)

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 *
 * App. Name : DelphiPlug
 * Autor     : Daniel Wischnewski
 * Copyright : Copyright © 2000-2003 by gate(n)etwork GmbH. All Right Reserved.
 * Urheber   : Daniel Wischnewski
 *
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

library DelphiPlug;

{ Important note about DLL memory management: ShareMem must be the
  first unit in your library's USES clause AND your project's (select
  Project-View Source) USES clause if your DLL exports any procedures or
  functions that pass strings as parameters or function results. This
  applies to all strings passed to and from your DLL--even those that
  are nested in records and classes. ShareMem is the interface unit to
  the BORLNDMM.DLL shared memory manager, which must be deployed along
  with your DLL. To avoid using BORLNDMM.DLL, pass string information
  using PChar or ShortString parameters. }

uses
  ShareMem,
  ExptIntf,
  uPlugIn in 'uPlugIn.pas';

{$R *.res}

exports
  InitExpert name ExpertEntryPoint;

begin
end.

The Unit Source Code (uPlugIn.pas)

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 *
 * Unit Name : uPlugIn
 * Autor     : Daniel Wischnewski
 * Copyright : Copyright © 2000-2003 by gate(n)etwork GmbH. All Right Reserved.
 * Urheber   : Daniel Wischnewski
 *
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit uPlugIn;

interface

uses
  ToolIntf, EditIntf, ExptIntf, VirtIntf, Windows, Messages;

const
  MIdx_Main = $0001;
  MIdx_ShowItems = $0002;
  MIdx_RunCommand = $0003;

type
  TDelphiPlug = class(TIExpert)
  private
  protected
  public
    // abstract methods to be overriden
    { Expert UI strings }
    function GetName: string; override; stdcall;
    function GetAuthor: string; override; stdcall;
    function GetComment: string; override; stdcall;
    function GetPage: string; override; stdcall;
{$IFDEF MSWINDOWS}
    function GetGlyph: HICON; override; stdcall;
{$ENDIF}
{$IFDEF LINUX}
    function GetGlyph: Cardinal; override; stdcall;
{$ENDIF}
    function GetStyle: TExpertStyle; override; stdcall;
    function GetState: TExpertState; override; stdcall;
    function GetIDString: string; override; stdcall;
    function GetMenuText: string; override; stdcall;
    { Launch the Expert }
    procedure Execute; override; stdcall;
  end;

function InitExpert(ToolServices: TIToolServices; RegisterProc:
  TExpertRegisterProc; var Terminate: TExpertTerminateProc): Boolean; export;
stdcall;

implementation

uses
  SysUtils, ShellAPI;

function InitExpert(ToolServices: TIToolServices; RegisterProc:
  TExpertRegisterProc; var Terminate: TExpertTerminateProc): Boolean; export;
  stdcall;
var
  DelphiPlug: TDelphiPlug;
begin
  Result := True;
  try
    // assign tools services
    ExptIntf.ToolServices := ToolServices;
    // create the Delphi-Plug
    DelphiPlug := TDelphiPlug.Create;
    // register with Delphi
    RegisterProc(DelphiPlug);
  except
    // kill assistant
    ToolServices.RaiseException(ReleaseException);
  end;
end;

{ TDelphiPlug }

procedure TDelphiPlug.Execute;
begin
  // en:
  //   Execute will be called, whenever the user clicks on the menu entry in the
  //   help menu
  // de:
  //   Execute wird aufgerufen, wenn der User auf den Eintrag im Hilfe-Menь
  //   klickt
  MessageBox(ToolServices.GetParentHandle, 'How may I help you?', 'Hmm',
    MB_ICONQUESTION + MB_OK);
end;

function TDelphiPlug.GetAuthor: string;
begin
  // en:
  //   returns the name of the author of the plugin
  // de:
  //   liefert den Namen des Autoren des PlugIns zurьck (wofьr auch immer)
  Result := 'sakura (Daniel Wischnewski)';
end;

function TDelphiPlug.GetComment: string;
begin
  // en:
  //   I got no idea where this comment will be displayed, ever.
  // de:
  //   Auch hier weiЯ ich nicht, wo das jemals angezeigt wird, aber bitte...
  Result := 'A simple Delphi-PlugIn example.';
end;

{$IFDEF MSWINDOWS}

function TDelphiPlug.GetGlyph: HICON;
begin
  // en:
  //   an icon handle for the entry in the help menu
  // de:
  //   Ein Icon-Handle fьrs Menь
  Result := NOERROR;
end;
{$ENDIF}
{$IFDEF LINUX}

function TDelphiPlug.GetGlyph: Cardinal;
begin
  // en:
  //   an icon handle for the entry in the help menu
  // de:
  //   Ein Icon-Handle fьrs Menь
  Result := NOERROR;
end;
{$ENDIF}

function TDelphiPlug.GetIDString: string;
begin
  // en:
  //   id of the expert
  // de:
  //   ID des Experten
  Result := 'DelphiPlugSampleI';
end;

function TDelphiPlug.GetMenuText: string;
begin
  // en:
  //   this text will be schon in the help menu. each time the menu drops down,
  //   this method will be called.
  //   NOTE:
  //     the method GetState must return esStandard, otherwise the help menu
  //     entry will not be generated and shown
  //
  // de:
  //   Text der im Hilfe Menь angezeigt wird. Diese Funktion wird jedesmal
  //   aufgerufen, wenn das Hilfemenь angezeigt wird.
  //   HINWEIS:
  //     die Methode GetState muЯ esStandard zurьckliefern, damit dieser Eintrag
  //     im Hilfemenь automatisch generiert wird
  Result := 'You will find me in the help menu';
end;

function TDelphiPlug.GetName: string;
begin
  // en:
  //   this name must be unique
  // de:
  //   dieser Name muss!!! einmalig sein
  Result := 'sakura_DelphiPlugSample';
end;

function TDelphiPlug.GetPage: string;
begin
  // en:
  //   interesting to experts expanding the default dialogs of the Delphi-IDE
  // de:
  //   Ist fьr Experte interessant, welche Standard-Dialoge erweitern sollen
  Result := '';
end;

function TDelphiPlug.GetState: TExpertState;
begin
  // en:
  //   returns a set of states
  //   possible values: esEnabled, esChecked
  // de:
  //   liefert ein Set von Stati zurьck
  //   mцgliche Werte: esEnabled, esChecked
  Result := [esEnabled];
end;

function TDelphiPlug.GetStyle: TExpertStyle;
begin
  // en:
  //   returns the type of expert
  // de:
  //   liefert die Art des Experten zurьck
  //   mцgliche Werte: esStandard, esForm, esProject, esAddIn
  Result := esStandard;
end;

end.
 

Взято с

Delphi Knowledge Base

Если отображается только часть TImage

Если отображается только часть TImage

При увеличении размера компонента TImage в RunTime пытаюсь рисоватьзаново на всем поле, но отображается только часть компонента (прежнегоразмера). В чем дело?

Нужно при инициализации выполнить SetBounds(), с максимальными размерами.

Источник: 

Если прозрачная часть glyph'а становится видной...

Если прозрачная часть glyph'а становится видной...

В некоторых видео режимах прозрачная часть glyph'а стандартного TBitBtn становится видной. Как этого избежать?

В примере используется техника закраски прозрачной части glyph'а цветом кнопки на которой он находится - таким образом glyph кажется прозрачным.

function InitStdBitBtn(BitBtn: TBitBtn; kind: TBitBtnKind): bool;
var
  Bm1: TBitmap;
  Bm2: TBitmap;
begin
  Result := false;
  if Kind = bkCustom then
    exit;
  Bm1 := TBitmap.Create;
  case Kind of
    bkOK: Bm1.Handle := LoadBitmap(hInstance, 'BBOK');
    bkCancel: Bm1.Handle := LoadBitmap(hInstance, 'BBCANCEL');
    bkHelp: Bm1.Handle := LoadBitmap(hInstance, 'BBHELP');
    bkYes: Bm1.Handle := LoadBitmap(hInstance, 'BBYES');
    bkNo: Bm1.Handle := LoadBitmap(hInstance, 'BBNO');
    bkClose: Bm1.Handle := LoadBitmap(hInstance, 'BBCLOSE');
    bkAbort: Bm1.Handle := LoadBitmap(hInstance, 'BBABORT');
    bkRetry: Bm1.Handle := LoadBitmap(hInstance, 'BBRETRY');
    bkIgnore: Bm1.Handle := LoadBitmap(hInstance, 'BBIGNORE');
    bkAll: Bm1.Handle := LoadBitmap(hInstance, 'BBALL');
  end;
  Bm2 := TBitmap.Create;
  Bm2.Width := Bm1.Width;
  Bm2.Height := Bm1.Height;
  Bm2.Canvas.Brush.Color := ClBtnFace;
  Bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
    Rect(0, 0, Bm1.width, Bm1.Height),
    Bm1.canvas.pixels[0, 0]);
  Bm1.Free;
  LockWindowUpdate(BitBtn.Parent.Handle);
  BitBtn.Kind := kind;
  BitBtn.Glyph.Assign(bm2);
  LockWindowUpdate(0);
  Bm2.Free;
  Result := true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  InitStdBitBtn(BitBtn1, bkOk);
end;

Есть ли CD-ROM?

Есть ли CD-ROM?

GetLogicalDrives()
GetDriveType() 

Автор ответа: Song
Взято с Vingrad.ru

Есть ли соединение с инетом?

Есть ли соединение с инетом?

За это отвечает ф-ии InternetGetConnectedState() из wininet.dll или InetIsOffLine() из url.dll

Автор ответа: Song
Взято с Vingrad.ru





Единственный 100% достоверный способ узнать находится ли комп в интернете это скачать что-то со стабильного внешнего сервера - такого как Microsoft, Yahoo, AT&T... По другому ни одна функция локального компьютера не сможет отличить нахождение компьютера в интранете и в интернете... Я в своей программе для определения коннекта с интернетом пингую наш собственный DNS сервер, который стоит за Firewall и естественно пинговка идет через провайдера интернет. (В некоторых Firewall может быть запрещен Ping - тогда надо именно попытаться скачать что-нибудь)
Автор ответа: Vit
Взято с Vingrad.ru


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

Совместимость: Delphi 3.x (или выше)

Для работы Вам необходимо импортировать функцию InetIsOffline из URL.DLL:

function InetIsOffline(Flag: Integer): Boolean; stdcall; external 'URL.DLL';

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

if InetIsOffline(0) then
ShowMessage('This computer is not connected to Internet!')
else
ShowMessage(You are connected to Internet!');

Эта функция возвращает TRUE если соединение с интернетов отсутствует, или FALSE если соединение установлено.

Замечание:
параметр Flag игнорируется, соответственно используем ноль.
Эта DLL обычно проинсталлирована на большинстве компьютеров. Она также существует в Win98 либо поставляется с Internet Explorer 4 или выше, Office 97 и т.д..
Более подробно можно прочитать в MSDN. Оригинал: http://msdn.microsoft.com/library/psdk/shellcc/shell/Functions/InetIsOffline.htm

Автор ответа: Vitaly Zayko

Взято с Исходников.ru


interface 

uses 
  Windows, SysUtils, Registry, WinSock, WinInet; 

type 
  TConnectionType = (ctNone, ctProxy, ctDialup); 

function ConnectedToInternet: TConnectionType; 
function RasConnectionCount: Integer; 


implementation 

//For RasConnectionCount ======================= 
const 
  cERROR_BUFFER_TOO_SMALL = 603; 
  cRAS_MaxEntryName       = 256; 
  cRAS_MaxDeviceName      = 128; 
  cRAS_MaxDeviceType      = 16; 
type 
  ERasError = class(Exception); 

  HRASConn = DWORD; 
  PRASConn = ^TRASConn; 
  TRASConn = record 
    dwSize: DWORD; 
    rasConn: HRASConn; 
    szEntryName: array[0..cRAS_MaxEntryName] of Char; 
    szDeviceType: array[0..cRAS_MaxDeviceType] of Char; 
    szDeviceName: array [0..cRAS_MaxDeviceName] of Char; 
  end; 

  TRasEnumConnections = 
    function(RASConn: PrasConn; { buffer to receive Connections data } 
    var BufSize: DWORD;    { size in bytes of buffer } 
    var Connections: DWORD { number of Connections written to buffer } 
    ): Longint;  
  stdcall; 
  //End RasConnectionCount ======================= 


function ConnectedToInternet: TConnectionType; 
var 
  Reg:       TRegistry; 
  bUseProxy: Boolean; 
  UseProxy:  LongWord; 
begin 
  Result := ctNone; 
  Reg    := TRegistry.Create; 
  with REG do 
    try 
      try 
        RootKey := HKEY_CURRENT_USER; 
        if OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet settings', False) then  
        begin 
          //I just try to read it, and trap an exception 
          if GetDataType('ProxyEnable') = rdBinary then 
            ReadBinaryData('ProxyEnable', UseProxy, SizeOf(Longword)) 
          else  
          begin 
            bUseProxy := ReadBool('ProxyEnable'); 
            if bUseProxy then 
              UseProxy := 1 
            else 
              UseProxy := 0; 
          end; 
          if (UseProxy <> 0) and (ReadString('ProxyServer') <> '') then 
            Result := ctProxy; 
        end; 
      except 
        //Obviously not connected through a proxy 
      end; 
    finally 
      Free; 
    end; 

  //We can check RasConnectionCount even if dialup networking is not installed 
  //simply because it will return 0 if the DLL is not found. 
  if Result = ctNone then  
  begin 
    if RasConnectionCount > 0 then Result := ctDialup; 
  end; 
end; 

function RasConnectionCount: Integer; 
var 
  RasDLL:    HInst; 
  Conns:     array[1..4] of TRasConn; 
  RasEnums:  TRasEnumConnections; 
  BufSize:   DWORD; 
  NumConns:  DWORD; 
  RasResult: Longint; 
begin 
  Result := 0; 

  //Load the RAS DLL 
  RasDLL := LoadLibrary('rasapi32.dll'); 
  if RasDLL = 0 then Exit; 

  try 
    RasEnums := GetProcAddress(RasDLL, 'RasEnumConnectionsA'); 
    if @RasEnums = nil then 
      raise ERasError.Create('RasEnumConnectionsA not found in rasapi32.dll'); 

    Conns[1].dwSize := SizeOf(Conns[1]); 
    BufSize         := SizeOf(Conns); 

    RasResult := RasEnums(@Conns, BufSize, NumConns); 

    if (RasResult = 0) or (Result = cERROR_BUFFER_TOO_SMALL) then Result := NumConns; 
  finally 
    FreeLibrary(RasDLL); 
  end; 
end;

Взято с сайта

Есть-ли способ восстановить несохраненные

Есть-ли способ восстановить несохраненные (uncommitted) изменения БД, например в случае отключения питания?

Нет. Такие изменения будут потеряны. Т.е. БД останется в состоянии, соответствующем последней подтвержденной (committed) транзакции. Несохраненные данные в БД останутся в виде "осиротевших" страниц, которые можно очистить при помощи Server Manager, пункт меню Validate Database, или в виде "мусорных" версий записей, которые будут автоматически очищены при очередном чтении данных.

Вполне возможно, что этот вопрос вызван тем, что восстановление состояния БД в IB отличается от других широкораспространенных SQL-серверов (Oracle, Informix, ...). IB не требует выполнения каких-то специфических действий для продолжения работы с БД в случае сбоя питания - изменения, происходящие до COMMIT, не записываются на место актуальных данных (т.е. отсутствует режим Dirty Read), поэтому они будут просто потеряны, а БД останется в рабочем состоянии.

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

Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко

Есть желание разрабатывать этот проект совместно?

Есть желание разрабатывать этот проект совместно?

Есть идея, но нужны добровольцы. Если кто желает действительно существенно улучшить эту базу знаний, то можем начать работу вместе. Но посылать мне примеры статей не совсем то, что нужно по многим причинам:
1) Надо прослеживать дубликаты
2) Надо нормально оформить текст
3) Надо определиться с разделом и т.д.

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

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

Любой желающий берёт любой небольшой раздел базы (например: "работа с TButton") и находит по форумам, в инете, по другим FAQ всю информацию касательно этого небольшого раздела, соответствующим образом оформляет текст и отсылает мне.

Формальные требования к оформлению:

1) Код Дельфи должен быть отформатирован (отступы, переносы и т.п.)
2) Название топика в начале
3) Ссылка на авторство в конце статьи
4) Никаких таблиц (их трудно вставлять в help), никаких рисунков (объём базы этого уже не позволяет)
5) Текст статей желательно посылать в ввиде обычного текста (txt). Мне крайне трудно переносить из Word и тем более из HTML - перенос обычно приводит к искажению всего оформления и зачастую мне приходится по новой переформатировать текст и коды.

Есть желающие?

Все желающие могут обратиться ко мне через форумы:

Vingrad.ru:
или
Sources.ru:

Exception при попытке создать обьект класса TPrinter

Exception при попытке создать обьект класса TPrinter

В создании обьекта класса TPrinter с использованием TPrinter.Create нет необходимости,
так как обьект класса TPrinter (называемый Printer) автоматически создается при
использовании модуля Printers.

Пример:

usesPrinters;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Printer.BeginDoc;
  Printer.Canvas.TextOut(100, 100, 'Hello World!');
  Printer.EndDoc;
end;

Взято из
DELPHI VCL FAQ

Перевод с английского   
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для

Extended Stored Procedures with Delphi - Using the ODS (Open Data Services) Api from Delphi

Extended Stored Procedures with Delphi - Using the ODS (Open Data Services) Api from Delphi

Have you ever tried to create a stored procedure on an SQL Server?
What if the functionality you wish to incorporate is not inside the SQL but in your Delphi project? Microsoft provides ODS (Open Data Services) which is an API to help you create such functionality by adding DLL's to your SQL Server that contain Extended Stored Procedures.
This is how you do it....

Answer:

As a special bonus, this article also is a simple solution to encrypting your data inside SQL Server using Extended Stored Procedures.

What do we need?

1.1.opends60.dll (from a full installation with developer tools of MSSQL or MSDE)  
2.2.   MsOdsApi.pas (Header file to use opends60.dll) (included at the end of the article)  
3.3.   A Local SQL Server for testing (MSDE will do fine).  

NOTE: For cryptography I used the components found under MIT license here:
http://www.cityinthesky.co.uk/cryptography.html

Steps:

1.1.   Create a new DLL.  
2.2.   Create a unit and in the uses clause add the MsOdsApi unit.  
3.3.   In the Library file just under ther Uses clause add Exports and the names of the functions to export:  

library

 MyEncryptDll;

uses
  SysUtils,
  Classes,
  Unit1 in 'Unit1.pas';

exports
  xp_DoEncrypt,
  xp_DoDecrypt;

begin
end.

4. In the Unit file just under the Uses clause add your function reference:

function

xp_DoEncrypt(pSrvProc: SRV_PROC): Integer; cdecl;
function xp_DoDecrypt(pSrvProc: SRV_PROC): Integer; cdecl;

NOTES: cdecl is required for ODS to be able to call your functions. SRV_PROC is a handle to the stored procedure information.

5. The code of the DoEncrypt is this: (DoDecrypt is exactly the same just with a DecryptString(s) call.

function

 xp_Encrypt(pSrvProc: SRV_PROC): Integer;cdecl;
var
  i, sz: Integer;
  bType: Byte;
  fNull: Bool;
  cbMaxLen, cbActualLen: ULONG;
  myData,myanswer,myKey:array [0..255] of char;
  FDCP_3des: TDCP_3des;
  s:string;
  ps:pchar;
begin
  for i:=0 to 255 do
    begin
      myData[i]:=#0;
      myanswer[i]:=#0;
      myKey[i]:=#0;
    end;
  if srv_rpcparams(pSrvProc) = 2 then  // Check if input parameters are present...
    begin
    srv_paraminfo(pSrvProc, 1, @bType,  // Let's use 1st input parameter!
       @cbMaxLen, @cbActualLen, // NOTE: We assume here what only 2 parameters
       @myData[0], @fNull);    //of type String can be passed!!!
    bType:=SRVVARCHAR;
    srv_paraminfo(pSrvProc, 2, @bType,
       @cbMaxLen, @cbActualLen,
       @myKey[0], @fNull);
    end
  else
    MyData := '';    // No input parameters? Use default value instead.
   
  //ENCRYPTION CODE BELOW YOU CAN DO WHATEVER YOU NEED HERE WITH THE PARAMETER VALUES 

  FDCP_3des:=TDCP_3des.Create(nil);
  FDCP_3des.BlockSize:=64;
  FDCP_3des.Algorithm:='3DES';
  FDCP_3des.CipherMode:=cmCBC;
  FDCP_3des.Id:=24;
  FDCP_3des.MaxKeySize:=192;
  FDCP_3des.InitStr(myKey,TDCP_sha1);
  s:=string(mydata);
  strpcopy(myAnswer,FDCP_3des.EncryptString(s));
  FDCP_3des.Burn;

  // SETTING UP ANSWER VALUES TO PCHAR AND GETTING SIZE

  s:=string(myAnswer);
  sz:=length(s);
  ps:=allocmem(sz);
  ps:=pchar(s);  

  // Describe columns
  // (Actually, you are doing that for every datatype and every column you want to return).
  srv_describe(pSrvProc,1 , 'Value', SRV_NULLTERM,
               SRVVARCHAR, sz,
               SRVVARCHAR, sz, nil);
    // Begin output...
  srv_setcoldata(pSrvProc, 1, @ps[0]);
  srv_sendrow(pSrvProc);   // Send the row.
  srv_senddone(pSrvProc,    // Finally send data back to SQL Server:
    (SRV_DONE_COUNT or SRV_DONE_MORE), 0, 1);   // send results completion message.
  // FREEING ENCRYPTION COMPONENT
  FreeAndNil(FDCP_3des);
  result := 1;               // Report success (1 = SUCCEED, 0 = FAIL)

end

;

NOTE: There are a number of things you can do with ODS. This is just an example for Delphi. You can read the ODS help in MSDN and do even more.

6. Testing and Debugging:

A) Install SQL 7.0/2000 on your workstation (or install Delphi on workstation where SQL Server is installed).

B) Register your Xp on SQL Server.
NOTES:
Register Xp like this:
use master
go
sp_addextendedproc 'xp_DoEncrypt', 'MyEncryptDll.dll'
go
sp_addextendedproc 'xp_DoDecrypt', 'MyEncryptDll.dll'
go
Unregister Xp like this:
use master
go
sp_dropextendedproc 'xp_DoEncrypt'
go
sp_dropextendedproc 'xp_DoDecrypt'
go
Unlock DLL in case it still being used by SQL like this:
use master
go
DBCC MyEncryptDll(FREE)
go
C) In Delphi, select from main menu Run -> Run Parameters.
In the Host Application field, specify a pathname to your SQL Server executable (sqlservr.exe). For SQL 7.0, this is enough. For SQL 2000, in the Parameters field specify a command line parameter "-sYOUR_SQL_NAME", where YOUR_SQL_NAME is the name assigned to your SQL Server during the installation.
Set breakpoints in your Delphi code and run project. SQL Server will start as a console application.
D) You can execute your Xp from Query Analyzer and trace code in Delphi.
NOTE:
Executing an extended stored procedure is done like this:
exec master..xp_DoEncrypt 'ValueToEncrypt','KeyValue'
go
E) To exit application, press Ctrl+Pause in the SQL Server console window.

-------------------------------------------------------
End of article. Bellow follows a unit required for ODS.
-------------------------------------------------------

MsOdsApi.pas(Copy from line below)

unit MsOdsApi;

//------------------------------------------------------------
// Open Data Services header file: srv.h
// Copyright (c) 1989, 1990, 1991, 1997 by Microsoft Corp.
//

// Avoid double inclusion
//#ifndef _ODS_SRV_H_
//  _ODS_SRV_H_

//#include "windows.h"

// ODS uses pack(4) on all CPU types
//#pragma pack(4)

//#ifdef __cplusplus
//extern "C" {
//#endif

// define model
//#if !defined( FAR )
//  FAR far
//#endif

//------------------------------------------------------------
// Formats of data types
//#if !defined(DBTYPEDEFS) // Do not conflict with DBLIB definitions
//#if !defined(MAXNUMERICLEN) // Do not conflict with ODBC definitions

//  DBTYPEDEFS

interface

uses
  Windows;

type
  DBBOOL      = Byte;
  DBBYTE      = Byte;
  DBTINYINT   = Byte;
  DBSMALLINT  = Smallint;
  DBUSMALLINT = Word;
  DBINT       = Longint;
  DBCHAR      = Char;
  PDBCHAR     = ^DBCHAR;
  DBBINARY    = Byte;
  DBBIT       = Byte;
  DBFLT8      = Double;

  srv_datetime = record
    // Format for SRVDATETIME
    dtdays: Longint;  // number of days since 1/1/1900
    dttime: Longword; // number 300th second since mid
  end;
  DBDATETIME = srv_datetime;

  srv_dbdatetime4 = record
    // Format for SRVDATETIM4
    numdays: Word; // number of days since 1/1/1900
    nummins: Word; // number of minutes sicne midnight
  end;
  DBDATETIM4 = srv_dbdatetime4;

  srv_money = record
    // Format for SRVMONEY
    mnyhigh: Longint;
    mnylow : Longword;
  end;
  DBMONEY = srv_money;

  DBFLT4   = Double;
  DBMONEY4 = Longint;

const
  MAXNUMERICDIG     = 38;
  DEFAULTPRECISION  = 19; // 18
  DEFAULTSCALE      = 0;
  MAXNUMERICLEN       = 16;

type
  srv_dbnumeric = packed record
    // Format for SRVNUMERIC,SRVNUMERICN,SRVDECIMAL,SRVDECIMALN
    precision: Byte;
    scale    : Byte;
    sign     : Byte;                               // 1 = Positive, 0 = Negative
    val      : array [0..MAXNUMERICLEN-1] of Byte; // Padded little-endian value
  end;
  DBNUMERIC = srv_dbnumeric;
  DBDECIMAL = DBNUMERIC;

//#endif  // #if !defined(MAXNUMERICLEN)
//#endif  // #if !defined( DBTYPEDEFS )

//------------------------------------------------------------
// Constants used by APIs

// Type Tokens
const
  SRV_TDS_NULL           = $1f;
  SRV_TDS_TEXT           = $23;
  SRV_TDS_GUID           = $24;
  SRV_TDS_VARBINARY      = $25;
  SRV_TDS_INTN           = $26;
  SRV_TDS_VARCHAR        = $27;
  SRV_TDS_BINARY         = $2d;
  SRV_TDS_IMAGE          = $22;
  SRV_TDS_CHAR           = $2f;
  SRV_TDS_INT1           = $30;
  SRV_TDS_BIT            = $32;
  SRV_TDS_INT2           = $34;
  SRV_TDS_DECIMAL        = $37;
  SRV_TDS_INT4           = $38;
  SRV_TDS_DATETIM4       = $3a;
  SRV_TDS_FLT4           = $3b;
  SRV_TDS_MONEY          = $3c;
  SRV_TDS_DATETIME       = $3d;
  SRV_TDS_FLT8           = $3e;
  SRV_TDS_NUMERIC        = $3f;
  SRV_TDS_NTEXT            = $63;
  SRV_TDS_BITN            = $68;
  SRV_TDS_DECIMALN       = $6a;
  SRV_TDS_NUMERICN       = $6c;
  SRV_TDS_FLTN           = $6d;
  SRV_TDS_MONEYN         = $6e;
  SRV_TDS_DATETIMN       = $6f;
  SRV_TDS_MONEY4         = $7a;
  SRV_TDS_INT8           = $7f;  // SQL 2000 and later
  SRV_TDS_BIGVARBINARY   = $A5;
  SRV_TDS_BIGVARCHAR     = $A7;
  SRV_TDS_BIGBINARY      = $AD;
  SRV_TDS_BIGCHAR        = $AF;
  SRV_TDS_NVARCHAR       = $e7;
  SRV_TDS_NCHAR            = $ef;

// Datatypes
// Also: values of symbol parameter to srv_symbol when type = SRV_DATATYPE
  SRVNULL        = SRV_TDS_NULL;
  SRVTEXT        = SRV_TDS_TEXT;
  SRVGUID        = SRV_TDS_GUID;
  SRVVARBINARY   = SRV_TDS_VARBINARY;
  SRVINTN        = SRV_TDS_INTN;
  SRVVARCHAR     = SRV_TDS_VARCHAR;
  SRVBINARY      = SRV_TDS_BINARY;
  SRVIMAGE       = SRV_TDS_IMAGE;
  SRVCHAR        = SRV_TDS_CHAR;
  SRVINT1        = SRV_TDS_INT1;
  SRVBIT         = SRV_TDS_BIT;
  SRVINT2        = SRV_TDS_INT2;
  SRVDECIMAL     = SRV_TDS_DECIMAL;
  SRVINT4        = SRV_TDS_INT4;
  SRVDATETIM4    = SRV_TDS_DATETIM4;
  SRVFLT4        = SRV_TDS_FLT4;
  SRVMONEY       = SRV_TDS_MONEY;
  SRVDATETIME    = SRV_TDS_DATETIME;
  SRVFLT8        = SRV_TDS_FLT8;
  SRVNUMERIC    = SRV_TDS_NUMERIC;
  SRVNTEXT    = SRV_TDS_NTEXT;
  SRVBITN    = SRV_TDS_BITN;
  SRVDECIMALN    = SRV_TDS_DECIMALN;
  SRVNUMERICN    = SRV_TDS_NUMERICN;
  SRVFLTN        = SRV_TDS_FLTN;
  SRVMONEYN      = SRV_TDS_MONEYN;
  SRVDATETIMN    = SRV_TDS_DATETIMN;
  SRVMONEY4      = SRV_TDS_MONEY4;
  SRVINT8        = SRV_TDS_INT8;        // SQL 2000 and later
  SRVBIGVARBINARY = SRV_TDS_BIGVARBINARY;
  SRVBIGVARCHAR  = SRV_TDS_BIGVARCHAR;
  SRVBIGBINARY   = SRV_TDS_BIGBINARY;
  SRVBIGCHAR     = SRV_TDS_BIGCHAR;
  SRVNVARCHAR    = SRV_TDS_NVARCHAR;
  SRVNCHAR    = SRV_TDS_NCHAR;

// values for srv_symbol type parameter
 SRV_ERROR     = 0;
 SRV_DONE      = 1;
 SRV_DATATYPE  = 2;
 SRV_EVENT     = 4;

// values for srv_symbol symbol parameter, when type = SRV_ERROR
  SRV_ENO_OS_ERR    = 0;
  SRV_INFO          = 1;
  SRV_FATAL_PROCESS = 10;
  SRV_FATAL_SERVER  = 19;

// Types of server events
// Also: values for srv_symbol symbol parameter, when type = SRV_EVENT
  SRV_CONTINUE      = 0;
  SRV_LANGUAGE      = 1;
  SRV_CONNECT       = 2;
  SRV_RPC           = 3;
  SRV_RESTART       = 4;
  SRV_DISCONNECT    = 5;
  SRV_ATTENTION     = 6;
  SRV_SLEEP         = 7;
  SRV_START         = 8;
  SRV_STOP          = 9;
  SRV_EXIT          = 10;
  SRV_CANCEL        = 11;
  SRV_SETUP         = 12;
  SRV_CLOSE         = 13;
  SRV_PRACK         = 14;
  SRV_PRERROR       = 15;
  SRV_ATTENTION_ACK = 16;
  SRV_CONNECT_V7    = 16; // TDS type for TDS 7 clients.  Overloaded with SRV_ATTENTION_ACK
  SRV_SKIP       = 17;
  SRV_TRANSMGR       = 18;
  SRV_OLEDB       = 20;
  SRV_INTERNAL_HANDLER    = 99;
  SRV_PROGRAMMER_DEFINED  = 100;

// values for srv_config option parameter
  SRV_CONNECTIONS        = 1;
  SRV_LOGFILE            = 2;
  SRV_STACKSIZE          = 3;
  SRV_REMOTE_ACCESS      = 7;
  SRV_REMOTE_CONNECTIONS = 9;
  SRV_MAX_PACKETS        = 10;
  SRV_MAXWORKINGTHREADS  = 11;
  SRV_MINWORKINGTHREADS  = 12;
  SRV_THREADTIMEOUT    = 13;
  SRV_MAX_PACKETSIZE    = 17;
  SRV_THREADPRIORITY    = 18;
  SRV_ANSI_CODEPAGE    = 19;
  SRV_DEFAULT_PACKETSIZE = 26;
  SRV_PASSTHROUGH    = 27;

// vlaues for srv_config value parameter when option = SRV_THREADPRIORITY
  SRV_PRIORITY_LOW      = THREAD_PRIORITY_LOWEST;
  SRV_PRIORITY_NORMAL   = THREAD_PRIORITY_NORMAL;
  SRV_PRIORITY_HIGH     = THREAD_PRIORITY_HIGHEST;
  SRV_PRIORITY_CRITICAL = THREAD_PRIORITY_TIME_CRITICAL;

// values for srv_sfield field parameter
  SRV_SERVERNAME = 0;
  SRV_VERSION    = 6;

// Length to indicate string is null terminated
  SRV_NULLTERM   = -1;

// values of msgtype parameter to srv_sendmsg
  SRV_MSG_INFO   = 1;
  SRV_MSG_ERROR  = 2;

// values of status parameter to srv_senddone
// Also: values for symbol parameters to srv_symbol when type = SRV_DONE
  SRV_DONE_FINAL     = $0000;
  SRV_DONE_MORE        = $0001;
  SRV_DONE_ERROR     = $0002;
  SRV_DONE_COUNT     = $0010;
  SRV_DONE_RPC_IN_BATCH   = $0080;

// return values of srv_paramstatus
  SRV_PARAMRETURN     = $0001;
  SRV_PARAMDEFAULT        = $0002;

// return values of srv_rpcoptions
  SRV_RECOMPILE           = $0001;
  SRV_NOMETADATA          = $0002;

// values of field parameter to srv_pfield
//  SRV_LANGUAGE 1   already defined above
//  SRV_EVENT    4   already defined above
  SRV_SPID                = 10;
  SRV_NETSPID             = 11;
  SRV_TYPE             = 12;
  SRV_STATUS             = 13;
  SRV_RMTSERVER             = 14;
  SRV_HOST             = 15;
  SRV_USER             = 16;
  SRV_PWD             = 17;
  SRV_CPID             = 18;
  SRV_APPLNAME             = 19;
  SRV_TDS             = 20;
  SRV_CLIB             = 21;
  SRV_LIBVERS             = 22;
  SRV_ROWSENT             = 23;
  SRV_BCPFLAG             = 24;
  SRV_NATLANG             = 25;
  SRV_PIPEHANDLE          = 26;
  SRV_NETWORK_MODULE          = 27;
  SRV_NETWORK_VERSION          = 28;
  SRV_NETWORK_CONNECTION       = 29;
  SRV_LSECURE             = 30;
  SRV_SAXP             = 31;
  SRV_UNICODE_USER          = 33;
  SRV_UNICODE_PWD          = 35;
  SRV_SPROC_CODEPAGE           = 36;

// return value of SRV_TDSVERSION macro
  SRV_TDS_NONE  = 0;
  SRV_TDS_2_0   = 1;
  SRV_TDS_3_4   = 2;
  SRV_TDS_4_2   = 3;
  SRV_TDS_6_0   = 4;
  SRV_TDS_7_0   = 5;

// Return values from APIs
type
 SRVRETCODE = Integer;        // SUCCEED or FAIL
 RETCODE    = Integer;

const
  SUCCEED = 1;   // Successful return value
  FAIL    = 0;   // Unsuccessful return value

  SRV_DUPLICATE_HANDLER   = 2;   // additional return value for srv_pre/post_handle

//------------------------------------------------
//PreDeclare structures
//
{struct srv_server;
typedef struct srv_server SRV_SERVER;

struct srv_config;
typedef struct srv_config SRV_CONFIG;

struct srv_proc;
typedef struct srv_proc SRV_PROC;}
type
  SRV_SERVER = Pointer;
  SRV_CONFIG = Pointer;
  SRV_PROC   = Pointer;

//------------------------------------------------
//------------------------------------------------
// ODS MACROs & APIs

// Describing and sending a result set
function srv_describe(srvproc: SRV_PROC;
  colnumber: Integer; column_name: PCHAR; namelen: Integer;
  desttype, destlen, srctype, srclen: Integer; srcData: Pointer
): Integer; cdecl;

function srv_setutype(srvproc: SRV_PROC; column: Integer; usertype: Longint): Integer; cdecl;
function srv_setcoldata(srvproc: SRV_PROC; column: Integer; data: Pointer): Integer; cdecl;
function srv_setcollen(srvproc: SRV_PROC; column, len: Integer): Integer; cdecl;
function srv_sendrow(srvproc: SRV_PROC): Integer; cdecl;
function srv_senddone(srvproc: SRV_PROC; status, curcmd: Word; count: Longint): Integer; cdecl;

// Dealing with Extended Procedure parameters
function srv_rpcparams(srvproc: SRV_PROC): Integer; cdecl;
function srv_paraminfo(srvproc: SRV_PROC; n: Integer; pbType: PByte; 
  pcbMaxLen, pcbActualLen: PULONG; pbData: PByte; pfNull: PBOOL): Integer; cdecl;
function srv_paramsetoutput(srvproc: SRV_PROC;
  n: Integer; pbData: PByte; cbLen: ULONG; fNull: BOOL): Integer; cdecl;

function srv_paramdata(srvproc: SRV_PROC; n: Integer): Pointer; cdecl;
function srv_paramlen(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_parammaxlen(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_paramtype(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_paramset(srvproc: SRV_PROC; n: Integer; data: Pointer; int: Integer): Integer; cdecl;

function srv_paramname(srvproc: SRV_PROC; n: Integer; var len: Integer): PChar; cdecl;
function srv_paramnumber(srvproc: SRV_PROC; name: PChar; namelen: Integer): Integer; cdecl;

//--------------------------------------------------------------
//--------------------------------------------------------------
// The rest of these APIs are still supported, in SQL Server 7.0,
// but may not be supported after SQL Server 7.0

// MACROs
{  SRV_GETCONFIG(a)      srv_getconfig     ( a )
  SRV_GETSERVER(a)      srv_getserver     ( a )
  SRV_GOT_ATTENTION(a)   srv_got_attention ( a )
SRV_EVENTDATA(a)      srv_eventdata     ( a )
SRV_IODEAD(a)         srv_iodead        ( a )
SRV_TDSVERSION(a)      srv_tdsversion     ( a )}

function srv_getconfig(server: SRV_SERVER): SRV_CONFIG; cdecl;
function srv_getserver(srvproc: SRV_PROC): SRV_SERVER; cdecl;
function srv_got_attention(srvproc: SRV_PROC): Bool; cdecl;
function srv_eventdata(srvproc: SRV_PROC): Pointer; cdecl;

// Memory
function srv_alloc(ulSize: Longint): Pointer; cdecl;
function srv_bmove(from: Pointer; pto: Pointer; count: Longint): Integer; cdecl;
function srv_bzero(location: Pointer; count: Longint): Integer; cdecl;
function srv_free(ptr: Pointer): Integer; cdecl;

function srv_config_fn(config: SRV_CONFIG; option: Longint; value: PChar; valuelen: Integer): Integer; cdecl;
function srv_config_alloc: SRV_CONFIG; cdecl;
function srv_convert(srvproc: SRV_PROC; srctype: Integer; src: Pointer; srclen: DBINT;
  desttype: Integer; dest: Pointer; destlen: DBINT): Integer; cdecl;
{
int (*  srv_errhandle(int (* handler)(SRV_SERVER * server,
     SRV_PROC   * srvproc,
     int         srverror,
     BYTE           severity,
     BYTE           state,
     int         oserrnum,
     char     * errtext,
     int         errtextlen,
     char     * oserrtext,
     int         oserrtextlen)))
   ( SRV_SERVER * server,
    SRV_PROC   * srvproc,
    int        srverror,
    BYTE          severity,
    BYTE          state,
    int        oserrnum,
    char     * errtext,
    int        errtextlen,
    char     * oserrtext,
    int        oserrtextlen );
}
function srv_event_fn(srvproc: SRV_PROC; event: Integer; data: PByte): Integer; cdecl;
function srv_getuserdata(srvproc: SRV_PROC): Pointer; cdecl;
function srv_getbindtoken(srvproc: SRV_PROC; token_buf: PChar): Integer; cdecl;
function srv_getdtcxact(srvproc: SRV_PROC; ppv: Pointer): Integer; cdecl;

//typedef int (* EventHandler)(void*);
type
  EventHandler = Pointer;
function srv_handle(server: SRV_SERVER; int: Longint; handler: EventHandler): EventHandler; cdecl;

function srv_impersonate_client(srvproc: SRV_PROC): Integer; cdecl;
function srv_init(config: SRV_CONFIG; connectname: PChar; namelen: Integer): SRV_SERVER; cdecl;
function srv_iodead(srvproc: SRV_PROC): Bool; cdecl;

function srv_langcpy(srvproc: SRV_PROC; start, nbytes: Longint; buffer: PChar): Longint; cdecl;
function srv_langlen(srvproc: SRV_PROC): Longint; cdecl;
function srv_langptr(srvproc: SRV_PROC): Pointer; cdecl;

function srv_log(server: SRV_SERVER; datestamp: Bool; msg: PChar; msglen: Integer): Integer; cdecl;
function srv_paramstatus(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_pfield(srvproc: SRV_PROC; field: Integer; len: PInteger): PChar; cdecl;

function srv_returnval(srvproc: SRV_PROC; value_name: PDBCHAR; len: Integer; status: Byte;
  iType, maxlen, datalen: DBINT; value: PByte): Integer; cdecl;

function srv_revert_to_self(srvproc: SRV_PROC): Integer; cdecl;

function srv_rpcdb(srvproc: SRV_PROC; len: PInteger): PChar; cdecl;
function srv_rpcname(srvproc: SRV_PROC; len: PInteger): PChar; cdecl;
function srv_rpcnumber(srvproc: SRV_PROC): Integer; cdecl;
function srv_rpcoptions(srvproc: SRV_PROC): Word; cdecl;
function srv_rpcowner(srvproc: SRV_PROC; len: PInteger): PChar; cdecl;

function srv_run(server: SRV_SERVER): Integer; cdecl;

function srv_sendmsg(srvproc: SRV_PROC;
  msgtype: Integer; msgnum: DBINT; msgClass, state: DBTINYINT;
  rpcname: PChar; rpcnamelen: Integer;
  linenum: Word; msg: PChar; msglen: Integer): Integer; cdecl;

function srv_ansi_sendmsg(srvproc: SRV_PROC;
  msgtype: Integer; msgnum: DBINT; msgClass, state: DBTINYINT;
  rpcname: PChar; rpcnamelen: Integer;
  linenum: Word; msg: PChar; msglen: Integer): Integer; cdecl;

function srv_sendstatus(srvproc: SRV_PROC; status: Longint): Integer; cdecl;
function srv_setuserdata(srvproc: SRV_PROC; ptr: Pointer): Integer; cdecl;
function srv_sfield(server: SRV_SERVER; field: Integer; len: PInteger): PChar; cdecl;
function srv_symbol(iType, symbol: Integer; len: PInteger): PChar; cdecl;
function srv_tdsversion(srvproc: SRV_PROC): Integer; cdecl;
function srv_writebuf(srvproc: SRV_PROC; ptr: Pointer; count: Word): Integer; cdecl;
function srv_willconvert(srctype, desttype: Integer): Bool; cdecl;
procedure srv_ackattention(srvproc: SRV_PROC); cdecl;
function srv_terminatethread(srvproc: SRV_PROC): Integer; cdecl;
function srv_sendstatistics(srvproc: SRV_PROC): Integer; cdecl;
function srv_clearstatistics(srvproc: SRV_PROC): Integer; cdecl;
function srv_setevent(server: SRV_SERVER; event: Integer): Integer; cdecl;
function srv_message_handler(srvproc: SRV_PROC;
  errornum: Integer; severity, state: Byte; oserrnum: Integer; errtext: PChar;
  errtextlen: Integer; oserrtext: PChar; oserrtextlen: Integer): Integer; cdecl;

function srv_pre_handle(server: SRV_SERVER; srvproc: SRV_PROC;
                   event: Longint; handler: EventHandler;  remove: Bool): Integer; cdecl;
function srv_post_handle(server: SRV_SERVER; srvproc: SRV_PROC;
                   event: Longint; handler: EventHandler;  remove: Bool): Integer; cdecl;

function srv_post_completion_queue(srvproc: SRV_PROC; inbuf: PChar; inbuflen: PChar): Integer; cdecl;
function srv_IgnoreAnsiToOem(srvproc: SRV_PROC; bTF: BOOL): Integer; cdecl;

//#ifdef __cplusplus
//}
//#endif

//#pragma pack()

const
  SS_MAJOR_VERSION   = 7;
  SS_MINOR_VERSION   = 00;
  SS_LEVEL_VERSION   = 0000;
  SS_MINIMUM_VERSION = '7.00.00.0000';
  ODS_VERSION        = ((SS_MAJOR_VERSION shl 24) or (SS_MINOR_VERSION shl 16));

//#endif //_ODS_SRV_H_

//////////////////////////////////////////////////////////////////
// Suggested implementation of __GetXpVersion
//
//__declspec(dllexport) ULONG __GetXpVersion()
//   {
//   return ODS_VERSION;
//   }
//////////////////////////////////////////////////////////////////

implementation

const
  sLibName = 'Opends60.DLL';


function srv_describe;                  external sLibName name 'srv_describe';
function srv_setutype;                  external sLibName name 'srv_setutype';
function srv_setcoldata;                external sLibName name 'srv_setcoldata';
function srv_setcollen;                 external sLibName name 'srv_setcollen';
function srv_sendrow;                   external sLibName name 'srv_sendrow';
function srv_senddone;                  external sLibName name 'srv_senddone';

// Dealing with Extended Procedure parameters
function srv_rpcparams;                 external sLibName name 'srv_rpcparams';
function srv_paraminfo;                 external sLibName name 'srv_paraminfo';
function srv_paramsetoutput;            external sLibName name 'srv_paramsetoutput';

function srv_paramdata;                 external sLibName name 'srv_paramdata';
function srv_paramlen;                  external sLibName name 'srv_paramlen';
function srv_parammaxlen;               external sLibName name 'srv_parammaxlen';
function srv_paramtype;                 external sLibName name 'srv_paramtype';
function srv_paramset;                  external sLibName name 'srv_paramset';

function srv_paramname;                 external sLibName name 'srv_paramname';
function srv_paramnumber;               external sLibName name 'srv_paramnumber';

//--------------------------------------------------------------
// The rest of these APIs are still supported, in SQL Server 7.0,
// but may not be supported after SQL Server 7.0

function srv_getconfig;                 external sLibName name 'srv_getconfig';
function srv_getserver;                 external sLibName name 'srv_getserver';
function srv_got_attention;             external sLibName name 'srv_got_attention';
function srv_eventdata;                 external sLibName name 'srv_eventdata';

// Memory
function srv_alloc;                     external sLibName name 'srv_alloc';
function srv_bmove;                     external sLibName name 'srv_bmove';
function srv_bzero;                     external sLibName name 'srv_bzero';
function srv_free;                      external sLibName name 'srv_free';

function srv_config_fn;                 external sLibName name 'srv_config';
function srv_config_alloc;              external sLibName name 'srv_config_alloc';
function srv_convert;                   external sLibName name 'srv_convert';
function srv_event_fn;                  external sLibName name 'srv_event';
function srv_getuserdata;               external sLibName name 'srv_getuserdata';
function srv_getbindtoken;              external sLibName name 'srv_getbindtoken';
function srv_getdtcxact;                external sLibName name 'srv_getdtcxact';
function srv_handle;                    external sLibName name 'srv_handle';
function srv_impersonate_client;        external sLibName name 'srv_impersonate_client';
function srv_init;                      external sLibName name 'srv_init';
function srv_iodead;                    external sLibName name 'srv_iodead';
function srv_langcpy;                   external sLibName name 'srv_langcpy';
function srv_langlen;                   external sLibName name 'srv_langlen';
function srv_langptr;                   external sLibName name 'srv_langptr';
function srv_log;                       external sLibName name 'srv_log';
function srv_paramstatus;               external sLibName name 'srv_paramstatus';
function srv_pfield;                    external sLibName name 'srv_pfield';
function srv_returnval;                 external sLibName name 'srv_returnval';
function srv_revert_to_self;            external sLibName name 'srv_revert_to_self';

function srv_rpcdb;                     external sLibName name 'srv_rpcdb';
function srv_rpcname;                   external sLibName name 'srv_rpcname';
function srv_rpcnumber;                 external sLibName name 'srv_rpcnumber';
function srv_rpcoptions;                external sLibName name 'srv_rpcoptions';
function srv_rpcowner;                  external sLibName name 'srv_rpcowner';

function srv_run;                       external sLibName name 'srv_run';

function srv_sendmsg;                   external sLibName name 'srv_sendmsg';
function srv_ansi_sendmsg;              external sLibName name 'srv_ansi_sendmsg';

function srv_sendstatus;                external sLibName name 'srv_sendstatus';
function srv_setuserdata;               external sLibName name 'srv_setuserdata';
function srv_sfield;                    external sLibName name 'srv_sfield';
function srv_symbol;                    external sLibName name 'srv_symbol';
function srv_tdsversion;                external sLibName name 'srv_tdsversion';
function srv_writebuf;                  external sLibName name 'srv_writebuf';
function srv_willconvert;               external sLibName name 'srv_willconvert';
procedure srv_ackattention;             external sLibName name 'srv_ackattention';
function srv_terminatethread;           external sLibName name 'srv_terminatethread';
function srv_sendstatistics;            external sLibName name 'srv_sendstatistics';
function srv_clearstatistics;           external sLibName name 'srv_clearstatistics';
function srv_setevent;                  external sLibName name 'srv_setevent';
function srv_message_handler;           external sLibName name 'srv_message_handler';

function srv_pre_handle;                external sLibName name 'srv_pre_handle';
function srv_post_handle;               external sLibName name 'srv_post_handle';
function srv_post_completion_queue;     external sLibName name 'srv_post_completion_queue';
function srv_IgnoreAnsiToOem;           external sLibName name 'srv_IgnoreAnsiToOem';

end.

Взято с

Delphi Knowledge Base

---

---