Статьи по Delphi (006)…

DirectX для начинающих. Часть вторая.

Небольшое отступление.

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

Переписано с использованием процедуры следующего вида:

procedure SAFE_DELETE(p: TInterfacedObject);
begin
  if p <> nil then
    p := nil
end;

Модуль basedd8.pas в проектах для DirectDraw переименован в basedd7.pas – всё-таки DirectDraw – это часть DirectX 7, в версий 8 он как таковой отсутствует.

Большая часть примеров в этой статье предназначена для работы с DirectDraw – как мне кажется, наиболее востребованному элементу DirectX (кроме, естественно, Direct3D).

Почему я не рекомендую использовать DelphiX.

Вот код, ответственный за вывод части изображения:

// Предполагаем, что края спрайта не выходят за границы экрана
SetRect(rRect, 0, 0, SPRITE_WIDTH, SPRITE_HEIGHT);
// Проверяем выход кра¸в, и если такая ситуация имеет место, то корректируем
// положение области копирования на поверхности спрайта
if nX < 0 then
  rRect.Left := -nX;
if nY < 0 then
  rRect.Top := -nY;
if nX + SPRITE_WIDTH > SCREEN_WIDTH then
  rRect.Right := SCREEN_WIDTH - nX;
if nY + SPRITE_HEIGHT > SCREEN_HEIGHT then
  rRect.Bottom := SCREEN_HEIGHT - nY;

nX + rRect.Left, nY + rRect.Top

DirectDraw предоставляет удобный инструмент для задания маски прозрачности. Цвета пикселей, которые игнорируются, называются «цветовыми ключами». Каждая поверхность может иметь свои цветовые ключи, причём их может быть несколько. Следующий фрагмент кода создаёт и присоединяет к поверхности «цветовой ключ», цвет которого – чёрный.

var
  ddck: TDDCOLORKEY;
begin
  ddck.dwColorSpaceLowValue := 0;
  ddck.dwColorSpaceHighValue := ddck.dwColorSpaceLowValue;
  pSprite.SetColorKey(DDCKEY_SRCBLT, @ddck);

Поэтому можно смело присваивать 0 для чёрной маски в любом режиме. Однако, предположим, нам надо задать цветовой ключ в виде чистого синего цвета. Для 24- и 32-битного режима это можно сделать с помощью макроса (функции) из модуля windows.pas:

function RGB(r, g, b: Byte): COLORREF;
begin
  Result := (r or (g shl 8) or (b shl 16));
end;

ddck.dwColorSpaceLowValue := RGB( 0, 0, 255 );
ddck.dwColorSpaceHighValue := ddck.dwColorSpaceLowValue;

В своё время я довольно долго промучился с этой проблемой, тем более что в имеющейся литературе ничего об этом не сказано. В конце концов решил, что необходимо написать аналогичную к RGB() функцию, но об этом немного позже. Давайте сначала выясним, какой же формат использует установленная на нашем компьютере видеокарта. DirectDraw позволяет узнать это с помощью функции IDirectDrawSurface7.GetPixelFormat(). Единственным параметром необходимо передать адрес структуры TDDPIXELFORMAT. Вот фрагмент соответствующего кода:

var
  ddpf: TDDPIXELFORMAT;
begin
  ZeroMemory(@ddpf, SizeOf(TDDPIXELFORMAT));
  ddpf.dwSize := SizeOf(TDDPIXELFORMAT);
  pSprite.GetPixelFormat(ddpf);

Формат цветовых составляющих описывается в полях dwRBitMask, dwGBitMask и dwBBitMask структуры TDDPIXELFORMAT – но только в том случае, если битовое поле dwFlags содержит флаг DDPF_RGB – признак того, что поверхность создана в RGB-режиме. Значения полей dwRBitMask, dwGBitMask и dwBBitMask для режимов с разной глубиной палитры описываются в разделе dwRBitMask, dwGBitMask и dwBBitMask справочной службы DirectX SDK:

DDPF_RGB 16 R: 0x0000F800 
            G: 0x000007E0 
            B: 0x0000001F 
            A: 0x00000000
 
DDPF_RGB 16 R: 0x0000001F 
            G: 0x000007E0 
            B: 0x0000F800 
            A: 0x00000000
 
DDPF_RGB 16 R: 0x00007C00 
            G: 0x000003E0 
            B: 0x0000001F 
            A: 0x00000000

Вот как должен быть переписан макрос для формата 5-6-5:

function RGB565(r, g, b: Byte): COLORREF;
begin
  Result := ((r shl 11) or (g shl 5) or b);
end;

А вот как должен выглядеть макрос для формата 5-5-5:

function RGB555(r, g, b: Byte): COLORREF;
begin
  Result := ((r shl 10) or (g shl 5) or b);
end;

2. Я решил написать небольшой класс TWave – он сам заботится об открытии звукового файла, чтении данных из него в звуковой буфер и проигрывании их. Функциональность класса не полная – это лишь пример. Благодаря ООП главный модуль main.pas серьёзно уменьшился, теперь для воспроизведения wav-файла средствами DirectSound достаточно написать:

var
  sound: TWave;
begin
  sound := TWave.Create();
  sound.OpenWaveFile(‘wavefile.wav’);
  sound.Play();

1. В Help-службе DirectX SDK 7 указаны такие возможные значения, которые могут быть помещены в переменную pdwVersion при вызове функции DirectXSetupGetVersion():

DirectX version   Value pointed to by pdwVersion 
DirectX 1         0x00040001 
DirectX 2         0x00040002 
DirectX 3         0x00040003 
DirectX 5.0       0x00040005 
DirectX 6.0       0x00040006 
DirectX 7.0       0x00040007 

А вот в Help-службе DirectX SDK 8 указаны такие:

DirectX version   Value pointed to by pdwVersion 
DirectX 1         0x00000000 
DirectX 2         0x00000000 
DirectX 3         0x00000000 
DirectX 5.0       0x00040005 
DirectX 6.0       0x00040006 
DirectX 7.0       0x00040007 
DirectX 8.0       0x00040008 

Скачать примеры: Samples2.Zip (106 K).

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

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

Хранящийся на диске файл 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;

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

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

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

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

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

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

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

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

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

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

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

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;

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

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

Например:

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

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

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

// созда¸м файл с заданным именем, в него будет производиться запись
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;

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

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

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

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

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

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

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

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

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

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

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

DirectDraw

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

Объект IDirectDraw

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Application-OnException :== ExceptionHandler;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Помните ли вы злополучное взаимное исключение 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;

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

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

Листинг 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');
  // убедиться, что поверхность восстановлена.
  Sигfасе.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;

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

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

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

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

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

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

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

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

Direct Show и Delphi.

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

Звучит заманчиво. Но для чего это может понадобиться, спросите Вы, вспоминая родной и привычный MediaPlayer. Представьте себе, что Вы запрограммировали трехмерный мир, с анимированными спрайтами, трехмерными объектами и т.п. И в отсвете выстрелов очередной "бродилки-стрелялки", пораженный пользователь нового шедевра, видит видео клип, воспроизводимый прямо на костях очередного пораженного монстра. :-) Каково? Убедил? Тогда продолжим. Кстати, раз уж упомянули DirectDraw - DirectShow интегрирован с DirectX так, что использует DirectDraw и DirectSound для вывода изображения и звука, и, при наличии аппаратного ускорения, автоматически им воспользуется.

Для работы с DirectShow Вам понадобятся:

Основы DirectShow.

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

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

Для создания такой "цепочки обработки" (которая, кстати, официально называются Filter Graph - "граф фильтров" или, в несколько вольном переводе - "схема соединения фильтров"), так вот для создания схемы соединения фильтров, предназначен самый базовый и лежащий в основе всех основ компонет DirectShow, под названием Filter Graph Manager - Менеджер Графа Фильтров.

Например, программа показывающая видео из AVI-файла может построить такой граф фильтров:

В этом примере пять фильтров, первый (File Source) просто читает данные с диска, второй фильтр (AVI Splitter) разделяет данные на кадры и передает упакованные видео данные фильтру AVI Decompressor, который их распаковывает и передает фильтру Default DirectSound Device, выводящему звук. AVI Decompressor передает распакованные данные фильтру Video Renderer, который выводит кадры видео на экран.

Фильтры делятся на три типа:

CoCreateInstance(CLSID_FilterGraph,nil,CLSCTX_INPROC_SERVER, 
  IID_IGraphBuilder,MyGraphBuilder);

uses DShow.pas

Давайте попробуем все это на примере:

uses
  ...DShow, ActiveX, ComObj;
var
  MyGraphBuilder: IGraphBuilder;
  MyMediaControl: IMediaControl;
begin
  CoInitialize(nil);
  {получаем интерфейс IGraphBuilder}
  CoCreateInstance(CLSID_FilterGraph, nil, CLSCTX_INPROC_SERVER,
    IID_IGraphBuilder, MyGraphBuilder);
  {вызываем RenderFile - граф фильтров строится автоматически}
  MyGraphBuilder.RenderFile(cool.avi',nil);
  {получаем интерфейс ImediaControl}
  MyGraphBuilder.QueryInterface(IID_IMediaControl, MyMediaControl);
  {Примечание - MyMediaControl - переменная типа IMediaControl}
  {проигрываем видео}
  MyMediaControl.Run;
  {ждем пока пользователь не нажмет ОК
  (видео воспроизводится в отдельном (thread) потоке)}
  ShowMessage('Нажмите ОК');
  CoUninitialize;
end;

Если Вы не поленитесь скопировать этот кусок кода в Delphi и запустить его то заметите, что avi-файл проигрывается в отдельном окошке, которое не принадлежит нашему приложению. Для управления окошком, в котором воспроизводится видео предназначен специальный интерфейс IVideoWindow. Получить этот интерфейс можно из экземпляра IGraphBuilder, вызвав QueryInterface и передав в качестве идентификатора интерфейса константу IID_IvideoWindow.

Интерфейс IVideoWindow содержит методы для управления заголовком, стилем, местоположением и размерами окошка в котором проигрывается видео.

Давайте попробуем переделать наш пример так, чтобы видео выводилось не в отдельном окошке, а, скажем на компоненте TPanel, расположенном в нашей форме. Добавьте на форму компонет TPanel, пусть он называется Panel1.

uses
  ...DShow, ActiveX, ComObj;
procedure TForm1.Button1Click(Sender: TObject);
var
  MyGraphBuilder: IGraphBuilder;
  MyMediaControl: IMediaControl;
  VideoWindow: IVideoWindow;
begin
  CoInitialize(nil);
  {получаем интерфейс IGraphBuilder}
  CoCreateInstance(CLSID_FilterGraph, nil, CLSCTX_INPROC_SERVER,
    IID_IGraphBuilder, MyGraphBuilder);
  {вызываем RenderFile - граф фильтров строится автоматически}
  MyGraphBuilder.RenderFile('C:\Program Files\Borland\Delphi5\Demos\Coolstuf\cool.avi', nil);
  {получаем интерфейс ImediaControl}
  MyGraphBuilder.QueryInterface(IID_IMediaControl, MyMediaControl);
  {Примечание - MyMediaControl - переменная типа IMediaControl}
  {получаем интерфейс IVideoWindow}
  MyGraphBuilder.QueryInterface(IID_IVideoWindow, VideoWindow);
  {Примечание - VideoWindow - переменная типа IVideoWindow}
  {располагаем окошко с видео на панель}
  VideoWindow.Set_Owner(Self.Panel1.Handle);
  VideoWindow.Set_WindowStyle(WS_CHILD or WS_CLIPSIBLINGS);
  VideoWindow.SetWindowPosition(0, 0, Panel1.ClientRect.Right,
    Panel1.ClientRect.Bottom);
  {проигрываем видео}
  MyMediaControl.Run;
  ShowMessage('Нажмите ОК');
  CoUninitialize;
end;

Надеюсь это проще, чем Вы ожидали?

DirectShow и DirectX.

Для того, чтобы использовать DirectShow совместно с DirectX нужно разобраться с понятием Multimedia Streaming (потоки мультимедиа).

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

На рисунке изображена иерархия объектов Multimedia Streaming.

Однако хватит теории. Давайте перейдем к делу. Попробуем создать необходимые объекты, чтобы вывести видео на Surface DirectX. Для этого нам понадобится обращаться к кадрам видео изображения (т.е. к обьекту типа Stream Sample). Значит, придется пройтись по всей цепочке иерархии, чтобы добраться до обьектов StreamSample. Вообще цепочка обьектов, которую предстоит создать выглядит так:

IAMMultiMediaStream
    + IDirectDrawMediaStream
           + IDirectDrawStreamSample

CoCreateInstance(CLSID_AMMultiMediaStream, nil, CLSCTX_INPROC_SERVER, 
  IID_IAMMultiMediaStream, AMStream);

AMStream.Initialize(STREAMTYPE_READ, AMMSF_NOGRAPHTHREAD, nil);

AMStream.AddMediaStream(DDraw, MSPID_PrimaryVideo, 0, NewMediaStremVideo);
AMStream.AddMediaStream(nil, MSPID_PrimaryAudio, AMMSF_ADDDEFAULTRENDERER, 
  NewMediaStremAudio);

AMStream.OpenFile('cool.avi', 0);

Осталось направить видео поток мультимедиа поток на Surface. Вот процедура, которая делает это:

procedure TForm1.RenderStreamToSurface(Surface: IDirectDrawSurface;
  MMStream: IMultiMediaStream);
var
  PrimaryVidStream: IMediaStream;
  DDStream: IDirectDrawMediaStream;
  Sample: IDirectDrawStreamSample;
  RECT: TRect;
  ddsd: TDDSURFACEDESC;
  Z: DWORD;
begin
  MMStream.GetMediaStream(MSPID_PrimaryVideo, PrimaryVidStream);
  PrimaryVidStream.QueryInterface(IID_IDirectDrawMediaStream, DDStream);
  ddsd.dwSize := sizeof(ddsd);
  DDStream.GetFormat(ddsd, Palitra, ddsd, Z);
  rect.top := (480 - ddsd.dwHeight) div 2;
  rect.left := (640 - ddsd.dwWidth) div 2;
  rect.bottom := rect.top + ddsd.dwHeight;
  rect.right := rect.left + ddsd.dwWidth;
  DDStream.CreateSample(Surface, Rect, 0, Sample);
  MMStream.SetState(STREAMSTATE_RUN);
end;

Как видите, в этой процедуре сначала получаем интерфейс типа IDirectDrawMediaStream (соответствующий второму уровню иерархии на нашем рисунке), потом из него получаем объект типа IDirectDrawStreamSample (переменная Sample), который соответствует третьему уровню иерархии нашего рисунка.

Теперь остается вызывать в цикле (в демо-программе это делается по таймеру - здесь для простоты опускаем):

hr := Sample.Update(0, 0, nil, 0);
if hr = $40003 {MS_S_ENDOFSTREAM} then
  MMStream.Seek(0);

Метод IDirectDrawStreamSample.Update выводит очередной кадр на Surface. При достижении конца потока он вернет ошибку с кодом $40003 (MS_S_ENDOFSTREAM), я в этом случае просто перематываю поток к началу, методом Seek.

Полностью программу, фрагменты кода из которой здесь приведены можно скачать здесь: DelphiDirectShow.zip (277 K) . В этой программе инициализируется DirectDraw, создается Surface , а затем на него выводится видео из avi-файла.

Пока все о DirectDraw - надеюсь эта информация послужит для Вас отправной точкой в написании чего-то потрясающего! :-).

Вывести список всех директорий, файлов и дисков.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

procedure TForm1.Button1Click(Sender: TObject);
 var
    D: PChar;
 begin
    D := 'C:\*.*';
    SendMessage(ListBox1.Handle,
                LB_DIR,
                DDL_ARCHIVE +
                DDL_DIRECTORY +
                DDL_DRIVES +
                DDL_EXCLUSIVE +
                DDL_HIDDEN +
                DDL_READONLY +
                DDL_READWRITE +
                DDL_SYSTEM,
                Integer(D));
 end;
 //Oder: 
//Or: 
procedure TForm1.Button2Click(Sender: TObject);
 var
   D: PChar;
 begin
    D := 'C:\*.*';
    ListBox2.Perform(LB_DIR,
                     DDL_ARCHIVE +
                     DDL_DIRECTORY +
                     DDL_DRIVES +
                     DDL_EXCLUSIVE +
                     DDL_HIDDEN +
                     DDL_READONLY +
                     DDL_READWRITE +
                     DDL_SYSTEM,
                     Integer(d));
 end;

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

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

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

Итератор для поиска файлов в директории.

Автор: Kingdom WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Итератор для поиска файлов в директории (first/next/eof)
Очень часто задают вопрос "как перебрать все файлы папки".
Так же часто предлагают использовать FindFirst/FindNext.
Я написал класс TEnumFolder который предоставляет более
удобный интерфейс поиска за счет использованием методов
First/Next/Eof.
Используйте свойства AbsPath и RelPath для получения абсолютного
и относетильного пути текущего файла/папки. Свойство SR типа PSearchRec,
содержит информацию о текущем файле/папке.
Так же можно указать режим перебора (IsFolderFirst = False) при котором,
 можно удалить всю папку(!), т.е. в начале находятся все файлы папки,
 а потом сама папка (т.к. можно удалять только пустую папку).
Зависимости: Classes, SysUtils
Автор:       Kingdom, dnsk@mail.ru, Санкт-Петербург
Copyright:   Kingdom
Дата:        30 сентября 2003 г.
***************************************************** }
unit EnmFolder;
interface
uses
  Classes, SysUtils;
type
  PSearchRec = ^TSearchRec;
  TEnumFolder = class
  private
    FBasePath: string;
    FList: TStrings;
    FSR: PSearchRec;
    FIsFolderFirst: Boolean;
    FBasePos: Integer;
    FNextProc: procedure of object;
    function GetAbsPath: string;
    function GetRelPath: string;
    procedure ClearList;
    function GetPathType(Path: string): Integer;
    procedure PushSR(Dir: string);
    procedure PopSR;
    procedure Next1;
    procedure Next2;
  public
    constructor Create(BasePath: string; IsFolderFirst: Boolean = True);
    destructor Destroy; override;
    procedure First;
    procedure Next;
    function Eof: Boolean;
    property AbsPath: string read GetAbsPath;
    property RelPath: string read GetRelPath;
    property SR: PSearchRec read FSR;
  end;
implementation
{ TEnumFolder }
constructor TEnumFolder.Create(BasePath: string; IsFolderFirst: Boolean);
begin
  inherited Create;
  FList := TStringList.Create;
  FBasePath := ExcludeTrailingBackslash(BasePath);
  FIsFolderFirst := IsFolderFirst;
  if IsFolderFirst then
    FNextProc := Next1
  else
    FNextProc := Next2;
end;
destructor TEnumFolder.Destroy;
begin
  ClearList;
  FList.Free;
  inherited;
end;
procedure TEnumFolder.ClearList;
begin
  while (FList.Count > 0) do
    PopSR;
end;
function TEnumFolder.GetAbsPath: string;
begin
  Result := FList[0] + SR.Name;
end;
function TEnumFolder.GetRelPath: string;
begin
  Result := Copy(AbsPath, FBasePos, MaxInt);
end;
function TEnumFolder.GetPathType(Path: string): Integer;
begin
  New(FSR);
  if (FindFirst(Path, faAnyFile, SR^) <> 0) then
    Result := -1 { Not found }
  else
  begin
    if (SR.Attr and faDirectory <> 0) then
    begin
      FBasePos := Length(Path) + 2;
      Path := ExtractFilePath(Path);
      FList.InsertObject(0, Path, TObject(SR));
      Result := 1; { Folder }
    end
    else
    begin
      Path := ExtractFilePath(Path);
      FBasePos := Length(Path) + 1;
      FList.InsertObject(0, Path, TObject(SR));
      Result := 0; { File }
    end;
  end;
end;
function TEnumFolder.Eof: Boolean;
begin
  Result := (FList.Count = 0);
end;
procedure TEnumFolder.First;
begin
  FSR := nil;
  ClearList;
  case GetPathType(FBasePath) of
    { Folder }
    1:
      if not FIsFolderFirst then
      begin
        PushSR(FBasePath);
        Next;
      end;
    { File }
    0: ;
  end;
end;
procedure TEnumFolder.Next;
begin
  FNextProc;
end;
procedure TEnumFolder.Next1;
begin
  { Push folder }
  if (SR.Attr and faDirectory <> 0) then
    PushSR(FList[0] + FSR.Name);
  while (FList.Count > 0) and (FindNext(SR^) <> 0) do
    PopSR;
end;
procedure TEnumFolder.Next2;
begin
  while (FList.Count > 0) do
    if (FindNext(SR^) <> 0) then
    begin
      PopSR;
      Break;
    end
    else if (SR.Attr and faDirectory <> 0) then
      PushSR(FList[0] + FSR.Name)
    else
      Break;
