Стать для делфи

Статьи …Development и Дельфи (http://delphid.dax.ru/).

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

vk_LButton = $01;
vk_RButton = $02;
vk_Cancel = $03;
vk_MButton = $04; { генерятся только системой вместе с L & RBUTTON }
vk_Back = $08;
vk_Tab = $09;
vk_Clear = $0C;
vk_Return = $0D;
vk_Shift = $10;
vk_Control = $11;
vk_Menu = $12;
vk_Pause = $13;
vk_Capital = $14;
vk_Escape = $1B;
vk_Space = $20;
vk_Prior = $21;
vk_Next = $22;

vk_End = $23;
vk_Home = $24;
vk_Left = $25;
vk_Up = $26;
vk_Right = $27;
vk_Down = $28;
vk_Select = $29;
vk_Print = $2A;
vk_Execute = $2B;
vk_SnapShot = $2C;
{ vk_Copy = $2C не используется клавиатурой }

vk_Insert = $2D;
vk_Delete = $2E;
vk_Help = $2F;
{ vk_A - vk_Z такие же, как и их ASCII-эквиваленты: 'A' - 'Z' }
{ vk_0 - vk_9 такие же, как и их ASCII-эквиваленты: '0' - '9' }

vk_NumPad0 = $60;
vk_NumPad1 = $61;
vk_NumPad2 = $62;
vk_NumPad3 = $63;
vk_NumPad4 = $64;
vk_NumPad5 = $65;
vk_NumPad6 = $66;
vk_NumPad7 = $67;
vk_NumPad8 = $68;
vk_NumPad9 = $69;
vk_Multiply = $6A;
vk_Add = $6B;
vk_Separator = $6C;
vk_Subtract = $6D;
vk_Decimal = $6E;
vk_Divide = $6F;
vk_F1 = $70;
vk_F2 = $71;
vk_F3 = $72;
vk_F4 = $73;
vk_F5 = $74;

vk_F6 = $75;
vk_F7 = $76;
vk_F8 = $77;
vk_F9 = $78;
vk_F10 = $79;
vk_F11 = $7A;
vk_F12 = $7B;
vk_F13 = $7C;
vk_F14 = $7D;
vk_F15 = $7E;
vk_F16 = $7F;
vk_F17 = $80;
vk_F18 = $81;
vk_F19 = $82;
vk_F20 = $83;
vk_F21 = $84;
vk_F22 = $85;
vk_F23 = $86;
vk_F24 = $87;
vk_NumLock = $90;
vk_Scroll = $91;

Как подсчитать занимаемое директорией место

Возвращаемая размерность - байты.):

var

DirBytes : integer;

function TFileBrowser.DirSize(Dir:string):integer;
var

SearchRec : TSearchRec;

Separator : string;

begin

if Copy(Dir,Length(Dir),1)='\' then

Separator := ''

else

Separator := '\';

if FindFirst(Dir+Separator+'*.*',faAnyFile,SearchRec) = 0 then begin

if FileExists(Dir+Separator+SearchRec.Name) then begin

DirBytes := DirBytes + SearchRec.Size;

{Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}

end else if DirectoryExists(Dir+Separator+SearchRec.Name) then begin

if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then begin

DirSize(Dir+Separator+SearchRec.Name);

end;

while FindNext(SearchRec) = 0 do begin

if FileExists(Dir+Separator+SearchRec.Name) then begin

DirBytes := DirBytes + SearchRec.Size;

{Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}

end else if DirectoryExists(Dir+Separator+SearchRec.Name) then

begin

if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then begin

DirSize(Dir+Separator+SearchRec.Name);

end;

FindClose(SearchRec);

end;

Сохранение параметров шрифта в файле.

function FontToStr(font: TFont): string;
procedure yes(var str:string);
begin

str := str + 'y';

end;
procedure no(var str:string);
begin

str := str + 'n';

end;
begin

{кодируем все атрибуты TFont в строку}

Result := '';

Result := Result + IntToStr(font.Color) + '|';

Result := Result + IntToStr(font.Height) + '|';

Result := Result + font.Name + '|';

Result := Result + IntToStr(Ord(font.Pitch)) + '|';

Result := Result + IntToStr(font.PixelsPerInch) + '|';

Result := Result + IntToStr(font.size) + '|';

if fsBold in font.style then yes(Result) else no(Result);

if fsItalic in font.style then yes(Result) else no(Result);

if fsUnderline in font.style then yes(Result) else no(Result);

if fsStrikeout in font.style then yes(Result) else no(Result);

end;

procedure StrToFont(str: string; font: TFont);
begin

if str = '' then Exit;

font.Color := StrToInt(tok('|', str));

font.Height := StrToInt(tok('|', str));

font.Name := tok('|', str);

font.Pitch := TFontPitch(StrToInt(tok('|', str)));

font.PixelsPerInch := StrToInt(tok('|', str));

font.Size := StrToInt(tok('|', str));

font.Style := [];

if str[0] = 'y' then font.Style := font.Style + [fsBold];

if str[1] = 'y' then font.Style := font.Style + [fsItalic];

if str[2] = 'y' then font.Style := font.Style + [fsUnderline];

if str[3] = 'y' then font.Style := font.Style + [fsStrikeout];

end;

function tok(sep: string; var s: string): string;

function isoneof(c, s: string): Boolean;

var

iTmp: integer;

begin

Result := False;

for iTmp := 1 to Length(s) do

begin

if c = Copy(s, iTmp, 1) then

begin

Result := True;

Exit;

end;

var

c, t: string;

begin

if s = '' then

begin

Result := s;

Exit;

end;

c := Copy(s, 1, 1);

while isoneof(c, sep) do

begin

s := Copy(s, 2, Length(s) - 1);

c := Copy(s, 1, 1);

end;

t := '';

while (not isoneof(c, sep)) and (s <> '') do

begin

t := t + c;

s := Copy(s, 2, length(s)-1);

c := Copy(s, 1, 1);

end;

Result := t;

end;

Изменение шрифта у всплывающих подсказок

unit Unit1;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Edit1: TEdit;

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

Type

TMyHintWindow = Class (THintWindow)

Constructor Create (AOwner: TComponent); override;

end;

Constructor TMyHintWindow.Create (AOwner: TComponent);
Begin

Inherited Create (Aowner);

Canvas.Font.Name := 'Times New Roman';

Canvas.Font.Size := 14;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Application.ShowHint := False;

HintWindowClass := TMyHintWindow;

Application.ShowHint := True;

end;

end.

Как проверить готовность диска a:\

function DiskInDrive(const Drive: char): Boolean;
var
DrvNum: byte;
EMode: Word;
begin
result := true; // было false
DrvNum := ord(Drive);
if DrvNum >= ord('a') then dec(DrvNum,$20);
EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try

while DiskSize(DrvNum-$40) = -1 do begin // при неудаче выводим

диалог

if (Application.MessageBox('Диск не готов...'+chr(13)+chr(10)+

'Повторить?',PChar('Диск '+UpperCase(Drive)),mb_OKCANCEL+

mb_iconexclamation{IconQuestion})=idcancel) then begin

Result:=false;

Break;

end;

finally
SetErrorMode(EMode);
end;
end;

Перекодировка текста

procedure WinToDos;
var Src, Str:PChar;//Src-строка для перевода Str-конечная

begin
Src := Memo1.Lines.GetText; //Берем текст из TMemo как тип PChar
CharToOem(Src, Str); //API функция для перевода текста

Memo2.Lines.Text := StrPas(Str);//Записываем назад
end;

procedure DosToWin;
var Src, Str:PChar;
begin
Src := Memo1.Lines.GetText; //Берем текст из TMemo как тип PChar
OemToChar(Src, Str); //API функция для перевода текста

Memo2.Lines.Text := StrPas(Str);//Записываем назад
end;

Открытие и закрытие привода CD-ROM

unit DriveTools;
interface
uses

Windows, SysUtils, MMSystem;

function CloseCD(Drive : Char) : Boolean;
function OpenCD(Drive : Char) : Boolean;
implementation
function OpenCD(Drive : Char) : Boolean;
Var

Res MciError;

OpenParm: TMCI_Open_Parms;

Flags : DWord;

S : String;

DeviceID : Word;

begin

Result:=false;

S:=Drive+':';

Flags:=mci_Open_Type or mci_Open_Element;

With OpenParm do begin

dwCallback := 0;

lpstrDeviceType := 'CDAudio';

lpstrElementName := PChar(S);

end;

Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));

IF Res<>0 Then exit;

DeviceID:=OpenParm.wDeviceID;