end;
procedure TEnumFolder.PushSR(Dir: string);
begin
  New(FSR);
  FindFirst(Dir + '\*.*', faAnyFile, FSR^);
  FindNext(FSR^); { Skip "." and ".." }
  FList.InsertObject(0, Dir + '\', TObject(FSR));
end;
procedure TEnumFolder.PopSR;
begin
  FList.Delete(0);
  FindClose(SR^);
  Dispose(SR);
  if FList.Count > 0 then
    FSR := PSearchRec(FList.Objects[0])
  else
    FSR := nil;
end;
end.

Пример использования:

procedure TForm1.Button1Click(Sender: TObject);
var
  fe: TEnumFolder;
begin
  { Показываем содержимое папки }
  Memo1.Lines.BeginUpdate;
  Memo1.Clear;
  fe := TEnumFolder.Create('c:\temp', True);
  fe.First;
  while not fe.Eof do
  begin
    Memo1.Lines.Add(fe.AbsPath);
    fe.Next;
  end;
  fe.Free;
  Memo1.Lines.EndUpdate;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
  fe: TEnumFolder;
begin
  { Удаляем папку }
  fe := TEnumFolder.Create('c:\temp', False);
  fe.First;
  while not fe.Eof do
  begin
    if (fe.SR.Attr and faDirectory) = 0 then
      DeleteFile(fe.AbsPath)
    else
      RemoveDir(fe.AbsPath);
    fe.Next;
  end;
  fe.Free;
end;

Искать нужный файл в дереве каталогов.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

uses
   ImageHlp;
 function SearchForFile(const ARootPath: string;
                        const AFileName: string;
                        var APathFound: string): Boolean;
 var
   Found: array[0..500] of Char;
 begin
   FillChar(Found, SizeOf(Found), #0 );
   Result := (SearchTreeForFile(PChar(ARootPath), PChar(AFileName), Found) = True);
   APathFound := ExtractFilePath(Found);
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 var
   APathFound: string;
 begin
   if SearchForFile('C:\WINDOWS\', 'winhlp32.exe', APathFound) then
     ShowMessage('winhlp32.exe found in: ' + APathFound);
 end;

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

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

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

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

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

DisableRegistryTools

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

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

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

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

uses
  Registry; 

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Но это окно можно закрыть из ТаsкВаr'а.

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

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

Но это окно можно закрыть из ТаsкВаr'а.

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

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

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

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

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

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

Эмуляция нажатия клавиши даже в неактивном окне.

Автор: Dimka Maslov WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Эмуляция нажатия клавиши в любом окне, в т.ч. неактивном
Процедура эмулирует нажатие клавиши в любом окне путём посылки ему пары
сообщений WM_KEYDOWN и WM_KEYUP. Процедура принимает два параметра -
Handle окна и код клавиши (см. описание констант VK_xxxx).
Зависимости: Windows
Автор:       Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright:   Dimka Maslov
Дата:        29 апреля 2002 г.
***************************************************** }
procedure EmulateKey(Wnd: HWND; VKey: Integer);
asm
   push 0
   push edx
   push 0101H //WM_KEYUP
   push eax
   push 0
   push edx
   push 0100H //WM_KEYDOWN
   push eax
   call PostMessage
   call PostMessage
end;
// Пример использования:
EmulateKey(Edit1.Handle, VK_RETURN);

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

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

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

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

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

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

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

Защита по ключевой дискете - защита от копирования.

Оформил: DeeCo

Автор: Серафим Бочкарев.

Скачать архив.(371 К).

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

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

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

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

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

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

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

Получить объем диска и его свободного места.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
  * Place a Button1 and DriveComboBox1 on your form. 
  * The function "SetCurrentDir" well be true if the disk in drive 
  * The procedure "GetDiskFreeSpaceEx" returns the free and total disk size 
}
 uses
   SysUtils;
 implementation
 function GetDiskSize(drive: Char; var free_size, total_size: Int64): Boolean;
 var
   RootPath: array[0..4] of Char;
   RootPtr: PChar;
   current_dir: string;
 begin
   RootPath[0] := Drive;
   RootPath[1] := ':';
   RootPath[2] := '\';
   RootPath[3] := #0;
   RootPtr := RootPath;
   current_dir := GetCurrentDir;
   if SetCurrentDir(drive + ':\') then
   begin
     GetDiskFreeSpaceEx(RootPtr, Free_size, Total_size, nil);
     // this to turn back to original dir 
    SetCurrentDir(current_dir);
     Result := True;
   end
   else
   begin
     Result := False;
     Free_size  := -1;
     Total_size := -1;
   end;
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 var
   free_size, total_size: Int64;
 begin
   if GetDiskSize(DriveComboBox1.Drive, free_size, total_size) then
     ShowMessage('free space =' +
       IntToStr(free_size) + #13 + 'total size=' +
       IntToStr(total_size))
   else
     ShowMessage('No disk in drive!');
 end;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Заблокировать перемещение формы.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{....}
   private
     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
      {....}
 procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
 begin
   inherited;
   with Message do
   begin
     if Result = HTCAPTION then
       Result := HTNOWHERE;
   end;
 end;

Создать неактивные пиктограммы для TSpeedButton и TBitBtn во время выполнения.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

procedure AddDisableBMP(SB : array of TObject);
 var
    BM, SBM : TBitmap;
   w, x, y, NewColor, i : integer;
   PixelColor : TColor;
 begin
   BM := TBitmap.Create;
   SBM := TBitmap.Create;
   try
     for i := 0 to High(SB) do
      begin
       if (SB[i] is TSpeedButton) then
         BM.Assign((SB[i] as TSpeedButton).Glyph)
       else if (SB[i] is TBitBtn) then
         BM.Assign((SB[i] as TBitBtn).Glyph)
       else
          Exit;
       if not Assigned(BM) or (BM.Width <> BM.Height) then Exit;
       w := BM.Width;
       SBM.Width := w * 2;
       SBM.Height := w;
       SBM.Canvas.Draw(0, 0, BM);
       for x := 0 to w - 1 do
         for y := 0 to w - 1 do
          begin
           PixelColor := ColorToRGB(BM.Canvas.Pixels[x, y]);
           NewColor := Round((((PixelColor shr 16) + ((PixelColor shr 8) and $00FF) +
             (PixelColor and $0000FF)) div 3)) div 2 + 96;
           BM.Canvas.Pixels[x, y] := RGB(NewColor, NewColor, NewColor);
         end;
       SBM.Canvas.Draw(w, 0, BM);
       if (SB[i] is TSpeedButton) then with (SB[i] as TSpeedButton) do
          begin
           Glyph.Assign(SBM);
           NumGlyphs := 2;
         end
       else
          with (SB[i] as TBitBtn) do
          begin
           Glyph.Assign(SBM);
           NumGlyphs := 2;
         end;
       BM := TBitmap.Create;
       SBM := TBitmap.Create;
     end;
   finally
     BM.Free;
     SBM.Free;
   end;
 end;

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

Автор: Robert Wittig

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

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

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

Автоматически закрыть TCommonDialog.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
  It is possible to close a common dialog shown by TCommonDialog.Execute 
  (or its overriddens) method while it is visible and application handles messages. 
  The solution is: 
  Es ist moglich einen TCommonDialog der mit TCommonDialog.Execute geoffnet wurde, 
  automatisch zu schliessen wahrend er sichtbar ist. Die Losung ist: 
}
 SendMessage(GetParent(OpenDialog1.Handle), WM_SYSCOMMAND, SC_CLOSE, 0);

Задать кнопку по умолчанию для диалога.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

function DefMessageDlg(const ACaption: string;
   const Msg: string;
   DlgType: TMsgDlgType;
   Buttons: TMsgDlgButtons;
   DefButton: Integer;
   HelpCtx: Longint): Integer;
 var
   i: Integer;
   btn: TButton;
 begin
   with CreateMessageDialog(Msg, DlgType, Buttons) do
     try
       Caption := ACaption;
       HelpContext := HelpCtx;
       for i := 0 to ComponentCount - 1 do
       begin
         if (Components[i] is TButton) then
         begin
           btn := TButton(Components[i]);
           btn.default := btn.ModalResult = DefButton;
           if btn.default then ActiveControl := btn;
         end;
       end;
       Result := ShowModal;
     finally
       Free;
     end;
 end;
 // Sets the focus on the "No"-Button 
// Setzt den Fokus auf den "Nein"-Button 
procedure TForm1.Button1Click(Sender: TObject);
 begin
   if DefMessageDlg('Title',
     '....?',
     mtConfirmation,
     mbYesNoCancel,
     mrNo,
     0) = mrYes then
     ShowMessage('....');
 end;

Динамически подключаемые библиотеки.

В разделе описаний DLL могут объявляться типы (в том числе и классы), константы и переменные, но они остаются скрытыми от вызывающей программы и могут использоваться только внутри DLL. В разделе описаний помимо стандартных для обычной программы объявлений используется специальный раздел объявления экспортируемых подпрограмм. Этот раздел начинается зарезервированным словом Exports, за которым через запятую перечисляются имена экспортируемых подпрограмм, например:

library MyLibrary;
function MyFunc(...): ...;
begin
end;
procedure MyProc;
begin
end;
exports
  MyFunc, MyProc;
begin
end.

exports
  MyFunc index 1, MyProc index 2;

exports
  MyFunc index I name 'NEWFUNC';

Для создания заготовки библиотечного модуля выберите опцию меню File | New | Unit или в окне репозитория щелкните по пиктограмме Da. В ответ Delphi откроет специальное окно проекта с длинным комментарием, в котором указывается на необходимость вставить ссылку на модуль ShareMem, если библиотека экспортирует длинные строки в параметрах обращения к подпрограммам или как результат функций. Эта ссылка должна быть первой как в предложении uses библиотеки, так и в uses файла проекта программы, которая использует эту библиотеку. Если подпрограммы библиотеки экспортируют строки ShortString или PChar, ссылаются на ShareMem не обязательно. Сразу же сохраните проект под именем Сmрiх, чтобы Delphi автоматически исправила имя библиотеки в предложении Library.

library Cmpix;
uses
  SysUtils, Classes;
{$R *.RES}
type
  TComplex = record Re, Im: Real;
  end;
function AddC(x, y: TComplex): TComplex; stdcall;
begin
  Result.Im := x.Im + y.Im;
  Result.Re := x.Re + y.Re
end;
function SubC(x, y: TComplex): TComplex; stdcall;
begin
  Result.Im := x.Im - y.Im;
  Result.Re := x.Re - y.Re
end;
function MulC(x, у: TComplex): TComplex; stdcall;
begin
  Result.Re := x.Re * y.Re + x.Im * y.Im;
  Result.Im := x.Re * y.Im - x.Im * y.Re
end;
function DivC(x, y: TComplex): TComplex; stdcall;
var
  z: Real;
begin
  z := sqr(y.Re) + sqr(y.Im);
  try
    Result.Re := (x.Re * y.Re + x.Im * y.Im) / z;
    Result.Im := (x.Re * y.Im - x.Im * y.Re) / z
  except
    Result.Re := le + 309;
    Result.Im := le + 309
  end
end;
exports
  AddC index 1 name 'ADDC' resident,
  SubC index 2,
  MulC index 3,
  DivC index 4;
begin
end.

procedure MyProc; External 'MyDLL'; 

procedure MyProc; External 'MyDLL' index 2; 

procedure MyProc; External 'MyDLL' Name 'ExtName'; 

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

type
  TComplex = record
    Re, Im: Real;
  end;
function ADDC(x, y: TComplex): TComplex; stdcall; external 'Cmplx';
function SubC(x, y: TComplex): TComplex; stdcall; external 'Cmplx';
function MulC(x, y: TComplex): TComplex; stdcall; external 'Cmplx';
function DivC(x, y: TComplex): TComplex; stdcall; external 'Cmplx';
procedure TfmExample.bbRunClick(Sender: TObject);
var
  x, y, z: TComplex;
  ..... // Далее смотри текст обработчика bbRunClick в п.12.6 end; end.

function AddC(x, у: TComplex): TComplex; stdcall; External 

Следующий пример иллюстрирует технику такой загрузки DLL Cmplx:

type
  TComplex = record
    Re, Im: Real;
  end;
  TComplexFunc = function(x, y: TComplex): TComplex; stdcall;
procedure TfmExample.bbRunClick(Sender: TObject);
var
  x, y, z: TComplex;
  AddC, SubC, MulC, DivC: TComplexFunc;
  Handle: LongWord;
  procedure Output(Operation: Char);
    ....//Тело процедуры Output остается без изменений
  end; //Output
begin //bbRunClick
  // Загружаем библиотеку CMPLX.DLL Handle := LoadLibrary('Cmplx.dll');
  if Handle = 0 then
  begin
    ShowMessage('He найдена библиотека CMPLX.DLL');
    Halt
  end;
  {Определяем адреса функций. Три первые вызываем по индексу,
  четвертую - по имени. При вызове по индексу младшее слово
  PChar должно содержать индекс, поэтому делаем приведение типов:}
  @AddC := GetProcAddress(Handle, PChar(Longint(1)));
  PSubC := GetProcAddress(Handle, PChar(Longint(2)));
  @MulC := GetProcAddress(Handle, PChar(Longint(3)));
  @DivC := GetProcAddress(Handle, 'DivC');
  x.re := Random;
  x.im := Random;
  y.re := Random;
  y.im := Random;
  Output('+');
  Output('-');
  Output('*');
  Output('/');
  mmOutput.Lines.Add('');
  // Освобождаем библиотеку FreeLibrary(Handle)
end;

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

unit Complx;
interface
type
  TComplex = record
    Re, Im: Real;
  end;
function AddC(x, y: TComplex): TComplex; stdcall; External 'Cmplx' index 1;
function SubC(x, y: TComplex): TComplex; stdcall; External 'Cmplx' index 2;
function MulC(x, y: TComplex): TComplex; stdcall; External 'Cmplx' index 3;
function DivC(x, y: TComplex): TComplex; stdcall; External 'Cmplx' index 4;
implementation
end.

При обращении к подпрограммам DLL, написанным на других языках программирования, может оказаться, что внешнее имя подпрограммы содержит символы, которые не могут содержаться в правильном идентификаторе Delphi. Например, язык C++ разрешает использовать в идентификаторах символ '@'. В этом случае (а также если вы хотите переименовать экспортируемую из DLL подпрограмму) именуйте подпрограмму любым правильным с точки зрения Delphi идентификатором и укажите истинное имя подпрограммы после слова name. Например:

function MyFunction: WordBool; stdcall; external 'MyDLL' name '_MyFunction@12'

Текст DLL

library DLLWithForm;
uses
  SysUtils,
  Classes,
  DLLFormU in 'DLLFormU.pas' {DLLForm};
{$R *.RES}
exports
  ShowModalForm, ShowForm, FreeForm;
begin
end.

Текст формы в DLL

unit DLLFormU;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons;
type
  TDLLForm = class(TForm)
    BitBtnl: TBitBtn;
    BitBtn2: TBitBtn;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    CallForm: THandle; //Дескриптор вызывающей формы
  public
    { Public declarations }
  end;
// Объявление экспортируемых подпрограмм
function ShowModalForm: Integer;
procedure ShowForm(aHandle: THandle);
procedure FreeForm;
var
  DLLForm: TDLLForm;
implementation
{$R *.DFM}
function ShowModalForm: Integer;
// Модальный вызов
begin
  DllForm := TDllForm.Create(Application);
  Result := DLLForm.ShowModal;
  DLLForm.Free;
end;
procedure ShowForm(Appl, Form: THandle);
// Немодальный вызов
begin
  Application.Handle := Appl; // Замена объекта
  Application DllForm := TDllForm.Create(Application);
  // Запоминаем дескриптор вызывающего окна для посылки
  // ему сообщения о закрытии
  CallForm := Form;
  DLLForm.Show
end;
procedure FreeForm;
// Уничтожение формы
begin
  DLLForm.Free
end;
procedure TDLLForm.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  if CallFormoO then
    SendMessage(CallForm, wm_User, 0, 0)
end;
end.

unit TestMainU;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;
type
  TTestMain = class(TForm)
    Buttoni: TButton; // Открыть в модальном режиме
    Button2: TButton; // Открыть в немодальном режиме
    Button3: TButton; // Закрыть окно
  label
    I: TLabel;
procedure ButtonlClick(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure ButtonSClick(Sender: TObject);
private
  { Private declarations }
public
  { Public declarations }
  procedure WMUser(var Msg: TMessage); message WM_USER;
end;
var
  TestMain: TTestMain;
implementation
{$R *.DFM}
function ShowModalForm: Integer; external 'DLLWithForm';
procedure ShowForm(Appl, Form: THandle); external ' DLLWithForm';
procedure FreeForm; external 'DLLWithForm';
procedure TTestMain.ButtonlClick(Sender: TObject);
// Модальный вызов
begin
  Button2.Enabled := False;
  labell.Caption := 'ModalResult = ' + IntToStr(ShowModalForm);
  labell.Show; // Показываем результат вызова
  Button2.Enabled := True
end;
procedure TTestMain.Button2Click(Sender: TObject);
// Немодальный вызов
begin
  Buttoni.Enabled := = False;
  Button2.Enabled := False;
  Buttons.Enabled := True;
label
  1. Hide;
  ShowForm(Application.Handle, Self.Handle);
end;
procedure TTestMain.Button3Click(Sender: TObject);
// Закрыть форму
begin
  FreeForm;
  Button1.Enabled := True;
  Button2.Enabled := True;
  Button3.Enabled := False;
end;
procedure TTestMain.WMUser(var Msg: TMessage);
// Сообщение из формы DLL о ее закрытии
begin
  Buttons.Click
end;
end.

При показе формы в немодальном режиме она может быть закрыта щелчком по собственной системной кнопке закрыть. В этом случае она должна каким-то образом известить вызывающую программу об этом событии. Для этого используется стандартный механизм посылки вызывающей форме Windows-сообщения. Сообщение должно иметь адрес, в роли которого используется дескриптор окна, получающего это сообщение. Вот почему вторым параметром обращения к функции ShowForm в DLL передается и в поле CallForm: запоминается дескриптор вызывающего окна. Обработчик события enclose формы проверяет это поле и, если оно определено, посылает вызывающему окну сообщение с индексом wm_user. В вызывающей программе предусмотрен обработчик этого сообщения, в котором реализуются необходимые действия.

DLL и ресурсы.

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

Отслеживание из DLL ее присоединение к процессу и отсоединение.

Автор: Xavier Pacheco

library DLLEntryLib;
uses
  SysUtils,
  Windows,
  Dialogs,
  Classes;
procedure DLLEntryPoint(dwReason: DWord);
begin
  case dwReason of
    DLL_PROCESS_ATTACH: ShowMessage('Attaching to process');
    DLL_PROCESS_DETACH: ShowMessage('Detaching from process');
    DLL_THREAD_ATTACH: MessageBeep(0);
    DLL_THREAD_DETACH: MessageBeep(0);
  end;
end;
begin
  { First, assign the procedure to the DLLProc variable }
  DllProc := @DLLEntryPoint;
  { Now invoke the procedure to reflect that the DLL is attaching to the
    process }
  DLLEntryPoint(DLL_PROCESS_ATTACH);
end.

{
Copyright © 1999 by Delphi 5 Developer's Guide - Xavier Pacheco and Steve Teixeira
}
unit MainFrm;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ComCtrls, Gauges;
type
  { Define a TThread descendant }
  TTestThread = class(TThread)
    procedure Execute; override;
    procedure SetCaptionData;
  end;
  TMainForm = class(TForm)
    btnLoadLib: TButton;
    btnFreeLib: TButton;
    btnCreateThread: TButton;
    btnFreeThread: TButton;
    lblCount: TLabel;
    procedure btnLoadLibClick(Sender: TObject);
    procedure btnFreeLibClick(Sender: TObject);
    procedure btnCreateThreadClick(Sender: TObject);
    procedure btnFreeThreadClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    LibHandle: THandle;
    TestThread: TTestThread;
    Counter: Integer;
    GoThread: Boolean;
  end;
var
  MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TTestThread.Execute;
begin
  while MainForm.GoThread do
  begin
    Synchronize(SetCaptionData);
    Inc(MainForm.Counter);
  end;
end;
procedure TTestThread.SetCaptionData;
begin
  MainForm.lblCount.Caption := IntToStr(MainForm.Counter);
end;
procedure TMainForm.btnLoadLibClick(Sender: TObject);
{ This procedure loads the library DllEntryLib.DLL }
begin
  if LibHandle = 0 then
  begin
    LibHandle := LoadLibrary('DLLENTRYLIB.DLL');
    if LibHandle = 0 then
      raise Exception.Create('Unable to Load DLL');
  end
  else
    MessageDlg('Library already loaded', mtWarning, [mbok], 0);
end;
procedure TMainForm.btnFreeLibClick(Sender: TObject);
{ This procedure frees the library }
begin
  if not (LibHandle = 0) then
  begin
    FreeLibrary(LibHandle);
    LibHandle := 0;
  end;
end;
procedure TMainForm.btnCreateThreadClick(Sender: TObject);
{ This procedure creates the TThread instance. If the DLL is loaded a
  message beep will occur. }
begin
  if TestThread = nil then
  begin
    GoThread := True;
    TestThread := TTestThread.Create(False);
  end;
end;
procedure TMainForm.btnFreeThreadClick(Sender: TObject);
{ In freeing the TThread a message beep will occur if the DLL is loaded. }
begin
  if not (TestThread = nil) then
  begin
    GoThread := False;
    TestThread.Free;
    TestThread := nil;
    Counter := 0;
  end;
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
  LibHandle := 0;
  TestThread := nil;
end;
end.

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

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

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

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

В Delphi:

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

   static void CALLBACK (*saveProc)(char*);
   void FAR _export pascal setupDLL (void CALLBACK (*func)(char*))
   {
      saveProc = func;
   }

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

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

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

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

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

Разработка DLL в среде Borland Delphi.

Если ваш компьютер работает под управлением операционной системы Windows, то вы не можете не знать о существовании динамических подсоединяемых библиотек (dynamic link libraries - DLL). Достаточно взглянуть на список файлов, расположенных в системном каталоге Windows - порой количество используемых операционной системой динамических библиотек достигает нескольких сотен. DLL являются неотъемлемой частью функционирования операционных систем семейства Microsoft Windows. Однако для вас может быть неочевидна необходимость использования динамических библиотек при разработке приложений. В рамках данной статьи мы поговорим о принципах функционирования DLL и их использования в процессе создания ваших собственных программ.

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

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

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

Screen.Cursors[myCursor] := LoadCursor(HInstance, MYCURSOR');

LoadCursor - функция Windows API, которая вызывается приложением из динамической библиотеки User 32.dll. Кстати, примером хранимых в динамической библиотеке ресурсов могут являться такие стандартные диалоги Windows, как диалог открытия файла, диалог печати или настройки принтера. Эти диалоги находятся в файле Comctl32.dll. Однако многие прикладные разработчики используют функции вызова форм этих диалогов, совершенно не задумываясь, где хранится их описание.

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

Аргументы в пользу использования DLL

Итак, прежде чем перейти к обсуждению структуры динамических библиотек, необходимо поговорить о тех преимуществах, которые предоставляет их использование разработчику. Во-первых, это повторное использование кода. Думаю, нет необходимости пояснять удобство использования один раз разработанных процедур и функций при создании нескольких приложений? Кроме того, в дальнейшем вы сможете продать некоторые из своих библиотек, не раскрывая исходных кодов. А чем тогда это лучше компонентов, спросите вы? А тем, что функции, хранящиеся в библиотеке, могут быть вызваны на выполнение из приложений, разработанных не на Object Pascal, а, например, с использованием C++Builder, Visual Basic, Visual C++ и т.д. Такой подход накладывает некоторые ограничения на принцип разработки библиотеки, но это возможно. Звучит заманчиво? Мне кажется, даже очень. Но это еще не все.

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

В-третьих, следует поговорить вот о чем. Всего несколько лет назад при разработке программного обеспечения вы могли совершенно не волноваться относительно распространения ваших продуктов где-либо, кроме вашей страны. Я хочу сказать, что проблема перевода на другие языки текста на элементах управления (пункты меню, кнопки, выпадающие списки, подсказки), сообщений об ошибках и т.д. не стояла так остро, как сейчас. Однако, с повсеместным внедрением интернета у вас появилась возможность быстрой передачи готовых программных продуктов практически в любую точку мира. И что будут делать с вашей программой где-нибудь в Объединенных Арабских Эмиратах, если кроме как по-русски, она с пользователем общаться не умеет? Вы сами можете оценить этот эффект, если хоть раз на экране вашего компьютера вместо с детства знакомого русского языка появляется "арабская вязь" (например, из-за "сбоя" шрифтов). Итак, уже сейчас вы должны планировать возможность распространения ваших приложений в других странах (если, конечно, у вас есть желание получить как можно больше прибыли). Соответственно, встает вопрос быстрого перевода интерфейса вашей программы на другие языки. Одним из путей может являться создание ресурсов интерфейсов внутри DLL. К примеру, можно создать одно приложение, которое в зависимости от версии динамической библиотеки будет выводить сообщения на различных языках.

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

Основы разработки DLL

Разработка динамических библиотек не представляет собой некий сверхсложный процесс, доступный лишь избранным. Если вы достаточно хорошо знакомы с разработкой приложений на Object Pascal, то вам не составит особого труда научиться работать с механизмом DLL. Итак, рассмотрим те особенности создания DLL, которые вам необходимо знать, а в завершении статьи разработаем свою собственную библиотеку.

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

library MyFirstDLL;
uses
  SysUtils, Classes, Forms, Windows;
procedure HelloWorld(AForm : TForm);
begin
  MessageBox(AForm.Handle, 'Hello world!', 'DLL Message Box',
  MB_OK or MB_ICONEXCLAMATION);
end;
exports
  HelloWorld;
begin
end.

Первое, на что следует обратить внимание, это ключевое слово library, находящееся вверху страницы. Library определяет этот модуль как модуль библиотеки DLL. Далее идет название библиотеки. В нашем примере мы имеем дело с динамической библиотекой, содержащей единственную процедуру: HelloWorld. Причем обратите внимание, что данная процедура по структуре ничем не отличается от тех, которые вы помещаете в модули своих приложений. Ключевое слово exports сигнализирует компилятору о том, что перечисленные ниже функции и/или процедуры должны быть доступны из вызывающих приложений (т.е. они как бы "экспортируются" из библиотеки). Подробнее о механизме экспорта мы поговорим чуть позже.

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

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

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

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

Экспорт функций из DLL

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

Наиболее распространенный способ экспорта - по имени. Взглянем на приведенный ниже текст:

exports
  SayHello,
  DoSomething,
  DoSomethingReallyCool;

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

Для того, чтобы определить выполняется ли ваш кодек в DLL или в вызывающем приложении, можно воспользоваться глобальной переменной IsLibrary. Она принимает значение true в том случае, если код вызывается из библиотеки и false в случае выполнения процедуры или функции из вызывающего приложения.

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

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

Выше я уже говорил о том, что код инициализации динамической библиотеки может быть помещен в блок begin...end. Однако кроме этого зачастую необходимо предусмотреть некоторые действия, выполняемые в процессе выгрузки DLL из оперативной памяти. В отличии от других типов модулей, модуль DLL не имеет ни секции initialization, ни секции finalization. К примеру, вы можете динамически выделить память в главном блоке, однако не понятно, где эта память должна быть освобождена. Для решения этой проблемы существует DLLProc - специальная процедура, вызываемая в определенные моменты функционирования DLL.

Для начала следует сказать о самой причине существования DLLProc. Динамическая библиотека получает сообщения от Windows в моменты своей загрузки и выгрузки из оперативной памяти, а также в тех случаях, когда какой-нибудь очередной процесс, использующий функции и/или ресурсы, хранящиеся в библиотеке, загружается в память. Такая ситуация возможно в том случае, когда библиотека необходима для функционирования нескольких приложений. А для того, чтобы вы имели возможность указывать, что именно должно происходить в такие моменты, необходимо описать специальную процедуру, которая и будет ответственна за такие действия. К примеру, она может выглядеть следующим образом:

procedure MyFirstDLLProc(Reason: Integer);
begin
  if Reason = DLL_PROCESS_DETACH then
    {DLL is unloading. Cleanup code here.}
end;

Однако системе совершенно не очевидно, что именно процедура MyFirstDllProc ответственна за обработку рассмотренных выше ситуаций. Поэтому вы должны поставить в соответствие адрес нашей процедуры глобальной переменной DLLProc. Это необходимо сделать в блоке begin...end примерно так:

begin
  DLLProc := @MyDLLProc;
  { Что-нибудь еще, что должно выполняться в
  процессе инициализации библиотеки }
end.

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

library MyFirstDLL;
uses
  SysUtils, Classes, Forms, Windows;
var
  SomeBuffer: Pointer;
procedure MyFirstDLLProc(Reason: Integer);
begin
  if Reason = DLL_PROCESS_DETACH then
    {DLL is выгружается из памяти.
    Освобождаем память, выделенную под буфер.}
    FreeMem(SomeBuffer);
end;
procedure HelloWorld(AForm: TForm);
begin
  MessageBox(AForm.Handle, 'Hello world!',
  'DLL Message Box', MB_OK or MB_ICONEXCLAMATION);
end;
{Какой-нибудь код, в котором используется SomeBuffer.}
exports
  HelloWorld;
begin
  {Ставим в соответствие переменной
  DLLProc адрес нашей процедуры.}
  DLLProc := @MyFirstDLLProc;
  SomeBuffer := AllocMem(1024);
end.

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

Загрузка DLL

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

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

Смысл динамического метода заключается в том, что вы загружаете библиотеку не при старте приложения, а в тот момент, когда вам это действительно необходимо. Сами посудите, ведь если функция, описанная в динамической библиотеке, используется только при 10% запусков программы, то совершенно нет смысла использовать статический метод загрузки. Выгрузка библиотеки из памяти в данном случае также осуществляется под вашим контролем. Еще одно преимущества такого способа загрузки DLL - это уменьшение (по понятным причинам) времени старта вашего приложения. А какие же у этого способа имеются недостатки? Основной, как мне кажется, - это то, что использование данного метода является более хлопотным, чем рассмотренная выше статическая загрузка. Сначала вам необходимо воспользоваться функцией Windows API LoadLibrary. Для получения указателя на экспортируемой процедуры или функции должна использоваться функция GetProcAddress. После завершения использования библиотеки DLL должна быть выгружена с применением FreeLibrary.

Вызов процедур и функций, загруженных из DLL.

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

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

procedure SayHello(AForm : TForm); external myfirstdll.dll';

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

...
HelloWorld(self);
...

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

Импорт из DLL может проводиться по имени процедуры (функции), порядковому номеру или с присвоением другого имени.

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

procedure HelloWorld(AForm : TForm);
external myfirstdll.dll' index 15;

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

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

procedure CoolProcedure;
external myfirstdll.dll' name DoSomethingReallyCool';

Здесь импортируемой процедуре CoolProcedure дается имя DoSomethingReallyCool. Вызов процедур и функций, импортируемых из динамически загружаемых библиотек несколько более сложен, чем рассмотренный нами выше способ. В данном случае требуется объявить указатель на функцию или процедуру, которую вы собираетесь использовать. Помните процедуру HelloWorld? Давайте посмотрим, что необходимо сделать для того, чтобы вызвать ее на выполнение в случае динамической загрузки DLL. Во-первых, вам необходимо объявить тип, который описывал бы эту процедуру:

type
  THelloWorld = procedure(AForm : TForm);

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

var
  DLLInstance : THandle;
  HelloWorld : THelloWorld;
begin
  { загружаем DLL }
  DLLInstance := LoadLibrary(myfirstdll.dll');
  { получаем указатель }
  @HelloWorld := GetProcAddress(DLLInstance, HelloWorld');
  { вызываем процедуру на выполнение }
  HelloWorld(Self);
  { выгружаем DLL из оперативной памяти }
  FreeLibrary(DLLInstance);
end;

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

procedure TForm1.DynamicLoadBtnClick(Sender: TObject);
type
  THelloWorld = procedure(AForm : TForm);
var
  DLLInstance : THandle;
  HelloWorld : THelloWorld;
begin
  DLLInstance := LoadLibrary(myfirstdll.dll');
  if DLLInstance = 0 then
  begin
    MessageDlg(Невозможно загрузить DLL', mtError, [mbOK], 0);
    Exit;
  end;
  @HelloWorld := GetProcAddress(DLLInstance, HelloWorld');
  if @HelloWorld <> nil then
    HelloWorld (Self)
  else
    MessageDlg(Не найдена искомая процедура!.', mtError, [mbOK], 0);
  FreeLibrary(DLLInstance);
end;

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

Разработку DLL, содержащую форму, я продемонстрирую на примере.

Итак, во-первых, создадим новый проект динамической библиотеки. Для этого выберем пункт меню File|New, а затем дважды щелкнем на иконку DLL. После этого вы увидите примерно следующий код:

library Project2;
{здесь были комментарии}
uses
  SysUtils, Classes;
{$R *.RES}
begin
end.

Сохраните полученный проект. Назовем его DllForms.dpr.

Теперь следует создать новую форму. Это можно сделать по-разному. Например, выбрав пункт меню File|New Form. Добавьте на форму какие-нибудь компоненты. Назовем форму DllForm и сохраним получившийся модуль под именем DllFormUnit.pas.

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

function ShowForm : Integer; stdcall;
var
  Form : TDLLForm;
begin
  Form := TDLLForm.Create(Application);
  Result := Form.ShowModal;
  Form.Free;
end;

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

Экспортируем нашу функцию с использованием ключевого слова exports :

exports
  ShowForm;

Компилируем проект и получаем файл dllforms.dll. Эти простые шаги - все, что необходимо сделать для создания динамической библиотеки, содержащей форму. Обратите внимание, что функция ShowForm объявлена с использованием ключевого слова stdcall. Оно сигнализирует компилятору использовать при экспорте функции соглашение по стандартному вызову (standard call calling convention). Экспорт функции таким образом создает возможность использования разработанной DLL не только в приложениях, созданных в Delphi.

Соглашение по вызову (Calling conventions) определяет, каким образом передаются аргументы при вызове функции. Существует пять основных соглашений: stdcall, cdecl, pascal, register и safecall. Подробнее об этом можно узнать, посмотрев раздел "Calling Conventions" в файле помощи Delphi.

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

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

library DllForms;
uses
  SysUtils, Classes, Forms,
  DllFormUnit in 'DllFormUnit.pas' {DllForm};
{$R *.RES}
function ShowForm : Integer; stdcall;
var
  Form : TDLLForm;
begin
  Form := TDLLForm.Create(Application);
  Result := Form.ShowModal;
  Form.Free;
end;
begin
end.

unit TestAppUnit;
interface
uses
  Windows, Messages, SysUtils, 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;
  function ShowForm : Integer; stdcall; external 'dllforms.dll';
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowForm;
end;
end.

Прошу заметить, что при экспорте функции также было использовано ключевое слово stdcall.

Следует обратить особое внимание на работу с дочерними формами в DLL. Если, к примеру, в вызывающем приложении главная форма имеет значение свойства FormStyle, равным MDIForm, то при попытке вызова из DLL MDIChild-формы, на экране появится сообщение об ошибке, в котором будет говориться, что нет ни одной активной MDI-формы.

В тот момент, когда вы пытаетесь показать ваше дочернее окно, VCL проверяет корректность свойства FormStyle главной формы приложения. Однако в нашем случае все вроде бы верно. Так в чем же дело? Проблема в том, что при проведении такой проверки, рассматривается объект Application, принадлежащий не вызывающему приложению, а собственно динамической библиотеке. Ну, и естественно, поскольку в DLL нет главной формы, проверка выдает ошибку. Для того чтобы избежать такой ситуации, надо назначить объекту Application динамической библиотеки объект Application вызывающего приложения. Естественно, это заработает только в том случае, когда вызывающая программа - VCL-приложение. Кроме того, перед выгрузкой библиотеки из памяти необходимо вернуть значение объекта Application библиотеки в первоначальное состояние. Это позволит менеджеру памяти очистить оперативную память, занимаемую библиотекой. Следовательно, вам нужно сохранить указатель на "родной" для библиотеки объект Application в глобальной переменной, которая может быть использована при восстановлении его значения.

Итак, вернемся немного назад и перечислим шаги, необходимые нам для работы с помещенным в DLL MDIChild-формами.

Первый шаг прост. Просто помещаем следующий код в верхней части модуля DLL:

var
  DllApp: TApplication;

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

procedure ShowMDIChild(MainApp: TApplication);
var
  Child: TMDIChild;
begin
  if not Assigned(DllApp) then
  begin
    DllApp := Application;
    Application := MainApp;
  end;
  Child := TMDIChild.Create(Application.MainForm);
  Child.Show;
end;

Все, что нам теперь необходимо сделать, - это предусмотреть возвращение значения объекта Application в исходное состояние. Делаем это с помощью процедуры MyDllProc:

procedure MyDLLProc(Reason: Integer);
begin
  if Reason = DLL_PROCESS_DETACH then
    { DLL is выгружается. Восстанавливаем значение указателя Application}
    if Assigned(DllApp) then
      Application := DllApp;
end;

Вместо заключения

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

Автоматизация кодирования импорта функций из DLL.

Оформил: DeeCo

Автор: Кочетов Андрей.

Решение этой задачи позволит значительно сократить трудоёмкость (а значит, и время, и количество внесённых ошибок) написания похожего кода в разных проектах и/или для разных DLL.

Уважаемый автор предлагает для решения этой задачи использовать механизм шаблонов (templates) языка С++. Это огромный шаг вперёд по сравнению с рутинным кодированием, но на мой взгляд, не идеальное решение, которому присущи некоторые недостатки:

Borland Software Corporation, отдав дань уважения OWL, задвинула её подальше и стала развивать Delphi и BCB на платформе VCL. Совершенно не вижу, почему бы благородным донам не поступить так же J.

bool (*FuncGetProc)(HMODULE PtrDll)

bool Example_Load(HMODULE PtrDll)
{
  if((Func1=(DLL_Func1)GetProcAddress(PtrDll, "@Func1$qiii")) == NULL) return false;
  if((Func2=(DLL_Func2)GetProcAddress(PtrDll, "@Func2$qpct1")) == NULL) return false;
return true;
}

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

int __cdecl Func1(int i1, int i2, int i3);
char * __cdecl Func2(char * s1, char * s2

Итак, начинаем:

рис. 1.

рис. 2.

Имя DLL-ки является префиксом у всех сгенерированных файлов и у функции в модуле CPP. Исходный текст DLL и тестового приложения находится в архиве DllTest.zip.

рис. 3.

рис. 4.

P.S. Немножко саморекламы: компонента TAskDll является составной частью пакета ASK Tools, см. соответствующую ссылку на http://goldenask.narod.ru/

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

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

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

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

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

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

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

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

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

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

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

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

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

Модуль-заготовка для динамического подключения библиотек.

Автор: Panov WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Модуль-заготовка для динамического подключения библиотек.
Модуль подключается к проекту.
Для загрузки и выгрузки библиотек используется по одной функции.
Зависимости: windows.pas, sysutils.pas
Автор:       panov, panov@hotbox.ru
Copyright:   нет
Дата:        30 марта 2004 г.
***************************************************** }
unit proc;
interface
uses windows, sysutils, classes;
const
  _MyLibraryName = '..\dll\proc.dll'; //имя библиотеки
var
  hLib: THandle;
procedure LoadLib;
procedure UnloadLib;
implementation
procedure LoadLib;
begin
  if hLib <> 0 then
    Exit;
  hLib := LoadLibrary(PChar(_MyLibraryName));
  if (hLib = 0) then
  begin
    raise Exception.Create('Не могу загрузить библиотеку ' + _MyLibraryName);
    Exit;
  end;
end;
procedure UnloadLib;
begin
  FreeLibrary(hLib);
  hLib := 0;
end;
initialization
  hLib := 0;
end.

Пример использования:

unit proc;
interface
uses windows, sysutils;
const
  _MyLibraryName = '..\dll\proc.dll'; //имя библиотеки
var
  hLib: THandle;
  ExecCmd: procedure(const aCommand: string; const aShow, aWaitExit: Boolean);
procedure LoadLib;
procedure UnloadLib;
implementation
procedure LoadLib;
begin
  if hLib <> 0 then
    Exit;
  hLib := LoadLibrary(PChar(_MyLibraryName));
  if (hLib = 0) then
  begin
    raise Exception.Create('Не могу загрузить библиотеку ' + _MyLibraryName);
    Exit;
  end;
  @ExecCmd := GetProcAddress(hLib, 'ExecCmd');
end;
procedure UnloadLib;
begin
  FreeLibrary(hLib);
  hLib := 0;
end;
initialization
  hLib := 0;
end.
{
В любом модуле пишем:
  uses proc;
...
  LoadLib; //Загрузка библиотеки.
  ExecCmd('c:\command.com',True,True);
  UnloadLib; //Выгрузка библиотеки.
}

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

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

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

Получить специфическую для DLL информацию о версии.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{*************************** 
** DllGetVersion Function ** 
***************************}
 { 
  Implemented by many of the Microsoft® Windows® Shell dynamic-link libraries (DLLs) to 
  allow applications to obtain DLL-specific version information. 
}
 { 
  Using DllGetVersion to Determine the Version Number 
  Starting with version 4.71, the Shell and common controls DLLs, among others, 
  began exporting DllGetVersion. 
  This function can be called by an application to determine which DLL 
  version is present on the system. It returns a structure that contains version information. 
  Note  DLLs do not necessarily export DllGetVersion. Always test for it 
  before attempting to use it. 
  For systems earlier than Windows 2000, DllGetVersion returns a DLLVERSIONINFO structure 
  that contains the major and minor version numbers, the build number, 
  and a platform identifier (ID). 
  For Windows 2000 and later systems, DllGetVersion might instead return a 
  DLLVERSIONINFO2 structure. This structure contains the QFE number that identifies 
  the service pack and provides a more robust way to compare version numbers than DLLVERSIONINFO. 
  Because the first member of DLLVERSIONINFO2 is a DLLVERSIONINFO structure, 
  the new structure is backward-compatible. 
}
 // DLLVERSIONINFO structure 
type
   PDLLVerInfo=^TDLLVersionInfo;
   TDLLVersionInfo=Record
     cbSize,   // Size of the structure, in bytes. 
    dwMajorVersion, // Major version of the DLL 
    dwMinorVersion, // Minor version of the DLL 
    dwBuildNumber, // Build number of the DLL 
    dwPlatformID: DWord; // Identifies the platform for which the DLL was built 
end;
 var
   DllGetVersion: function(dvi: PDLLVerInfo): PDLLVerInfo; stdcall;
 function GetDllVersion(DllName: string; var DLLVersionInfo: TDLLVersionInfo): Boolean;
 var
   hInstDll: THandle;
   p: pDLLVerInfo;
 begin
   Result := False;
   // Get a handle to the DLL module. 
  // das Handle zum DLL Modul ermitteln. 
  hInstDll := LoadLibrary(PChar(DllName));
   if (hInstDll = 0) then Exit;
   // Return the address of the specified exported (DLL) function. 
  // Adresse der Dll-Funktion ermitteln 
  @DllGetVersion := GetProcAddress(hInstDll, 'DllGetVersion');
   // If the handle is not valid, clean up an exit. 
  // Wenn das Handle иngь1tig ist, wird die Funktion verlassen 
  if (@DllGetVersion) = nil then
   begin
     FreeLibrary(hInstDll);
     Exit;
   end;
   new(p);
   try
     ZeroMemory(p, SizeOf(p^));
     p^.cbSize := SizeOf(p^);
     // Call the DllGetVersion function 
    // Die DllGetVersion() Funktion aufrufen 
    DllGetVersion(p);
     DLLVersionInfo.dwMajorVersion := p^.dwMajorVersion;
     DLLVersionInfo.dwMinorVersion := p^.dwMinorVersion;
     @DllGetVersion := nil;
     Result := True;
   finally
     dispose(P);
   end;
  // Free the DLL module. 
 // Dll wieder freigeben. 
 FreeLibrary(hInstDll);
 end;
 // Example to get version info from comctl32.dll 
// Beispiel, um von comctl32 Versions/Informationen zu erhalten 
procedure TForm1.Button1Click(Sender: TObject);
 var
   DLLVersionInfo: TDLLVersionInfo;
 begin
  if not GetDllVersion('comctl32.dll',DLLVersionInfo) then
  begin
    DLLVersionInfo.dwMajorVersion := 4;
    DLLVersionInfo.dwMinorVersion := 0;
  end;
  with DLLVersionInfo do
    ShowMessage(Format('ComCtl Version: %d.%d / Build: %d',[dwMajorVersion, dwMinorVersion, dwBuildNumber]))
 end;

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

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

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

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

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

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

--my.rc--
STRINGTABLE
{
00001, "My String #1"
00002, "My String #2"
}

brcc32 my.rc

--my.dpr--

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

dcc32 my.dpr

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

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

Отладка DLL в Windows XP.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

И снова баннеры - Download Accelerator 5.3.0.0.

Оформил: DeeCo Автор: http://www.cracklab.narod.ru

	* Possible StringData Ref from Data Obj ->"http://ads.downloadaccelerator.com/cgi-bin/ads"

Реализация Drag-and-Drop из внешнего приложения в ваше.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
  The following example demonstrates the Drag&Drop machanism from an external 
  application (Wordpad, Microsoft,..) to a TMemo in your own application. 
{ 
  Das folgende Beispiel demonstriert der Drag&Drop Maechanismus 
  aus externen Anwendungen (wie zum Beispiel WordPad oder Microsoft Word) 
  in ein TMemo des eigenen Delphi-Programms. 
 }
 unit TMemoDragDropFrm;
 { **************************************************************** 
  Source File Name :  TMemoDragDropFrm.pas 
  Typ              :  Hauptformular 
  Autor            :  Andreas Kosch 
  Compiler         :  Delphi 4.02 CSS 
  Betriebssystem   :  Windows 98 
  Beschreibung     :  Text via OLE Drag&Drop ььегnеhmеn aus einer 
                      anderen Anwendung (wie zum Beispiel WordPad) 
                      ььегnеhmеn. 
  16.01.2003: Test mit Delphi 7 und Microsoft Word XP unter Windowx XP 
 **************************************************************** }
  { Comments by Thomas Stutz }
 interface
 uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, ComCtrls, ActiveX, ShlObj, ComObj, StdCtrls;
 type
   // TForm1's declaration indicates that it's a TForm and that 
  // it supports the IDropTarget interface: 
 { 
  IDropTarget 
  Any application wanting to accept drop operations must 
  implement the IDropTarget interface. 
  Methods of the IDropTarget interface: 
  DragEnter 
    Dragged item has just been moved into the application's window, 
    return the relevant icon. 
  DragOver 
    Dragged item is being moved over the application's window, 
    return the relevant icon. 
  DragLeave 
    Dragged item has just moved out of the application's window. 
  Drop 
    The dragged item has been dropped on this application. 
  }
   TForm1 = class(TForm, IDropTarget)
     Memo1: TMemo;
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
   private
     { Private declarations }
     // IDropTarget 
    function DragEnter(const dataObj: IDataObject;
                        grfKeyState: Longint;
                        pt: TPoint;
                        var dwEffect: Longint): HResult; stdcall;
     function DragOver(grfKeyState: Longint;
                       pt: TPoint;
                       var dwEffect: Longint): HResult; stdcall;
     function DragLeave: HResult; stdcall;
     function Drop(const dataObj: IDataObject;
                   grfKeyState: Longint; pt: TPoint;
                   var dwEffect: Longint): HResult; stdcall;
    // IUnknown 
   // Ignore referance counting 
   function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
   public
     { Public declarations }
   end;
 var
   Form1: TForm1;
 implementation
 {$R *.dfm}
 uses
   ShellAPI;
 // In the OnCreate event handler, two important methods are called. 
// First, OleInitalize is called. This initializes the OLE libraries and should always be 
// called before your application uses any OLE functions. 
// RegisterDragDrop registers the window as a valid drop target. 
// If this isn't called, the window will never receive any drop events. 
procedure TForm1.FormCreate(Sender: TObject);
 begin
   OleInitialize(nil);
   {Allow window to accept drop events}
   OleCheck(RegisterDragDrop(Handle, Self));
   { Execute Wordpad for testing }
   ShellExecute(Handle, 'open', 'wordpad', 'c:\Test.doc', nil, SW_SHOW);
 end;
 // OnDestroy does the exact opposite. It calls RevokeDropTarget to indicate that 
// drop events are no longer accepted. 
// It then calls OleUninitialize, since the application is finished using all OLE functions. 
procedure TForm1.FormDestroy(Sender: TObject);
 begin
   {Finished accepting drops}
   RevokeDragDrop(Handle);
   OleUninitialize;
 end;
 {-----------------------------------------------------------------}
 { IDropTarget-Implementierung                                     }
 {-----------------------------------------------------------------}
 function TForm1.DragEnter(const dataObj: IDataObject;
   grfKeyState: Longint;
   pt: TPoint;
   var dwEffect: Longint): HResult;
 begin
   dwEffect := DROPEFFECT_COPY;
   Result  := S_OK;
 end;
 function TForm1.DragOver(grfKeyState: Longint;
   pt: TPoint;
   var dwEffect: Longint): HResult;
 begin
   dwEffect := DROPEFFECT_COPY;
   Result := S_OK;
 end;
 function TForm1.DragLeave: HResult;
 begin
   Result := S_OK;
 end;
 function TForm1._AddRef: Integer;
 begin
    Result := 1;
 end;
 function TForm1._Release: Integer;
 begin
    Result := 1;
 end;
 function TForm1.Drop(const dataObj: IDataObject;
   grfKeyState: Longint;
   pt: TPoint;
   var dwEffect: Longint): HResult;
 var
   aFmtEtc: TFORMATETC;
   aStgMed: TSTGMEDIUM;
   pData: PChar;
 begin
   {Make certain the data rendering is available}
   if (dataObj = nil) then
     raise Exception.Create('IDataObject-Pointer is not valid!');
   with aFmtEtc do
   begin
     cfFormat := CF_TEXT;
     ptd := nil;
     dwAspect := DVASPECT_CONTENT;
     lindex := -1;
     tymed := TYMED_HGLOBAL;
   end;
   {Get the data}
   OleCheck(dataObj.GetData(aFmtEtc, aStgMed));
   try
     {Lock the global memory handle to get a pointer to the data}
     pData := GlobalLock(aStgMed.hGlobal);
     { Replace Text }
     Memo1.Text := pData;
   finally
     {Finished with the pointer}
     GlobalUnlock(aStgMed.hGlobal);
     {Free the memory}
     ReleaseStgMedium(aStgMed);
   end;
   Result := S_OK;
 end;
 end.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Пример шифрования данных.

Автор: Vit WEB сайт: http://forum.vingrad.ru

procedure DoEncode(var Source: string; const Key: string);
asm
 Push ESI
 Push EDI
 Push EBX
 Or EAX,EAX
 Jz @Done
 Push EAX
 Push EDX
 Call UniqueString
 Pop EDX
 Pop EAX
 Mov EDI,[EAX]
 Or EDI,EDI
 Jz @Done
 Mov ECX,[EDI-4]
 Jecxz @Done
 Mov ESI,EDX
 Or ESI,ESI
 Jz @Done
 Mov EDX,[ESI-4]
 Dec EDX
 Js @Done
 Mov EBX,EDX
 Mov AH,DL
 Cld
 @L1:
 Test AH,8
 Jnz @L3
 Xor AH,1
 @L3:
 Not AH
 Ror AH,1
 Mov AL,[ESI+EBX]
 Xor AL,AH
 Xor AL,[EDI]
 Stosb
 Dec EBX
 Jns @L2
 Mov EBX,EDX
 @L2:
 Dec ECX
 Jnz @L1
 @Done:
 Pop EBX
 Pop EDI
 Pop ESI
end;

2) Единственный байт гаммы(или ксорирующей последовательности), который меняется при шифровании - это длина пароля. Остальные символы пароля НИКАК НЕ ПЕРЕМЕШИВАЮТСЯ в ходе шифрования. Алгоритм шифрования примерно такой:

Len := Lengh(Key);
Index := Lengh(Key) - 1;
i := 1;
repeat
  Len := func1(Len);
  Source[i] := (Key[Index] xor Len) xor Source[i];
  dec(Index);
  if Index := 0 then
    Index := Lengh(Key) - 1;
until
  i < Lenght(Source);

И это - фатальный недостаток.

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

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

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

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

Пример:

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

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

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

Или.

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

DOS команды.

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

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

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

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

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

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

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

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

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

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

Получить выходные данные DOS приложения.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{----------------------------CreateDOSProcessRedirected--------------------------- 
 Description    : executes a (DOS!) app defined in the CommandLine parameter redirected 
                  to take input from InputFile and give output to OutputFile 
 Result         : True on success 
 Parameters     : 
                  CommandLine : the command line for the app, including its full path 
                  InputFile   : the ascii file where from the app takes input 
                  OutputFile  : the ascii file to which the app's output is redirected 
                  ErrMsg      : additional error message string. Can be empty 
 Error checking : YES 
 Target         : Delphi 2, 3, 4 
 Author         : Theodoros Bebekis, email bebekis@otenet.gr 
 Notes          : 
 Example call   : CreateDOSProcessRedirected('C:\MyDOSApp.exe', 
                                             'C:\InputPut.txt', 
                                             'C:\OutPut.txt', 
                                             'Please, record this message') 
-----------------------------------------------------------------------------------}
 function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile,
   ErrMsg: string): Boolean;
 const
   ROUTINE_ID = '[function: CreateDOSProcessRedirected ]';
 var
   OldCursor: TCursor;
   pCommandLine: array[0..MAX_PATH] of Char;
   pInputFile, pOutPutFile: array[0..MAX_PATH] of Char;
   StartupInfo: TStartupInfo;
   ProcessInfo: TProcessInformation;
   SecAtrrs: TSecurityAttributes;
   hAppProcess, hAppThread, hInputFile, hOutputFile: THandle;
 begin
   Result := False;
   { check for InputFile existence }
   if not FileExists(InputFile) then
     raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
       'Input file * %s *' + #10 +
       'does not exist' + #10 + #10 +
       ErrMsg, [InputFile]);
   { save the cursor }
   OldCursor     := Screen.Cursor;
   Screen.Cursor := crHourglass;
   { copy the parameter Pascal strings to null terminated strings }
   StrPCopy(pCommandLine, CommandLine);
   StrPCopy(pInputFile, InputFile);
   StrPCopy(pOutPutFile, OutputFile);
   try
     { prepare SecAtrrs structure for the CreateFile calls 
      This SecAttrs structure is needed in this case because 
      we want the returned handle can be inherited by child process 
      This is true when running under WinNT. 
      As for Win95 the documentation is quite ambiguous }
     FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);
     SecAtrrs.nLength        := SizeOf(SecAtrrs);
     SecAtrrs.lpSecurityDescriptor := nil;
     SecAtrrs.bInheritHandle := True;
     { create the appropriate handle for the input file }
     hInputFile := CreateFile(pInputFile,
       { pointer to name of the file }
       GENERIC_READ or GENERIC_WRITE,
       { access (read-write) mode }
       FILE_SHARE_READ or FILE_SHARE_WRITE,
       { share mode } @SecAtrrs,                             { pointer to security attributes }
       OPEN_ALWAYS,                           { how to create }
       FILE_ATTRIBUTE_TEMPORARY,              { file attributes }
       0);                                   { handle to file with attributes to copy }
     { is hInputFile a valid handle? }
     if hInputFile = INVALID_HANDLE_VALUE then
       raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
         'WinApi function CreateFile returned an invalid handle value' +
         #10 +
         'for the input file * %s *' + #10 + #10 +
         ErrMsg, [InputFile]);
     { create the appropriate handle for the output file }
     hOutputFile := CreateFile(pOutPutFile,
       { pointer to name of the file }
       GENERIC_READ or GENERIC_WRITE,
       { access (read-write) mode }
       FILE_SHARE_READ or FILE_SHARE_WRITE,
       { share mode } @SecAtrrs,                             { pointer to security attributes }
       CREATE_ALWAYS,                         { how to create }
       FILE_ATTRIBUTE_TEMPORARY,              { file attributes }
       0);                                   { handle to file with attributes to copy }
     { is hOutputFile a valid handle? }
     if hOutputFile = INVALID_HANDLE_VALUE then
       raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
         'WinApi function CreateFile returned an invalid handle value' +
         #10 +
         'for the output file * %s *' + #10 + #10 +
         ErrMsg, [OutputFile]);
     { prepare StartupInfo structure }
     FillChar(StartupInfo, SizeOf(StartupInfo), #0);
     StartupInfo.cb          := SizeOf(StartupInfo);
     StartupInfo.dwFlags     := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
     StartupInfo.wShowWindow := SW_HIDE;
     StartupInfo.hStdOutput  := hOutputFile;
     StartupInfo.hStdInput   := hInputFile;
     { create the app }
     Result := CreateProcess(nil,                           { pointer to name of executable module }
       pCommandLine,
       { pointer to command line string }
       nil,                           { pointer to process security attributes }
       nil,                           { pointer to thread security attributes }
       True,                          { handle inheritance flag }
       CREATE_NEW_CONSOLE or
       REALTIME_PRIORITY_CLASS,       { creation flags }
       nil,                           { pointer to new environment block }
       nil,                           { pointer to current directory name }
       StartupInfo,                   { pointer to STARTUPINFO }
       ProcessInfo);                  { pointer to PROCESS_INF }
     { wait for the app to finish its job and take the handles to free them later }
     if Result then
     begin
       WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
       hAppProcess := ProcessInfo.hProcess;
       hAppThread  := ProcessInfo.hThread;
     end
     else
       raise Exception.Create(ROUTINE_ID + #10 + #10 +
         'Function failure' + #10 + #10 +
         ErrMsg);
   finally
     { close the handles 
      Kernel objects, like the process and the files we created in this case, 
      are maintained by a usage count. 
      So, for cleaning up purposes we have to close the handles 
      to inform the system that we don't need the objects anymore }
     if hOutputFile <> 0 then CloseHandle(hOutputFile);
     if hInputFile <> 0 then CloseHandle(hInputFile);
     if hAppThread <> 0 then CloseHandle(hAppThread);
     if hAppProcess <> 0 then CloseHandle(hAppProcess);
     { restore the old cursor }
     Screen.Cursor := OldCursor;
   end;
 end;

Конвертирует строку из кодировки DOS в кодировку Windows и обратно.

Автор: Сергей WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Конвертирует строку из кодировки DOS в кодировку Windows и обратно
Конвертирует строку из кодировки DOS в кодировку Windows и обратно
Зависимости: ???
Автор:       Сергей, nfkazak@inbox.ru, Краснодар
Copyright:   VIP BANK
Дата:        11 сентября 2002 г.
***************************************************** }
function WinToDos(St: string): string;
var
  Ch: PChar;
begin
  Ch := StrAlloc(Length(St) + 1);
  AnsiToOem(PChar(St), Ch);
  Result := Ch;
  StrDispose(Ch)
end;
function DosToWin(St: string): string;
var
  Ch: PChar;
begin
  Ch := StrAlloc(Length(St) + 1);
  OemToAnsi(PChar(St), Ch);
  Result := Ch;
  StrDispose(Ch)
end;

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

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

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

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

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

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

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

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

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

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

uses 
  Wininet; 
function DownloadURL(const aUrl: string): Boolean; 
var 
  hSession: HINTERNET; 
  hService: HINTERNET; 
  lpBuffer: array[0..1024 + 1] of Char; 
  dwBytesRead: DWORD; 
begin 
  Result := False; 
  // hSession := InternetOpen( 'MyApp', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0); 
  hSession := InternetOpen('MyApp', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); 
  try 
    if Assigned(hSession) then 
    begin 
      hService := InternetOpenUrl(hSession, PChar(aUrl), nil, 0, 0, 0); 
      if Assigned(hService) then 
        try 
          while True do 
          begin 
            dwBytesRead := 1024; 
            InternetReadFile(hService, @lpBuffer, 1024, dwBytesRead); 
            if dwBytesRead = 0 then break; 
            lpBuffer[dwBytesRead] := #0; 
            Form1.Memo1.Lines.Add(lpBuffer); 
          end; 
          Result := True; 
        finally 
          InternetCloseHandle(hService); 
        end; 
    end; 
  finally 
    InternetCloseHandle(hSession); 
  end; 
end;

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

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

 
{Forces a download of the requested file, object, or directory 
listing from the origin server, not from the cache}
 function DownloadURL_NOCache(const aUrl: string; var s: String): Boolean;
 var
   hSession: HINTERNET;
   hService: HINTERNET;
   lpBuffer: array[0..1024 + 1] of Char;
   dwBytesRead: DWORD;
 begin
   Result := False;
   s := '';
   // hSession := InternetOpen( 'MyApp', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0); 
  hSession := InternetOpen('MyApp', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
   try
     if Assigned(hSession) then
     begin
       hService := InternetOpenUrl(hSession, PChar(aUrl), nil, 0, INTERNET_FLAG_RELOAD, 0);
       if Assigned(hService) then
         try
           while True do
           begin
             dwBytesRead := 1024;
             InternetReadFile(hService, @lpBuffer, 1024, dwBytesRead);
             if dwBytesRead = 0 then break;
             lpBuffer[dwBytesRead] := #0;
             s := s + lpBuffer;
           end;
           Result := True;
         finally
           InternetCloseHandle(hService);
         end;
     end;
   finally
     InternetCloseHandle(hSession);
   end;
 end;
 //aufrufen 
var
   s: String;
 begin
  if DownloadURL('http://www.swissdelphicenter.ch/', s) then
    ShowMessage(s);
 end;

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

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

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

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

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

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

Как скачать файл через Proxy.

DownloadFile('http://some.com/some.zip', 'c:\some.zip');
function DownloadFile(const FileURL, FileName: String): Cardinal;
var
  hSession, hFile: HInternet;
  Buffer: array[1..1024] of Byte;
  BufferLen, fSize: LongWord;
  f: File;
begin
  Result := 0;
  hSession := InternetOpen('STEROID Download',
                           INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if Assigned(hSession) then begin
    hFile := InternetOpenURL(hSession, PChar(FileURL), nil, 0,
                             INTERNET_FLAG_RELOAD, 0);
    if Assigned(hFile) then begin
      AssignFile(f, FileName);
      Rewrite(f,1);
      fSize := 0;
      repeat
        InternetReadFile(hFile, @Buffer, SizeOf(Buffer), BufferLen);
        BlockWrite(f, Buffer, BufferLen);
        fSize := fSize + BufferLen;
      until (BufferLen = 0);
      CloseFile(f);
      Result := fSize;
      InternetCloseHandle(hFile);
    end;
    InternetCloseHandle(hSession);
  end;
end;

Комментарий:

function InternetOpen(lpszAgent: PChar;
                      dwAccessType: DWORD;
                      lpszProxy, lpszProxyBypass: PChar;
                      dwFlags: DWORD): HINTERNET; stdcall;

Автоматизация создание BackUp-ов проектов.

Оформил: DeeCo

Автор: ReNoiZer.

Пример использования:

@echo Off
echo ---------------------------
echo   RNZ prj. BackUp batch
echo ---------------------------
@echo On
set tmpName=MyProject_src
set backupDir=_BackUp\D6\Prj\MyProject
start /w winrar a -r -y -ag_YYMMDD_HHMM -x.\Data\*.* -x@.\xlist.lst "%temp%\%tmpName%" %1
mkdir "..\_sources"
mkdir C:\"%backupDir%"
mkdir D:\"%backupDir%"
mkdir E:\"%backupDir%"
mkdir \\"MyNetDir\%backupDir%"
copy /y "%temp%\%tmpName%*.rar" "..\_sources"
copy /y "%temp%\%tmpName%*.rar" C:\"%backupDir%"
copy /y "%temp%\%tmpName%*.rar" D:\"%backupDir%"
copy /y "%temp%\%tmpName%*.rar" E:\"%backupDir%"
copy /y "%temp%\%tmpName%*.rar" \\"MyNetDir\%backupDir%"
del "%temp%\%tmpName%*.rar"
rem start "..\_sources"
rem start C:\"%backupDir%"
rem start D:\"%backupDir%"
rem start E:\"%backupDir%"
rem start \\"MyNetDir\%backupDir%"
set tmpName=
set backupDir=

BackUp.CMD и xlist.lst копируем в директорию(каталог, папку) с проектом, xlist.lst содержит список исключений и может иметь примерно следующий вид:

Файл xlist.lst.

~*.*
*.~*
*.rar
*.bak
*.dcu
*.res
*.exe
_qsq*.*

Интерфейс присоединения Drag-and-Dock.

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

type
  TStartDockEvent = procedure(Sender: TObject;
    var DragObject: TDragDockObject) of object;
  TEndDragEvent = procedure(Sender, Target: TObject;
    X, Y: Integer) of object;

Док тоже извещается о событиях во время переноса:

type
  TGetSitelnfoEvent = procedure(Sender: TObject; DockClient: TControl;
    var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean) of object;
  TDockOverEvent = procedure(Sender: TObject; Source: TDragDockObject;
    X, Y: Integer; State: TDragState; var Accept: Boolean) of object;
  TDockDropEvent = procedure(Sender: TObject;
    Source: TDragDockObject; X, Y: Integer) of object;
  TUnDockEvent = procedure(Sender: TObject; Client: TControl;
    NewTarget: TWinControl; var Allow: Boolean) of object;

Как только пользователь нажал кнопку мыши над переносимым компонентом и начал сдвигать его с места, всем потенциальным докам (компонентам, свойство которых Docksite установлено в True) рассылается событие onGetsiteinfo. С ним передаются параметры: кто хочет "приземлиться" (параметр Dockclient) и где (MousePos). В ответ док должен сообщить решение, принимает он компонент (параметр CanDock) и предоставляемый прямоугольник (infiuenceRect) или нет. При помощи этого события можно принимать только определенные элементы управления, как показано в примере:

procedure TForml.Раnе11GеtSitе1nfо(Sender: TObject; DockClient: TControl;
  var InfiuenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);
begin
  if DockClient is TBitBtn then
    CanDock := False;
end;

Между доком и содержащимися на нем элементами управления есть двусторонняя связь. Все "припаркованные" элементы управления содержатся в векторном свойстве Dockclients, а их количество можно узнать из свойства.

DockClientCount:
s: = ' ';
for i := 0 to Panell.DockClientCount - 1 do
  AppendStr(s, Panell.DockClients[i].Name + #0$D#0$A);
ShowMessage(s);

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

procedure TMyForm.ButtonlEndDock(Sender, Target: TObject; X, Y: Integer);
begin
  (Sender as TControl).HostDockSite.SetTextBuf(pChar((Sender as TControl).Name));
end;

Компоненты можно не только переносить с одного дока на другой, но и отпускать в любом месте. Хотя сам по себе компонент TControl и его потомки не являются окнами Windows, но специально для этого случая создается окно-носитель. Свойство FloatingDockSiteClass как раз и определяет класс создаваемого окна. По умолчанию для большинства компонентов значение этого свойства равно TCustomDockForm. Это — форма, которая обладает свойствами дока и создается в момент отпускания элемента управления вне других доков. Внешне она ничем не отличается от обычной стандартной формы. Если вы хотите, чтобы ваша плавающая панель инструментов выглядела по- особенному, нужно породить потомка от класса TCustomDockForm и связать свойство FloatingDockSiteCiass с этим порожденным классом:

TMyCustomFloatingForm = class(TCustomDockForm)
public
  constructor Create(AOwner: TComponent); override;
end;
constructor TMyCustomFloatingForm.Create(AOwner: TComponent};
begin
  inherited Create(AOwner);
  BorderStyle := bsNone;
end;
procedure TForml.FormCreate(Sender: TObject);
begin
  ToolBarl.FioatingDockSiteCiass := TMyCustomFloatingForm;
end;

Переносить компоненты можно не только с помощью мыши, но и программно. Для этого есть пара методов ManualDock и ManualFioat. В приводимом ниже примере нажатие кнопки с именем BitBtnl переносит форму custForm на док MainForm.Paneil и размещает ее по всей доступной площади (параметр выравнивания alclient). Нажатие кнопки BitBtn2 снимает эту форму с дока и выравнивает ее по центру экрана. В свойствах UndockHeight и undockwidth хранятся высота и ширина элемента управления на момент, предшествующий помещению на док:

procedure TMainForm.BitBtnlClick(Sender: TObject);
begin
  GustForm.ManualDock(MainForm.Pane11, nil, alClient);
end;
procedure TMainForm.BitBtn2Click(Sender: TObject);
begin
  with CustForm do
  begin
    ManualFloat(Rect((Screen.Width - UndockWidth) div 2,
      (Screen.Height - UndockHeight) div 2, (Screen.Width + UndockWidth) div 2,
      (Screen.Height + UndockHeight) div 2));
  end;
end;

Полное рассмотрение внутреннего устройства механизмов Drag-and-Dock потребовало бы расширения объема этой главы. Тем, кто хочет использовать их на все 100%, рекомендуем обратиться к свойствам useDockManager и DockManager. Последнее представляет собой СОМ-интерфейс, позволяющий расширить возможности дока, вплоть до записи его состояния в поток (класс TStream).

Примеры использования Drag and Drop для различных визуальных компонентов.

Проще всего делать Drag из тех компонентов, для которых однозначно ясно, что именно перетаскивать. Для этого устанавливаем у источника DragMode = dmAutomatic, а у приемника пишем обработчики событий OnDragOver - разрешение на прием, и OnDragDrop - действия, производимые при окончании перетаскивания.

procedure TForm1.StringGrid2DragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
begin
  Accept := Source = Edit1;
  // разрешено перетаскивание только из Edit1,
  // при работе программы меняется курсор
end;
procedure TForm1.StringGrid2DragDrop(Sender, Source: TObject; X,
  Y: Integer);
var
  ACol, ARow: Integer;
begin
  StringGrid2.MouseToCell(X, Y, ACol, ARow);
  // находим, над какой ячейкой произвели Drop
  StringGrid2.Cells[Acol, Arow] := Edit1.Text;
  //  записываем в нее содержимое Edit1
end;

Теперь рассмотрим копирование в упорядоченный список ListBox1 из другого списка. В OnDragOver проверяем, выбран ли хоть один элемент в источнике:

Accept := (Source = ListBox2) and (ListBox2.ItemIndex >= 0);

for i := 0 to ListBox2.Items.Count - 1 do
  if (ListBox2.Selected[i]) and (ListBox1.Items.IndexOf(ListBox2.Items[i]) < 0) then
    ListBox1.Items.Add(ListBox2.Items[i]);

Для ListBox2 реализуем перенос строк из ListBox1 и перестановку элементов в желаемом порядке. В OnDragOver разрешаем Drag из любого ListBox:

Accept := (Source is TListBox) and ((Source as TListBox).ItemIndex >= 0);

А OnDragDrop будет выглядеть так:

var
  s: string;
begin
  if Source = ListBox1 then
  begin
    ListBox2.Items.Add(ListBox1.Items[ListBox1.ItemIndex]);
    ListBox1.Items.Delete(ListBox1.ItemIndex);
    //удаляем перенесенный элемент
  end
  else //внутренняя перестановка
  begin
    s := ListBox2.Items[ListBox2.ItemIndex];
    ListBox2.Items.Delete(ListBox2.ItemIndex);
    ListBox2.Items.Insert(ListBox2.ItemAtPos(Point(X, Y), False), s);
    //находим, в какую позицию переносить и вставляем
  end;
end;

Научимся переносить текст в Memo, вставляя его в нужное место. Поскольку я выбрал в качестве источника любой из ListBox, подключим в Инспекторе Объектов для OnDragOver уже написанный ранее обработчик ListBox2DragOver, а в OnDragDrop напишем.

if not CheckBox1.Checked then // при включении добавляется в конец текста
begin
  Memo1.SelStart := LoWord(Memo1.Perform(EM_CHARFROMPOS, 0, MakeLParam(X, Y)));
  // устанавливаем позицию вставки согласно координатам мыши
  Memo1.SelText := TListBox(Source).Items[TListBox(Source).ItemIndex];
end
else
  memo1.lines.add(TListBox(Source).Items[TListBox(Source).ItemIndex]);

Замечу, что для RichEdit EM_CHARFROMPOS работает несколько иначе, что продемонстрировано в следующем примере. Перенос из Memo реализован с помощью правой кнопки мыши, для того, чтобы не изменять стандартное поведение Memo, и поскольку нажатие левой кнопки снимает выделение. Для Memo1 установлено DragMode = dmManual, а перетаскивание инициируется в OnMouseDown.

if (Button = mbRight) and (Memo1.SelLength > 0) then
  Memo1.BeginDrag(True);

Обработчик RichEdit1DragOver очевиден, а в RichEdit1DragDrop пишем.

var
  p: tpoint;
begin
  if not CheckBox1.Checked then
  begin
    p := point(x, y);
    RichEdit1.SelStart := RichEdit1.Perform(EM_CHARFROMPOS, 0, Integer(@P));
    RichEdit1.SelText := Memo1.SelText;
  end
  else
    RichEdit1.Lines.Add(Memo1.SelText);
end;

Рассмотрим теперь перетаскивание в ListView1 (ViewStyle = vsReport). В OnDragOver разрешим прием из ListBox2 и из себя же:

Accept := ((Source = ListBox2) and (ListBox2.ItemIndex >= 0)) or (Source = Sender);

А вот OnDragDrop теперь будет посложнее.

var
  Item, CurItem: TListItem;
begin
  if Source = ListBox2 then
  begin
    Item := ListView1.DropTarget;
    if Item <> nil then
      //  случай перетаскивания на Caption
      if Item.SubItems.Count = 0 then
        Item.SubItems.Add(ListBox2.Items[ListBox2.ItemIndex])
          //  добавляем SubItem, если их еще нет
      else
        Item.SubItems[0] := ListBox2.Items[ListBox2.ItemIndex]
          //  иначе заменяем имеющийся SubItem
    else
    begin
      // при перетаскивании на пустое место создаем новый элемент
      Item := ListView1.Items.Add;
      Item.Caption := ListBox2.Items[ListBox2.ItemIndex];
    end;
  end
  else // случай внутренней перестановки
  begin
    CurItem := ListView1.Selected;
    // запомним выбранный элемент
    Item := ListView1.GetItemAt(x, y);
    // другой метод определения элемента на который делаем Drop
    if Item <> nil then
      Item := ListView1.Items.Insert(Item.Index)
        // вставляем новый элемент перед найденным
    else
      Item := ListView1.Items.Add;
    // или добавляем новый элемент в конец
    Item.Assign(CurItem);
    // копируем исходный в новый
    CurItem.Free;
    // уничтожаем исходный
  end;
end;

Для ListView2 установим ViewStyle = vsSmallIcon и покажем, как вручную расставлять значки. В OnDragOver зададим условие.

Accept := (Sender = Source) and ([htOnLabel, htOnItem, htOnIcon] *
  ListView2.GetHitTestInfoAt(x, y) = []);
// пересечение множеств должно быть пустым - запрещаем накладывать элементы

А код в OnDragDrop очень простой:

ListView2.Selected.SetPosition(Point(X, Y));

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

var
  Node, SelNode: TTreeNode;
begin
  Node := TreeView1.GetNodeAt(x, y);
  // находим узел-приемник
  Accept := (Sender = Source) and (Node <> nil);
  if not Accept then
    Exit;
  SelNode := Treeview1.Selected;
  while (Node.Parent <> nil) and (Node <> SelNode) do
  begin
    Node := Node.Parent;
    if Node = SelNode then
      Accept := False;
  end;

Код OnDragDrop выглядит так:

var
  Node, SelNode: TTreeNode;
begin
  Node := TreeView1.GetNodeAt(X, Y);
  if Node = nil then
    Exit;
  SelNode := TreeView1.Selected;
  SelNode.MoveTo(Node, naAddChild);
  // все уже встроено в TreeView
end;

Теперь разрешим перенос в TreeView2 из TreeView1.

Accept := (Source = TreeView1) and (TreeView2.GetNodeAt(x, y) <> nil);

И в OnDragDrop копируем выбранную в TreeView1 ветвь во всеми подветвями, для чего придется сделать рекурсивный обход:

var
  Node: TTreeNode;
procedure CopyNode(FromNode, ToNode: TTreeNode);
var
  TempNode: TTreeNode;
  i: integer;
begin
  TempNode := TreeView2.Items.AddChild(ToNode, '');
  TempNode.Assign(FromNode);
  for i := 0 to FromNode.Count - 1 do
    CopyNode(FromNode.Item[i], TempNode);
end;
begin
  Node := TreeView2.GetNodeAt(X, Y);
  if Node = nil then
    Exit;
  CopyNode(TreeView1.Selected, Node);
end;

Рассмотрим теперь перенос ячеек в StringGrid1. Поскольку, как и в случае с Memo, простое нажатие левой кнопки занято под другие действия, установим DragMode = dmManual и будем запускать Drag при нажатии левой кнопки, удерживая клавиши Alt или Ctrl. Запишем в OnMouseDown:

var
  Acol, ARow: Integer;
begin
  with StringGrid1 do
    if (ssAlt in Shift) or (ssCtrl in Shift) then
    begin
      MouseToCell(X, Y, Acol, Arow);
      if (Acol >= FixedCols) and (Arow >= FixedRows) then
        // не будем перетаскивать из фиксированных ячеек
      begin
        if ssAlt in Shift then
          Tag := 1
        else if ssCtrl in Shift then
          Tag := 2;
        // запомним что нажато - Alt или Ctrl -  в Tag StringGrid1
        BeginDrag(True)
      end
      else
        Tag := 0;
    end;
end;

Код OnDragOver учитывает также возможность перетаскивания из StringGrid2 (описание ниже).

var
  Acol, ARow: Integer;
begin
  with StringGrid1 do
  begin
    MouseToCell(X, Y, Acol, Arow);
    Accept := (Acol >= FixedCols) and (Arow >= FixedRows)
      and (((Source = StringGrid1) and (Tag > 0))
      or (Source = StringGrid2));
  end;

Часть OnDragDrop, относящаяся к внутреннему переносу:

var
  ACol, ARow, c, r: Integer;
  GR: TGridRect;
begin
  StringGrid1.MouseToCell(X, Y, ACol, ARow);
  if Source = StringGrid1 then
    with StringGrid1 do
    begin
      Cells[Acol, Arow] := Cells[Col, Row];
      //копируем ячейку-источник в приемник
      if Tag = 1 then
        Cells[Col, Row] := '';
      // очищаем источник, если было нажато Alt
      Tag := 0;
    end;

А вот из StringGrid2 сделаем перенос выбранного диапазона ячеек с помощью правой кнопки, для этого в OnMouseDown.

if Button = mbRight then
  StringGrid2.BeginDrag(True);

И теперь часть StringGrid1DragDrop, относящаяся к переносу из StringGrid2:

if Source = StringGrid2 then
begin
  GR := StringGrid2.Selection;
  // Selection - выделенные в StringGrid2 ячейки
  for r := 0 to GR.Bottom - GR.Top do
    for c := 0 to GR.Right - GR.Left do
      if (ACol + c < StringGrid1.ColCount) and
        (ARow + r < StringGrid1.RowCount) then
        // застра***мся от записи вне StringGrid1
        StringGrid1.Cells[ACol + c, ARow + r] :=
          StringGrid2.Cells[c + GR.Left, r + GR.Top];
end;

Теперь покажем, как этот диапазон ячеек из StringGrid2 перенести в Memo2. Для этого в OnDragOver Memo2 пишем:

Accept := (Source = StringGrid2) or (Source = DBGrid1);

И в OnDragDrop Memo2:

var
  c, r: integer;
  s: string;
begin
  Memo2.Clear;
  if Source = StringGrid2 then
    with StringGrid2 do
      for r := Selection.Top to Selection.Bottom do
      begin
        s := '';
        for c := Selection.Left to Selection.Right do
          s := s + Cells[c, r] + #9;
        // разделим ячейки табуляцией
        memo2.lines.add(s);
      end

Кроме того, в Memo2 можно переносить выбранную запись из DBGrid1, у которого установлено в Options dgRowSelect = True. В сетке отображается таблица из стандартной поставки Delphi DBDEMOS - Animals.dbf. Перетаскивание осуществляется аналогично StringGrid2, правой кнопкой мыши, только по событию OnMouseMove.

if ssRight in Shift then
  DBGrid1.BeginDrag(true);

Код в Memo2DragDrop, относящийся к переносу из DBGrid1:

else
  with DBGrid1.DataSource.DataSet do
  begin
    s := '';
    for c := 0 to FieldCount - 1 do
      s := s + Fields[c].AsString + ' | ';
    memo2.lines.add(s);
  end;
  // в случае dgRowSelect = False для переноса одного поля достаточно сделать
  // memo2.lines.add(DbGrid1.SelectedField.AsString);

Drag из DBGrid1 принимается также на Panel3, условие приема очевидно, а OnDragDrop выглядит так:

Panel3.Height := 300; // раскрываем панель
Image1.visible := True;
OleContainer1.Visible := false;
Image1.Picture.Assign(DBGrid1.DataSource.DataSet.FieldByName('BMP'));
// показываем графическое поле текущей записи таблицы

Теперь покажу, как можно передвигать мышью визуальные компоненты в Run-Time. Для Panel1 установим DragMode = dmAutomatic, в OnDragOver формы пишем:

var
  Ct: TControl;
begin
  Ct := ControlAtPos(Point(X + Panel1.Width, Y + Panel1.Height), True, True);
  // для упрощения проверяем перекрытие с другими контролами только правого нижнего угла
  Accept := (Source = Panel1) and ((Ct = nil) or (Ct = Panel1));

И в OnDragDrop формы очень просто.

Panel1.Left := X;
Panel1.Top := Y;

Другой метод перетаскивания можно встретить в каждом FAQ по Delphi:

procedure TForm1.Panel2MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
const
  SC_DragMove = $F012;
begin
  ReleaseCapture;
  Panel2.Perform(WM_SysCommand, SC_DragMove, 0);
end;

И в завершение реализация популярной задачи перетаскивания значков файлов на форму из Проводника. Для этого следует описать обработчик сообщения WM_DROPFILES.

private
  procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;

DragAcceptFiles(Handle, true);

И в OnDestroy отключить его.

DragAcceptFiles(Handle, False);

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

procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
const
  maxlen = 254;
var
  h: THandle;
  //i,num:integer;
  pchr: array[0..maxlen] of char;
  fname: string;
begin
  h := Msg.Drop;
  // дана реализация для одного файла, а
  //если предполагается принимать группу файлов, то можно добавить:
  //num:=DragQueryFile(h,Dword(-1),nil,0);
  //for i:=0 to num-1 do begin
  //  DragQueryFile(h,i,pchr,maxlen);
  //...обработка каждого
  //end;
  DragQueryFile(h, 0, pchr, maxlen);
  fname := string(pchr);
  if lowercase(extractfileext(fname)) = '.bmp' then
  begin
    Image1.visible := True;
    OleContainer1.Visible := false;
    image1.Picture.LoadFromFile(fname);
    Panel3.Height := 300;
  end
  else if lowercase(extractfileext(fname)) = '.doc' then
  begin
    Image1.visible := False;
    OleContainer1.Visible := True;
    OleContainer1.CreateObjectFromFile(fname, false);
    Panel3.Height := 300;
  end
  else if lowercase(extractfileext(fname)) = '.htm' then
    ShellExecute(0, nil, pchr, nil, nil, 0)
  else if lowercase(extractfileext(fname)) = '.txt' then
    Memo2.Lines.LoadFromFile(fname)
  else
    Memo2.Lines.Add(fname);
  DragFinish(h);
end;

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

Drag and Drop из TScrollBox.

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

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

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

Интерфейс переноса Drag-and-Drop.

Любой элемент управления из Палитры компонентов Delphi является источником в механизме Drag-and-Drop. Его поведение на начальном этапе переноса зависит от значения свойства.

type TDragMode = (dmManual, dmAutomatic);
property DragMode: TDragMode;

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

procedure BeginDrag(Immediate: Boolean; Threshold: Integer = -1);

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

property DragCursor: TCursor;

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

procedure DragOver(Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);

Если параметр Accept получает значение True, то данный компонент становится приемником. Источник переноса определяется параметром source. Через этот параметр разработчик получает доступ к свойствам и методам источника. Текущее положение курсора задают параметры X и Y. Параметр state возвращает информацию о характере движения мыши:

type TDragState = (dsDragEnter, dsDragLeave, dsDragMove);

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

type TDragDropEvent = procedure(Sender, Source: TObject;
    X, Y: Integer) of object;
property OnDragDrop: TDragDropEvent;

При завершении переноса элемент управления — источник — получает соответствующее сообщение, которое обрабатывается методом.

type TEndDragEvent = procedure(Sender, Target: TObject;
    X, Y: Integer) of object;
property OnEndDrag: TEndDragEvent;

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

procedure EndDrag(Drop: Boolean); 

Листинг 27.1. Секция implementation модуля главной формы проекта DemoDragDrop.

implementation
{$R *.DFM}
procedure TMainForm.EditlMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, У: Integer);
begin
  if Button = mbLeft then
    TEdit(Sender).BeginDrag(True);
end;
procedure TMainForm.Edit2DragOver(Sender, Source: TObject;
  X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
  if Source is TEdit then
    Accept := True
  else
    Accept := False;
end;
procedure TMainForm.Edit2DragDrop(Sender, Source: TObject;
  X, Y: Integer);
begin
  TEdit(Sender).Text := TEdit(Source).Text;
  TEdit(Sender).SetFocus;
  TEdit(Sender).SelectAll;
end;
procedure TMainForm.EditlEndDrag(Sender, Target: TObject;
  X, Y: Integer);
begin
  if Assigned(Target) then
    TEdit(Sender).Text := 'Текст перенесен в ' + TEdit(Target).Name;
end;
procedure TMainForm.FormDragOver(Sender, Source: TObject;
  X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
  if Source.ClassName = 'TPanel' then
    Accept := True
  else
    Accept := False;
end;
procedure TMainForm.FormDragDrop(Sender, Source: TObject;
  X, Y: Integer);
begin
  TPanel(Source).Left := X;
  TPanel(Source).Top := Y;
end;
end.

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

Drag and Drop для TListBox на примере двойного списка.

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

procedure TfrDualList.ListDragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
var
  DragIndex: integer;
begin
  // из другого листбокса принимаем всегда
  if Source <> Sender then
    Accept := true
      // а если это мы сами - надо проверить возможность изменения порядка
    // в списке и позицию сбрасывания
  else
    with (Sender as TListBox) do
    begin
      Accept := False;
      if not Sorted and ((SelCount = 1) or (not MultiSelect)) then
      begin
        DragIndex := ItemAtPos(Point(X, Y), True);
        if (DragIndex >= 0) and (DragIndex <> ItemIndex) then
          Accept := True; // попали внутрь видимого списка
      end;
    end;
  // установка изображения курсора
  if State = dsDragLeave then
    (Source as TListBox).DragCursor := crDrag;
  if (State = dsDragEnter) and ((Source as TListBox).SelCount > 1) then
    (Source as TListBox).DragCursor := crMultiDrag;
end;
procedure TfrDualList.ListDragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  if Source <> Sender then // перемещаем элементы из другого листбокса
    MoveItems(TListBox(Source), TListBox(Sender))
  else
    BoxMoveSel(TListBox(Sender), // перемещаем элемент внутри списка
      TListBox(Sender).ItemAtPos(Point(X, Y), True));
end;

Drag and Drop из RichEdit.

 var
   Form1: TForm1;
   richcopy: string;
   transfering: boolean;
 implementation
 {$R *.DFM\}
 procedure TForm1.RichEdit1MouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
  if length(richedit1.seltext)>0 then begin
   richcopy:=richedit1.seltext;
   transfering:=true;
  end; //seltext
 end;
 procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
   Y: Integer);
 begin
  if transfering then begin
   transfering:=false;
   listbox1.items.add(richcopy);
  end; //transfering
 end;

Drag and Drop TImage.

Вот рабочий пример. Расположите на форме панель побольше, скопируйте и измените приведенный код так, чтобы изображение загружалось из ВАШЕГО каталога Delphi.

procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  with Source as TImage do
  begin
    Left := X;
    Top := Y;
  end;
end;
procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := Source is TImage;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  with TImage.Create(Self) do
  begin
    Parent := Panel1;
    AutoSize := True;
    Picture.LoadFromFile('D:\DELPHI\IMAGES\CHIP.BMP');
    DragMode := dmAutomatic;
    OnDragOver := Panel1DragOver;
    OnDragDrop := Panel1DragDrop;
  end;
end;

Drag and Drop несколько элементов в TListView.

{ ListView1.DragMode := dmAutomatic } 
procedure TForm1.ListView1DragDrop(Sender, Source: TObject; X, Y: Integer); 
var 
  DragItem, DropItem, CurrentItem, NextItem: TListItem; 
begin 
  if Sender = Source then 
    with TListView(Sender) do 
    begin 
      DropItem    := GetItemAt(X, Y); 
      CurrentItem := Selected; 
      while CurrentItem <> nil do 
      begin 
        NextItem := GetNextItem(CurrentItem, SdAll, [IsSelected]); 
        if DropItem = nil then DragItem := Items.Add 
        else 
          DragItem := Items.Insert(DropItem.Index); 
        DragItem.Assign(CurrentItem); 
        CurrentItem.Free; 
        CurrentItem := NextItem; 
      end; 
    end; 
end; 
procedure TForm1.ListView1DragOver(Sender, Source: TObject; X, Y: Integer; 
  State: TDragState; 
  var Accept: Boolean); 
begin 
  Accept := Sender = ListView1; 
end;

Пример Drag and Drop между двумя DBGrid.

// Модуль MyDBGrid
unit MyDBGrid;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Grids, DBGrids;
type
  TMyDBGrid = class(TDBGrid)
  private
    { Private declarations }
    FOnMouseDown: TMouseEvent;
  protected
    { Protected declarations }
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
  published
    { Published declarations }
    property Row;
    property OnMouseDown read FOnMouseDown write FOnMouseDown;
  end;
procedure Register;
implementation
procedure TMyDBGrid.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseDown) then
    FOnMouseDown(Self, Button, Shift, X, Y);
  inherited MouseDown(Button, Shift, X, Y);
end;
procedure Register;
begin
  RegisterComponents('Samples', [TMyDBGrid]);
end;
end.
// Модуль GridU1
unit GridU1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Db, DBTables, Grids, DBGrids, MyDBGrid, StdCtrls;
type
  TForm1 = class(TForm)
    MyDBGrid1: TMyDBGrid;
    Table1: TTable;
    DataSource1: TDataSource;
    Table2: TTable;
    DataSource2: TDataSource;
    MyDBGrid2: TMyDBGrid;
    procedure MyDBGrid1MouseDown(Sender: TObject;
      Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure MyDBGrid1DragOver(Sender, Source: TObject;
      X, Y: Integer; State: TDragState; var Accept: Boolean);
    procedure MyDBGrid1DragDrop(Sender, Source: TObject;
      X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
var
  SGC: TGridCoord;
procedure TForm1.MyDBGrid1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  DG: TMyDBGrid;
begin
  DG := Sender as TMyDBGrid;
  SGC := DG.MouseCoord(X, Y);
  if (SGC.X > 0) and (SGC.Y > 0) then
    (Sender as TMyDBGrid).BeginDrag(False);
end;
procedure TForm1.MyDBGrid1DragOver(Sender, Source: TObject;
  X, Y: Integer; State: TDragState; var Accept: Boolean);
var
  GC: TGridCoord;
begin
  GC := (Sender as TMyDBGrid).MouseCoord(X, Y);
  Accept := Source is TMyDBGrid and (GC.X > 0) and (GC.Y > 0);
end;
procedure TForm1.MyDBGrid1DragDrop(Sender, Source: TObject;
  X, Y: Integer);
var
  DG: TMyDBGrid;
  GC: TGridCoord;
  CurRow: Integer;
begin
  DG := Sender as TMyDBGrid;
  GC := DG.MouseCoord(X, Y);
  with DG.DataSource.DataSet do
  begin
    with (Source as TMyDBGrid).DataSource.DataSet do
      Caption := 'Вы перетащили "' + Fields[SGC.X - 1].AsString + '"';
    DisableControls;
    CurRow := DG.Row;
    MoveBy(GC.Y - CurRow);
    Caption := Caption + ' в "' + Fields[GC.X - 1].AsString + '"';
    MoveBy(CurRow - GC.Y);
    EnableControls;
  end;
end;
end.
// Форма GridU1
object Form1: TForm1
  Left = 200
    Top = 108
    Width = 544
    Height = 437
    Caption = 'Form1'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    PixelsPerInch = 96
    TextHeight = 13
    object MyDBGrid1: TMyDBGrid
    Left = 8
      Top = 8
      Width = 521
      Height = 193
      DataSource = DataSource1
      Row = 1
      TabOrder = 0
      TitleFont.Charset = DEFAULT_CHARSET
      TitleFont.Color = clWindowText
      TitleFont.Height = -11
      TitleFont.Name = 'MS Sans Serif'
      TitleFont.Style = []
      OnDragDrop = MyDBGrid1DragDrop
      OnDragOver = MyDBGrid1DragOver
      OnMouseDown = MyDBGrid1MouseDown
  end
  object MyDBGrid2: TMyDBGrid
    Left = 7
      Top = 208
      Width = 521
      Height = 193
      DataSource = DataSource2
      Row = 1
      TabOrder = 1
      TitleFont.Charset = DEFAULT_CHARSET
      TitleFont.Color = clWindowText
      TitleFont.Height = -11
      TitleFont.Name = 'MS Sans Serif'
      TitleFont.Style = []
      OnDragDrop = MyDBGrid1DragDrop
      OnDragOver = MyDBGrid1DragOver
      OnMouseDown = MyDBGrid1MouseDown
  end
  object Table1: TTable
    Active = True
      DatabaseName = 'DBDEMOS'
      TableName = 'ORDERS'
      Left = 104
      Top = 48
  end
  object DataSource1: TDataSource
    DataSet = Table1
      Left = 136
      Top = 48
  end
  object Table2: TTable
    Active = True
      DatabaseName = 'DBDEMOS'
      TableName = 'CUSTOMER'
      Left = 104
      Top = 240
  end
  object DataSource2: TDataSource
    DataSet = Table2
      Left = 136
      Top = 240
  end
end

Drag and Drop - как использовать ItemAtPos для получения элемента DirListBox.

Просто сохраните результат функции ItematPos в переменной формы, и затем используйте эту переменную в обработчике ListBoxDragDrop. Пример:

FDragItem := ItematPos(X, Y, True);
if FDragItem >= 0 then
  BeginDrag(false);
...
procedure TForm1.ListBoxDragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  if Source is TDirectoryListBox then
    ListBox.Items.Add(TDirectoryListBox(Source).GetItemPath(FDragItem));
end;

Drag and Drop со списками.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
 This example shows how to drag&drop within a TListBox. 
 The Demo Program also shows how to implement an autoscroll-feature. 
 Dieses Beispiel zeigt, wie man drag & drop in einer TListBox realisiert. 
 Im Demo-Programm wird auch eine Autoscroll-Funktion gezeigt. 
}
 procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
   State: TDragState; var Accept: Boolean);
 begin
   Accept := Sender is TListBox;
 end;
 procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
 var
   iTemp: Integer;
   ptTemp: TPoint;
   szTemp: string;
 begin
   { change the x,y coordinates into a TPoint record }
   ptTemp.x := x;
   ptTemp.y := y;
   { Use a while loop instead of a for loop due to items possible being removed 
   from listboxes this prevents an out of bounds exception }
   iTemp := 0;
    while iTemp <= TListBox(Source).Items.Count-1 do
   begin
     { look for the selected items as these are the ones we wish to move }
     if TListBox(Source).selected[iTemp] then
     begin
       { use a with as to make code easier to read }
       with Sender as TListBox do
       begin
       { need to use a temporary variable as when the item is deleted the 
        indexing will change }
         szTemp := TListBox(Source).Items[iTemp];
         { delete the item that is being dragged  }
         TListBox(Source).Items.Delete(iTemp);
       { insert the item into the correct position in the listbox that it 
       was dropped on }
         Items.Insert(itemAtPos(ptTemp, True), szTemp);
       end;
     end;
     Inc(iTemp);
   end;
 end;

Как получить список файлов из Проводника.

Развлекался когда-то - вот, осталось:

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ShellAPI, Grids, StdCtrls;
type
  TForm1 = class(TForm)
    lb: TListBox;
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    procedure WMDropFiles(var M: TMessage); message WM_DROPFILES;
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
var
  CountFiles: integer;
  SizeName: integer;
  cch: integer;
var
  hDrop: integer;
  Point: TPoint;
  lpszFile: PChar;
{$R *.DFM}
procedure TForm1.WMDropFiles(var M: TMessage);
var
  i: integer;
begin
  hDrop := M.WParam;
  DragQueryPoint(hDrop, Point);
  CountFiles := DragQueryFile(hDrop, $FFFFFFFF, nil, cch);
  for i := 0 to CountFiles - 1 do
  begin
    SizeName := DragQueryFile(hDrop, i, nil, cch);
    GetMem(lpszFile, SizeName + 1);
    DragQueryFile(hDrop, i, lpszFile, SizeName + 1);
    lb.Items.Add(lpszFile);
    FreeMem(lpszFile, SizeName + 1);
  end;
  DragFinish(hDrop);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  DragAcceptFiles(Handle, True);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  lb.Items.Clear;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
  ShellAbout(Handle, 'Anton Saburov', 'APSystems', 0);
end;
end.

Перемещение из DbGrid.

Скопируйте код из данного "Совета", сохраните его с именем DBGrid.pas и установите компонент в палитру. У Вас появится новый компонент EDBGrid с двумя новыми событиями: OnMouseDown и OnMouseUp. Я не считаю эту информацию конфиденциальной: это ошибка разработчиков Delphi! На самом деле эти два события должны быть частью компонента DBGrid.

unit Dbgrid;
interface
uses
  DBGrids, Controls, Classes;
type
  TEDBGrid = class(TDBGrid)
  private
    FOnMouseDown: TMouseEvent;
    FOnMouseUp: TMouseEvent;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
      Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
      Integer); override;
  published
    property OnMouseDown: TMouseEvent read FOnMouseDown write
      FOnMouseDown;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
  end;
procedure Register;
implementation
procedure Register;
begin
  RegisterComponents('Data Controls', [TEDBGrid]);
end;
procedure TEDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if Assigned(FOnMouseDown) then
    FOnMouseDown(Self, Button, Shift, X, Y);
  inherited MouseDown(Button, Shift, X, Y);
end;
procedure TEDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  if Assigned(FOnMouseUp) then
    FOnMouseUp(Self, Button, Shift, X, Y);
  inherited MouseUp(Button, Shift, X, Y);
end;
end.

Drag and Drop c Win95 Explorer.

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs,
  ComCtrls;
type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure FileIsDropped(var Msg: TMessage); message WM_DropFiles;
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
uses
  shellapi;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
  DragAcceptFiles(Handle, True);
end;
procedure TForm1.FileIsDropped(var Msg: TMessage);
var
  hDrop: THandle;
  fName: array[0..254] of CHAR;
  NumberOfFiles: INTEGER;
  fCounter: INTEGER;
  Names: string;
begin
  hDrop := Msg.WParam;
  NumberOfFiles := DragQueryFile(hDrop, -1, fName, 254);
  Names := '';
  for fCounter := 1 to NumberOfFiles do
  begin
    DragQueryFile(hDrop, fCounter, fName, 254);
    // Здесь вы получаете один к одному имя вашего файла
    Names := Names + #13#10 + fName;
  end;
  ShowMessage('Бросаем ' + IntToStr(NumberOfFiles) + ' файла(ов) : ' + Names);
  DragFinish(hDrop);
end;
end.

Drag and Drop c Win95 Explorer 2.

Автор: Aleksey.

{Так можно заставить окно принимать файлы, перетаскиваемые из проводника}
{ОБЯЗАТЕЛЬНО ПОМЕСТИТЕ В СЕКЦИЮ PRIVATE СТРОКИ
procedure CreateParams(var Params: TCreateParams); override;
procedure WMDropFiles(var Message: TWMDropFiles); message WM_DROPFILES;
и не забудьте - ShellAPI поместить в uses}
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited
    CreateParams(Params);
  {сделаем окно способным принимать файлы}
  Params.ExStyle := Params.ExStyle or WS_EX_ACCEPTFILES;
end;
procedure TForm1.WMDropFiles(var Message: TWMDropFiles);
var
  aFile: array[0..255] of Char;
  //FilesCount : Integer;
begin
  inherited;
  {так можно узнать сколько файлов перетягивается}
  // FilesCount := DragQueryFile(Message.drop, $FFFFFFFF, nil, 0);
  begin
    {здесь можно поставить цикл открытия всех перетаскиваемых файлов
    for N := 0 to FilesCount - 1 do DragQueryFile(Message.drop, N, aFile, 256);
    а в данном случае открывается только первый файл в списке}
    DragQueryFile(Message.drop, 0, aFile, 256);
    Memo1.Lines.LoadFromFile(aFile);
  end;
  DragFinish(Message.Drop);
end;
procedure TForm1.FormCreate(Sender: TObject); {Form1.OnCreate}
begin
  {сделаем окно неравнодушным к пролетающим над ним файлам}
  DragAcceptFiles(Handle, True);
end;

Как перетаскивать (Drag and Drop) выделенный текст между компонентами Memo.

Данный способ позволяет не погружаясь глубоко в создание компонент осуществить операцию "drag and drop" выделенного текста.

Создайте новый компонент (TMyMemo), наследовав его от TMemo. И объявите его следующим образом:

type
  TMyMemo = class(TMemo)
  private
    FLastSelStart : Integer;
    FLastSelLength : Integer;
    procedure WMLButtonDown(var message: TWMLButtonDown); message WM_LBUTTONDOWN;
  published
    property LastSelStart : Integer read FLastSelStart write FLastSelStart;
    property LastSelLength : Integer read FLastSelLength write FLastSelLength;
end;

Добавьте обработчик WMLButtonDown:

procedure TMyMemo.WMLButtonDown(var message: TWMLButtonDown);
var
  Ch: Integer;
begin
  if SelLength > 0 then
  begin
    Ch := LoWord(Perform(EM_CHARFROMPOS, 0,
    MakeLParam(message.XPos, message.YPos)));
    LastSelStart := SelStart;
    LastSelLength := SelLength;
    if (Ch >= SelStart) and (Ch then
      BeginDrag(True)
    else
      inherited;
  end
  else
    inherited;
end;

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

procedure TForm1.MyMemo1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
  Accept := Source is TMyMemo;
end;

Так же для них необходимо сделать обработчики событий OnDragDrop:

procedure TForm1.MyMemo1DragDrop(Sender, Source: TObject;
X, Y: Integer);
var
  Dst, Src : TMyMemo;
  Ch : Integer;
  Temp : string;
begin
  Dst := Sender as TMyMemo;
  Src := Source as TMyMemo;
  Ch := LoWord(Dst.Perform(EM_CHARFROMPOS,0,MakeLParam(X,Y)));
  if (Src = Dst) and (Ch >= Src.LastSelStart) and
  (Ch then
    Exit;
  Dst.Text := Copy(Dst.Text,1,Ch)+Src.SelText+
  Copy(Dst.Text,Ch+1,Length(Dst.Text)-Ch);
  Temp := Src.Text;
  Delete(Temp,Src.LastSelStart+1,Src.LastSelLength);
  Src.Text := Temp;
end;

Запустите приложение, поместите в поля memo какой-нибудь текст, и посмотрите что произойдёт, если перетащить текст между полями.

Drag and Drop между двумя компонентами ListBox.

Вот пересмотренный OnDragDrop, использующий source (источник) и sender (передатчик) вместо DstList и SrcList. Теперь, если вы установили SrcList и DstList для использования тех же методов OnDragOver и OnDragDrop и создали обработчик события OnDragDrop, то для операции Drag and Drop вы можете использовать оба решения.

procedure TDualListDlg.DstListDragDrop(Sender, Source: TObject; X,
  Y: Integer);
var
  droppedOnIndex: integer;
  anItem: integer;
  numberOfItems: integer;
begin
  if (Sender is TListbox) and (Source is TListBox) then
  begin
    droppedOnIndex := TListBox(Sender).ItemAtPos(Point(X, Y), false);
    numberOfItems := TListBox(Source).SelCount;
    anItem := 0;
    while numberOfItems > 0 do
    begin
      if TListBox(Source).Selected[anItem] = true then
      begin
        TListBox(Sender).Items.Insert(droppedOnIndex,
          TListBox(Source).Items[anItem]);
        TListBox(Source).Items.Delete(anItem);
        TListBox(Source).Update;
        TListBox(Sender).Update;
        numberOfItems := numberOfItems - 1;
      end
      else
        anItem := anItem + 1;
    end;
  end;
end;

Для того, чтобы предотвратить операцию Drag and Drop с одним и тем же компонентом, используйте следующий код в обработчике события OnDragOver:

if (Sender is TListBox) and (Source is TListBox) then
begin
  if TListBox(Sender).Name = TListBox(Source).Name then
    Accept := False
  else
    Accept := true;
end;

Перетаскивание элементов управления c рамкой контура.

Начните со свеженькой формы. Бросьте на нее компонент Notebook и установите его свойство Align в alClient. Разработайте форму на первой странице компонента Notebook. Создайте вторую страницу в Notebook, поместите туда Paintbox и установите его свойство Align в alClient. Далее добавьте нижеследующие строчки в секцию Private вашей формы:

Img : TBitmap;
DragX, DragY, DragW, DragH, XOff, YOff : Integer;

В обработчике формы OnCreate:

Img := TBitmap.Create;

В общем, для всех перетаскиваемых компонентов, обработчике события OnMouseDown:

IF NOT (ssShift IN Shift) THEN Exit;
Img := GetFormImage;
Notebook1.PageIndex := 1;
WITH Sender AS TControl DO
BEGIN
DragW := Width;
DragH := Height;
XOff:= X;
YOff := Y;
BeginDrag(True);
END;

В общем, для всех перетаскиваемых компонентов, обработчике события EndDrag:

Notebook1.PageIndex := 0;
WITH Sender AS Tcontrol DO
BEGIN
Left := X-Xoff;
Top := Y-YOff;
END;

Поместите следующую строку в обработчик события OnPaint компонента PaintBox:

PaintBox1.Canvas.Draw(0, 0, Img);

И наконец, если вам еще это не надоело, поместите следующую строчку в обработчик OnDragOver компонента PaintBox:

IF (X=DragX) AND (Y=DragY) THEN Exit;
WITH PaintBox1.Canvas DO
BEGIN
DrawFocusRect(Bounds(DragX-XOff, DragY-YOff, DragW, DragH);
DragX := X; DragY := Y;
DrawFocusRect(Bounds(DragX-XOff, DragY-YOff, DragW, DragH);
END;

Начнем с самого начала. Причина того, что вы получаете курсор "crNoDrop" в том, что под курсором элемент управления не готов принять перетаскиваемый компонент. Чтобы исправить эту ситуацию, дважды щелкните (в Инспекторе Объектов) на событии формы или компонента OnDragOver и установите параметр Accept в, например так:

procedure TForm1.FormDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
  Accept := true ;
end;

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

FOR N := 0 TO ComponentCount-1 DO
  IF COmponents[N] IS TButton THEN
    IF IntersectRect(DummyRect, TControl(Components[N]).BoundsRect,
      (Bounds(X-XOff, Y-YOff, DragW, DragH)) >0 THEN
        Accept := False;

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

Drag and Drop с минимизированным приложением.

Вот некоторый код из моей программы, который с помощью компонента CheckBox проверяет возможность принятия перетаскиваемых файлов минимизированным приложением:

procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
{Вызывается только если TApplication НЕ получает drag/drop}
begin
  RecordDragDrop(Msg.Drop, False); {внутренняя функция}
  Msg.Result := 0;
end;
procedure TForm1.AppOnMessage(var Msg: TMsg; var Handled: Boolean);
{когда активно, получаем сообщения WM_DROPFILES, посылаемые
форме ИЛИ минимизированному приложению}
begin
  if Msg.message = WM_DROPFILES then
  begin
    RecordDragDrop(Msg.wParam, Msg.hWnd = Application.Handle);
    Handled := True;
  end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  DragAcceptFiles(Handle, True);
  DragAcceptFiles(Application.Handle, False);
  Application.OnMessage := nil;
end;

OK? Первоначально вызов DragAcceptFiles работает с дескриптором главной формы...

Рисование кривых по заданным точкам.

Здесь я использую процедуру рисования кривой Безье между двумя точками. Можно задать кривизну кривой(20-35 лучше всего). Можно задать число отрезков между соседними точками, а если в процедуре DrawSlice убрать коментарий со строки.

//  num_slices:=trunc(sqrt(sqr(p1.x-p2.x)+sqr(p1.y-p2.y)));

То число отрезков между соседними точками будет расчитываться автоматически, исходя из растояния между ними. Если потребуются дополнительные коментарии, пишите по адресу andrus78@mail.ru.

unit u_bezier;
interface
uses Windows, Graphics, SysUtils;
type TArrayPoint = array of TPoint; //массив точек
const num_slices: integer = 20; //число отрезков между двумя точками
  krivizna: integer = 30; //кривизна кривой (длина плеча направляющей)
procedure DrawBezier(acanv: TCanvas; var ArrPoint: TArrayPoint);
/////////////////////////////////////////////////////////////////////
implementation
uses unit1;
type
  TBezierPoint = record //точка Безье
    x, y: integer; //основной узел
    xl, yl, //левая контрольная точка
      xr, yr: single; //правая контрольная точка
  end;
  TArrayBezierPoint = array of TBezierPoint; //массив точек Безье
const grad_to_rad = pi / 180; //перевод градусов в радианы
  rad_to_grad = 180 / pi; //перевод радиан в градусы
  rad_90 = 90 * grad_to_rad; //90 градусов в радианах
  rad_180 = 180 * grad_to_rad; //180 градусов в радианах
  rad_270 = 270 * grad_to_rad; //270 градусов в радианах
  rad_360 = 360 * grad_to_rad; //360 градусов в радианах
var Canvas: TCanvas; //рабочий холст, на котором происходит рисование
//определить угол в радианах между точкой и положительным направлением оси х
function GetAngle(dx, dy: single): single;
begin
  if dx = 0 then begin
    if dy = 0 then Result := 0
    else if dy < 0 then Result := rad_270
    else Result := rad_90;
    exit
  end;
  Result := arctan(abs(dy) / abs(dx));
  if dy < 0 then
    if dx < 0 then Result := rad_180 + Result
    else Result := rad_360 - Result
  else
    if dx < 0 then Result := rad_180 - Result
end;
//определить направляющие линии к точке p
procedure GetCooPerpendikular(a, o, b: TPoint; var p: TBezierPoint);
var alfa, beta, gamma, dx, dy, angle_napr: single;
  l1, l2: single;
begin
  dx := a.x - o.x; dy := a.y - o.y;
  alfa := GetAngle(dx, dy);
  l1 := sqrt(dx * dx + dy * dy) * (krivizna / 100); //растояние oa
  dx := b.x - o.x; dy := b.y - o.y;
  beta := GetAngle(dx, dy);
  l2 := sqrt(dx * dx + dy * dy) * (krivizna / 100); //растояние ob
  gamma := (alfa + beta) / 2; //биссектриса угла aob
  if alfa > beta then angle_napr := gamma + rad_90
  else angle_napr := gamma - rad_90;
  p.xl := o.x + l1 * cos(angle_napr);
  p.yl := o.y + l1 * sin(angle_napr);
  p.xr := o.x + l2 * cos(angle_napr + rad_180);
  p.yr := o.y + l2 * sin(angle_napr + rad_180)
end;
//вычислить координаты точки, лежащей на участке кривой между
//двумя точками Безье в пределах от 0 до 1
procedure BezierValue(P1, P2: TBezierPoint; t: single; var X, Y: integer);
var t_sq, t_cb, r1, r2, r3, r4: single;
begin
  t_sq := t * t;
  t_cb := t * t_sq;
  r1 := (1 - 3 * t + 3 * t_sq - t_cb);
  r2 := (3 * t - 6 * t_sq + 3 * t_cb);
  r3 := (3 * t_sq - 3 * t_cb);
  r4 := (t_cb);
  X := round(r1 * p1.x + r2 * p1.xr + r3 * p2.xl + r4 * p2.x);
  Y := round(r1 * p1.y + r2 * p1.yr + r3 * p2.yl + r4 * p2.y)
end;
//рисуй участок кривой между двумя точками Безье
procedure DrawSlice(p1, p2: TBezierPoint);
var i: integer;
  x, y: integer;
  r1, r2: TRect;
begin
//  если убрать комментарий, то количество отрезков между соседними
//  точками будет расчитываться исходя из растояния между ними
//  num_slices:=trunc(sqrt(sqr(p1.x-p2.x)+sqr(p1.y-p2.y)));
  Canvas.MoveTo(p1.x, p1.y);
  for i := 1 to num_slices - 1 do begin
    BezierValue(p1, p2, i / num_slices, x, y);
    Canvas.LineTo(x, y)
  end;
  Canvas.LineTo(p2.x, p2.y)
end;
//рисуй кривую на холсте acanv по точкам массива ArrPoint
procedure DrawBezier(acanv: TCanvas; var ArrPoint: TArrayPoint);
var ArrBezPoint: TArrayBezierPoint;
  i, num_point: integer;
  a, o, b: TPoint;
begin
  Canvas := acanv;
  num_point := high(ArrPoint) + 1;
  SetLength(ArrBezPoint, num_point);
  for i := 0 to num_point - 1 do begin
    ArrBezPoint[i].x := ArrPoint[i].x;
    ArrBezPoint[i].y := ArrPoint[i].y;
  end;
  ArrBezPoint[0].xr := ArrPoint[0].x;
  ArrBezPoint[0].yr := ArrPoint[0].y;
  ArrBezPoint[0].xl := ArrPoint[0].x;
  ArrBezPoint[0].yl := ArrPoint[0].y;
  for i := 1 to num_point - 2 do begin
    a := ArrPoint[i - 1];
    o := ArrPoint[i];
    b := ArrPoint[i + 1];
    GetCooPerpendikular(a, o, b, ArrBezPoint[i])
  end;
  ArrBezPoint[num_point - 1].xr := ArrPoint[num_point - 1].x;
  ArrBezPoint[num_point - 1].yr := ArrPoint[num_point - 1].y;
  ArrBezPoint[num_point - 1].xl := ArrPoint[num_point - 1].x;
  ArrBezPoint[num_point - 1].yl := ArrPoint[num_point - 1].y;
  for i := 1 to num_point - 1 do
    DrawSlice(ArrBezPoint[i - 1], ArrBezPoint[i])
end;
end.
// *********************************** //
// использовать этот модуль можно так: //
// *********************************** //
procedure TForm1.Button2Click(Sender: TObject);
var ArrPoint: TArrayPoint;
begin
  SetLength(ArrPoint, 5);
  ArrPoint[0].x := random(200); ArrPoint[0].y := random(200);
  ArrPoint[1].x := random(200); ArrPoint[1].y := random(200);
  ArrPoint[2].x := random(200); ArrPoint[2].y := random(200);
  ArrPoint[3].x := random(200); ArrPoint[3].y := random(200);
  ArrPoint[4].x := random(200); ArrPoint[4].y := random(200);
  num_slices := 10;
  krivizna := 30;
  DrawBezier(Form1.Canvas, ArrPoint)
end;
// нужно не забыть включить модуль в список используемых:
// implementation
// uses u_bezier;

Рисование без мерцания.

Тем не менее, вы можете пропустить первую фазу, которая вызывает мерцание, одним из двух способов: первый способ заключается в том, что вы форсируете обновление сами, с помощью вызова функции Windows API InvalidateRect. На входе он получает дескриптор окна, указатель на закрашиваемую область - передаем NIL, если вы хотите отрисовать всю область окна - и третий параметр, сообщающий о необходимости очистки фона. Вот как раз последний параметр и должен содержать значение FALSE, если вы сами будете в методе Paint полностью отрисовывать всю область:

InvalidateRect( Handle, NIL, FALSE ) ;

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

ControlStyle := ControlStyle + [ csOpaque ] ;

Если вы хотите углубиться в тему дальше, то я отошлю вас к моей статье "Optimizing Display Updates in Delphi" (Оптимизация обновления экрана в Delphi), опубликованной в первом выпуске журнала "Delphi magazine".

Как вывести на Canvas надпись под углом.

{Create a rotated font based on the font object F}
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
var
  LF: TLogFont;
begin
  FillChar(LF, SizeOf(LF), #0);
  with LF do
  begin
    lfHeight := F.Height;
    lfWidth := 0;
    lfEscapement := Angle*10;
    lfOrientation := 0;
    if fsBold in F.Style then
      lfWeight := FW_BOLD
    else
      lfWeight := FW_NORMAL;
    lfItalic := Byte(fsItalic in F.Style);
    lfUnderline := Byte(fsUnderline in F.Style);
    lfStrikeOut := Byte(fsStrikeOut in F.Style);
    lfCharSet := DEFAULT_CHARSET;
    StrPCopy(lfFaceName, F.name);
    lfQuality := DEFAULT_QUALITY;
    {everything else as default}
    lfOutPrecision := OUT_DEFAULT_PRECIS;
    lfClipPrecision := CLIP_DEFAULT_PRECIS;
    case F.Pitch of
      fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
      fpFixed: lfPitchAndFamily := FIXED_PITCH;
      else
        lfPitchAndFamily := DEFAULT_PITCH;
    end;
  end;
  Result := CreateFontIndirect(LF);
end;
...
{create the rotated font}
if FontAngle <> 0 then
  Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle);
...

Вращаются только векторные шрифты.

Отрисовка стрелки с заданными параметрами.

Автор: Александр WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Отрисовка стрелки с заданными параметрами
// рисует стрелку с заданными параметрами
// X_Line, Y_Line - координаты "неподвижного" конца линии стрелки;
// Length_Line, Length_Arrow - длина линии и бокового ребра стрелки;
// Angle_Line, Angle_Arrow - углы между линией стрелки и горизонтальной
// осью и между линией стрелки и боковым ребром стрелки;
// IsAllTriangle - если True, то "подвижные" концы боковых рёбер стрелки
// соединяются отрезком прямой(и не рисуется высота равнобедренного треугольника стрелки);
// DrawSurface - поверхность на которой будет рисоваться стрелка
Зависимости: ничего неожиданного
Автор:       Александр
Copyright:   default
Дата:        14 февраля 2004 г.
***************************************************** }
procedure DrawArrow(X_Line, Y_Line, Length_Line, Length_Arrow: Integer;
  Angle_Line, Angle_Arrow: Extended;
  IsAllTriangle: Boolean; DrawSurface: TCanvas);
var
  XB, YB, XE, YE, XM, YM: Integer;
begin
  XB := Round(X_Line + Cos(Angle_Line) * Length_Line);
  YB := Round(Y_Line - Sin(Angle_Line) * Length_Line);
  XM := Round(XB - Cos(Angle_Arrow - Angle_Line) * Length_Arrow);
  YM := Round(YB - Sin(Angle_Arrow - Angle_Line) * Length_Arrow);
  XE := Round(XB + Sin(Angle_Arrow + Angle_Line - Pi / 2) * Length_Arrow);
  YE := Round(YB + Cos(Angle_Arrow + Angle_Line - Pi / 2) * Length_Arrow);
  DrawSurface.MoveTo(X_Line, Y_Line);
  if IsAllTriangle then
  begin
    DrawSurface.LineTo(Round((XM + XE) / 2), Round((YM + YE) / 2));
    DrawSurface.MoveTo(XB, YB);
  end
  else
    DrawSurface.LineTo(XB, YB);
  DrawSurface.LineTo(XM, YM);
  if IsAllTriangle then
    DrawSurface.LineTo(XE, YE)
  else
    DrawSurface.MoveTo(XE, YE);
  DrawSurface.LineTo(XB, YB)
end;

Как нарисовать кривую Безье.

Как нарисовать кривую Безье. Именно она применяется для построения гладких кривых во всех графических программах - от PaintBrush до CorelDraw и PhotoShop. Для задания кривой Безье n-ной степени (чем больше степень, тем более кривой может быть линия; кривая первой степени - отрезок) нужно указать n+1 точку. Первая и последняя точки будут началом и концом кривой, а остальные точки задаю ее поведение на других участках. В частности, первая и n-ая точки задают касательные и кривизну кривой на ее концах. В большинстве программ используются кривые Безье третьего порядка. Начиная с Delphi5 такую кривую можно нарисовать при помощи функции PolyBezier. Кривая Безье задается параметрически (x=x(t), y=y(t)). Это позволяет ей вести себя абсолютно произвольно. Если бы она задавалась, как y(x), она не смогла бы даже сделать поворот на 180 градусов. Функции x(t) и y(t) выглядят так: x(t)= Cn0 * t0 * (1-t)n * x0 + Cn1 * t1 * (1-t)n-1 * x1 + Cn2 * t2 * (1-t)n-2 * x2 + ... + Cnn * tn * (1-t)0 * xn y(t)= Cn0 * t0 * (1-t)n * y0 + Cn1 * t1 * (1-t)n-1 * y1 + Cn2 * t2 * (1-t)n-2 * y2 + ... + Cnn * tn * (1-t)0 * yn где n - порядок кривой, Cni - коэффициенты в разложении бинома Ньютона, t - параметр, меняющийся от 0 до 1, xi, yi - координаты опорных точек. Эта программа строит кривую Безье n-ного порядка. n задается в SpinEdit1. Все узлы можно перемещать по полю мышью. Для создания нового узла нужно нажать мышью на пустое место на поле или увеличить порядок кривой. Скачать необходимые для компиляции файлы проекта можно на http://program.dax.ru

uses Math;
const
  RectSize = 5;
  MaxN = 128;
var
  n: integer = -1;
  pt: array[0..MaxN] of TPoint;
  C: array[0..MaxN] of single;
  bm: TBitMap;
function GetBinomialCoefficient(m, i: integer): single;
  function Factorial(x: integer): double;
  var
    i: integer;
  begin
    result := 1;
    for i := 2 to x do
      result := result * i;
  end;
begin
  result := Factorial(m) / (Factorial(i) * Factorial(m - i));
end;
procedure DrawBezier(Canvas: TCanvas; Count: integer);
type
  TPointArray = array[word] of TPoint;
  PPointArray = ^TPointArray;
var
  p: PPointArray;
  Step, qx, qy, t, q: single;
  i, j: integer;
begin
  GetMem(p, sizeof(TPoint) * (Count + 1));
  Step := 1.0 / Count;
  for i := 0 to Count do
  begin
    t := i * Step;
    qx := 0;
    qy := 0;
    for j := 0 to n do
    begin
      q := C[j] * IntPower(1 - t, j) * IntPower(t, n - j);
      qx := qx + q * pt[j].x;
      qy := qy + q * pt[j].y;
    end;
    p[i] := Point(round(qx), round(qy));
  end;
  Canvas.Polyline(Slice(p^, Count + 1));
  FreeMem(p);
end;
procedure DrawLines(canvas: TCanvas; const pt: array of TPoint);
var
  i: integer;
begin
  Canvas.Pen.Color := clGreen;
  Canvas.Pen.Width := 1;
  Canvas.MoveTo(pt[0].x, pt[0].y);
  for i := 0 to n do
  begin
    Canvas.Rectangle(Bounds(pt[i].x - RectSize, pt[i].y - RectSize,
      2 * RectSize, 2 * RectSize));
    Canvas.LineTo(pt[i].x, pt[i].y);
  end;
end;
procedure Redraw;
begin
  with Form1.PaintBox1 do
  begin
    bm.Canvas.FillRect(Bounds(0, 0, Width, Height));
    if Form1.CheckBox1.Checked then
      DrawLines(bm.Canvas, pt);
    bm.Canvas.PolyBezier(pt);
    bm.Canvas.Pen.Color := clRed;
    bm.Canvas.pen.Width := Form1.SpinEdit3.Value;
    DrawBezier(bm.Canvas, Form1.SpinEdit2.Value);
    Canvas.Draw(0, 0, bm);
  end;
end;
var
  moving: integer = -1;
  oldr: TRect;
procedure FillRandom(NewN: integer);
var
  i: integer;
begin
  randomize;
  for i := n + 1 to NewN do
    pt[i] := Point(random(Form1.PaintBox1.Width - 20) + 10,
      random(Form1.PaintBox1.Height - 20) + 10);
  n := NewN;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  bm := TBitmap.Create;
  bm.Width := PaintBox1.Width;
  bm.Height := PaintBox1.height;
  SpinEdit1.MinValue := 1;
  SpinEdit1.MaxValue := MaxN;
  SpinEdit1.Value := 3;
  SpinEdit2.MinValue := 6;
  SpinEdit2.MaxValue := MaxN * 4;
  SpinEdit2.Value := 50;
  SpinEdit2.OnChange := PaintBox1.OnPaint;
  SpinEdit3.MinValue := 1;
  SpinEdit3.MaxValue := 8;
  SpinEdit3.Value := 3;
  SpinEdit3.OnChange := PaintBox1.OnPaint;
  CheckBox1.Checked := true;
  CheckBox1.OnClick := PaintBox1.OnPaint;
end;
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  i: integer;
  r: TRect;
begin
  if Button <> mbLeft then
    Exit;
  for i := 0 to n do
    if (abs(X - pt[i].x) <= RectSize) and (abs(Y - pt[i].y) <= RectSize) then
    begin
      moving := i;
      r.TopLeft := Form1.ClientToScreen(PaintBox1.BoundsRect.TopLeft);
      r.BottomRight := Form1.ClientToScreen(PaintBox1.BoundsRect.BottomRight);
      GetClipCursor(oldr);
      ClipCursor(@r);
      Exit;
    end;
  if moving < 0 then
  begin
    SpinEdit1.Value := SpinEdit1.Value + 1;
    pt[n] := Point(X, Y);
    Redraw;
  end;
end;
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
begin
  if moving < 0 then
    Exit;
  pt[moving] := Point(X, Y);
  Redraw;
end;
procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbLeft) and (moving >= 0) then
  begin
    moving := -1;
    ClipCursor(@oldr);
  end;
end;
procedure TForm1.SpinEdit1Change(Sender: TObject);
var
  i: integer;
begin
  FillRandom(SpinEdit1.Value);
  SpinEdit2.MinValue := n * 2;
  for i := 0 to n do
    C[i] := GetBinomialCoefficient(n, i);
  Redraw;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  Redraw;
end;

Отрисовка битового образца.

unit aplanes_;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
  sky, aplane: TBitMap; // битовые образы: небо и самолет
implementation
{$R *.DFM}
procedure TForm1.FormPaint(Sender: TObject);
begin
     // создать битовые образы
  sky := TBitMap.Create;
  aplane := TBitMap.Create;
     // загрузить картинки
  sky.LoadFromFile('sky.bmp');
  aplane.LoadFromFile('aplane.bmp');
  Form1.Canvas.Draw(0, 0, sky); // отрисовка фона
  Form1.Canvas.Draw(20, 20, aplane); // отрисовка левого самолета
  aplane.Transparent := True;
     // теперь элементы рисунка, цвет которых совпадает с цветом
     // левой нижней точки битового образа, не отрисовываются
  Form1.Canvas.Draw(120, 20, aplane); // отрисовка правого самолета
     // освободить память
  sky.free;
  aplane.free;
end;
end.

Программа рисует на форме календарь на 2002 год.

Скачать необходимые для компиляции файлы проекта можно на program.dax.ru

const year = 2002; // Год календаря
var months: array [1..12] of byte;
procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.Caption := 'Календарь на ' + IntToStr(year) + ' год';
  Form1.Color := clWhite;
  // Длины месяцев:
  months[1] := 31;
  months[2] := 28 + ord(IsLeapYear(year));
  months[3] := 31;
  months[4] := 30;
  months[5] := 31;
  months[6] := 30;
  months[7] := 31;
  months[8] := 31;
  months[9] := 30;
  months[10] := 31;
  months[11] := 30;
  months[12] := 31;
end;
procedure TForm1.FormPaint(Sender: TObject);
const // Настройки размеров календаря:
  MonthDX = 150;
  MonthDY = 135;
  DayDX = 20;
  DayDY = 15;
  MonthH = 20;
var
  month, i: integer;
  day: integer;
  s: string[2];
begin
  with Form1.Canvas do for month := 1 to 12 do begin
    // Вывод названия месяца:
    Font.Name := 'Times';
    Font.Size := 13;
    TextOut((month - 1) mod 3 * MonthDX, (month - 1) div 3 * MonthDY,
      LongMonthNames[month]);
    Font.Name := 'Courier';
    Font.Size := 8;
    // Вывод названий дней недели:
    for day := 1 to 7 do
      TextOut((month - 1) mod 3 * MonthDX,
        day mod 7 * DayDY + (month - 1) div 3 * MonthDY + MonthH,
        ShortDayNames[(day + 1) mod 7 + 1]);
    // Определение дня недели первого числа месяца:
    day := DayOfWeek(EncodeDate(year, month, 1)) - 2;
    if day < 0 then inc(day, 7);
    // Вывод чисел:
    for i := 1 to months[month] do begin
      str(i: 2, s);
      TextOut(day div 7 * DayDX + (month - 1) mod 3 * MonthDX + DayDX,
        day mod 7 * DayDY + (month - 1) div 3 * MonthDY + MonthH, s);
      inc(day);
    end;
  end;
end;

Выводим цветной текст на форме под любым углом.

Пример демонстрирует вывод теста случайным образом на форме под определённым углом. Добавляем в форму компонент TButton и в событие OnClick следующий код:

procedure TForm1.Button1Click(Sender: TObject);
var
  logfont: TLogFont;
  font: Thandle;
  count: integer;
begin
  LogFont.lfheight := 20;
  logfont.lfwidth := 20;
  logfont.lfweight := 750;
  LogFont.lfEscapement := -200;
  logfont.lfcharset := 1;
  logfont.lfoutprecision := out_tt_precis;
  logfont.lfquality := draft_quality;
  logfont.lfpitchandfamily := FF_Modern;
  font := createfontindirect(logfont);
  SelectObject(Form1.canvas.handle, font);
  SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
  SetBKmode(Form1.canvas.handle, transparent);
  for count := 1 to 10 do
  begin
    Canvas.TextOut(Random(form1.width), Random(form1.height), 'Delphi World');
    SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255), Random(255)));
  end;
  DeleteObject(font);
end;

Как вывести цветную надпись на StatusBare.

Статусбар, это стандартный элемент управления Windows и как все отображает шрифт, заданный в параметре clBtnText, который устанавливается через Панель управления. Поумолчанию этот цвет чёрный, но он может менятся в зависимоти пользовательской темы. StatusBar и связанные с ним панели имеют возможность самостоятельной перерисовки (owner-draw), позволяющей рисовать текст различными цветами. Для этого необходимо в TStatusBar.Panels установить свойство Style в OwnerDraw.

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
          Panel: TStatusPanel; const Rect: TRect);
begin
  if Panel = StatusBar.Panels[0] then
  begin
    StatusBar.Canvas.Font.Color := clRed;
    StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
  end
  else
  begin
    StatusBar.Canvas.Font.Color := clGreen;
    StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
  end;
end; 

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

{ 
  This tip might be useful if you want to program 
  a screen capture tool and show a bounding box 
  around a control or for a spy tool like winsight to 
  highlight a object on the screen. 
} 
var 
 hOldWnd :HWND; 
procedure FrameWindow(Wnd: HWnd); 
var 
  Rect: TRect; 
  DC: hDC; 
  OldPen, Pen: hPen; 
  OldBrush, Brush: hBrush; 
  X2, Y2: Integer; 
begin 
  { Get the target window's rect and DC } 
  GetWindowRect(Wnd, Rect); 
  DC := GetWindowDC(Wnd); 
  { Set ROP appropriately for highlighting } 
  SetROP2(DC, R2_NOT); 
  { Select brush and pen } 
  Pen := CreatePen(PS_InsideFrame, 4, 0); 
  OldPen := SelectObject(DC, Pen); 
  Brush := GetStockObject(Null_Brush); 
  OldBrush := SelectObject(DC, Brush); 
  { Set dimensions of highlight } 
  X2 := Rect.Right - Rect.Left; 
  Y2 := Rect.Bottom - Rect.Top; 
  { Draw highlight box } 
  Rectangle(DC, 0, 0, X2, Y2); 
  { Clean up } 
  SelectObject(DC, OldBrush); 
  SelectObject(DC, OldPen); 
  ReleaseDC(Wnd, DC); 
  { Do NOT delete the brush, because it was a stock object } 
  DeleteObject(Pen); 
end; 
procedure TForm1.Timer1Timer(Sender: TObject); 
var 
  hNewWnd: HWnd; 
begin 
  hNewWnd := WindowFromPoint(Mouse.CursorPos); 
  { To avoid flickering, remove the old frame ONLY if moved to new window } 
  if hNewWnd <> hOldWnd then 
  begin 
    if hOldWnd <> 0 then 
      FrameWindow(hOldWnd); 
    if hNewWnd <> 0 then 
      FrameWindow(hNewWnd); 
    hOldWnd := hNewWnd; 
  end; 
end;

Рисование КРИВЫХ в Delphi.

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

PBezierPoint = ^TBezierPoint;
TBezierPoint = record
  X, Y: double;   // основной узел
  Xl, Yl: double; // левая контрольная точка
  Xr, Yr: double; // правая контрольная точка
end;
// P1 и P2 - две точки TBezierPoint, расположенные между 0 и 1:
// когда t=0 X=P1.X, Y=P1.Y; когда t=1 X=P2.X, Y=P2.Y;
procedure BezierValue(P1, P2: TBezierPoint; t: double; var X, Y: double);
var
  t_sq, t_cb, r1, r2, r3, r4: double;
begin
  t_sq := t * t;
  t_cb := t * t_sq;
  r1 := (1 - 3 * t + 3 * t_sq - t_cb) * P1.X;
  r2 := (3 * t - 6 * t_sq + 3 * t_cb) * P1.Xr;
  r3 := (3 * t_sq - 3 * t_cb) * P2.Xl;
  r4 := (t_cb) * P2.X;
  X := r1 + r2 + r3 + r4;
  r1 := (1 - 3 * t + 3 * t_sq - t_cb) * P1.Y;
  r2 := (3 * t - 6 * t_sq + 3 * t_cb) * P1.Yr;
  r3 := (3 * t_sq - 3 * t_cb) * P2.Yl;
  r4 := (t_cb) * P2.Y;
  Y := r1 + r2 + r3 + r4;
end;

Для рисования кривой Безье разделяем интервал между P1 и P2 на несколько отрезков (их количество влияет на точность воспроизведения кривой, 3 - 4 точки вполне достаточно), затем в цикле создаем массив точек, используем описанную выше процедуру с параметром t от 0 до 1 и рисуем данный массив точек, используя функцию polyline().

Рисование КРИВЫХ в Delphi 2.

Тем не менее эта технология жива до сих пор и приносит свои плоды:

(********************************************************************)
(*                         GRAPHIX TOOLBOX 4.0                      *)
(*       Copyright (c) 1985, 87 by  Borland International, Inc.     *)
(********************************************************************)
unit GShell;
interface
{------------------------------ вырезано --------------------------}
procedure Bezier(A: PlotArray; MaxContrPoints: integer;
  var B: PlotArray; MaxIntPoints: integer);
implementation
{------------------------------ вырезано --------------------------}
procedure Bezier {(A : PlotArray; MaxContrPoints : integer;
var B : PlotArray; MaxIntPoints : integer)};
const
  MaxControlPoints = 25;
type
  CombiArray = array[0..MaxControlPoints] of Float;
var
  N: integer;
  ContrPoint, IntPoint: integer;
  T, SumX, SumY, Prod, DeltaT, Quot: Float;
  Combi: CombiArray;
begin
  MaxContrPoints := MaxContrPoints - 1;
  DeltaT := 1.0 / (MaxIntPoints - 1);
  Combi[0] := 1;
  Combi[MaxContrPoints] := 1;
  for N := 0 to MaxContrPoints - 2 do
    Combi[N + 1] := Combi[N] * (MaxContrPoints - N) / (N + 1);
  for IntPoint := 1 to MaxIntPoints do
  begin
    T := (IntPoint - 1) * DeltaT;
    if T <= 0.5 then
    begin
      Prod := 1.0 - T;
      Quot := Prod;
      for N := 1 to MaxContrPoints - 1 do
        Prod := Prod * Quot;
      Quot := T / Quot;
      SumX := A[MaxContrPoints + 1, 1];
      SumY := A[MaxContrPoints + 1, 2];
      for N := MaxContrPoints downto 1 do
      begin
        SumX := Combi[N - 1] * A[N, 1] + Quot * SumX;
        SumY := Combi[N - 1] * A[N, 2] + Quot * SumY;
      end;
    end
    else
    begin
      Prod := T;
      Quot := Prod;
      for N := 1 to MaxContrPoints - 1 do
        Prod := Prod * Quot;
      Quot := (1 - T) / Quot;
      SumX := A[1, 1];
      SumY := A[1, 2];
      for N := 1 to MaxContrPoints do
      begin
        SumX := Combi[N] * A[N + 1, 1] + Quot * SumX;
        SumY := Combi[N] * A[N + 1, 2] + Quot * SumY;
      end;
    end;
    B[IntPoint, 1] := SumX * Prod;
    B[IntPoint, 2] := SumY * Prod;
  end;
end; { Bezier }
end. { GShell }

Как вывести текст с красивым обрезанием если не помещается.

Используй вызов DrawTextEx, установив в параметре dwDTFormat значение DT_PATH_ELLIPSIS.

procedure TForm1.FormPaint(Sender: TObject);
var
  r: TRect;
begin
  r := Rect(20, 20, 110, 70);
  // DT_PATH_ELLIPSIS or DT_WORD_ELLIPSIS or DT_END_ELLIPSIS
  DrawTextEx(Form1.Canvas.Handle, 'Delphi World - это круто!!!',
   25, r, DT_WORD_ELLIPSIS, nil);
end;

Рисовать неактивный текст.

function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer;
  var Rect: TRect; Format: Word): Integer;
begin
  SetBkMode(Canvas.Handle, TRANSPARENT);
  OffsetRect(Rect, 1, 1);
  Canvas.Font.color := ClbtnHighlight;
  DrawText(Canvas.Handle, Str, Count, Rect, Format);
  Canvas.Font.Color := ClbtnShadow;
  OffsetRect(Rect, -1, -1);
  DrawText(Canvas.Handle, Str, Count, Rect, Format);
end;

Хочу прорисовать границу ячейки в Excel.

Cells[i,j].Borders.LineStyle := xlContinuous; 

Вывод шрифтов в списке в виде самих шрифтов.

unit Fontlist;
interface
uses
  Windows, Classes, Graphics, Forms, Controls, StdCtrls;
type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Label1: TLabel;
    FontLabel: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure DrawItem(Control: TWinControl; index: Integer; Rect: TRect;
      State: TOwnerDrawState);
    procedure ListBox1MeasureItem(Control: TWinControl; index: Integer;
      var Height: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
  Listbox1.Items := Screen.Fonts;
end;
procedure TForm1.ListBox1Click(Sender: TObject);
begin
  FontLabel.Caption := ListBox1.Items[ListBox1.ItemIndex];
end;
procedure TForm1.DrawItem(Control: TWinControl; index: Integer;
  Rect: TRect; State: TOwnerDrawState);
begin
  with ListBox1.Canvas do
  begin
    FillRect(Rect);
    Font.name := ListBox1.Items[index];
    Font.Size := 0; // use font's preferred size
    TextOut(Rect.Left+1, Rect.Top+1, ListBox1.Items[index]);
  end;
end;
procedure TForm1.ListBox1MeasureItem(Control: TWinControl; index: Integer;
  var Height: Integer);
begin
  with ListBox1.Canvas do
  begin
    Font.name := Listbox1.Items[index];
    Font.Size := 0; // use font's preferred size
    Height := TextHeight('Wg') + 2; // measure ascenders and descenders
  end;
end;
end.

Как нарисовать фрактал.

Автор: http://www.swissdelphicenter.ch

procedure DrawMandelbrot(ACanvas: TCanvas; X, Y, au, bu: Double; X2, Y2:
  Integer);
var
  c1, c2, z1, z2, tmp: Double;
  i, j, Count: Integer;
begin
  c2 := bu;
  for i := 10 to X2 do
  begin
    c1 := au;
    for j := 0 to Y2 do
    begin
      z1 := 0;
      z2 := 0;
      Count := 0;
      {count is deep of iteration of the mandelbrot set
       if |z| >=2 then z is not a member of a mandelset}
      while (((z1 * z1 + z2 * z2 < 4) and (Count <= 90))) do
      begin
        tmp := z1;
        z1 := z1 * z1 - z2 * z2 + c1;
        z2 := 2 * tmp * z2 + c2;
        Inc(Count);
      end;
      //the color-palette depends on TColor(n*count mod t)
{$IFDEF LINUX}
      ACanvas.Pen.Color := (16 * Count mod 255);
      ACanvas.DrawPoint(j, i);
{$ELSE}
      ACanvas.Pixels[j, i] := (16 * Count mod 255);
{$ENDIF}
      c1 := c1 + X;
    end;
    c2 := c2 + Y;
  end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
  R: TRect;
  au, ao: Integer;
  dX, dY, bo, bu: Double;
begin
  // Initialize Mandelbrot
  R.Left := 0;
  R.Right := 200;
  R.Top := 0;
  R.Bottom := 205;
  ao := 1;
  au := -2;
  bo := 1.5;
  bu := -1.5;
  //direct scaling cause of speed
  dX := (ao - au) / (R.Right - R.Left);
  dY := (bo - bu) / (R.Bottom - R.Top);
  DrawMandelbrot(Self.Canvas, dX, dY, au, bu, R.Right, R.Bottom);
end;

Как нарисовать график функции.

procedure TForm1.Button3Click(Sender: TObject);
var
  x, y: array[1..50] of double;
  i: integer;
  scalex, scaley, ymin, ymax, xmin, xmax: double;
begin
  for i := 1 to 50 do
  begin
    y[i] := sin(i * 0.5);
    x[i] := i;
  end;
  xmin := x[1];
  xmax := x[1];
  ymin := y[1];
  ymax := y[1];
  for i := 2 to 50 do
  begin // или используйте ymin:=MinValue(y); и т.д.
    if y[i] < ymin then
      ymin := y[i];
    if y[i] > ymax then
      ymax := y[i];
    if x[i] < xmin then
      xmin := x[i];
    if x[i] > xmax then
      xmax := x[i];
  end;
  scalex := paintbox1.Width / (xmax - xmin);
  scaley := paintbox1.Height / (ymax - ymin);
  with paintbox1.canvas do
  begin
    moveto(trunc(scalex * (x[1] - xmin)), paintbox1.height - trunc(scaley * (y[1]
      - ymin)));
    for i := 2 to 50 do
      Lineto(trunc(scalex * (x[i] - xmin)), paintbox1.height - trunc(scaley *
        (y[i] - ymin)));
  end;
end;

Как нарисовать график функции 2.

Забавная штука синусы:

for i := 1 to 500 do
  paintbox1.Canvas.Pixels[round(sin(i * 5) * 10 + 50), round(sin(i * 10) * 10 +
    50)] := RGB(0, 0, 0);

Рисование графов.

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

var
  x, l: Integer;
  y, a: Double;
begin
  Image1.Picture.Bitmap := TBitmap.Create;
  Image1.Picture.Bitmap.Width := Image1.Width;
  Image1.Picture.Bitmap.Height := Image1.Height; {Эти три строчки могут быть
  размещены в обработчике Form1.Create}
  l := Image1.Picture.Bitmap.Width;
  for x := 0 to l do
  begin
    a := (x / l) * 2 * Pi; {Преобразуем позицию по оси X к углу между 0 & 2Pi}
    y := Sin(a); {Ваша функция должна находиться здесь}
    y := y * (Image1.Picture.Bitmap.Height / 2); {Масштабируем по оси Y}
    y := y * -1; {Инвертируем Y, верх экрана это 0 !}
    y := y + (Image1.Picture.Bitmap.Height / 2);
      {Добавляем компенсацию для среднего 0}
    Image1.Picture.Bitmap.Canvas.Pixels[Trunc(x), Trunc(y)] := clBlack;
  end;
end;

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

Вывести полупрозрачный текст.

procedure TForm1.FormPaint(Sender: TObject);
var
  x, y: integer;
  bm: TBitMap;
begin
  Form1.ClientWidth := 200;
  Form1.ClientHeight := 100;
  randomize;
  for x := 0 to 199 do
    for y := 0 to 99 do
      if random(3) = 1 then
        Form1.Canvas.Pixels[x,y] := clGreen
      else
        Form1.Canvas.Pixels[x,y] := clLime;
  bm := TBitMap.Create;
  bm.Width := 200;
  bm.Height := 100;
  with bm.Canvas do
  begin
    Brush.Color := clGreen;
    FillRect(ClipRect);
    Font.name := 'Arial';
    Font.Size := 50;
    Font.Color := clGray;
    Font.Style := [fsBold];
    TextOut((bm.Width - TextWidth('Text')) div 2,
    (bm.Height - TextHeight('Text')) div 2, 'Text');
  end;
  Form1.Canvas.CopyMode := cmSrcPaint;
  Form1.Canvas.CopyRect(bm.Canvas.ClipRect, bm.Canvas,
  bm.Canvas.ClipRect);
  bm.Destroy;
end;

Рисование иконки в TImage.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

DrawIcon(Image1.Canvas.Handle, 0, 0, LoadCursor(0, IDC_ARROW));

Как рисовать картинки в пунктах меню (через OwnerDraw).

unit DN_Win;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Menus, StdCtrls,
type
  TDNForm = class(TForm)
    MainMenu1: TMainMenu;
    cm_MainExit: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure cm_MainExitClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    BM: TBitmap;
    procedure WMDrawItem(var Msg:TWMDrawItem); message wm_DrawItem;
    procedure WMMeasureItem(var Msg:TWMMeasureItem); message wm_MeasureItem;
end;
var
  DNForm: TDNForm;
implementation
{$R *.DFM}
var
  Comm, yMenu: word;
procedure TDNForm.FormCreate(Sender: TObject);
begin
  yMenu:=GetSystemMetrics(SM_CYMENU);
  comm:=cm_MainExit.Command;
  ModifyMenu(MainMenu1.Handle,0,mf_ByPosition or mf_OwnerDraw,comm,'Go');
end;
procedure TDNForm.cm_MainExitClick(Sender: TObject);
begin
  DNForm.Close;
end;
procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem);
begin
  with Msg.MeasureItemStruct^ do
    if ItemID=comm then
    begin
      ItemWidth:=yMenu;
      Itemheight:=yMenu;
    end;
end;
procedure TDNForm.WMDrawItem(var Msg: TWMDrawItem);
var
  MemDC:hDC;
  BM:hBitMap;
  mtd:longint;
begin
  with Msg.DrawItemStruct^ do
  begin
    if ItemID=comm then
    begin
      BM:=LoadBitMap(hInstance,'dver');
      MemDC:=CreateCompatibleDC(hDC);
      SelectObject(MemDC,BM);
      if ItemState=ods_Selected then
        mtd:=NotSrcCopy
      else
        mtd:=SrcCopy;
      StretchBlt(hDC,rcItem.left, rcItem.top, yMenu, yMenu, MemDC,
      0, 0, 24, 23, mtd);
      DeleteDC(MemDC);
      DeleteObject(BM);
    end;
  end;
end;
end.

Компонент для отрисовки линий.

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

unit Lines; {от Bill Murto, CIS 73730,2505}
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms;
type
  TLineOrigin = (loTopLeft, loTopRight);
  TLine = class(TGraphicControl)
  private
    { Private declarations }
    fOrigin: TLineOrigin;
    fPen: TPen;
    procedure SetOrigin(Value: TLineOrigin);
    procedure SetPen(Value: TPen);
  protected
    { Protected declarations }
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Origin: TLineOrigin read fOrigin write SetOrigin default
      loTopLeft;
    property Pen: TPen read fPen write SetPen;
    property Height default 33;
    property Width default 33;
    procedure StyleChanged(Sender: TObject);
  end;
procedure Register;
implementation
procedure Register;
begin
  RegisterComponents('Samples', [TLine]);
end;
procedure TLine.SetOrigin(Value: TLineOrigin);
begin
  if fOrigin <> Value then
  begin
    fOrigin := Value;
    Invalidate;
  end;
end;
procedure TLine.SetPen(Value: TPen);
begin
  fPen.Assign(Value);
end;
procedure TLine.StyleChanged(Sender: TObject);
begin
  Invalidate;
end;
constructor TLine.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Height := 33;
  Width := 33;
  fPen := TPen.Create;
  fPen.OnChange := StyleChanged;
  if csOpaque in ControlStyle then
    ControlStyle := ControlStyle - [csOpaque];
end;
procedure TLine.Paint;
begin
  with Canvas do
  begin
    Pen := fPen;
    if (Width <= Pen.Width) or (Height <= Pen.Width) then
    begin
      if Width <= Pen.Width then
      begin
        MoveTo(0, 0);
        LineTo(0, Height);
      end;
      if Height <= Pen.Width then
      begin
        MoveTo(0, 0);
        LineTo(Width, 0);
      end;
    end
    else
      case fOrigin of
        loTopLeft:
          begin
            MoveTo(0, 0);
            LineTo(Width, Height);
          end;
        loTopRight:
          begin
            MoveTo(Width, 0);
            LineTo(0, Height);
          end;
      end;
  end;
end;
destructor TLine.Destroy;
begin
  fPen.Free;
  inherited Destroy;
end;
end.

Нарисовать линию, не используя функции LineTo.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
  Enables you do draw a line if for some reason you 
  cannot use the delphi LineTo procedure. 
  For example, for drawing higher resolution lines 
  or drawing lines in 2D arrays. 
}
 procedure DrawLine(APoint1, APoint2: TPoint; ACanvas: TCanvas);
 var
   Lpixel, LMaxAxisLength: integer;
   LRatio: Real;
 begin
   LMaxAxisLength := Max(abs(APoint1.X - APoint2.X), abs(APoint1.Y - APoint2.Y));
   for Lpixel := 0 to LMaxAxisLength do
    begin
     LRatio := Lpixel / LMaxAxisLength;
     ACanvas.Pixels[APoint1.X + Round((APoint2.X - APoint1.X) * LRatio),
       APoint1.Y + Round((APoint2.Y - APoint1.Y) * LRatio)] :=
       ACanvas.Pen.Color;
   end;
 end;
 // Draw a double resolution line 
procedure DrawLineDouble(APoint1, APoint2: TPoint; ACanvas: TCanvas);
 var
   Lpixel, LMaxAxisLength: integer;
   LRatio: Real;
   LPoint: TPoint;
 begin
   LMaxAxisLength := max(abs(APoint1.X - APoint2.X), abs(APoint1.Y - APoint2.Y));
   for Lpixel := 0 to LMaxAxisLength do
    begin
     LRatio := Lpixel / LMaxAxisLength;
     LPoint.X := APoint1.X + Round((APoint2.X - APoint1.X) * LRatio);
     LPoint.Y := APoint1.Y + Round((APoint2.Y - APoint1.Y) * LRatio);
     with ACAnvas do
      begin
       Pixels[LPoint.X * 2, LPoint.Y * 2] := clBlack;
       Pixels[(LPoint.X * 2) + 1, LPoint.Y * 2] := clBlack;
       Pixels[LPoint.X * 2, (LPoint.Y * 2) + 1] := clBlack;
       Pixels[(LPoint.X * 2) + 1, (LPoint.Y * 2) + 1] := clBlack;
     end;
   end;
 end;

Как элемент списка нарисовать своим цветом.

Не забудь установить свойство Style у твоего ListBox в lbOwnerDrawFixed или в lbOwnerDrawVariable.

procedure TForm1.ListBox1DrawItem(Control: TWinControl; index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
  with ListBox1 do
  begin
    if odSelected in State then
      Canvas.Brush.Color:=clTeal { твой цвет }
    else
      Canvas.Brush.Color:=clWindow;
    Canvas.FillRect(Rect);
    Canvas.TextOut(Rect.Left+2,Rect.Top,Items[index]);
  end;
end;

Рисование квадрата мышкой.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

private
   { Private declarations }
   AnchorX, AnchorY,
   CurX, CurY: Integer;
   Bounding: Boolean;
 end;
 implementation
 procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   AnchorX := X;
   CurX := X;
   AnchorY  := Y;
    CurY := Y;
   Bounding := True;
 end;
 procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
   Y: Integer);
 begin
   if Bounding then
    begin
     Canvas.Pen.Mode := pmNot;
     Canvas.Pen.Width := 2;
     Canvas.Brush.Style := bsClear;
     Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
     CurX := X;
      CurY := Y;
     Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
   end;
 end;
 procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   if Bounding then
    begin
     Bounding := False;
     Canvas.Pen.Mode := pmNot;
     Canvas.Brush.Style := bsClear;
     Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
   end;
 end;

Как рисовать линии (или ещё что-нибудь) на экране (TDesktopCanvas).

// Пример рисует две горизонтальные линии на экране используя TDesktopCanvas.
program TrinitronTraining;
uses
  Messages, Windows, Graphics, Forms;
type
  TDesktopCanvas = class(TCanvas)
  private
    DC : hDC;
    function GetWidth:Integer;
    function GetHeight:Integer;
  public
    constructor Create;
    destructor Destroy; override;
  published
    property Width: Integer read GetWidth;
    property Height: Integer read GetHeight;
end;
{ Объект TDesktopCanvas }
function TDesktopCanvas.GetWidth:Integer;
begin
  Result:=GetDeviceCaps(Handle,HORZRES);
end;
function TDesktopCanvas.GetHeight:Integer;
begin
  Result:=GetDeviceCaps(Handle,VERTRES);
end;
constructor TDesktopCanvas.Create;
begin
  inherited Create;
  DC := GetDC(0);
  Handle := DC;
end;
destructor TDesktopCanvas.Destroy;
begin
  Handle := 0;
  ReleaseDC(0, DC);
  inherited Destroy;
end;
const
  YCount = 2;
var
  desktop : TDesktopCanvas;
  dx,dy : Integer;
  i : Integer;
  F : array[1..YCount] of TForm;
function CreateLine(Y : Integer) : TForm;
begin
  Result := TForm.Create(Application);
  with Result do begin
    Left := 0;
    Top := y;
    Width := dx;
    Height := 1;
    BorderStyle := bsNone;
    FormStyle := fsStayOnTop;
    Visible := True;
  end;
end;
procedure ProcessMessage;
var
  Msg : TMsg;
begin
  if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
    if Msg.message = WM_QUIT then
      Application.Terminate;
end;
begin
  desktop := TDesktopCanvas.Create;
  try
    dx := desktop.Width;
    dy := desktop.Height div (YCount+1);
  finally
    desktop.free;
  end;
  for i:=1 to YCount do
    F[i]:=CreateLine(i*dy);
  Application.NormalizeTopMosts;
  ShowWindow(Application.Handle, SW_Hide);
  for i:=1 to YCount do
    SetWindowPos(F[i].Handle, HWND_TOPMOST, 0,0,0,0, SWP_NOACTIVATE+SWP_NOMOVE+SWP_NOSIZE);
  {
  следующие строки используются для того, чтобы не останавливаться
  repeat
  ProcessMessage;
  until false;
  }
  Sleep(15000);
  for i:=1 to YCount do
    F[i].Free;
end.

Можно ли рисовать на рамке формы.

Обрабатывайте событие WM_NCPAINT. В примере рамка обводится красной линией толщиной в 1 пиксель.