try

Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);

IF Res=0 Then exit;

Result:=True;

finally

mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));

end;

end;
function CloseCD(Drive : Char) : Boolean;
Var

Res : MciError;

OpenParm: TMCI_Open_Parms;

Flags : DWord;

S : String;

DeviceID : Word;

begin

Result:=false;

S:=Drive+':';

Flags:=mci_Open_Type or mci_Open_Element;

With OpenParm do begin

dwCallback := 0;

lpstrDeviceType := 'CDAudio';

lpstrElementName := PChar(S);

end;

Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));

IF Res<>0 Then exit;

DeviceID:=OpenParm.wDeviceID;

try

Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);

IF Res=0 Then exit;

Result:=True;

finally

mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));

end;

end;
end.

Как подавить реакцию на Ctrl+Alt+Del?

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

// Включение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, 0, 0);
// Выключение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, 0, 0);

Кстати, SystemParametersInfo имеет еще кучу полезных ключей SPI_****, подробности см. в win32.hlp

Как изменить изображение на кнопке ПУСК?

{ объявляем глобальные переменные }
var

Form1: TForm1;

StartButton: hWnd;

OldBitmap: THandle;

NewImage: TPicture;

{ добавляем следующий код в событие формы OnCreate }
procedure TForm1.FormCreate(Sender: TObject);
begin

NewImage := TPicture.create;

NewImage.LoadFromFile('C:\Windows\Circles.BMP');

StartButton := FindWindowEx

(FindWindow('Shell_TrayWnd',nil),0,'Button', nil);

OldBitmap := SendMessage(StartButton,

BM_SetImage, 0,

NewImage.Bitmap.Handle);

end;
{ Событие OnDestroy }
procedure TForm1.FormDestroy(Sender: TObject);
begin

SendMessage(StartButton,BM_SetImage,0,OldBitmap);

NewImage.Free;

end;

Как изменить обои на рабочем столе?

program wallpapr;
uses Registry, WinProcs;
procedure SetWallpaper(sWallpaperBMPPath:String;bTile:boolean);
var

reg : TRegIniFile;

begin
// Изменяем ключи реестра
// HKEY_CURRENT_USER
//   Control Panel\Desktop
//     TileWallpaper (REG_SZ)
//     Wallpaper (REG_SZ)

reg := TRegIniFile.Create('Control Panel\Desktop' );

with reg do begin

WriteString( '', 'Wallpaper',

sWallpaperBMPPath );

if( bTile )then

begin

WriteString('', 'TileWallpaper', '1' );

end else begin

WriteString('', 'TileWallpaper', '0' );

end;

reg.Free;

// Оповещаем всех о том, что мы изменили системные настройки
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil,

{Эта строка - продолжение предыдущей}SPIF_SENDWININICHANGE );

end;

// пример установки WallPaper по центру рабочего стола

SetWallpaper('c:\winnt\winnt.bmp', False );

//Эту строчку надо написать где-то в программе.

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

В uses пpописываешь модуль Registry и дальше так:

var
R:TRegistry;
No:String;
begin
R:=TRegistry.Create;
R.RootKey:=HKEY_LOCAL_MACHINE;
R.OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion', False) {если false то пытается откpыть не создавая}
No:=R.ReadString('VersionNumber');
if No=..... then ...... else ......
end;

Кроме того, обязательно посмотрите на список функций WinAPI, имена которых начинаются с Get.... Например, GetComputerName, GetVersionEx, GetSystemInfo, SystemParametersInfo.

Как скопировать экран в TCanvas?

var

bmp: TBitmap;

DC: HDC;

begin

bmp:=TBitmap.Create;

bmp.Height:=Screen.Height;

bmp.Width:=Screen.Width;

DC:=GetDC(0); //Дескpиптоp экpана

bitblt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,

DC, 0, 0, SRCCOPY);

bmp.SaveToFile('Screen.bmp');

ReleaseDC(0, DC);

end;

Как извлечь иконку из EXE или DLL

Процесс получения иконок из .EXE, .DLL или .ICO файлов полностью идентичен.
Различие только в том, что в .ICO файле может храниться только одна иконка, а в
.EXE и .DLL несколько. Для получения иконок из файлов, в модуле ShellAPI, есть
функция:
function ExtractIcon(Inst: THandle; FileName: PChar; IconIndex: Word): HIcon;
где
Inst - указатель на приложение вызвавшее функцию, FileName - имя файла
из которого необходимо получить иконку, IconIndex - номер необходимой иконки.
Если функция возвращает значение не равное нулю, то в файле есть следующая иконка.
В данном примере в компонент Image1 выводится иконка запущенного файла.
USES ShellAPI;
procedure TForm1.FormCreate(Sender: TObject);
VAR A: ARRAY [0..78] OF Char;
begin

{Получение имени запущенного файла}
StrPCopy(A, ParamStr(0));
{Вывод на экран нулевой иконки из файла}
Image1.Picture.Icon.Handle := ExtractIcon(HInstance, A, 0);
end;

Как преобразовать ICO в BMP?

var
Icon : TIcon;
Bitmap : TBitmap;
begin
Icon := TIcon.Create;
Bitmap := TBitmap.Create;
Icon.LoadFromFile('c:\picture.ico');
Bitmap.Width := Icon.Width;
Bitmap.Height := Icon.Height;
Bitmap.Canvas.Draw(0, 0, Icon );
Bitmap.SaveToFile('c:\picture.bmp');
Icon.Free;
Bitmap.Free;
end;

Как преобразовать BMP (32x32) в ICO?

unit main;

interface

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

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

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var winDC, srcdc, destdc : HDC;
oldBitmap : HBitmap;
iinfo : TICONINFO;
begin
GetIconInfo(Image1.Picture.Icon.Handle, iinfo);

WinDC := getDC(handle);
srcDC := CreateCompatibleDC(WinDC);
destDC := CreateCompatibleDC(WinDC);
oldBitmap := SelectObject(destDC, iinfo.hbmColor);
oldBitmap := SelectObject(srcDC, iinfo.hbmMask);

BitBlt(destdc, 0, 0, Image1.picture.icon.width,
Image1.picture.icon.height,
srcdc, 0, 0, SRCPAINT);
Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);
DeleteDC(destDC);
DeleteDC(srcDC);
DeleteDC(WinDC);

image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName)
+ 'myfile.bmp');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
image1.picture.icon.loadfromfile('c:\myicon.ico');
end;

end.

Реестр. Свое расширение

//Use the registry to register your own filetype. uses registry;

procedure TForm1.RegisterFileType(prefix:String; exepfad:String);
var reg:TRegistry;
begin
reg:=TRegistry.Create;
reg.RootKey:=HKEY_CLASSES_ROOT;
//create a new key --> .pci
reg.OpenKey('.'+prefix,True);
//create a new value for this key --> pcifile
reg.WriteString('',prefix+'file');
reg.CloseKey; //create a new key --> pcifile
reg.CreateKey(prefix+'file');
//create a new key pcifile\DefaultIcon
reg.OpenKey(prefix+'file\DefaultIcon',True);
//and create a value where the icon is stored --> c:\project1.exe,0 reg.WriteString('',exepfad+',0');
reg.CloseKey;
reg.OpenKey(prefix+'file\shell\open\command',True);
//create value where exefile is stored --> c:\project1.exe "%1"
reg.WriteString('',exepfad+' "%1"'); reg.CloseKey;
reg.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
RegisterFileType('pci','c:\project1.exe');
end;

64-битное кодирование/декодирование

Const

Base64Table='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function Base64Decode(cStr:string):string;
var ResStr:string;

DecStr:string;

RecodeLine : array [1..76] of byte;

f1,f2 : word;

l:integer;

begin

l :=length(cStr);

ResStr:='';

for f1:=1 to l do

if cStr[f1]='=' then RecodeLine[f1]:=0

else RecodeLine[f1]:=pos(cStr[f1],Base64Table)-1;

f1:=1;

while f1<length(cStr) do

begin

DecStr:=chr(byte(RecodeLine[f1] shl 2)+RecodeLine[f1+1] shr 4)+

chr(byte(RecodeLine[f1+1] shl 4)+RecodeLine[f1+2] shr 2)+

chr(byte(RecodeLine[f1+2] shl 6)+RecodeLine[f1+3]);

ResStr:=ResStr+DecStr;

inc(f1,4);

end;

Base64Decode:=ResStr;

end;

Как программным путем включить Num Lock?

procedure TMyForm.Button1Click(Sender: TObject);

Var

KeyState : TKeyboardState;

begin

GetKeyboardState(KeyState);

if (KeyState[VK_NUMLOCK] = 0) then

KeyState[VK_NUMLOCK] := 1

else

KeyState[VK_NUMLOCK] := 0;

SetKeyboardState(KeyState);

end;

Для Caps Lock замените VK_NUMLOCK на VK_CAPITAL.

Drag & Drop с TImage

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('...');

DragMode := dmAutomatic;

OnDragOver := Panel1DragOver;

OnDragDrop := Panel1DragDrop;

END;

end;

Быстрое копирование файлов

procedure CopyFile( Source, Dest : string );
var

SrcFile : Integer;

DestFile : Integer;

S : string;

RetCode : Longint;

OpenFileBuf : TOFStruct;

FName : array[ 0..255 ] of Char;

begin

StrPCopy( FName, Source );

SrcFile := LZOpenFile( FName, OpenFileBuf, of_Read );

StrPCopy( FName, Dest );

DestFile := LZOpenFile( FName, OpenFileBuf, of_Create );

RetCode := LZCopy( SrcFile, DestFile );

if RetCode >= 0 then

begin

LZClose( SrcFile );

LZClose( DestFile );

end

else

begin

Str( RetCode, S );

MessageDlg( 'Не могу скопировать ' + Source + ' в ' +

Dest + #13 + 'Код ошибки = ' + S, mtError, [mbOk], 0 );

end;

Вращение изображения

procedure RotateRight(BitMap : tImage);

var FirstC, LastC, c, r : integer;

procedure FixPixels(c,r : integer);

var SavePix, SavePix2 : tColor;

i, NewC, NewR : integer;

begin

SavePix := Bitmap.Canvas.Pixels[c,r];

for i := 1 to 4 do begin

newc := BitMap.Height-r+1;

newr := c;

SavePix2 := BitMap.Canvas.Pixels[newc,newr];

Bitmap.Canvas.Pixels[newc,newr] := SavePix;

SavePix := SavePix2;

c := Newc;

r := NewR;

end;

begin

if BitMap.Width <> BitMap.Height then exit;

BitMap.Visible := false;

with Bitmap.Canvas do begin

firstc := 0;

lastc := BitMap.Width;

for r := 0 to BitMap.Height div 2 do begin

for c := firstc to lastc do begin

FixPixels(c,r);

end;

inc(FirstC);

Dec(LastC);

end;

BitMap.Visible := true;

end;

Добавление события OnMouseLeave

unit BS_Label;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TBS_Label = class(TLabel)

private

{ Private declarations }

FOnMouseLeave: TNotifyEvent;

FOnMouseEnter: TNotifyEvent;

procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;

procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;

protected

{ Protected declarations }

public

{ Public declarations }

published

{ Published declarations }

property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;

property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;

end;

procedure Register;

implementation

procedure Register;
begin

RegisterComponents('Custom', [TBS_Label]);

end;

{ TBS_Label }

procedure TBS_Label.CMMouseEnter(var Message: TMessage);
begin

if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);

end;

procedure TBS_Label.CMMouseLeave(var Message: TMessage);
begin

if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);

end;

end.

Завершение всех работающий приложений

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

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

procedure TForm1.ButtonKillAllClick(Sender: TObject);
var

pTask : PTaskEntry;

Task : Bool;

ThisTask: THANDLE;

begin

GetMem (pTask, SizeOf (TTaskEntry));

pTask^.dwSize := SizeOf (TTaskEntry);

Task := TaskFirst (pTask);

while Task do

begin

if pTask^.hInst = hInstance then

ThisTask := pTask^.hTask

else

TerminateApp (pTask^.hTask, NO_UAE_BOX);

Task := TaskNext (pTask);

end;

TerminateApp (ThisTask, NO_UAE_BOX);

end;

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

const crMyCursor = 1;

procedure TForm1.FormCreate(Sender: TObject);
begin

// Загружаем курсор. Единственный способ для этого

Screen.Cursors[crMyCursor] :=

LoadCursorFromFile('c:\mystuff\mycursor.ani');

// Используем курсор на форме

Cursor := crMyCursor;

end;

(С) Автор статьи: Михаил Христосенко // Development и Дельфи (http://delphid.dax.ru/). При использовании этого материала ссылка на автора и источник информации обязательна!!!

Удачи в программировании...