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

Общая техника использования функций и процедур – получить дату создания файла.

Эта функция при нажатии на Button1 выводит информацию о файле.

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
function GetFileDate(TheFileName: string): string; // эта строка необязательна
var
  Form1: TForm1;
implementation
{$R *.dfm}
function GetFileDate(TheFileName: string): string;
var
  FHandle: integer;
begin
  FHandle := FileOpen(TheFileName, 0);
  result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
  FileClose(FHandle);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  label1.Caption := GetFileDate('C:\borland.exe');
end;
end.

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

Заголовок и стандартные директивы.

Заголовок процедуры имеет вид:

PROCEDURE  [()]; 

Заголовок функции:

FUNCTION  [()]: ; 

Сразу за заголовком подпрограммы может следовать одна из стандартных директив assembler, external, far, forward, inline, interrupt, near. Эти директивы уточняют действия компилятора и распространяются на всю подпрограмму и только на нее, т. е., если за подпрограммой следует другая подпрограмма, стандартная директива, указанная за заголовком первой, не распространяется на вторую.

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

Директива  Порядок        Очистка       Регистры
safecall   Справа налево  Подпрограмма  Нет 
Stdcall    Справа налево  Подпрограмма  Нет 
Cdecl      Справа налево  Программа     Нет 
Pascal     Слева направо  Подпрограмма  Нет 
Register   Слева направо  Подпрограмма  Да 

Примечание

Передача функции как параметра.

В нашем случае лучшим решением будет использование процедурного типа. Допустим, что DllFunction() на входе хочет получить определенную функцию, поясним это на примере кода:

type
  TMyFuncType = function: integer;
var
  MyFunc: TMyFuncType;
function foo: integer;
begin
  result := 1;
end;
begin
  MyFunc := foo;
  DllFunction(longint(MyFunc));

Вы можете это сделать и так:

DllFunction( longint( @foo )) ;

Также, в зависимости от того, как написана DllFunction(), вы можете в вызове подразумевать приведение типа:

function DllFunction( p: TMyFuncType ): Integer;
far; external 'mydll';

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

unit Unit1;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;
type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
type
  IntFunc = function: integer;
function DllFunction(iFunc: IntFunc): integer; far;
begin
  DllFunction := iFunc; {Обратите внимание на то, что это вызов функции}
end;
function iFoo: integer; far;
begin
  iFoo := 1;
end;
procedure TestIFunc;
var
  i: integer;
begin
  i := DllFunction(iFoo);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  TestIFunc;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
  Close;
end;
end.

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

i := longint(@foo)

Другая вещь, которую вы можете сделать - исключить работу с longint и вызывать функцию dll следующим образом:

DLLfunction (@foo);

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

Функция для работы с палитрами и RGB.

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

procedure TForm1.FormClick(Sender: TObject);
var
  blue: Byte;
begin
  For blue := 0 to 255 do
  Begin
    Color := RGB(255-blue,0,blue);
    Update;
  End;
end;

Указатель на функцию.

Ниже приведен простой пример для Borland Delphi, использующий указатели функций для управления программным потоком. Просто создайте простую форму с единственной кнопкой и скопируйте код из Unit1 во вновь созданный модуль. Добавьте к проекту Unit2 и скомпилируйте проект. Дайте мне знать, если у вас возникнут какие-либо проблемы.

interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;
type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
  CurrProc: LongInt;
  MyVal: LongInt;
implementation
uses Unit2;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
  NewProc: LongInt;
  MyString: string;
begin
  CurrProc := 2; { начальная точка в таблице методов }
  MyVal := 0; { вспомогательная переменная }
  NewProc := 0;
    { возвращаемое значение для следующего индекса в таблице методов }
  while CurrProc < 6 do
  begin
    { выполняем текущий индекс в таблице методов и получаем следующую процедуру }
    NewProc := ProcTable[CurrProc](MyVal);
    { просто показываем значения NewProc и CurrProc }
    FmtStr(MyString, 'NewProc [%d] CurrProc [%d]', [NewProc, CurrProc]);
    MessageDlg(MyString, mtInformation, [mbOK], 0);
    { присваиваем текущую процедуру возвращаемой процедуре }
    CurrProc := NewProc;
  end;
end;
end.

{ Это простой пример, определяющий массив указателей на функции }
interface
type
  { определяем Procs как функцию }
  Procs = function(var ProcNum: LongInt): LongInt;
var
  { объявляем массив указателей на функции }
  ProcTable: array[1..5] of Procs;
  { определения интерфейсов функций }
function Proc1(var MyVal: LongInt): LongInt; far;
function Proc2(var MyVal: LongInt): LongInt; far;
function Proc3(var MyVal: LongInt): LongInt; far;
function Proc4(var MyVal: LongInt): LongInt; far;
function Proc5(var MyVal: LongInt): LongInt; far;
implementation
uses Dialogs;
function Proc1(var MyVal: LongInt): LongInt;
begin
  MessageDlg('Процедура 1', mtInformation, [mbOK], 0);
  Proc1 := 6;
end;
function Proc2(var MyVal: LongInt): LongInt;
begin
  MessageDlg('Процедура 2', mtInformation, [mbOK], 0);
  Proc2 := 3;
end;
function Proc3(var MyVal: LongInt): LongInt;
begin
  MessageDlg('Процедура 3', mtInformation, [mbOK], 0);
  Proc3 := 4;
end;
function Proc4(var MyVal: LongInt): LongInt;
begin
  MessageDlg('Процедура 4', mtInformation, [mbOK], 0);
  Proc4 := 5;
end;
function Proc5(var MyVal: LongInt): LongInt;
begin
  MessageDlg('Процедура 5', mtInformation, [mbOK], 0);
  Proc5 := 1;
end;
initialization
  { инициализируем содержание массива указателей на функции }
  @ProcTable[1] := @Proc1;
  @ProcTable[2] := @Proc2;
  @ProcTable[3] := @Proc3;
  @ProcTable[4] := @Proc4;
  @ProcTable[5] := @Proc5;
end.

Пример: (Здесь может встретиться пара синтаксических ошибок - я не компилил это).

type
  TBaseForm = class(TForm)
  public
    procedure Method1; virtual; abstract;
  end;
type
  TDerivedForm1 = class(TBaseForm)
  public
    procedure Method1; override;
  end;
  TDerivedForm2 = class(TBaseForm)
  public
    procedure Method1; override;
  end;
procedure TDerivedForm1.Method1;
begin
  ....
end;
procedure TDerivedForm2.Method1;
begin
  ....
end;
{Для вызова функции из вашего toolbar,
получите активную в настоящий момент форму и вызовите Method1}
procedure OnButtonClick;
var
  AForm: TBaseForm;
begin
  AForm := ActiveForm as TBaseForm;
  AForm.Method1;
end;

Указатель на функцию 2.

type
TYourDLLFunc = function(Parm1: TParm1; Parm2: TParm2): TParm3;

var
YourDllFunc: TYourDLLFunc;

DLLHandle := LoadLibrary('YourDLL.DLL');

@YourDLLFunc := GetProcAddress(DLLHandle, 'YourDLLFuncName');

Parm3 := YourDLLFunc(Parm1, Parm2);

Вычисление автокорреляционной функции.

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

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Вычисление автокорреляционной функции
Зависимости: Math
Автор:       lookin, lookin@mail.ru, Екатеринбург
Copyright:   lookin
Дата:        2 июня 2002 г.
***************************************************** }
//TDoubleArray = array of double
procedure AutoCorrelation(ValueArray: TDoubleArray; var ACArray: TDoubleArray;
  FromValue, ToValue: integer);
var
  i, j, N: integer;
  avr, dev, xxsum: double;
begin
  //ValueArray - массив типа double для которого вычисляется функция
  //FromValue - номер точки, начиная с которого выбираются элементы массива
  //ToValue - номер точки, на котором заканчивается выбор элементов массива
  //ACArray - массив возвращаемых значений автокорреляционной функции
  //для 5-и точек
  N := ToValue - FromValue;
  SetLength(ACArray, 5);
  if N < 5 then
  begin
    for i := 0 to 4 do
      ACArray[i] := 0;
    Exit;
  end
  else
  begin
    SetLength(rv, N);
    dev := 0;
    for i := 0 to N - 1 do
      rv[i] := ValueArray[i + FromValue];
    avr := Mean(rv);
    for i := 0 to N - 1 do
      dev := dev + Sqr(rv[i] - avr);
    dev := dev / N;
    for j := 0 to 4 do
    begin
      xxsum := 0;
      for i := 0 to (N - 1) - j do
        xxsum := xxsum + (rv[i] - avr) * (rv[i + j] - avr);
      ACArray[j] := xxsum / (dev * (N - j));
    end;
  end;
end;

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

var
  SourceArray, ACCoefs: TDoubleArray;
begin
  AutoCorrelation(SourceArray, ARCoefs, 0, Length(SourceArray) - 1);
  for i := 0 to Length(ACCoefs) - 1 do
    showmessage(FloatToStr(ACCoefs[i]));

Оптимизация функции методом деформируемого многогранника (Метод Нелдера-Мида).

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

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Оптимизация функции методом деформируемого многогранника (Метод Нелдера-Мида)
Передаваемая структура:
TNelderOption = record
Size: Cardinal; // Размер структуры (обязательно)
Flags: Cardinal; // Флаги (обязательно)
Func: TMathFunction; // Функция (обязательно)
N: Integer; // Размерность (обязательно)
X0: PExtended; // Указатель на начальную точку (обязательно)
X: PExtended; // Указатель куда записывать результат (обязательно)
Eps: Extended; // Точность (опция FIND_MIN_USE_EPS)
Delta: Extended; // Способ проверки (опция FIND_MIN_USE_DELTA)
R: Extended; // Расстояние между вершинами симплекса (опция FIND_MIN_USE_R)
Mode: Integer; // Метод решения (опция FIND_MIN_USE_MODE)
Alpha: Extended; // Коэффициент отражения (опция FIND_MIN_USE_ALPHA)
Beta: Extended; // Коэффициент сжатия (опция FIND_MIN_USE_BETA)
Gamma: Extended; // Коэффициент растяжения (опция FIND_MIN_USE_GAMMA)
end;
Возвращаемое значение - 0 если хорошо, иначе ошибка
Зависимости: Windows
Автор:       Mystic, mystic2000@newmail.ru, ICQ:125905046, Харьков
Copyright:   Mystic (посвящается Оксане в память о ее дипломе)
Дата:        25 апреля 2002 г.
***************************************************** }
const
  CONST_1_DIV_SQRT_2 = 0.70710678118654752440084436210485;
  FIND_MIN_OK = 0;
  FIND_MIN_INVALID_OPTION = 1;
  FIND_MIN_INVALID_FUNC = 2;
  FIND_MIN_INVALID_N = 3;
  FIND_MIN_INVALID_X0 = 4;
  FIND_MIN_INVALID_X = 5;
  FIND_MIN_INVALID_EPS = 6;
  FIND_MIN_INVALID_DELTA = 7;
  FIND_MIN_INVALID_R = 8;
  FIND_MIN_MODE_NOT_SUPPORT = 9;
  FIND_MIN_OUT_OF_MEMORY = 10;
  FIND_MIN_INVALID_ALPHA = 11;
  FIND_MIN_INVALID_BETA = 12;
  FIND_MIN_INVALID_GAMMA = 13;
  FIND_MIN_MODE_STD = 0;
  FIND_MIN_MODE_1 = 1;
  FIND_MIN_MODE_2 = 2;
  FIND_MIN_USE_EPS = $00000001;
  FIND_MIN_USE_R = $00000002;
  FIND_MIN_USE_MODE = $00000004;
  FIND_MIN_USE_DELTA = $00000008;
  FIND_MIN_USE_ALPHA = $00000010;
  FIND_MIN_USE_BETA = $00000020;
  FIND_MIN_USE_GAMMA = $00000040;
  // Некоторые комбинации стандартных опций:
  FIND_MIN_USE_EPS_R = FIND_MIN_USE_EPS or FIND_MIN_USE_R;
  FIND_MIN_USE_EPS_R_MODE = FIND_MIN_USE_EPS_R or FIND_MIN_USE_MODE;
  FIND_MIN_USE_EPS_R_DELTA = FIND_MIN_USE_EPS_R or FIND_MIN_USE_DELTA;
  FIND_MIN_USE_EPS_R_MODE_DELTA = FIND_MIN_USE_EPS_R_MODE or FIND_MIN_USE_DELTA;
  FIND_MIN_USE_ALL = FIND_MIN_USE_EPS or FIND_MIN_USE_R or FIND_MIN_USE_MODE or
    FIND_MIN_USE_DELTA or FIND_MIN_USE_ALPHA or
    FIND_MIN_USE_BETA or FIND_MIN_USE_GAMMA;
type
  PMathFunction = ^TMathFunction;
  TMathFunction = function(X: PExtended): Extended;
  PNelderOption = ^TNelderOption;
  TNelderOption = record
    Size: Cardinal; // Размер структуры (обязательно)
    Flags: Cardinal; // Флаги (обязательно)
    Func: TMathFunction; // Функция (обязательно)
    N: Integer; // Размерность (обязательно)
    X0: PExtended; // Указатель на начальную точку (обязательно)
    X: PExtended; // Указатель куда записывать результат (обязательно)
    Eps: Extended; // Точность (опция FIND_MIN_USE_EPS)
    Delta: Extended; // Способ проверки (опция FIND_MIN_USE_DELTA)
    R: Extended; // Расстояние между вершинами симплекса (опция FIND_MIN_USE_R)
    Mode: Integer; // Метод решения (опция FIND_MIN_USE_MODE)
    Alpha: Extended; // Коэффициент отражения (опция FIND_MIN_USE_ALPHA)
    Beta: Extended; // Коэффициент сжатия (опция FIND_MIN_USE_BETA)
    Gamma: Extended; // Коэффициент растяжения (опция FIND_MIN_USE_GAMMA)
  end;
  {**********
    Проверка указателя Option на то, что все его параметры доступны для чтения
  **********}
function CheckNelderOptionPtr(Option: PNelderOption): Integer;
begin
  // Проверка указателя #1 (допустимость указателя)
  if IsBadReadPtr(@Option, 4) then
  begin
    Result := FIND_MIN_INVALID_OPTION;
    Exit;
  end;
  // Проверка указателя #2 (слишком мало параметров)
  if Option.Size < 24 then
  begin
    Result := FIND_MIN_INVALID_OPTION;
    Exit;
  end;
  // Проверка указателя #3 (все данные можно читать?)
  if IsBadReadPtr(@Option, Option.Size) then
  begin
    Result := FIND_MIN_INVALID_OPTION;
    Exit;
  end;
  Result := FIND_MIN_OK;
end;
{************
  Копирование данных из одной структуры в другую с попутной проверкой
  на допустимость значений всех параметров.
************}
function CopyData(const InOption: TNelderOption; var OutOption: TNelderOption):
  Integer;
var
  CopyCount: Cardinal;
begin
  Result := FIND_MIN_OK;
  // Копируем одну структуру в другую
  CopyCount := SizeOf(TNelderOption);
  if InOption.Size < CopyCount then
    CopyCount := InOption.Size;
  Move(InOption, OutOption, CopyCount);
  // Устанавливаем размер
  OutOption.Size := SizeOf(TNelderOption);
  // Проверка Option.Func
  if IsBadCodePtr(@OutOption.Func) then
  begin
    Result := FIND_MIN_INVALID_FUNC;
    Exit;
  end;
  // Проверка Option.N
  if OutOption.N <= 0 then
  begin
    Result := FIND_MIN_INVALID_N;
    Exit;
  end;
  // Проверка Option.X0
  if IsBadReadPtr(OutOption.X0, OutOption.N * SizeOf(Extended)) then
  begin
    Result := FIND_MIN_INVALID_X0;
    Exit;
  end;
  // Проверка Option.X
  if IsBadWritePtr(OutOption.X, OutOption.N * SizeOf(Extended)) then
  begin
    Result := FIND_MIN_INVALID_X;
    Exit;
  end;
  // Проверка Option.Eps
  if (FIND_MIN_USE_EPS and OutOption.Flags) <> 0 then
  begin
    if OutOption.Size < 34 then // Eps не вписывается в размер
    begin
      Result := FIND_MIN_INVALID_OPTION;
      Exit;
    end
    else if OutOption.Eps <= 0 then
    begin
      Result := FIND_MIN_INVALID_EPS;
      Exit;
    end;
  end
  else
  begin
    OutOption.Eps := 1E-06; // Default value;
  end;
  // Проверка OutOption.Delta
  if (FIND_MIN_USE_DELTA and OutOption.Flags) <> 0 then
  begin
    if OutOption.Size < 44 then
    begin
      Result := FIND_MIN_INVALID_OPTION;
      Exit;
    end
    else if (OutOption.Delta < 0.0) or (OutOption.Delta > 1.0) then
    begin
      Result := FIND_MIN_INVALID_DELTA;
      Exit;
    end;
  end
  else
  begin
    OutOption.Delta := 0.5; // Default value
  end;
  // Проверка OutOption.R
  if (FIND_MIN_USE_R and OutOption.Flags) <> 0 then
  begin
    if OutOption.Size < 54 then
    begin
      Result := FIND_MIN_INVALID_OPTION;
      Exit;
    end
    else if (OutOption.R <= 0.0) then
    begin
      Result := FIND_MIN_INVALID_R;
      Exit;
    end;
  end
  else
  begin
    OutOption.R := 100.0; // Default value
  end;
  // Проверка OutOption.Mode
  if (FIND_MIN_USE_MODE and OutOption.Flags) <> 0 then
  begin
    if OutOption.Size < 58 then
    begin
      Result := FIND_MIN_INVALID_OPTION;
      Exit;
    end
    else if (OutOption.Mode <> FIND_MIN_MODE_STD) then
      if (OutOption.Mode <> FIND_MIN_MODE_1) then
        if (OutOption.Mode <> FIND_MIN_MODE_2) then
        begin
          Result := FIND_MIN_MODE_NOT_SUPPORT;
          Exit;
        end;
  end
  else
  begin
    OutOption.Mode := FIND_MIN_MODE_STD; // Default value
  end;
  // Проверка OutOption.Alpha
  if (FIND_MIN_USE_ALPHA and OutOption.Flags) <> 0 then
  begin
    if OutOption.Size < 68 then
    begin
      Result := FIND_MIN_INVALID_OPTION;
      Exit;
    end
    else if OutOption.Alpha < 0.0 then
    begin
      Result := FIND_MIN_INVALID_ALPHA;
      Exit;
    end;
  end
  else
  begin
    OutOption.Alpha := 1.0; // Default value
  end;
  // Проверка OutOption.Beta
  if (FIND_MIN_USE_BETA and OutOption.Flags) <> 0 then
  begin
    if OutOption.Size < 78 then
    begin
      Result := FIND_MIN_INVALID_OPTION;
      Exit;
    end
    else if (OutOption.Beta < 0.0) or (OutOption.Beta > 1.0) then
    begin
      Result := FIND_MIN_INVALID_BETA;
      Exit;
    end;
  end
  else
  begin
    OutOption.Beta := 0.5; // Default value
  end;
  // Проверка OutOption.Gamma
  if (FIND_MIN_USE_GAMMA and OutOption.Flags) <> 0 then
  begin
    if OutOption.Size < 88 then
    begin
      Result := FIND_MIN_INVALID_OPTION;
      Exit;
    end
    else if OutOption.Gamma < 1.0 then
    begin
      Result := FIND_MIN_INVALID_GAMMA;
      Exit;
    end;
  end
  else
  begin
    OutOption.Gamma := 1.5; // Default value
  end;
end;
type
  TNelderTempData = record
    D1: Extended;
    D2: Extended;
    FC: Extended;
    FU: Extended;
    XN: PExtended;
    D0: PExtended;
    FX: PExtended;
    C: PExtended;
    U: PExtended;
    V: PEXtended;
    Indexes: PInteger;
  end;
function InitializeTempData(var TempData: TNelderTempData; N: Integer): Integer;
var
  SizeD0: Integer;
  SizeFX: Integer;
  SizeC: Integer;
  SizeU: Integer;
  SizeV: Integer;
  SizeIndexes: Integer;
  SizeAll: Integer;
  Ptr: PChar;
begin
  // Вычисляем размеры
  SizeD0 := N * (N + 1) * SizeOf(Extended);
  SizeFX := (N + 1) * SizeOf(Extended);
  SizeC := N * SizeOf(Extended);
  SizeU := N * SizeOf(Extended);
  SizeV := N * SizeOf(Extended);
  SizeIndexes := (N + 1) * SizeOf(Integer);
  SizeAll := SizeD0 + SizeFX + SizeC + SizeU + SizeV + SizeIndexes;
  Ptr := SysGetMem(SizeAll);
  if not Assigned(Ptr) then
  begin
    Result := FIND_MIN_OUT_OF_MEMORY;
    Exit;
  end;
  TempData.D0 := PExtended(Ptr);
  Ptr := Ptr + SizeD0;
  TempData.FX := PExtended(Ptr);
  Ptr := Ptr + SizeFX;
  TempData.C := PExtended(Ptr);
  Ptr := Ptr + SizeC;
  TempData.U := PExtended(Ptr);
  Ptr := Ptr + SizeU;
  TempData.V := PExtended(Ptr);
  Ptr := Ptr + SizeV;
  TempData.Indexes := PInteger(Ptr);
  // Ptr := Ptr + SizeIndexes
  Result := FIND_MIN_OK;
end;
procedure FinalizeTempData(var TempData: TNelderTempData);
var
  Ptr: Pointer;
begin
  Ptr := TempData.D0;
  TempData.D0 := nil;
  TempData.FX := nil;
  TempData.C := nil;
  TempData.U := nil;
  TempData.V := nil;
  TempData.Indexes := nil;
  SysFreeMem(Ptr);
end;
{*********
  Строится симплекс:
    В целях оптимизации поменяем местами строки и столбцы
**********}
procedure BuildSimplex(var Temp: TNelderTempData; const Option: TNelderOption);
var
  I, J: Integer;
  PtrD0: PExtended;
begin
  with Temp, Option do
  begin
    D1 := CONST_1_DIV_SQRT_2 * R * (Sqrt(N + 1) + N - 1) / N;
    D2 := CONST_1_DIV_SQRT_2 * R * (Sqrt(N + 1) - 1) / N;
    FillChar(D0^, N * SizeOf(Extended), 0);
    PtrD0 := D0;
    PChar(PtrD0) := PChar(PtrD0) + N * SizeOf(Extended);
    for I := 0 to N - 1 do
      for J := 0 to N - 1 do
      begin
        if I = J then
          PtrD0^ := D1
        else
          PtrD0^ := D2;
        PChar(PtrD0) := PChar(PtrD0) + SizeOf(Extended);
      end;
  end;
end;
{*********
  Перемещение симплекса в точку A
*********}
procedure MoveSimplex(var Temp: TNelderTempData; const Option: TNelderOption; A:
  PExtended);
var
  I, J: Integer;
  PtrA, PtrD0: PExtended;
begin
  with Temp, Option do
  begin
    PtrD0 := D0;
    for I := 0 to N do
    begin
      PtrA := A;
      for J := 0 to N - 1 do
      begin
        PtrD0^ := PtrD0^ + PtrA^;
        PChar(PtrD0) := PChar(PtrD0) + SizeOf(Extended);
        PChar(PtrA) := PChar(PtrA) + SizeOf(Extended);
      end;
    end;
  end;
end;
// Быстрая сортировка значений FX
procedure QuickSortFX(L, R: Integer; FX: PExtended; Indexes: PInteger);
var
  I, J, K: Integer;
  P, T: Extended;
begin
  repeat
    I := L;
    J := R;
    // P := FX[(L+R) shr 1] :
    P := PExtended(PChar(FX) + SizeOf(Extended) * ((L + R) shr 1))^;
    repeat
      // while FX[I] < P do Inc(I):
      while PExtended(PChar(FX) + SizeOf(Extended) * I)^ < P do
        Inc(I);
      // while FX[J] > P do Dec(J):
      while PExtended(PChar(FX) + SizeOf(Extended) * J)^ > P do
        Dec(J);
      if I <= J then
      begin
        // Переставляем местами значения FX
        T := PExtended(PChar(FX) + SizeOf(Extended) * I)^;
        PExtended(PChar(FX) + SizeOf(Extended) * I)^ := PExtended(PChar(FX) +
          SizeOf(Extended) * J)^;
        PExtended(PChar(FX) + SizeOf(Extended) * J)^ := T;
        // Поддерживаем порядок и в индексах
        K := PInteger(PChar(Indexes) + SizeOf(Integer) * I)^;
        PInteger(PChar(Indexes) + SizeOf(Integer) * I)^ :=
          PInteger(PChar(Indexes) + SizeOf(Integer) * J)^;
        PInteger(PChar(Indexes) + SizeOf(Integer) * J)^ := K;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then
      QuickSortFX(L, J, FX, Indexes);
    L := I;
  until I >= R;
end;
procedure CalcFX(var Temp: TNelderTempData; Option: TNelderOption);
var
  I: Integer;
  PtrD0, PtrFX: PExtended;
begin
  with Temp, Option do
  begin
    // Вычисление значений функции
    PtrD0 := D0;
    PtrFX := FX;
    for I := 0 to N do
    begin
      PtrFX^ := Func(PtrD0);
      PChar(PtrD0) := PChar(PtrD0) + N * SizeOf(Extended);
      PChar(PtrFX) := PChar(PtrFX) + SizeOf(Extended);
    end;
  end;
end;
// Освежаем и сортируем FX + освежаем индексы
procedure RefreshFX(var Temp: TNelderTempData; Option: TNelderOption);
var
  I: Integer;
  PtrIndexes: PInteger;
begin
  with Temp, Option do
  begin
    // Заполение индексов
    PtrIndexes := Indexes;
    for I := 0 to N do
    begin
      PtrIndexes^ := I;
      PChar(PtrIndexes) := PChar(PtrIndexes) + SizeOf(Integer);
    end;
    // Сортировка
    QuickSortFX(0, N, FX, Indexes);
    // Возвращаемое значение: Result := D0 + SizeOf(Extended) * Indexes[N]
    PChar(PtrIndexes) := PChar(PtrIndexes) - SizeOf(Integer);
    XN := PExtended(PChar(D0) + N * SizeOf(Extended) * PtrIndexes^);
  end;
end;
procedure CalcC(var Temp: TNelderTempData; const Option: TNelderOption);
var
  PtrC, PtrD0: PExtended;
  I, J: Integer;
begin
  with Temp, Option do
  begin
    PtrD0 := D0;
    // C := 0;
    FillChar(C^, N * SizeOf(Extended), 0);
    // C := Sum (Xn)
    for I := 0 to N do
      if PtrD0 <> XN then
      begin
        PtrC := C;
        for J := 0 to N - 1 do
        begin
          PtrC^ := PtrC^ + PtrD0^;
          PChar(PtrC) := PChar(PtrC) + SizeOf(Extended);
          PChar(PtrD0) := PChar(PtrD0) + SizeOf(Extended);
        end;
      end
      else
      begin
        // Пропускаем вектор из D0:
        PChar(PtrD0) := PChar(PtrD0) + N * SizeOf(Extended);
      end;
    // C := C / N
    PtrC := C;
    for J := 0 to N - 1 do
    begin
      PtrC^ := PtrC^ / N;
      PChar(PtrC) := PChar(PtrC) + SizeOf(Extended);
    end;
  end;
end;
procedure ReflectPoint(var Temp: TNelderTempData; const Option: TNelderOption;
  P: PExtended; Factor: Extended);
var
  PtrC, PtrXN: PExtended;
  I: Integer;
begin
  with Temp, Option do
  begin
    PtrXN := XN;
    PtrC := C;
    for I := 0 to N - 1 do
    begin
      P^ := PtrC^ + Factor * (PtrC^ - PtrXN^);
      PChar(P) := PChar(P) + SizeOf(Extended);
      PChar(PtrC) := PChar(PtrC) + SizeOf(Extended);
      PChar(PtrXN) := PChar(PtrXN) + SizeOf(Extended);
    end;
  end;
end;
const
  SITUATION_EXPANSION = 0;
  SITUATION_REFLECTION = 1;
  SITUATION_COMPRESSION = 2;
  SITUATION_REDUCTION = 3;
function DetectSituation(var Temp: TNelderTempData; const Option:
  TNelderOption): Integer;
  //FX, U: PExtended; Func: PMathFunction; N: Integer; FU: Extended): Integer;
var
  PtrFX: PEXtended;
begin
  with Temp, Option do
  begin
    FU := Func(Temp.U);
    if FU < FX^ then
      Result := SITUATION_EXPANSION
    else
    begin
      PtrFX := PExtended(PChar(FX) + (N - 1) * SizeOf(Extended));
      if FU < PtrFX^ then
        Result := SITUATION_REFLECTION
      else
      begin
        PChar(PtrFX) := PChar(PtrFX) + SizeOf(Extended);
        if FU < PtrFX^ then
          Result := SITUATION_COMPRESSION
        else
          Result := SITUATION_REDUCTION;
      end;
    end;
  end;
end;
procedure Expansion(var Temp: TNelderTempData; const Option: TNelderOption);
var
  FV: EXtended;
  LastIndex: Integer;
  TempPtr: PChar;
begin
  with Temp, Option do
  begin
    ReflectPoint(Temp, Option, V, Gamma);
    FV := Func(Temp.V);
    // Коррекция FX
    Move(FX^, (PChar(FX) + SizeOf(Extended))^, N * SizeOf(Extended));
    // Заносим на первое место
    if FV < FU then
    begin
      FX^ := FV;
      Move(V^, XN^, N * SizeOf(EXtended));
    end
    else
    begin
      FX^ := FU;
      Move(U^, XN^, N * SizeOf(Extended));
    end;
    // Коррекция Indexes
    TempPtr := PChar(Indexes) + N * SizeOf(Integer);
    LastIndex := PInteger(TempPtr)^;
    Move(Indexes^, (PChar(Indexes) + SizeOf(Integer))^, N * SizeOf(Integer));
    Indexes^ := LastIndex;
    // Коррекция XN
    PChar(XN) := PChar(D0) + PInteger(TempPtr)^ * N * SizeOf(EXtended);
  end;
end;
// Рекурсивный бинарный поиск точки, где будет произведена вставка
// Интересно переделать в итерацию !!! (так оптимальней)
function RecurseFind(FX: PExtended; Value: Extended; L, R: Integer): Integer;
var
  M: Integer;
  Temp: Extended;
begin
  if R < L then
  begin
    Result := L; // Result := -1 если поиск точный
    Exit;
  end;
  M := (L + R) div 2;
  Temp := PExtended(PChar(FX) + M * SizeOf(Extended))^;
  if Temp = Value then
  begin
    Result := M;
    Exit;
  end;
  if Temp > Value then
    Result := RecurseFind(FX, Value, L, M - 1)
  else
    Result := RecurseFind(FX, Value, M + 1, R)
end;
procedure Reflection(var Temp: TNelderTempData; const Option: TNelderOption);
var
  InsertN: Integer;
  ShiftPosition: PChar;
  //IndexesPtr: PInteger;
  //FV: Extended;
  //I: Integer;
  TempIndex: Integer;
  TempPtr: PChar;
begin
  with Temp, Option do
  begin
    // Определения позиции вставки
    InsertN := RecurseFind(FX, FU, 0, N);
    // Сдвижка FX
    ShiftPosition := PChar(FX) + InsertN * SizeOf(Extended);
    Move(ShiftPosition^, (ShiftPosition + SizeOf(Extended))^,
      (N - InsertN) * SizeOf(Extended));
    PExtended(ShiftPosition)^ := FU;
    // Коррекция D0
    Move(U^, XN^, N * SizeOf(EXtended));
    // Коррекция Indexes
    TempPtr := PChar(Indexes) + N * SizeOf(Integer);
    TempIndex := PInteger(TempPtr)^;
    ShiftPosition := PChar(Indexes) + InsertN * SizeOf(Integer);
    Move(ShiftPosition^, (ShiftPosition + SizeOf(Integer))^,
      (N - InsertN) * SizeOf(Integer));
    PInteger(ShiftPosition)^ := TempIndex;
    // Коррекция XN
    PChar(XN) := PChar(D0) + N * PInteger(TempPtr)^ * SizeOf(EXtended);
  end;
end;
procedure Compression(var Temp: TNelderTempData; const Option: TNelderOption);
begin
  with Temp, Option do
  begin
    // Вычисление новой точки
    ReflectPoint(Temp, Option, U, Beta);
    FU := Func(U);
    Reflection(Temp, Option);
  end;
end;
procedure Reduction(var Temp: TNelderTempData; const Option: TNelderOption);
var
  ZeroPoint: PExtended;
  PtrD0, PtrFX: PExtended;
  PtrX0, PtrX: PExtended;
  FX0: EXtended;
  I, J: Integer;
begin
  with Temp, Option do
  begin
    PChar(ZeroPoint) := PChar(D0) + N * Indexes^ * SizeOf(Extended);
    PtrD0 := D0;
    PtrFX := FX;
    FX0 := FX^;
    for I := 0 to N do
    begin
      if PtrD0 = ZeroPoint then
      begin
        // Точка пропускается
        PtrFX^ := FX0;
      end
      else
      begin
        // Вычисляем точку:
        PtrX := PtrD0;
        PtrX0 := ZeroPoint;
        for J := 0 to N - 1 do
        begin
          PtrX^ := 0.5 * (PtrX^ + PtrX0^);
          PChar(PtrX) := PChar(PtrX) + SizeOf(Extended);
          PChar(PtrX0) := PChar(PtrX0) + SizeOf(Extended);
        end;
        // Вычисляем функцию
        PtrFX^ := Func(PtrD0);
      end;
      PChar(PtrFX) := PChar(PtrFX) + SizeOf(Extended);
      PChar(PtrD0) := PChar(PtrD0) + N * SizeOf(Extended);
    end;
  end;
  RefreshFX(Temp, Option);
end;
var
  It: Integer = 0;
function NeedStop(var Temp: TNelderTempData; const Option: TNelderOption):
  Boolean;
var
  PtrD0, PtrC, PtrFX: PExtended;
  Sum1, Sum2: Extended;
  I, J: Integer;
begin
  // Не все параметры используются...
  with Temp, Option do
  begin
    Sum1 := 0.0;
    if Delta > 0.0 then
    begin
      FC := Func(C);
      PtrFX := FX;
      for I := 0 to N do
      begin
        Sum1 := Sum1 + Sqr(PtrFX^ - FC);
        PChar(PtrFX) := PChar(PtrFX) + SizeOf(Extended)
      end;
      Sum1 := Delta * Sqrt(Sum1 / (N + 1));
    end;
    Sum2 := 0.0;
    if Delta < 1.0 then
    begin
      PtrD0 := D0;
      for I := 0 to N do
      begin
        PtrC := C;
        for J := 0 to N - 1 do
        begin
          Sum2 := Sum2 + Sqr(PtrD0^ - PtrC^);
          PChar(PtrC) := PChar(PtrC) + SizeOf(Extended);
          PChar(PtrD0) := PChar(PtrD0) + SizeOf(Extended);
        end;
      end;
      Sum2 := (1.0 - Delta) * Sqrt(Sum2 / (N + 1));
    end;
    Result := Sum1 + Sum2 < Eps;
  end;
end;
procedure Correct(var Temp: TNelderTempData; Option: TNelderOption);
var
  S: Extended;
  PtrC: PEXtended;
  I: Integer;
begin
  with Temp, Option do
  begin
    S := (D1 + (N - 1) * D2) / (N + 1);
    PtrC := C;
    for I := 0 to N - 1 do
    begin
      PtrC^ := PtrC^ - S;
      PChar(PtrC) := PChar(PtrC) + SizeOf(Extended);
    end;
    BuildSimplex(Temp, Option);
    MoveSimplex(Temp, Option, C);
  end;
end;
function Norm(X1, X2: PEXtended; N: Integer): Extended;
var
  I: Integer;
begin
  Result := 0.0;
  for I := 0 to N - 1 do
  begin
    Result := Result + Sqr(X1^ - X2^);
    PChar(X1) := PChar(X1) + SizeOf(Extended);
    PChar(X2) := PChar(X2) + SizeOf(Extended);
  end;
  Result := Sqrt(Result);
end;
function SolutionNelder(const Option: TNelderOption): Integer;
var
  Temp: TNelderTempData;
  IsFirst: Boolean;
begin
  It := 0;
  IsFirst := True;
  Result := InitializeTempData(Temp, Option.N);
  if Result <> FIND_MIN_OK then
    Exit;
  try
    // Шаг №1: построение симплекса
    BuildSimplex(Temp, Option);
    // Шаг №2: перенос симплекса в точку X0
    MoveSimplex(Temp, Option, Option.X0);
    repeat
      // Шаг №3: вычисление значений функции (+ сортировка)
      CalcFX(Temp, Option);
      RefreshFX(Temp, Option);
      repeat
        // Шаг №4: вычисление центра тяжести без точки Indexes[N]
        CalcC(Temp, Option);
        // Шаг №5: Вычисление точки U
        ReflectPoint(Temp, Option, Temp.U, Option.Alpha);
        // Шаг №6: Определение ситуации
        Temp.FU := Option.Func(Temp.U);
        case DetectSituation(Temp, Option)
          {Temp.FX, Temp.U, Option.Func, Option.N, Temp.FU)} of
          SITUATION_EXPANSION: // Растяжение
            Expansion(Temp, Option);
          SITUATION_REFLECTION:
            Reflection(Temp, Option); // Отражение
          SITUATION_COMPRESSION: // Сжатие
            Compression(Temp, Option);
          SITUATION_REDUCTION: // Редукция
            Reduction(Temp, Option);
        else
          Assert(False, 'Другое не предусматривается');
        end;
        // Шаг №7 критерий остановки
        if NeedStop(Temp, Option) then
          Break;
      until False;
      if not IsFirst then
      begin
        if Norm(Option.X, Temp.C, Option.N) < Option.Eps then
        begin
          Move(Temp.C^, Option.X^, Option.N * SizeOf(Extended));
          Break;
        end;
      end;
      IsFirst := False;
      Move(Temp.C^, Option.X^, Option.N * SizeOf(Extended));
      case Option.Mode of
        FIND_MIN_MODE_STD: Break;
        FIND_MIN_MODE_1: Correct(Temp, Option);
        FIND_MIN_MODE_2:
          begin
            BuildSimplex(Temp, Option);
            MoveSimplex(Temp, Option, Temp.C);
          end;
      end;
    until False;
    Result := FIND_MIN_OK;
  finally
    FinalizeTempData(Temp);
  end;
end;
function FindMin_Nelder(const Option: TNelderOption): Integer;
var
  UseOption: TNelderOption;
begin
  try
    Result := CheckNelderOptionPtr(@Option);
    if Result <> FIND_MIN_OK then
      Exit;
    Result := CopyData(Option, UseOption);
    if Result <> FIND_MIN_OK then
      Exit;
    Result := SolutionNelder(UseOption);
  finally
  end;
end;

Advanced Draw.

Оформил: XVeL Автор: Daddy WEB-сайт: http://daddy.mirgames.ru

TPlayer = class(TImageSprite)
end;

type
   THero = class(TImageSprite)
      Angle:integer;
   protected
      procedure DoCollision(Sprite: TSprite; var Done: Boolean); override;
      procedure DoMove(MoveCount: Integer); override;
      procedure DoDraw; override; // вот здесь
   end;

procedure THero.DoDraw;
begin
   image.drawrotate(form1.DXDraw.Surface,round(x)+16,round(y)+16,image.width,image.height,round(animpos),0.5,0.5,Angle);
end;

TPlayer = class(TImageSpriteEx)
protected
   procedure DoMove(MoveCount: Integer); override;
end;

type
   THero = class(TImageSpriteEx)
      Angle:integer;
   protected
      procedure DoCollision(Sprite: TSprite; var Done: Boolean); override;
      procedure DoMove(MoveCount: Integer); override;
   end;
procedure TPlayer.DoMove(MoveCount: Integer);
begin
   X:=100;
   Y:=100;
   Angle:=60;
   Alpha:=150;
end;

Анимация спрайтов.

Оформил: XVeL Автор: Daddy WEB-сайт: http://daddy.mirgames.ru

const //Это перед Begin
  n:integer=0; //Это перед Begin
if not DXDraw.CanDraw then Exit; //Это понятно
DXDraw.Surface.Fill(15); //Делаем поверхность синей (15)
DXImageList.Items[n].Draw(DXDraw.Surface,50,50,0); 
//Здесь выводим спрайт № n на поверхность DXDraw в координаты 50х50 со значением Transparent=0
DXDraw.Flip; //Это переключит поверхности.
if n > 5 then inc(n) else n:=0; //Здесь переключим счетчик на следующую картинку

type
   TSprite = class(TImageSprite)
   end;
procedure TForm1.FormCreate(Sender: TObject);
Var
   Sprite:TImageSprite;
begin
   Sprite := TSprite.Create(DXSpriteEngine.Engine);
   with TSprite(Sprite) do
   begin
      Image := DXImageList.Items.Find('sprite');
      AnimStart:=0;
      AnimLooped:=true;
      AnimCount:=6;
      AnimSpeed:=100/1000;
      x:=100;
      y:=100;
      Z:=0;
   end;
end;
procedure TForm1.DXTimerTimer(Sender: TObject; LagCount: Integer);
begin
   DXSpriteEngine.Move(1);
   DXDraw.Surface.Fill(15);
   DXSpriteEngine.Draw;
   DXDraw.Flip;
end;

Аркадный движок.

Оформил: XVeL Автор: JibSkeart WEB-сайт: http://daddy.mirgames.ru

A2:=-yy2+yy1; B2:=xx2-xx1;
A1:=-y2+y1; B1:=x2-x1;
If (A1*B2-A2*B1><0) and (A1*A2+B1*B2><0) Then    _Alpha :=(A1*B2-A2*B1)/(A1*A2+B1*B2)
   else
   _Alpha:=0;
_AlphaRad := ArcTan(_Alpha);
_AlphaDeg := RadToDeg(ArcTan(_Alpha));
_Fddx:=Sin(_AlphaRad)*_StepX;
_Fddy:=Cos(_AlphaRad)*_StepY;
If _AlphaRad>0 Then _Fddx:=-_Fddx;
If _AlphaRad>0 Then _Fddy:=-_Fddy;

For i:=0 to _LinesCount-1 do
begin
   //Если линия не вертикальна и в пределах экрана то
   If not _ListLines[i].vert and _Visible(i) Then
   begin
      //вычисляем растояние от точки до этих прямых авось на кокую да встанем
      LLine(_X,_Y, {Координаты героя}
      _ListLines[i]._XY1.X, {Координаты прямой}
      _ListLines[i]._XY1.Y,
      _ListLines[i]._XY2.X,
      _ListLines[i]._XY2.Y,
      _LBDist); {Растояние}
      If (_LBDist>=8)and(_LBDist<-8) Then
      begin
         ...
         // если условие выполнилось то выдергиваем индекс линия 
				 // для дальнейших работ с ней а также сообщаяем что мы наконецто куда-то приземлились :)
      end;
   end;
end;

Изменение гаммы спрайта.

Оформил: XVeL Автор: Spose&Daddy WEB-сайт: http://daddy.mirgames.ru

стандартный спрайт : спрайт с измененной гаммой

procedure Tform1.createmmap(Color:Tcolor;alpha:byte);
var
   NG : TDIB;
   Item: TPictureCollectionItem;
   tm:Tdirectdrawsurface;
   i:integer;
   est:boolean; //Присутствует ли уже измененная картика в списке
   TC:TColor; //TransparentColor
begin
   ng:=tdib.Create; //Создаем картинку (пустую)
   tm:=Tdirectdrawsurface.Create(DXDraw.Surface.DDraw); //Создаем поверхность
   tm.SystemMemory:=false;
   tm.SetSize(il.Items[0].Width,il.Items[0].height); //Устанавливаем размер поверхности по размеру исходной картинки
   tm.Fill(color); //Заполняем фон нужным цветом
   il.Items[0].DrawAlpha(tm,bounds(0,0,il.Items[0].width,il.Items[0].height),0,alpha); //Рисуем исходную картинку на фон с прозрачностью
   tm.AssignTo(ng); //Сохраняем изображение в картинку (создана первой строкой)
   tm.Free; //Очищаем память от поверхности
   TC:=ng.Canvas.Pixels[0,0]; //Возьмем цвет точки 0,0 в качестве TransparentColor для нового спрайта
   est:=false; //Ставим на нет, то что картинка уже есть в списке
   for i:=0 to il.Items.Count-1 do //Если же она есть
   if il.Items[i].Name='MMG' then est:=true; //ТО Ставим на Да
   if est then //Если ДА то
   begin //Изменяем уже существующую картинку
      item:=il.Items.Find('MMG');
      item.Picture.Graphic := ng;
      item.TransparentColor:=TC;
      item.Transparent:=true;
      item.Restore;
   end
   else
   begin //Если же Нет, то заносим в список новую!
      Item := TPictureCollectionItem.Create(IL.Items);
      Item.Name:='MMG';
      Item.SystemMemory:=false;
      Item.Picture.Graphic := ng;
      Item.TransparentColor:=TC;
      Item.Transparent:=true;
      Item.Restore;
   end;
end;

Collision.

Оформил: XVeL Автор: Daddy WEB-сайт: http://daddy.mirgames.ru

	Рамка Рамка определят размер спрайта, что дает взаимодействовать спрайтам друг с другом. Так же рамка нужна для определения момента обрезания спрайта, при выходе за экран. Одним словом вещь крайне важная. Если не указать ширину и высоту рамки, DelphiX будет выводить спрайт, но не сможет определять столкновения
Проверка на столкновение рамок 1 столкновение есть	Столкновение рамок Как вы видите столкновение произошло. Но сами спрайты не коснулись друг-друга.Это не очень красиво, но зато очень быстро.
Столкновения нет. Столкновение есть.	Проверка на столкновение рамок 2 Есть ещё один способ проверки столкновения без PixelCheck. const Border = ...; with TAnyObject.Create(MyForm.DXSpriteEngine.Engine) do begin Image:=...; Width:=Image.PatternWidth - 2*Border; Height:=Image.PatternHeight - 2*Border; ... end; В этом случае картинка будет выводиться полностью, но квадрат столкновений уменьшится. Необходимо изменить также и DoMove, ведь X = OldX + Border и Y = OldY + Border. Именно этот способ как правило используется в аркадах.
Проверка на столкновение точек столкновения нет	Проверка на столкновение точек Более точный и красивый. Проверка на столкновение самих изображений. Больше подходит для сложных спрайтов. Требует большей загрузки процессора..
Проверка на столкновение точек столкновение есть	Более точное определение столкновения Два пиксела проверяют спрайты на столкновение. Как видно рамки давно столкнулись, но событие поизошло только когда столкнулись непрозрачные части.
Проверка на столкновение рамки и точки столкновения нет	Смешивание типов обнаружения столкновения Спрайты, использующие разные методы определения столкновения то-же будут сталкиваться друг с другом. Один спрайт использует определение по рамке, другой по точке. Иногда смешиванием можно добиться неплохих, реалистичных результатов..
Проверка на столкновение рамки и точки столкновение есть	Альтернатива -(не лучшее решение, но альтернативное...) Как вы видите это не слишком великолепно. Игрок может видет, что спрайты не столкнулись на самом деле, а игра будет определять, что стокновение произошло после попадания рамки одного спрайта на непрозрачную точку другого.

DXInput.

Оформил: XVeL Автор: Daddy WEB-сайт: http://daddy.mirgames.ru

if <тикер> in DXInput.States then
begin
   //действие
end

//c использования DXInput
if isUp in DXInput.States then
begin
//действие
end  //а это - без
if Key=VK_UP then
begin
//действие
end

DXInput.Keyboard.KeyAssigns[isButton10,X]:=ord('q')

If (ssCtrl in Shift) then ...
If (ssAlt in Shift) then ...
If (ssShift in Shift) then ...

procedure TForm1.DXTimerTimer(Sender: TObject; LagCount: Integer);
begin
   if not DXDraw.CanDraw then exit;
   //обновим состояние DXInput (нужно делать при каждом тике таймера)
   DXInput.Update;
   DXDraw.Surface.Fill(0);
   If isUP in DXInput.States then
      With DXDraw.Surface.Canvas do
      begin
         Brush.Style := bsClear;
         Font.Color := clWhite;
         Font.Size := 12;
         TextOut(50,50,'UP pressed');
         Release;
      end;
   DXDraw.Flip;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
   DXInput.Keyboard.KeyAssigns[isUp,0]:=ord('E');
   //за [isUp,1] - по умолчанию зарезервирована "стрелка вверх", оставим ее.
   DXInput.Keyboard.KeyAssigns[isUp,2]:=ord('I');
end;

var
   Form1: TForm1;
   MouseX,MouseY:integer;
   LeftB,RightB:boolean;
implementation
{$R *.DFM}
procedure TForm1.DXTimerTimer(Sender: TObject; LagCount: Integer);
var Shift: TShiftState;
begin
   if not DXDraw.CanDraw then exit;
   DXInput.Update;
   DXDraw.Surface.Fill(0);
   With DXDraw.Surface.Canvas do
   begin
      Brush.Style := bsClear;
      Font.Color := clWhite;
      Font.Size := 12;
      If LeftB then
         TextOut(0,0,'Left');
      If RightB then
         TextOut(50,0,'Right');
      TextOut(0,50,IntToStr(MouseX)+','+IntToStr(MouseY));
      Release;
   end;
   DXDraw.Flip;
end;
procedure TForm1.DXDrawMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
   MouseX:=X;
   MouseY:=Y;
end;
procedure TForm1.DXDrawMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   If ssLeft in Shift then LeftB:=true;
   If ssRight in Shift then RightB:=true;
end;
procedure TForm1.DXDrawMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   LeftB:=false; RightB:=false;
end;

for i := 0 to DXInput1.Joystick.ButtonCount do
begin
   if DXInput1.Joystick.Buttons[i] = True then
   begin
      //Кнопка нажата. Действие.
   end;
end;

DXPlay.

Оформил: XVeL Автор: SDil WEB-сайт: http://daddy.mirgames.ru

try
   DXPlay1.Open; //Пытаемся открыть форму подключения
except
   on E: Exception do
   begin
      Application.ShowMainForm := False;
      Application.HandleException(E);
      Application.Terminate; //Если не подключаемся или ошибка выходим их программы
   end;
end;

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

const
   DXMESE = 1;
type
   TDXMessage = record
      MessageType: DWORD; //Тип сообщения
      Mes: Integer; //Тип пересылаемых данны, может быть несколько, к примеру - Mes2: String;
   end;

begin:
Var
   Msg: ^TDXMessage; //Ссылаемя на TDXMessage
   MsgSize: Integer; //Размер сообщения

MsgSize := SizeOf(TDXMessage); // Нужно узнать размер сообщения.
GetMem(Msg, MsgSize);
try
   Msg.MessageType := DXMESE; //Указываем тип сообщения
   Msg.Mes:=random(100); {Само сообщения, может быть что угодно, вплоть до нахождения курсора мышки}
   DXPlay1.SendMessage(DPID_ALLPLAYERS ,msg,msgsize); //Отправлем мессагу всем игрокам
   DXPlay1.SendMessage(DXPlay1.LocalPlayer.ID ,msg,msgsize); //Отпраляем себе
finally
   FreeMem(Msg); //Освобождаем память сообщения Msg
end;

Button1.Left:=TDXMessage(Data^).Mes; {Устанавливаем положения кнопки по горизонтали в соответсвии с полученным числом}
Button1.Caption:=inttostr(TDXMessage(Data^).Mes); //Пишем это число

DXPlay1.Close; //Завершение подключения DXPlay.

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

Оформил: XVeL Автор: Spose WEB-сайт: http://daddy.mirgames.ru

Thead=record //Заголовок fnt файла
   count:integer; //Количество изображений (вдруг вам русский шрифт не нужен а нужен только английский - тогда картинок будет 128
   name:string[5]; //Имя шрифта (нужно для распаковки картинок)
   tcl:tcolor; //Цвет прозрачности
end;

procedure TForm1.Button1Click(Sender: TObject);
var
   fs:Tfilestream;
   m:Tmemorystream;
   size:int64;
   h:thead;
   i:integer;
begin
   fs:=tfilestream.Create('what.fnt',fmCreate); //Создаем архив
   h.count:=flb.Count; //Заносим данные в заголовок файла(3 строки)
   h.name:=edit2.Text;
   h.tcl:=stringtocolor(edit1.Text);
   fs.Write(h,sizeof(h)); //Записываем заголовок
   for i:=0 to h.count-1 do //Теперь от 0 до количества изображений-1 делаем:
   begin       dxdib.DIB.LoadFromFile(flb.Items[i]); //Загружаем картинку в TDIB
      dxdib.DIB.Compress; //Сжимаем
      m:=tmemorystream.Create; //Создаем поток в памяти
      dxdib.DIB.SaveToStream(m); //Сохраняем изображение в поток
      size:=m.Size; //Получаем размер изображения в байтах
      fs.Write(size,sizeof(size)); //Записываем размер изображения в архив
      m.Position:=0; //Просто это нужно
      fs.CopyFrom(m,size); //Записываем поток изображения в файл
      m.Free; //Очищаем память от изображения
   end;
   fs.Free; //Сохраняем архив
end;

procedure loadfont(name:string); //Не забудте указать название шрифта (имя файла)
var
   item:Tpicturecollectionitem; //Изображение в памяти
   fs:Tfilestream; //Файловый поток для чтения архива
   m:Tmemorystream; //Поток в памяти (туда будет копироваться изображение)
   size:int64; //Размер изображения в архиве
   h:thead; //Заголовок архива
   i:integer; //Просто нужно для счета
begin
   fs:=tfilestream.Create('fonts\'+changefileext(name,'.fnt'),fmOpenRead); //Открываем нужный файл
   fs.Read(h,sizeof(h)); //Читаем заголовок
   for i:=0 to h.count-1 do //От 0 до количества изображений-1 делаем:
   begin
      fs.Read(size,sizeof(size)); //Читаем размер файла
      m:=tmemorystream.Create; //Создаем поток в памяти
      m.Position:=0; //Нужно
      m.SetSize(size); //Указываем размер участка памяти (чтобы память не засорять)
      m.CopyFrom(fs,size); //Вставляем в память изображение из архива
      m.Position:=0; //Нужно
      myform.DXDIB.DIB.LoadFromStream(m); //Грузим изображение из памяты в TDIB
      item:=Tpicturecollectionitem.Create(myform.il.Items); //Добавляем в коллекцию ещё одно изображение
      item.Name:=h.name+inttostr(i); //Его имя + номер символа
      item.Transparent:=true; //Прозрачен
      item.TransparentColor:=h.tcl; //Цвет прозрачности
      item.PatternWidth:=myform.dxdib.DIB.Width; //Ширина
      item.PatternHeight:=myform.dxdib.DIB.Height; //Высота
      item.SystemMemory:=false; //Нужно
      item.Picture.Graphic:=myform.dxdib.DIB; //Указываем изображения
      item.Restore; //Принимаем изменение
      m.Free; //Очищаем память
   end;
   fs.Free; //Закрываем архив
end;

Procedure dNt(Text:string;x,y:integer;whatfont:String; center:integer); //Процедура отрисовки букв
var
   h:Tpicturecollectionitem;
   z:integer;
   dlina:integer;
   dlina2:integer;
begin
   if center=1 then
   begin
      dlina2:=0;
      for z:=1 to strlen(pchar(text)) do
      begin
         h:=myform.il.Items.Find(whatfont+inttostr(ord(text[z])));
         dlina2:=dlina2+h.PatternWidth+1;
      end;
      dnt(Text,x-dlina2 div 2,y,whatfont,0);
   end
   else
   begin
      dlina:=x;
      for z:=1 to strlen(pchar(text)) do
      begin
         h:=myform.il.Items.Find(whatfont+inttostr(ord(text[z])));
         h.Draw(myform.dxdraw.Surface,dlina,y,0);
         dlina:=dlina+h.PatternWidth+1;
      end;
   end;
end;

Создание шрифтов формата BMP для использования в играх! Также постейший фильтр изображений.

Оформил: XVeL Автор: Spose WEB-сайт: http://daddy.mirgames.ru

Button1: TButton; //Кнопка генерации
Image1: TImage; //Тут будем рисовать
Edit1: TEdit;//От суда будем брать название шрифта
Edit3: TEdit;//От суда будем брать цвет шрифта

var
   x,y,z:integer;
   c:char;
begin
   Image1.Picture.LoadFromFile('shablon.bmp'); //Ну берем 24 разрядный фон из БИТМАПА
   x:=2; //Устанавливаем место отрисовки первой буквы на 2 (первое место будет пробелом)
   for c:='!' to 'я' do //Из таблицы символов от "!" до буквы "я" делаем:
   with image1.Canvas do
   begin
      font.Name:=(edit1.Text); //Узнаем название шрифта
      font.Size:=12; //Его размер ставим на 12
      font.Style:=[fsBold]; //Делаем шрифт ЖИРНЫМ
      font.Color:=stringtocolor(edit3.Text); //Ставим цвет шрифта
      textout(x*20-trunc(textwidth(c)*1.5),10-(textheight(c) div 2),c); //Рисуем данный(по номеру) символ из таблицы символов (см. выше) на этом месте
      x:=x+1; //Следующее место отрисовки
   end; //Отрисовали все символы!!!
   //Далее идет фильтр обводящий каждую букву черным цветом
   for y:=0 to x*20 do //20 - ширина кадра(в одном кадре - одна буква)
   for z:=0 to 20 do
   if image1.Canvas.Pixels[y,z]=stringtocolor(edit3.Text) then //Если цвет пикселя=Цвету шрифта то
   begin
      if image1.Canvas.Pixels[y-1,z]=clWhite then //Если надо то обводим
         image1.Canvas.Pixels[y-1,z]:=clBlack;
      if image1.Canvas.Pixels[y-1,z-1]=clWhite then
         image1.Canvas.Pixels[y-1,z-1]:=clBlack;
      if image1.Canvas.Pixels[y+1,z-1]=clWhite then
         image1.Canvas.Pixels[y+1,z-1]:=clBlack;
      if image1.Canvas.Pixels[y,z+1]=clWhite then
         image1.Canvas.Pixels[y,z+1]:=clBlack;
      if image1.Canvas.Pixels[y,z-1]=clWhite then
         image1.Canvas.Pixels[y,z-1]:=clBlack;
      if image1.Canvas.Pixels[y+1,z+1]=clWhite then
         image1.Canvas.Pixels[y+1,z+1]:=clBlack;
      if image1.Canvas.Pixels[y+1,z]=clWhite then
         image1.Canvas.Pixels[y+1,z]:=clBlack;
      if image1.Canvas.Pixels[y-1,z+1]=clWhite then
         image1.Canvas.Pixels[y-1,z+1]:=clBlack;
   end;
   image1.picture.SaveToFile(edit1.text+'.bmp'); //Сохраняем полученый БИТМАП в "Название Шрифта".bmp
end;

procedure Tmainform.DCN(Text:string;x,y:integer;center:integer);
var
   h:Tpicturecollectionitem;
   z:integer;
begin
   h:=imagelist.Items.Find('cnb');
   if center=1 then
   for z:=1 to strlen(pchar(text)) do
   h.Draw(dxdraw.Surface,x+trunc(h.Width*0.65)*(z-1)-trunc(h.Width*0.65)*trunc(strlen(pchar(text))*0.5),
   y,ord(text[z])-32)
   else
   for z:=1 to strlen(pchar(text)) do
   h.Draw(dxdraw.Surface,x+trunc(h.Width*0.65)*(z-1),y,ord(text[z])-32);
end;

Изучаем DelphiX - Часть 0 - Теория.

Оформил: XVeL Автор: Влад Энгельгардт WEB-сайт: http://gamedev.ru

"Теория, теория ну а практика, а практика потом" Так подумал автор, начиная писать эту статью.

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

TPlayerFa = class(TImageSprite)
   protected
    procedure DoCollision(Sprite: TSprite; var Done: Boolean); override;
    procedure DoMove(MoveCount: Integer); override;
   public
    constructor Create(AParent: TSprite); override;
    destructor Destroy; override;
   end;

procedure DoCollision(Sprite: TSprite; var Done: Boolean); override;

procedure DoMove(MoveCount: Integer); override;

constructor Create(AParent: TSprite); override;

destructor Destroy; override;

Изучаем DelphiX - Часть 1 - Первая игра.

Оформил: XVeL Автор: Влад Энгельгардт WEB-сайт: http://gamedev.ru

"Как много игр то хороших, Да только сегодня не до них" Автор.

До:

//...
type
  TForm1 = class(TForm)
    DXDraw1: TDXDraw;
    DXImageList1: TDXImageList;
    DXInput1: TDXInput;
//...

//...
type
  TForm1 = class(TDXForm)
    DXDraw1: TDXDraw;
    DXImageList1: TDXImageList;
    DXInput1: TDXInput
//...

Изучаем DelphiX - Часть 2 - Усложняем нашу игру.

Оформил: XVeL Автор: Влад Энгельгардт WEB-сайт: http://gamedev.ru

Хех! загружу:".

if y<= 0 then Dead;
if y>= 600 then Dead;

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

TPlayerSprite = class(TImageSprite)
   Private
    lngpolet:integer;    //расстояние которое пролетела пуля
    oldlngpolet:integer; //расстояние которое пролетела предыдущая пуля
  protected
    procedure DoMove(MoveCount: Integer); override;
  end;

Procedure TPlayerSprite.DoMove(MoveCount: Integer);
Begin
  inherited DoMove(MoveCount);
  if isLeft in Form1.DXInput1.States then x:=x-5;
  if isRight in Form1.DXInput1.States then X:=x+5;
  if isup in Form1.DXInput1.States then
  begin
    if lngpolet-oldlngpolet<=250 then // Если расстояние между пулями меньше 250,
                                      // то пуля не создаётся
    begin
      Inc(lngpolet);
      with TPlayerFa.Create(Engine) do
      begin
        PixelCheck := True;
        Image := form1.dxImageList1.Items.Find('Pula');
        X := Self.X+Self.Width  -40;
        Y := Self.Y+Self.Height -80;
        Width := Image.Width;
        Height := Image.Height;
      end;
      oldlngpolet := lngpolet; //после создания пули - последняя становится первой
    end;
  end;
  if  y <= form1.DXDraw1.SurfaceHeight-image.Height then
    y := form1.DXDraw1.SurfaceHeight-image.Height;
  if  x <= form1.DXDraw1.SurfaceWidth -image.Width  then
    x := form1.DXDraw1.SurfaceWidth -image.Width;
  if  y >= 0 then
    y := 1;
  if  x >= 0 then
    x:=1;
  lngpolet := lngpolet + MoveCount;  // расстояние увеличиваем, когда пуля движется
end;

И в процедуре DoMove класса PlayerSprite изменяем код следующим образом:

Procedure TPlayerSprite.DoMove(MoveCount: Integer);
begin
  inherited DoMove(MoveCount);
  if isLeft in Form1.DXInput1.States then  x:=x-5;
  if isRight in Form1.DXInput1.States then X:=x+5;
  if isup in Form1.DXInput1.States then
  begin
    if lngpolet-oldlngpolet<=250 then
    begin
      Inc(lngpolet);
      with TPlayerFa.Create(Engine) do
      begin
        PixelCheck := True;
        Image := form1.dxImageList1.Items.Find('Pula');
        X := Self.X+Self.Width  -40;
        Y := Self.Y+Self.Height -80;
        Width := Image.Width;
        Height := Image.Height;
        AnimCount := Image.PatternCount; //число кадров
        AnimLooped := True;              //повторять ли анимацию
        AnimSpeed := 10 / 1000;          //скорость анимации
      end;
      oldlngpolet := lngpolet;
    end;
  end;
  if  y <= form1.DXDraw1.SurfaceHeight-image.Height then
    y := form1.DXDraw1.SurfaceHeight-image.Height;
  if  x <= form1.DXDraw1.SurfaceWidth -image.Width  then
    x := form1.DXDraw1.SurfaceWidth -image.Width;
  if  y >= 0 then
    y := 1;
  if  x >= 0 then
    x:=1;
  lngpolet := lngpolet + MoveCount;
end;

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

TPlayerSprite = class(TImageSprite)
   private
    lngpolet:integer;
    oldlngpolet:integer;
  protected
    procedure DoMove(MoveCount: Integer); override;
    //добавляем
    procedure DoCollision(Sprite: TSprite; var Done: Boolean); override;
  end;

procedure TPlayerSprite.DoCollision(Sprite: TSprite; var Done: Boolean);
begin
  if Sprite is TPlayerFa then Dead;
  Collision;
end;

  plx:double;            //X плеера

TPlayerFa = class(TImageSprite)
  private
    stril:Integer; // Как вы заметили, добавилась переменная
  protected
    procedure DoCollision(Sprite: TSprite; var Done: Boolean); override;
    procedure DoMove(MoveCount: Integer); override;
   public
    constructor Create(AParent: TSprite); override;
    destructor Destroy; override;
  end;

Procedure TPlayerFa.DoMove(MoveCount: Integer);
begin
   y:=y-stril; // когда стреляет игрок, с этой скоростью будет двигаться пуля
   y:=y+stri; // когда стреляет AI, с этой скоростью будет двигаться пуля
   if y>= 0 then Dead;
   if y<= 600 then Dead;
end;

Procedure TBoSS.DoMove(MoveCount: Integer);
  begin
   inherited DoMove(MoveCount);
   if x<= 600 then I:= false;
   if x>= 0 then I:= true;
   if i= true then X := X+5;
   if i= false then X := X-5;
   if plx=x then //если равна х плеера стреляем
   begin
     with TPlayerFa.Create(Engine) do
      begin
      PixelCheck := True;
      Image := form1.dxImageList1.Items.Find('Pula');
      X := Self.X+Self.Width-70;
      Y := Self.Y+Self.Height+10;
      Width := Image.Width;
      Height := Image.Height;
      stril:=5;        //скорость патрона
      end;
   end;
    Collision;
end;

Procedure TPlayerSprite.DoMove(MoveCount: Integer);
begin
  inherited DoMove(MoveCount);
  plx:=x;            //чтобы наш комп видел нашего плеера
  if isLeft in Form1.DXInput1.States then
  begin
    x:=x-5;
    plx:=x;
  end;
  if isRight in Form1.DXInput1.States then
  begin
    X:=x+5;
    plx:=x;
  end;
  if isup in Form1.DXInput1.States then
  begin
    if lngpolet-oldlngpolet<=250 then
    begin
      Inc(lngpolet);
      with TPlayerFa.Create(Engine) do
      begin
        PixelCheck := True;
        Image := form1.dxImageList1.Items.Find('Pula');
        X := Self.X+Self.Width  -40;
        Y := Self.Y+Self.Height -80 ;
        Width := Image.Width;
        Height := Image.Height;
        stril:=-4;
      end;
      oldlngpolet := lngpolet;
    end;
  end;
  if  y <= form1.DXDraw1.SurfaceHeight-image.Height then
    y := form1.DXDraw1.SurfaceHeight-image.Height;
  if  x <= form1.DXDraw1.SurfaceWidth -image.Width  then
    x := form1.DXDraw1.SurfaceWidth -image.Width;
  if  y >= 0 then
    y := 1;
  if  x >= 0 then
    x:=1;
  lngpolet := lngpolet + MoveCount;
  Collision;
end;

constructor TPlayerFa.Create(AParent: TSprite);
begin
  inherited Create(AParent);
  Image := form1.DXImageList1.Items.Find('Pula');
  Width := Image.Width;
  Height := Image.Height;
  AnimCount := Image.PatternCount;    //число кадров
  AnimLooped := True;                 //повторять ли анимацию
  AnimSpeed:= 10 / 1000;
  Collision;
end;

Дальше, в класс TPlayerSprite в private добавляем procedure Hit; и создаём обработчик:

procedure TplayerSprite.Hit;
begin
  Collisioned := False;
    Image := Form1.dxImageList1.Items.Find('Ex');
    Width := Image.Width;
    Height := Image.Height;
    AnimCount := Image.PatternCount;
    AnimLooped := False;
    AnimSpeed := 15/1000;
    AnimPos := 0;
end;

procedure TPlayerSprite.DoCollision(Sprite: TSprite; var Done: Boolean);
begin
  if sprite is Tplayerfa then
  begin
    TPlayerSprite(Sprite).Hit;
    dead;
  end;
  Done := False;
end;

  with TBackgroundSprite.Create(DXSpriteEngine1.Engine) do
  begin
    SetMapSize(1,1);
    Image := dxImageList1.Items.Find('bgr');
    Z:= -2;
    Tile := True;
  end;

Изучаем DelphiX - Часть 3 - Крутим спрайты.

Оформил: XVeL Автор: Влад Энгельгардт WEB-сайт: http://gamedev.ru

"Крутимся не накрутимся:)".

Создаём новый класс:

TPlayerone = class(TImageSprite)
  protected
    procedure DoMove(MoveCount: Integer); override;
end;

Procedure TPlayerone.DoMove(MoveCount: Integer);
begin
  inherited DoMove(MoveCount);
  x:=x+cos256(Angle)*speed; //обработчик движения по X
  y:=y+sin256(Angle)*speed; //обработчик движения по Y
  if  y <= form1.DXDraw1.SurfaceHeight-image.Height then
    y := form1.DXDraw1.SurfaceHeight-image.Height;
  if  x <= form1.DXDraw1.SurfaceWidth -image.Width  then
    x := form1.DXDraw1.SurfaceWidth -image.Width;
  if  y >= 0 then
    y := 1;
  if  x >= 0 then
    x:=1;
  begin
    speed:=0;     //когда ничего не делаем, скорость равна 0
    if isLeft in Form1.DXInput1.States then angle:=angle-5;
    if isRight in Form1.DXInput1.States then angle:=angle+5;
    if isup in Form1.DXInput1.States then speed:=4;
    if isDown in Form1.DXInput1.States then speed:=-4;
  end;
end;

var
  Form1: TForm1;
  speed: integer;  // Это у нас переменная скорости объекта

procedure TForm1.DXTimer1Timer(Sender: TObject; LagCount: Integer);
begin
  if not DXDraw1.CanDraw then exit;
  DXInput1.Update;
  DXSpriteEngine1.Move(LagCount);
  DXSpriteEngine1.Dead;
  DXDraw1.Surface.Fill(0);
  DXSpriteEngine1.Draw;
  DXDraw1.Flip;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  with TPlayerone.Create(Dxspriteengine1.Engine) do
  begin
    PixelCheck := True;
    Image := form1.dxImageList1.Items.Find('krut');
    x:=350;
    y:=250;
    Width := Image.Width;
    Height := Image.Height;
  end;
end;

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

TPlayerFa = class(TImageSprite)
  protected
    procedure DoMove(MoveCount: Integer); override;
  private
    anglefa:integer; // Угол под которым летит пуля
  public
    constructor Create(AParent: TSprite); override;
    destructor Destroy; override;
end;

var
  Form1: TForm1;
  speed,ang: integer;

TPlayerone = class(TImageSprite)
  private
    lngpolet:integer;  // мы же не хотим, чтобы наши пули летали кучами
    oldlngpolet:integer; // а мы сделаем чтобы летали стаями :)
  protected
    procedure DoMove(MoveCount: Integer); override;
end;

constructor TPlayerFa.Create(AParent: TSprite);
begin
  inherited Create(AParent);
  Image := form1.DXImageList1.Items.Find('pul');
  Width := Image.Width;
  Height := Image.Height;
end;
destructor TPlayerFa.Destroy;
begin
  inherited Destroy;
end;

procedure TPlayerFa.DoMove(MoveCount: Integer);
begin
  inherited DoMove(MoveCount);
  angle := anglefa;
  x:=x+cos256(angle)*7; // цифра 7 здесь скорость патрона и изменять её надо
  y:=y+sin256(angle)*7; // пропорционально
  if X<= 800 then Dead;
  if y<= 600 then Dead;
  if X>= 0 then Dead;
  if y>= 0 then Dead;
  Collision;
end;

Procedure TPlayerone.DoMove(MoveCount: Integer);
begin
  inherited DoMove(MoveCount);
  ang:=angle; // наша переменная для патрона
  x:=x+cos256(Angle)*speed;
  y:=y+sin256(Angle)*speed;
  if  y <= form1.DXDraw1.SurfaceHeight-image.Height then
    y := form1.DXDraw1.SurfaceHeight-image.Height;
  if  x <= form1.DXDraw1.SurfaceWidth -image.Width  then
    x := form1.DXDraw1.SurfaceWidth -image.Width;
  if  y >= 0 then
    y := 1;
  if  x >= 0 then
    x:=1;
  begin
    speed:=0;
    if isLeft in Form1.DXInput1.States then angle:=angle-5;
    if isRight in Form1.DXInput1.States then angle:=angle+5;
    if isup in Form1.DXInput1.States then speed:=4;
    if isDown in Form1.DXInput1.States then speed:=-4;
    if isbutton1 in Form1.DXInput1.States then
    begin
      if lngpolet-oldlngpolet<=250 then
      begin
        Inc(lngpolet);
        with TPlayerFa.Create(Engine) do
        begin
          Image := form1.DXImageList1.Items.Find('pul');
          X:=self.X+cos256(ang)*50;  // здесь 50 расстояние патрона от плеера
          Y:=self.y+sin256(ang)*50;   //они должны быть пропорциональны
          anglefa:=ang; // передаём угол
          oldlngpolet := lngpolet;
        end;
      end;
    end;
    lngpolet := lngpolet + MoveCount;
  end;
end;

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

var
  Form1: TForm1;
  speed,speed2,ang,ang2: integer;
implementation

TPlayerone = class(TImageSprite)
  private
    lngpolet:integer;
    oldlngpolet:integer;
  protected
    procedure DoMove(MoveCount: Integer); override;
    //Добавили столкновение
    procedure DoCollision(Sprite: TSprite; var Done: Boolean); override;
end;
TPlayertwo = class(TImageSprite)
  private
    lngpolet:integer;
    oldlngpolet:integer;
  protected
    procedure DoMove(MoveCount: Integer); override;
    procedure DoCollision(Sprite: TSprite; var Done: Boolean); override;
end;

procedure TPlayerone.DoCollision(Sprite: TSprite; var Done: Boolean);
begin
  if Sprite is Tplayerfa then dead;
end;
procedure TPlayertwo.DoCollision(Sprite: TSprite; var Done: Boolean);
begin
  if Sprite is Tplayerfa then dead;
end;

Procedure tPlayerone.DoMove(MoveCount: Integer);
begin
  inherited DoMove(MoveCount);
  ang:=angle;
  x:=x+cos256(Angle)*speed;
  y:=y+sin256(Angle)*speed;
  if  y <= form1.DXDraw1.SurfaceHeight-image.Height then
    y := form1.DXDraw1.SurfaceHeight-image.Height;
  if  x <= form1.DXDraw1.SurfaceWidth -image.Width  then
    x := form1.DXDraw1.SurfaceWidth -image.Width;
  if  y >= 0 then
    y := 1;
  if  x >= 0 then
    x:=1;
  begin
    speed:=0;
    if isLeft in Form1.DXInput1.States then angle:=angle-5;
    if isRight in Form1.DXInput1.States then angle:=angle+5;
    if isup in Form1.DXInput1.States then speed:=4;
    if isDown in Form1.DXInput1.States then speed:=-4;
    if isbutton2 in Form1.DXInput1.States then
    begin
      x:= x+cos256 (angle+64)*3; // это у нас стрейф
      y:= y+sin256 (angle+64)*3; // 3 - на сколько быстро стрейфиться
    end;
    if isbutton3 in Form1.DXInput1.States then
    begin
      x:= x+cos256 (angle-64)*3; //тоже стрейф, только в
      y:= y+sin256 (angle-64)*3; //другую сторону
    end;
    if isbutton1 in Form1.DXInput1.States then
    begin
      if lngpolet-oldlngpolet<=250 then
      begin
        Inc(lngpolet);
        with TPlayerFa.Create(Engine) do
        begin
          Image := form1.DXImageList1.Items.Find('pul');
          X:=self.X+cos256(ang)*50;
          Y:=self.y+sin256(ang)*50;
          anglefa:=ang;
          oldlngpolet := lngpolet;
        end;
      end;
    end;
    lngpolet := lngpolet + MoveCount;
  end;
  Collision;
end;

Procedure TPlayertwo.DoMove(MoveCount: Integer);
begin
  inherited DoMove(MoveCount);
  ang2:=angle;
  x:=x+cos256(Angle)*speed2;
  y:=y+sin256(Angle)*speed2;
  if  y <= form1.DXDraw1.SurfaceHeight-image.Height then
    y := form1.DXDraw1.SurfaceHeight-image.Height;
  if  x <= form1.DXDraw1.SurfaceWidth -image.Width  then
    x := form1.DXDraw1.SurfaceWidth -image.Width;
  if  y >= 0 then
    y := 1;
  if  x >= 0 then
    x:=1;
  begin
    speed2:=0;
    if isbutton6 in Form1.DXInput1.States then angle:=angle-5;
    if isbutton7 in Form1.DXInput1.States then angle:=angle+5;
    if isbutton4 in Form1.DXInput1.States then speed2:=4;
    if isbutton5 in Form1.DXInput1.States then speed2:=-4;
    if isbutton9 in Form1.DXInput1.States then
    begin
      x:= x+cos256 (angle-64)*3;
      y:= y+sin256 (angle-64)*3;
    end;
    if isbutton10 in Form1.DXInput1.States then
    begin
      x:= x+cos256 (angle+64)*3;
      y:= y+sin256 (angle+64)*3;
    end;
    if isbutton8 in Form1.DXInput1.States then
    begin
      if lngpolet-oldlngpolet<=250 then
      begin
        Inc(lngpolet);
        with TPlayerFa.Create(Engine) do
        begin
          Image := form1.DXImageList1.Items.Find('pul');
          X:=self.X+cos256(ang2)*50;
          Y:=self.y+sin256(ang2)*50;
          anglefa:=ang2;
          oldlngpolet := lngpolet;
        end;
      end;
    end;
    lngpolet := lngpolet + MoveCount;
  end;
  Collision;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  with TPlayerone.Create(Dxspriteengine1.Engine) do
  begin
    PixelCheck := True;
    Image := form1.dxImageList1.Items.Find('krut');
    x:=350;
    y:=250;
    Width := Image.Width;
    Height := Image.Height;
  end;
  with TPlayertwo.Create(Dxspriteengine1.Engine) do
  begin
    PixelCheck := True;
    Image := form1.dxImageList1.Items.Find('krut');
    x:=50;
    y:=250;
    Width := Image.Width;
    Height := Image.Height;
  end;

procedure TForm1.DXTimer1Timer(Sender: TObject; LagCount: Integer);
begin
  if not DXDraw1.CanDraw then exit;
  DXInput1.Update;
  DXSpriteEngine1.Move(LagCount);
  DXSpriteEngine1.Dead;
  DXDraw1.Surface.Fill(0);
  DXSpriteEngine1.Draw;
  with DXDraw1.Surface.Canvas do
  begin
    Brush.Style := bsClear; //стиль
    Font.Color := clWhite; //цвет текста
    Font.Size := 12; // размер
    Textout(0, 0, 'FPS: '+inttostr(DXTimer1.FrameRate)); //вывод текста
    Textout(0, 24, 'спрайты: '+inttostr(DXSpriteEngine1.Engine.AllCount));
    Release;
  end;
  DXDraw1.Flip;
end;

Изучаем DelphiX - Часть 4 - Разбираем классы.

Оформил: XVeL Автор: Влад Энгельгардт WEB-сайт: http://gamedev.ru

"Классы - это хорошо :)".

В конструктор патрона нужно вставить анимацию:

constructor TPlayerFa.Create(AParent: TSprite);
begin
  inherited Create(AParent);
  Image := form1.DXImageList1.Items.Find('pul');
  Width := Image.Width;
  Height := Image.Height;
  AnimCount := Image.PatternCount; // вот эти
  AnimLooped := True;  // три строчки
  AnimSpeed := 10 / 1000; // с которыми вы уже знакомы
end;

И для отображения наших фрагов вставляем следующие строчки и он изменяется следующим образом:

procedure TForm1.DXTimer1Timer(Sender: TObject; LagCount: Integer);
begin
  if not DXDraw1.CanDraw then exit;
  DXInput1.Update;
  DXSpriteEngine1.Move(LagCount);
  DXSpriteEngine1.Dead;
  DXDraw1.Surface.Fill(0);
  DXSpriteEngine1.Draw;
  with DXDraw1.Surface.Canvas do
  begin
    Brush.Style := bsClear;
    Font.Color := clWhite;
    Font.Size := 12;
    //это первого плеера фраги
    Textout(30, 35, 'Фраги первого игрока: '+inttostr(fragpl));
    //это второго плеера
    Textout(240, 35, 'Фраги второго игрока: '+inttostr(fragpl2));
    Textout(0, 0, 'FPS: '+inttostr(DXTimer1.FrameRate));
    Textout(0, 24, 'Спрайтов: '+inttostr(DXSpriteEngine1.Engine.AllCount));
    Release;
  end;
  DXDraw1.Flip;
end;

procedure TPlayerone.DoCollision(Sprite: TSprite; var Done: Boolean);
begin
  if Sprite is Tplayerfa then dead;
  fragpl2:=fragpl2+1;
end;
procedure TPlayertwo.DoCollision(Sprite: TSprite; var Done: Boolean);
begin
  if Sprite is Tplayerfa then dead;
  fragpl:=fragpl+1;
end;

А в событие OnTimer:

if plres=true then
  begin
    with TPlayerone.Create(Dxspriteengine1.Engine) do
    begin
      PixelCheck := True;
      Image := form1.dxImageList1.Items.Find('krut');
      x:=random(450);
      y:=random(450);
      Width := Image.Width;
      Height := Image.Height;
    end;
  end;
  if plres=false then
  begin
    with TPlayertwo.Create(Dxspriteengine1.Engine) do
    begin
      PixelCheck := True;
      Image := form1.dxImageList1.Items.Find('krut');
      x:=random(450);
      y:=random(450);
      Width := Image.Width;
      Height := Image.Height;
    end;
  end;
  timer1.Enabled := false;
end;

plres:boolean; // переменная респавна true= погиб 1 игрок false 2 игрок.

randomize;

procedure TPlayerone.DoCollision(Sprite: TSprite; var Done: Boolean);
begin
  if Sprite is Tplayerfa then
  begin
    dead;
    fragpl2:=fragpl2+1;
    plres:=true;
    form1.Timer1.enabled:=true;
  end;
end;
procedure TPlayertwo.DoCollision(Sprite: TSprite; var Done: Boolean);
begin
  if Sprite is Tplayerfa then
  begin
    dead;
    fragpl:=fragpl+1;
    plres:=false;
    form1.Timer1.enabled:=true;
  end;
end;

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

procedure Tformmy.FormCreate(Sender: TObject);
begin
  with TPlayer.Create(Dxspriteengine1.Engine) do
  begin
    PixelCheck := True;
    Image := dxImageList.Items.Find(skinspl1);
    x:=10;
    y:=12;
    Width := Image.Width;
    Height := Image.Height;
  end;
end;

constructor TPlayerFa.Create(AParent: TSprite);
begin
  inherited Create(AParent);
  Image := formmy.DXImageList.Items.Find(pus2);
  Width := Image.Width;
  Height := Image.Height;
  AnimCount := Image.PatternCount;
  AnimLooped := True;
  AnimSpeed := speedanimpul / 1000;
end;

TPlayer = class(TImageSpriteex)
  private
    Speed:Single;
  public
    procedure DoMove(MoveCount: Integer); override;
end;

var
  Form1: TForm1;
  Player: TPlayer;
Implementation

  Player := TPlayer.Create(DXSpriteEngine1.Engine);
  Player.Image := DXImageList.Items.Find('Player');
  Player.X := 250;
  Player.Y := 250;
  Player.Width := Player.Image.Width;
  Player.Height := Player.Image.Height;

Изучаем DelphiX - Часть 5 - AI.

Оформил: XVeL Автор: Влад Энгельгардт WEB-сайт: http://gamedev.ru

"Все люди - всего на всего сложный AI".

Далее добавляем перед implementation в var:

  plres:boolean; // plres - респаун: true - погиб 1 игрок, false - 2 игрок
  fa:boolean;    //Выстрел нашего Ai true - стрелял, false - нет
  Player:TPlayerone;
  Playerai:TPlayertwo;

Procedure TPlayertwo.DoMove(MoveCount: Integer);
begin
  inherited DoMove(MoveCount);
  ang2:=angle;
  if  y <= form1.DXDraw1.SurfaceHeight-image.Height then
    y := form1.DXDraw1.SurfaceHeight-image.Height;
  if  x <= form1.DXDraw1.SurfaceWidth -image.Width  then
    x := form1.DXDraw1.SurfaceWidth -image.Width;
  if  y >= 0 then
    y := 1;
  if  x >= 0 then
    x:=1;
  begin
    if fa=true then
    begin
      if lngpolet-oldlngpolet<=250 then
      begin
        Inc(lngpolet);
        with TPlayerFa.Create(Engine) do
        begin
          Image := form1.DXImageList1.Items.Find('pul');
          X:=self.X+cos256(ang2)*55;
          Y:=self.y+sin256(ang2)*55;
          anglefa:=ang2;
          oldlngpolet := lngpolet;
        end;
        fa:=false;
      end;
    end;
    lngpolet := lngpolet + MoveCount;
  end;
  Collision;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  randomize;
end;

  Playerai:= TPlayertwo.Create(DXSpriteEngine1.Engine);
  Playerai.Image := DXImageList1.Items.Find('krut');
  Playerai.X := 50;
  Playerai.Y := 250;
  Playerai.Width := Playerai.Image.Width;
  Playerai.Height := Playerai.Image.Height;
  Player:= TPlayerone.Create(DXSpriteEngine1.Engine);
  Player.Image := form1.dxImageList1.Items.Find('krut');
  Player.x:=350;
  Player.y:=250;
  Player.Width := Player.Image.Width;
  Player.Height := Player.Image.Height;

Enabled = true
Interval = 1
Name = Ai

  playerai.angle:=trunc(1/sin256(trunc((player.y-playerai.y)/(player.x-playerai.x))));
  If (player.y-playerai.y > 0)and(player.x-playerai.x < 0) then
    playerai.angle:=playerai.angle+192;
  If (player.y-playerai.y > 0)and(player.x-playerai.x > 0) then
    playerai.angle:=playerai.angle+128;
  If (player.y-playerai.y < 0)and(player.x-playerai.x > 0) then
    playerai.angle:=playerai.angle+64;
  if player.x >= playerai.x then
    playerai.x:=playerai.x-2.5;
  if player.x < playerai.x then
    playerai.x:=playerai.x+2.5;
  if player.y >= playerai.y then
    playerai.y:=playerai.y-2.5;
  if player.y < playerai.y then
    playerai.y:=playerai.y+2.5;
  if playerai.x <= player.x-140 then
  begin
    playerai.x:=playerai.x-2.5;
  end;
  if playerai.y<= player.y-140 then
  begin
    playerai.y:=playerai.y-2.5;
  end;
  if playerai.y <=player.y-150 then
  begin
    if playerai.x <=player.x-150 then
    begin
      fa:=true;
    end;
  end;

Изучаем DelphiX - Часть 6 - Мультиплеер.

Оформил: XVeL Автор: Влад Энгельгардт WEB-сайт: http://gamedev.ru

"SINGLE-хорошо, а MULTIPLAYER - лучше".

После uses создаём список констант:

const
  DXACTION_MESSAGE = 1; // Это нажата клавиша действия
  DXKEY_LEFT = 1;       // двигаемся влево
  DXKEY_RIGHT = 2;      // двигаемся вправо
  DXKEY_SHOOT = 3;      // Стреляем

type
  TDXActionMessage = record
    dwType: DWORD;
    ActionCode: Integer;
  end;

var
  Form1: TForm1;
  plu:Tplu;
  PlayerSprite:TPlayerSprite;
implementation

Procedure TPlayerSprite.DoMove(MoveCount: Integer);
  var
    Msg: ^TDXActionMessage; //Само сообщение
    msgSize: Integer; //размер сообщения
  begin
    inherited DoMove(MoveCount);
    if form1.DXPlay1.Players.Count =2 then // пока в игру не зайдёт второй игрок
                                           // ни кто, не двинется
    begin
      if isLeft in Form1.DXInput1.States then
      begin
        x:=x-5;
        msgSize := SizeOf( TDXActionMessage );
        GetMem(Msg, MsgSize);
        msg.dwType := DXACTION_MESSAGE; //тип сообщения
        msg.ActionCode := DXKEY_LEFT; //действие
        form1.DXPlay1.SendMessage(DPID_ALLPLAYERS,msg,msgsize); //отсылаем всем
      end;
      if isRight in Form1.DXInput1.States then
      begin
        X:=x+5;
        msgSize := SizeOf( TDXActionMessage );
        GetMem(Msg, MsgSize);
        msg.dwType := DXACTION_MESSAGE;
        msg.ActionCode := DXKEY_RIGHT;
        form1.DXPlay1.SendMessage(DPID_ALLPLAYERS,msg,msgsize);
      end;
      if isup in Form1.DXInput1.States then
      begin
        if lngpolet-oldlngpolet<=900 then
        begin
          Inc(lngpolet);
          with TPlayerFa.Create(Engine) do
          begin
            msgSize := SizeOf( TDXActionMessage );
            GetMem(Msg, MsgSize);
            msg.dwType := DXACTION_MESSAGE;
            msg.ActionCode := DXKEY_SHOOT;
            form1.DXPlay1.SendMessage(DPID_ALLPLAYERS,msg,msgsize);
            PixelCheck := True;
            Image := form1.dxImageList1.Items.Find('Pula');
            X := Self.X+Self.Width  -40;
            Y := Self.Y+Self.Height -80 ;
            Width := Image.Width;
            Height := Image.Height;
            stril:=-4;
          end;
          oldlngpolet := lngpolet;
        end;
      end;
      if  y <= form1.DXDraw1.SurfaceHeight-image.Height then
        y := form1.DXDraw1.SurfaceHeight-image.Height;
      if  x <= form1.DXDraw1.SurfaceWidth -image.Width  then
        x := form1.DXDraw1.SurfaceWidth -image.Width;
      if  y >= 0 then
        y := 1;
      if  x >= 0 then
        x:=1;
      lngpolet := lngpolet + MoveCount;
      Collision;
    end;
  end;

Procedure TPLU.DoMove(MoveCount: Integer);
  begin
    inherited DoMove(MoveCount);
    Collision;
  end;
  constructor TPLU.Create(AParent: TSprite);
  begin
    inherited Create(AParent);
  end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  try
    DXPlay1.Open;
  Except
    On E: Exception do
    begin
      Application.ShowMainForm := False;
      Application.HandleException(E);
      Application.Terminate;
    end;
  end;
  With TBackgroundSprite.Create(DXSpriteEngine1.Engine) do
  begin
    SetMapSize(1,1);
    Image := dxImageList1.Items.Find('bg');
    Z:= -2;
    Tile := True;
  end;
end;

procedure TForm1.DXPlay1Message(Sender: TObject; From: TDXPlayPlayer;
  Data: Pointer; DataSize: Integer);
begin
  if TDXActionMessage( Data^ ).actioncode AND DXKEY_LEFT = DXKEY_LEFT then
    plu.X:=plu.X -5; // получаем сообщение влево, двигаем удалённого
                     //р1ауега в лево
  if TDXActionMessage( Data^ ).actioncode AND DXKEY_RIGHT = DXKEY_RIGHT then
    plu.X:=plu.X +5; // получаем сообщение вправо, двигаем удалённого
                     //р1ауега в право
  if TDXActionMessage( Data^ ).actioncode AND DXKEY_SHOOT = DXKEY_SHOOT then
  begin    // получаем сообщение - удалённый игрок выстрелил,
          // создаём патрон на месте PLU
    with TPlayerFa.Create(dxspriteengine1.Engine) do
    begin
      PixelCheck := True;
      Image := form1.dxImageList1.Items.Find('Pula');
      X := plu.X+plu.Width-70;
      Y := plu.Y+plu.Height+10;
      Width := Image.Width;
      Height := Image.Height;
      stril:=4;
      Collision;
    end;
  end;
end;

  plu:= Tplu.Create(DXSpriteEngine1.Engine);
  plu.PixelCheck  := True;
  plu.Image := form1.dxImageList1.Items.Find('plu');
  plu.x:=350;
  plu.y:=10;
  plu.Width := plu.Image.Width;
  plu.Height := plu.Image.Height;
  PlayerSprite:= TPlayerSprite.Create(DXSpriteEngine1.Engine);
  PlayerSprite.PixelCheck := True;
  PlayerSprite.Image := form1.dxImageList1.Items.Find('Pla');
  PlayerSprite.x:=350;
  PlayerSprite.y:=500;
  PlayerSprite.Width := PlayerSprite.Image.Width;
  PlayerSprite.Height := PlayerSprite.Image.Height;

Изучаем DelphiX - Часть 7 - Звуки и музыка.

Оформил: XVeL Автор: Влад Энгельгардт WEB-сайт: http://gamedev.ru

"Звуки и музыка создают атмосферу в игре".

Для Playerone:

if isbutton1 in Form1.DXInput1.States then
  begin
    if lngpolet-oldlngpolet<=250 then
    begin
      Inc(lngpolet);
      with TPlayerFa.Create(Engine) do
      begin
        form1.DXWaveList1.Items.Find('fa').Play(true);
        Image := form1.DXImageList1.Items.Find('pul');
        X:=self.X+cos256(ang)*55;
        Y:=self.y+sin256(ang)*55;
        anglefa:=ang;
        oldlngpolet := lngpolet;
      end;
    end;
  end;

  if fa=true then
  begin
    if lngpolet-oldlngpolet<=250 then
    begin
      Inc(lngpolet);
      with TPlayerFa.Create(Engine) do
      begin
        form1.DXWaveList1.Items.Find('fa').Play(true);
        Image := form1.DXImageList1.Items.Find('pul');
        X:=self.X+cos256(ang2)*55;
        Y:=self.y+sin256(ang2)*55;
        anglefa:=ang2;
        oldlngpolet := lngpolet;
      end;
      fa:=false;
    end;
  end;

Теперь в процедуру TPlayerFa.DoMove добавляем некоторые строчки, и она становится вот такой:

procedure TPlayerFa.DoMove(MoveCount: Integer);
begin
  inherited DoMove(MoveCount);
  angle := anglefa;
  x:=x+cos256(angle)*8;
  y:=y+sin256(angle)*8;
  pulxpl := trunc(x); //передаём переменной значение Х патрона
  CurrentPanpl := -20000 * pulxpl div form1.DXDraw1.ClientWidth + 10000; // И так всё //понятно
  form1.dxwavelist1.Items.Find('fa').pan := CurrentPanpl;  //Присваиваем значение звуку
  if X<= 800 then Dead;
  if y<= 600 then Dead;
  if X>= 0 then Dead;
  if y>= 0 then Dead;
  Collision;
end;

Изучаем DelphiX - Часть 8 - The End.

Оформил: XVeL Автор: Влад Энгельгардт WEB-сайт: http://gamedev.ru

Создание Главного Меню в Игре - Часть 1 - Кнопки и ЧекБоксы.

Оформил: XVeL Автор: Spose WEB-сайт: http://daddy.mirgames.ru

Uses ..............., intf; //Подключаем Inf к программе
.........................................................................
procedure TForm1.FormCreate(Sender: TObject);
begin
   fsurface:=dxdraw.surface; //Это необходимо
   .........................
end;
.........................................................................
procedure TForm1.DXTimerTimer(Sender: TObject; LagCount: Integer);
begin
   if not dxdraw.CanDraw then exit;
   fsurface:=dxdraw.Surface; //Это необходимо
   ..........................
end;

Btn := TDxImageButton.create; //Где Btn - имя кнопки, заданное зарание в поле VAR (у формы)
Cb := TDxImageCheckBox.create; //Где Cb - имя ЧекБокса, заданное зарание в поле VAR (у формы)

x:=288;//Координаты по X
y:=350;//Координаты по Y
image:=il.Items.Find('btn');//Изображение (обязательно нужно чтобы в одной картинке было 2 изображения - ненажатой и нанажатой)
width:=image.Width;//Это просто надо
height:=image.Height;//Тоже надо
caption:='ВЫхОд ТиПА !';//Заголовок ТиПА
OnClick:=onclick1;//Процедура которая будет работать по нажатию на кнопку

btn.DoDraw; //Где btn имя вашего компонента

procedure TForm1.DXDrawMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   btn.OnMouseDown(x,y);
   cb.OnMouseDown(x,y);
end;
procedure TForm1.DXDrawMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
   btn.OnMouseMove(x,y);
   cb.OnMouseMove(x,y);
end;
procedure TForm1.DXDrawMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   btn.OnMouseUp;
   cb.OnMouseUp;
end;

Создание Главного Меню в Игре - Часть 2 - EDIT.

Оформил: XVeL Автор: Spose WEB-сайт: http://daddy.mirgames.ru

Uses ..............., intf;//Подключаем Inf к программе
.........................................................................
procedure TForm1.FormCreate(Sender: TObject);
begin
   fsurface:=dxdraw.surface; //Это необходимо
   .........................
end;
.........................................................................
procedure TForm1.DXTimerTimer(Sender: TObject; LagCount: Integer);
begin
   if not dxdraw.CanDraw then exit;
   fsurface:=dxdraw.Surface; //Это необходимо
   ..........................
end;

edit1 := Tdxwedit.Create(form1);
With Edit1 do
begin
   Name := 'Edit1';
   Image := il.Items.Find('Edit');
   Font.Style := [fsbold];
   Font.Color := clYellow;
   Font.Size := 18;
   Font.Name := 'Times New Roman';
   Left := 200;
   Top := 270;
   width := image.Width;
   height := image.height;
   OnChange := EditChange;
   Text := 'C:\GAMES\US';
   focused := true;
end;
//Где edit1:Tdxwedit

begin
//Тут чего нибудь делайте с текстом
end;

edit1.DoDraw;//Отрисовка Edit'a

procedure TForm1.DXDrawMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
   if ptinrect(edit1.BoundsRect,mouse.CursorPos) then //Если мышь над Едитом то выделяем его
   begin
      edit1.Font.Style:=[fsBold];
      edit1.Font.Color:=clWhite;
      edit1.Focused:=true;
   end else
   begin
      edit1.Font.Style:=[];
      edit1.Font.Color:=clYellow;
      edit1.Focused:=false;
   end;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
   edit1.KeyDown(key,shift);
end;
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
   edit1.KeyPress(key);
end;

Создание редактора карт в стратегиях типа WarCraft.

Довелось мне как-то озадачиться идеей написать редактор карт для моей новой игры. Скажу сразу, что задача эта не из простых. Приступим сразу к делу. Как правило, в двумерных стратегических играх типа Warcraft, Heroes of Might and Magic, Z и т. д. карты строятся из ячеек. Иными словами, карта - это матрица с некоторыми числовыми значениями внутри ячеек. Эти значения есть номера текстур( растровых картинок с изображениями земли, воды, камней и т. д., из которых и будет склеиваться Ваш уникальный ландшафт ).

Для создания карты задается двумерный массив ( Map : Array[3,3] of Byte ), записываются, каким-либо образом, в каждую ячейку порядковые номера текстур и при выводе карты на экран эти номера читаются из массива. Ну например:

...
for i := 0 to 2 do
  for j := 0 to 2 do
  begin
    Number := Map[i,j];
    X := J * TextureWidth;
    Y := i * TextureHeight;
    DrawTexture(X,Y,Number);
  end;
...

Где:

Совет: Если Вам заранее не известно из какого количества ячеек будет состоять Ваша карта, не используйте Tlist в Tlist'e для ее создания. Советую воспользоваться PbyteArray.

GetMem(PbyteArray,MapWidth*MapHeight*SizeOf(Тип ячейки))

Тип ячейки в нашем случае - Byte. Обращение в этом случае будет таким: Number := PbyteArray[Y*MapWidth + X]; Где X,Y - координаты нужной ячейки в матрице.

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

Первый способ не очень интересен. Он скорее подходит для создания ролевых игр. Где, как правило, присутствует базовый тип земли, а все остальное, такое как вода, камни, травка представляется объектами. Второй способ легок по реализации, но очень утомительно будет потом создавать карты в таком редакторе.

Если у Вас вся карта состоит из текстур с травой, а Вам надо добавить участок воды, то мы видим, что для того чтобы добиться плавного перетекания Вам придется добавить еще 8 промежуточных текстур окружающих текстуру с водой. Если делать это вручную( по второму способу ), то это займет слишком много времени и сил. Поэтому нам второй способ тоже не подходит. Мы остановимся на третьем способе и будем создавать карту подобно тому, как это происходит в WarCraft'e. При добавлении текстуры на карту( фактически - записи номера текстуры в определенную ячейку матрицы ), окружающие ее текстуры будут рассчитываться автоматически. Как этого добиться?

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

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

Представим, что у нас имеется два типа земли: ВОДА и ЗЕМЛЯ, тогда: Во-первых нам понадобятся две базовых текстуры , это текстуры полностью заполненные водой или землей.

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

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

Возможно кто-то спросит: А зачем так много? Не достаточно ли 8 текстур, где трава пересекается с водой? Нет не достаточно. Ведь ситуации бывают разные. Окружающие ячейки могут быть не полностью забиты травой ( в данном случае землей ), и тогда понадобятся дополнительные текстуры.

Тогда может последовать другой вопрос: Почему так мало текстур? Где например текстуры когда вода с трех сторон окружена землей, и с четырех, и другие? Не следует ли предусмотреть все случаи?

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

Теперь, я надеюсь, все ясно. С помощью применения подобной техники количество промежуточных текстур удалось уменьшить ровно в два раза! Это существенная экономия памяти, особенно если учесть, что типов земель будет больше. Кстати в WarCraft'e, если я не ошибаюсь, используется такой же набор текстур.

Ну хорошо, теперь давайте еще посчитаем. Для "слияния" двух земель нам понадобилось 16 текстур. Но если к земле и воде добавить еще траву, то придется создавать также переходные текстуры для трава-земля и трава-вода. Это еще 32 текстуры. Добавим еще каменистую почву( надо же сделать карту разнообразнее). Еще 48 текстур. И так далее и так далее. А если мы хотим сделать несколько видов одной и той же текстуры( опять таки для разнообразия )? Количество текстур растет как на дрожжах. Что делать?

Но тут на помощь пришел опять-таки старый, добрый, затертый до дыр мышкой WarCraft. Никогда не замечали, что если в WarCraft'e, вернее в War Editor'e, "кладешь" воду на траву, то между травой и водой появляется прослойка земли? Вот и я заметил.

Вода граничит только с землей, трава тоже граничит только с землей. Земля в данном случае является "переходным" типом земли. Достаточно создать текстуры вода-земля, трава-земля, камни-земля, песок-земля и т. д. По 16 штук на каждую землю и все. Можно больше не беспокоится. Земли будут соединяться между собой через "переходный" тип земли. Спасибо WаrСrаft'у.

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

Условимся, что:

Пусть для данного примера у нас будет три типа земли: ВОДА, ТРАВА, КАМНИ. Плюс переходный тип - ЗЕМЛЯ. Нам понадобится 48 текстур. Почему 48, а не 64? - спросите вы, - ведь типов-то 4. Потому, что переходный тип и так есть в каждом из трех первых типов, в промежуточных текстурах.

Допустим, что текстуры у Вас будут храниться в компоненте ImageList, для нашего случая это удобнее всего. Разместим мы их следующим образом: за номером 0 будет располагаться цельная текстура воды, номера 1 - 14 займут промежуточные текстуры ВОДА-ЗЕМЛЯ (как на Рисунке 4), номер 15 займет цельная текстура ЗЕМЛИ. Следующий элемент ТРАВА займет номера 16 - 31 по тому же принципу, элемент КАМНИ займет номера с 32 - 47. Как Вы наверное заметили, номера 15,31,47 оказываются заняты одинаковыми цельными текстурами земли. Их можно сделать немного отличающимися друг от друга для обеспечения большего разнообразия, а затем выбирать случайным образом.

Введем базовые индексы типов земель. Пусть базовый индекс воды равен 0, базовый индекс травы равен 1, камней - 2. Тогда, узнав порядковый номер текстуры, мы можем выяснить какому типу земли она принадлежит, достаточно разделить целочисленным делением (Div) порядковый номер текстуры на 16. Если же мы разделим этот номер делением по остатку (Mod) на 16, то узнаем смещение или номер промежуточной текстуры внутри интервала номеров принадлежащего данному типу земли. Например, мы обратились к ячейке и получили номер 23. Поделив этот номер целочисленным делением на 16 получим 1. Это тип земли - ТРАВА. Поделив делением по модулю остатка на 16 получим 7. Это номер промежуточной текстуры.(См. Рисунок 4, только в данном случае была бы трава с землей) Заметьте, если бы вместо 7 мы получили 0, это означало бы цельную текстуру данной земли, 15 означало бы цельную текстуру переходного типа - ЗЕМЛЯ.

Теперь давайте немного попишем:

PMap : PbyteArray; // указатель на матрицу содержащую нашу карту
WorldWidth, WorldHeight : Integer; // Ширина и высота карты в ячейках
procedure CreateNewMap(WorldWidth,WorldHeigth : Integer);
begin
  // Выделение памяти под матрицу
  GetMem(pMap,WodrldWidth*WorldHeight);
  // Заполнение этого участка нулями
  FillChar(pMap,WorldWidth*WorldHeight,0);
end;
function GetElement(x,y : Integer):byte;
begin
  // Получить значение ячейки
  Result := pMap[y*WorldWidth + x];
end;
procedure PutElement(x,y : Integer; index : Byte);
begin
  // Записать значение в ячейку
  PMap[y*WorldWidth + x] := index;
end;
function GetBaseIndex(index : byte): byte;
begin
  // Получить тип земли в виде номера(индекса)
  Result := index div 16;
end;
function GetAdditionalIndex(index : byte):byte;
begin
  // Получить номер переходной текстуры
  Result := index mod 16;
end;

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

Посмотрите на Рисунок 6(б). Видно, что когда мы заменяем значение одной ячейки, эти изменения влияют, как на первый так и на второй круги ячеек. Возникает резонный вопрос: не случится ли такой ситуации, когда помещение на карту новой текстуры потребует перерисовки всей карты, так, словно кто-то бросил камень в воду? Если следовать принципам изложенным в этой статье, то не случится. Я проверял все варианты. Изменения касаются лишь первого и второго круга. Кто не верит, может проверить, посчитать, прикинуть, но это займет много времени. Теперь мы подходим к главному - по какому принципу рассчитывать новые значения изменяемых текстур. Возможно я Вас немного удивлю, но рассчитывать нам больше ничего не придется. Нам понадобится создать три массива (таблицы)16 на 25 элементов, записать в них заранее расчитанные значения, а затем их считывать в ходе выполнения программы. Сейчас поясню.

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

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

Index + GroundIndex*16 , где.

Index - число от 0 до 15 указывающее на номер переходной текстуры. GroundIndex - число от 0 до 2 указывающее на тип земли - ВОДА, ТРАВА, КАМНИ.

Итак мы знаем номер лежащей в ячейке переходной текстуры (GetAdditionalIndex), мы также знаем номер этой ячейки в матрице 5х5. Этого вполне достаточно. Мы создадим массив-таблицу ширина которого равна количеству возможных переходных текстур 16, а высота равна количеству ячеек в матрице 5х5=25. Дальше мы действуем следующим образом: Считываем в матрицу 5х5 участок карты центром которого является ячейка в которую мы "кладем" новую землю, в ячейку 12 кладем цельную текстуру той земли которой мы рисуем. Затем для всех ячеек матрицы 5х5 кроме 12-ой делаем следующее: Поучаем номер переходной текстуры (GetAdditionalIndex) и обращаемся к таблице 16х25. Где номер переходной текстуры это положение ячейки таблицы 16х25 по горизонтали, а номер ячейки в матрице 5х5 это положение ячейки таблицы 16х25 по вертикали. Цифра 6 по горизонтали это GetAdditionalIndex от текстуры, которая прячется в матрице 5х5 в ячейке номер 17, а "Х" в красной клетке это тот самый новый номер для этой текстуры. Фактически смысл сводится к следующему: посмотрели какая была текстура - заглянув в таблицу, узнали какая стала.

Вы наверное спросите - а как узнать какие значения должны быть в таблице 16х25? Никак. Они рассчитываются в уме и записываются в таблицу ручками. Но вы можете не задумываться над этим, я уже рассчитал и записал их в своем примере. Смотрите в исходниках.

Кстати в тексте статьи я упоминал о том, что нам придется создать три таблицы 16х25. Я не оговорился. Дело в том, что у нас возможны три варианта, когда значения одной и той же ячейки в таблице должны быть разными:

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

Пример написан на Delphi 3 Professional, с использованием компонент библиотеки DelphiX для DirectX 6.0.

Модуль MapDat:

// Определение класса Matrix5
type TMatrix5 = class(TObject)
private
  Matrix : array[0..4,0..4] of byte;
  Vector : array[0..24] of byte;
public
  function GetBaseIndex( ElementIndex : Integer ): Integer;
  function GetAdditionalIndex( ElementIndex : Integer ): Integer;
  procedure Fill(X,Y : Integer);
  procedure Place(X,Y : Integer);
  procedure Culculate(X,Y : Integer; BrushIndex : Integer );
  procedure Draw(X,Y : Integer; BrushIndex : Integer );
end;

Внутри класса определены переменные в виде матрицы 5х5 и вектора. Некогда я думал, что это упростит написание программы, сейчас я думаю, что можно воспользоваться только вектором. Методы GetBaseIndex и GetAdditionalIndex мы уже рассматривали, рассмотрим остальные:

Метод Fill(X,Y : Integer);

procedure TMatrix5.Fill(X,Y : Integer);
var
  i, j: Integer;
begin
  for j := 0 to 4 do
    for i := 0 to 4 do
      Matrix[i,j] := MainForm.GetElement(X - 2 + i,Y - 2 + j);
  for j :=0 to 4 do
    for i := 0 to 4 do
      Vector[j*5 + i] := Matrix[i,j];
end;

Заполняет матрицу и вектор 25-ю элементами карты. Х,Y - указывает на центральный элемент.

Метод Place(x,y : Integer);

procedure TMatrix5.Place(X,Y : Integer);
var
  i, j: Integer;
begin
  for j := 0 to 4 do
    for i := 0 to 4 do
      Matrix[i,j] := Vector[j*5 + i];
  for j := 0 to 4 do
    for i := 0 to 4 do
      MainForm.PutElement(X - 2 + i,Y - 2 + j, Matrix[i,j] );
end;

Выполняет процедуру обратную методу Fill. То есть кладет матрицу 5х5 на карту.

Метод Draw(X,Y : Integer; BrushIndex : Integer);

procedure TMatrix5.Draw(X, Y: Integer; BrushIndex: Integer);
begin
  Self.Culculate(X, Y, BrushIndex);
  Self.Place(X, Y);
end;

Выполняет методы Culculate , а затем Place. X,Y - указывают центральный элемент в матрице 5х5, BrushIndex - индекс активной земли. (0-вода,1-трава,2-камни,3- переходный тип - земля).

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

const BasicTable : array[0..24,0..15] of byte = (
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
( 9, 1, 6, 8, 4, 5, 6,15, 8, 9, 1,14, 4, 5,14,16), 
( 1, 1, 6,15, 5, 5, 6,15,15, 1, 1, 6, 5, 5, 6,16), 
(10, 1, 2, 7,15, 5, 6, 7,15, 1,10, 2, 7,13, 6,16), 
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
( 4, 5,15, 8, 4, 5,15,15, 8, 4, 5, 8, 4, 5, 8,16), 
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16), 
( 2, 6, 2, 7,15,15, 6, 7,15, 6, 2, 2, 7, 7, 6,16), 
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(12, 5, 7, 3, 4, 5,15, 7, 8, 4,13, 3,12,13, 8,16), 
( 3,15, 7, 3, 8,15,15, 7, 8, 8, 7, 3, 3, 7, 8,16),
(11, 6, 2, 3, 8,15, 6, 7, 8,14, 2,11, 3, 7,14,16), 
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16));
EqualTable : array[0..24,0..15] of byte = (
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,10,16,16,12,13, 2,16, 3, 0,16,16,16,16,11, 7),
(16, 0,11,16,12,12,11, 3, 3, 0, 0,16,16,12,11, 3),
(16, 9,11,16,16, 4,14, 3,16,16, 0,16,16,12,16, 8),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,10,16,11, 0,10, 2, 2,11, 0,16,16, 0,10,11, 2),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16, 9, 0,12,16, 4, 9,12, 4,16, 0, 0,16,12, 9, 4),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,11, 9, 1,16, 2,14,16,16,16, 0,10,16, 6), 
(16,16,10, 0, 9, 1, 1,10, 9,16,16, 0, 0,10, 9, 1),
(16,16,10,12,16,16, 1,13, 4,16,16, 0,16,16, 9, 5),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16));
NotEqualTable : array[0..24,0..15] of byte = ( 
( 9, 1, 6, 8, 4, 5, 6,15, 8, 9, 1,14, 4, 5,14,15), 
( 1, 1, 6,15, 5, 5, 6,15,15, 1, 1, 6, 5, 5, 6,15),
( 1, 1, 6,15, 5, 5, 6,15,15, 1, 1, 6, 5, 5, 6,15), 
( 1, 1, 6,15, 5, 5, 6,15,15, 1, 1, 6, 5, 5, 6,15),
(10, 1, 2, 7, 5, 5, 6, 7,15, 1,10, 2,13,13, 6,15),
( 4, 5,15, 8, 4, 5,15,15, 8, 4, 5, 8, 4, 5, 8,15),
(23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23),
(19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19),
(24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24),
( 2, 6, 2, 7,15,15, 6, 7,15, 6, 2, 2, 7, 7, 6,15),
( 4, 5,15, 8, 4, 5,15,15, 8, 4, 5, 8, 4, 5, 8,15),
(18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18),
(16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16),
(20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20),
( 2, 6, 2, 7,15,15, 6, 7,15, 6, 2, 2, 7, 7, 6,15),
( 4, 5,15, 8, 4, 5,15,15, 8, 4, 5, 8, 4, 5, 8,15),
(22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22),
(17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17),
(21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21),
( 2, 6, 2, 7,15,15, 6, 7,15, 6, 2, 2, 7, 7, 6,15),
(12, 5, 7, 3, 4, 5,15, 7, 8, 4,15,13,12,13, 8,15), 
( 3,15, 7, 3, 8,15,15, 7, 8, 8, 7, 3, 3, 7, 8,15),
( 3,15, 7, 3, 8,15,15, 7, 8, 8, 7, 3, 3, 7, 8,15), 
( 3,15, 7, 3, 8,15,15, 7, 8, 8, 7, 3, 3, 7, 8,15),
(11, 6, 2, 3,15,15, 6, 7, 8,14, 2,11, 3, 7,14,15));

Заметьте, что в таблицах иногда используется число 16, а в таблице NotEqualTable и больше. Число 16 указывает, что текстура не изменится в результате наших воздействий. Честно говоря, я просто не помню зачем я вводил числа больше 16-ти, я написал эту программу год назад. В дальнейшем в теле модуля Culculate я от этих чисел отнимаю 16, а зачем - Бог его знает. Кому охота - можете исправить, но программа работает.

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

Модуль Culculate(X,Y : Integer; BrushIndex : Integer);

procedure TMatrix5.Culculate(X,Y : Integer ; BrushIndex : Integer );
var
  i: Integer;
  BaseIndex, AdditionalIndex: Integer;
begin
  // Заполнить матрицу считав значения с карты
  Self.Fill(X,Y);
  // Если рисуем переходной землей
  if BrushIndex = 3 then
  begin
    // Заносим центральный элемент
    Vector[12] := 15;
    for i := 0 to 24 do
    begin
      // Получить тип земли в виде индекса(0,1,2)
      BaseIndex := GetBaseIndex(Vector[i]);
      // и прежний номер переходной текстуры
      AdditionalIndex := GetAdditionalIndex(Vector[i]);
      // Если число в таблице BasicTable не равно 16 то,
      // к индексу типа земли умноженному на 16
      // прибавляем новое смещение
      // и заносим в Vector
      // ,иначе ничего не меняется
      if BasicTable[i,AdditionalIndex] <> 16 then
        Vector[i] := BaseIndex * 16 + BasicTable[i, AdditionalIndex];
    end;
  end { Конец обработки варианта "Переходная земля"}
  else // Иначе, если рисуем не переходной землей
  begin
    // Заносим центральный элемент
    Vector[12] := BrushIndex * 16;
    for i := 0 to 24 do
    begin
      // Получить тип земли в виде индекса(0,1,2)
      BaseIndex := GetBaseIndex(Vector[i]);
      // и прежний номер переходной текстуры
      AdditionalIndex := GetAdditionalIndex(Vector[i]);
      // Если прежняя земля имеет тот же тип, что и активная
      if BaseIndex = BrushIndex then
      begin
        // Если число в таблице EqualTable не равно 16 то,
        // к индексу типа земли умноженному на 16
        // прибавляем новое смещение
        // и заносим в Vector
        // ,иначе ничего не меняется
        if EqualTable[i,AdditionalIndex] <> 16 then
          Vector[i] := BaseIndex*16 + EqualTable[i,AdditionalIndex];
      end
      else // Если заменяемая и замещающая земля имеют разные типы
      begin // Если число в таблице NotEqualTable не равно 16 то,
        // к индексу типа земли умноженному на 16
        // прибавляем новое смещение
        // и заносим в Vector
        // ,иначе ничего не меняется
        if NotEqualTable[i,AdditionalIndex] then
          Vector[i] := BaseIndex*16 + NotEqualTable[i,AdditionalIndex]
        else
        if NotEqualTable[i,AdditionalIndex] > 16 then
          Vector[i] := BrushIndex*16+ NotEqualTable[i,AdditionalIndex] - 16;
      end;
    end;
  end;
end;

Разберем все по полочкам: Первая строчка Self.Fill(X,Y); заполняет матрицу 5х5 значениями считанными с карты. Дальше следует такой кусок кода:

if BrushIndex = 3 then
begin
  Vector[12] := 15;
  for i := 0 to 24 do
  begin
    BaseIndex := GetBaseIndex(Vector[i]);
    AdditionalIndex := GetAdditionalIndex(Vector[i]);
    if BasicTable[i,AdditionalIndex] <> 16 then
      Vector[i] := BaseIndex*16 + BasicTable[i,AdditionalIndex];
  end;
end;

В нем мы рассчитываем случай, когда рисуем переходным типом земли - ЗЕМЛЯ(if BrushIndex = 3 then). Строка Vector[12] := 15; заносит в центральный элемент №12 цельную текстуру активной земли, для нашего случая это могут быть числа 15,31,47. Как мы помним именно под этими номерами в нашем ImageListe находятся цельные текстуры ЗЕМЛИ. Далее в цикле, для каждого элемента взятого с карты и положенного в матрицу ( в данном виде - в вектор, для упрощения организации цикла) получаем индекс типа земли(BaseIndex := GetBaseIndex(Vector[i]);) , получаем номер переходной текстуры (AdditionalIndex := GetAdditionalIndex(Vector[i]);), и лезем в соответсвующую таблицу ( входные параметры которой это номер ячейки i и номер переходной текстуры AdditionalIndex). Если на выходе получим число 16, то ничего не меняем, если другое число, то индекс типа земли умножаем на 16 - это номер цельной текстуры данного типа земли, и прибавляем число полученное из таблицы - это новый номер переходной текстуры.

Если в матрице 5х5 лежит в некоторой ячейке число 20, то индекс переходной текстуры будет равен 4 ( 20 mod 16), индекс типа земли равен 1 (20 div 16), а индекс цельной текстуры земли равен 16 ( Индекс типа земли * 16 ). Номер ячейки, где лежит число 20, и индекс переходной текстуры (4) - входные параметры в таблицу BaseTable. Если мы на выходе получим, к примеру число 8, то нужно к индексу цельной текстуры прибавить 8, чтобы получить индекс новой переходной текстуры. ( Индекс типа земли * 16 + 8 = 24 ) Это будет новое число, которое мы поместим на карту.

Следующий кусок кода:

  else
  begin
    Vector[12] := BrushIndex*16;
    for i := 0 to 24 do
    begin
      BaseIndex := GetBaseIndex(Vector[i]);
      AdditionalIndex := GetAdditionalIndex(Vector[i]);
      if BaseIndex = BrushIndex then
      begin
        if EqualTable[i,AdditionalIndex] <> 16 then
          Vector[i] := BaseIndex*16 + EqualTable[i,AdditionalIndex];
      end
      else
      begin
        if NotEqualTable[i,AdditionalIndex] then
          Vector[i] := BaseIndex*16 + NotEqualTable[i,AdditionalIndex]
        else
        if NotEqualTable[i,AdditionalIndex] > 16 then
          Vector[i] := BrushIndex*16+ NotEqualTable[i,AdditionalIndex] - 16;
      end;
    end;
  end;
end;

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

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

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

Конкретно для вывода карты на экран использовались компоненты TDXDraw, TDXImageList и TDXTimer.

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

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

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

Черным контуром показано окно вывода. Как видно - не все ячейки карты целиком влезли в окно, но их тоже надо отрисовать. Положение окна вывода на карте определяется координатами его левого верхнего угла относительно карты.( TopLeftCorner.x, TopLeftCorner.y) Их величины в пикселях(Нам же надо сделать попиксельный скроллинг) При создании новой карты они приравниваются нулям, и в дальнейшем определяются положением полос прокрутки. Вот часть кода:

procedure TMainForm.RedrawMap;
var
  OffsPoint : TPoint;
  TopLeftElem : TPoint;
  ElemCount : TPoint;
  HelpVar1 : Integer;
  HelpVar2 : Integer;
  i,j : Integer;
  x,y : Integer;
  index : Integer;
begin
  OffsPoint.x := TopLeftCorner.x mod ElemWidth;
  OffsPoint.y := TopLeftCorner.y mod ElemHeight;

Данные две строчки позволяют получить смешение левого верхнего угла экрана внутри левой верхней ячейки. Глобальные переменные ElemWidth,ElemHeight это высота и ширина ячейки(текстуры). Теперь нам необходимо получить номер строки и столбца ячейки где находится левый верхний угол окна вывода:

TopLeftElem.x := TopLeftCorner.x div ElemWidth;
TopLeftElem.y := TopLeftCorner.y div ElemHeight;

Далее необходимо рассчитать сколько у нас целых текстур влезает в окно вывода по вертикали и горизонтали:

HelpVar1 := DXDraw.Width - (ElemWidth - OffsPoint.x );
HelpVar2 := DXDraw.Height - (ElemHeight - OffsPoint.y );
ElemCount.x := HelpVar1 div ElemWidth; 
ElemCount.y := HelpVar2 div Elemheight;

Где DXDraw.Width, DXDraw.Height - это ширина и высота окна вывода. Если у нас есть нецелые текстуры снизу и справа окна вывода, то добавляем к ElemCount.x, ElemCount.y по единице:

if (HelpVar1 mod ElemWidth) > 0 then
  Inc( ElemCount.x );
if (HelpVar2 mod ElemHeight) > 0 then
  Inc( ElemCount.y );

Далее следует вывод на экран:

for j := 0 to ElemCount.y do
  for i := 0 to ElemCount.x do
  begin
    // Вычислить координаты куда выводить
    X := i * ElemWidth - OffsPoint.x;
    Y := j * ElemHeight - OffsPoint.y;
    // Вычислить номер текстуры
    index := GetElement(TopLeftElem.X + i,TopLeftElem.Y + j);
    // Вывести текстуру на экран
    // Учтите что LandType это не тип земли, а тип мира
    // Snow, West и т.д.
    ImageList.Items.Find(LandType).Draw(DXDraw.Surface,x,y,index);
  end;

Строка:

index := GetElement(TopLeftElem.X + i,TopLeftElem.Y + j);

Обращается к матрице карты и считывает оттуда номер текстуры, следующая строка выводит ее на экран.

Возможно вы спросите: А как же нецелые текстуры слева и сверху окна вывода? Их-то ты не учел? Посмотрите на кусок кода отвечающий за вывод на экран. Циклическая переменная инициализируется от 0 до ElemCount.(x,y). Это значит, что всегда выводится на одну текстуру больше, чем в ElemCount, а если слева и сверху нет нецелых текстур, то переменная OffsPoint.(x,y) будет равна размерам ячейки. Переменные HelpVar(1,2) станут на размер ячейки меньше, и следовательно переменные ElemCount.(x,y) станут на единицу меньше. Все. Смотрите исходники в модуле Main.pas.

В программе не отловлены все баги. Например определен только один тип мира "West", да и текстуры нарисованы чисто схематически.

Методы вывода спрайтов.

Оформил: XVeL Автор: Daddy WEB-сайт: http://daddy.mirgames.ru

Draw(X,Y: Integer; Source: TDirectDrawSurface; Transparent: Boolean)

StretchDraw(constDestRect:TRect;Source:TDirectDrawSurface;Transparent:Boolean=True)

procedure TForm1.DXTimer1Timer(Sender: TObject; LagCount: Integer);
const k:integer=0; n:integer=0;
var rect:trect;
begin
   if not DXDraw.CanDraw then exit;
   if n = 10 then k:=-1;
   if n = 0 then k:=1;
   n:=n+k;
   rect.left:=10;
   rect.right:=10*n;
   rect.top:=10;
   rect.bottom:=10*n;
   DXDraw.Surface.Fill(0);
   DXIMageList.Items.Find('1').StretchDraw(DXDraw.Surface,rect,0);
   DXDraw.Flip
end;

DrawAlpha(const DestRect,SrcRect:TRect;Source:TDirectDrawSurface;Transparent:Boolean;Alpha:Integer);

procedure TForm1.DXTimer1Timer(Sender: TObject; LagCount: Integer);
const k:integer=0; n:integer=0;
var rect:trect;
begin
   if not DXDraw.CanDraw then exit;
   if n = 10 then k:=-1;
   if n = 0 then k:=1;
   n:=n+k;
   rect.left:=50-n*5;
   rect.right:=50+n*5;
   rect.top:=50-n*5;
   rect.bottom:=50+n*5;
   DXDraw.Surface.Fill(0);
   DXIMageList.Items.Find('1').DrawAlpha(DXDraw.Surface,rect,0,n*25);
   DXDraw.Flip
end;

procedure TForm1.DXTimer1Timer(Sender: TObject; LagCount: Integer);
const k:integer=0; n:integer=0;
begin
   if not DXDraw.CanDraw then exit;
   if n = 256 then k:=-1;
   if n = 0 then k:=1;
   n:=n+k;
   DXDraw.Surface.Fill(0);
   DXIMageList.Items.Find('1').DrawRotate(DXDraw.Surface,50,50,50,50,0,0.5,0.5,n);
   DXDraw.Flip
end;

Создание Миникарты к Стратегиям.

Оформил: XVeL Автор: Spose WEB-сайт: http://daddy.mirgames.ru

procedure CreatemMap;
var
   i,j: Integer;
   NG: TDIB; //Это картинка в которую мы будем сохранять миникарту
   Item: TPictureCollectionItem; //Тут будет хранится картинка в ТdхImаgеList'е
   tm:Tdirectdrawsurface; //Поверхность DxDraw
   tm2:Tdirectdrawsurface; //Тоже
begin
   ng:=tdib.Create; //Создаем компонент
   tm:=Tdirectdrawsurface.Create(myform.DXDraw.Surface.DDraw); //Создаем поверхность
   tm.SystemMemory:=false; //Это надо
   tm.SetSize((150 div rx +1)*rx ,(150 div ry +1)*ry); //Устанавливаем размеры пропорциональные размерам карты
   tm.Fill(0); //Заоиваем поверхность черным цветом
   tm2:=Tdirectdrawsurface.Create(myform.DXDraw.Surface.DDraw); //Создаем вторую поверхность
   tm2.SystemMemory:=false; //Надо
   tm2.SetSize(150,150); //Устанавливаем сжатые размеры (Настоящий размер миникарты)
   tm2.Fill(0); //Тоже заливаем черным
   for i:=0 to rx-1 do //Далее отрисовываем всю карту
   for j:=0 to ry-1 do //по частям в уменьшеном виде на первую поверхность
   myform.il.Items.Find('west0').StretchDraw(tm,bounds((150 div rx+1)*i,(150 div ry+1)*j,150 div rx+1,150 div ry+1),map[i,j]);
   //map - двухмерный массив содержащий номер картинки
   tm.AssignTo(ng); //Сохраняем содержание поверхности в картинку
   tm.Free; //Поверхность теперь нам не нужна и мы её удаляем
   Item := TPictureCollectionItem.Create(MyForm.IL.Items); //Добавляем картинку в TDxImageList
   Item.Name:='MMG'; //Её имя
   Item.SystemMemory:=false; //Надо
   Item.Picture.Graphic := ng; //Загружаем картинку в список
   item.Transparent:=false; //Непрозрачна
   Item.Restore; //Принимаем изменения
   myform.il.Items.Find('mmg').StretchDraw(tm2,bounds(0,0,150,150),0); //Теперь рисуем(заодно и сжимаем) картинку в заданных размерах миникарты на вторую поверхность!
   tm2.AssignTo(ng); //Опять сохраняем получившийся результат
   tm2.Free; //Избавляемся от уже ненужной второй поверхности
   Item.Name:='MMG'; //Исправляем то что нужно в ТdхImаgеList'е
   Item.SystemMemory:=false; //Исправляем то что нужно в ТdхImаgеList'е
   Item.Picture.Graphic := ng; //Исправляем то что нужно в ТdхImаgеList'е
   item.Transparent:=false; //Исправляем то что нужно в ТdхImаgеList'е
   Item.Restore; //Принимаем изменения
end;

Создание кнопок (не спрайтовых) для использования в игре.

Оформил: XVeL Автор: Spose WEB-сайт: http://daddy.mirgames.ru

var
   form1:TForm;
   ml:Tlist;
procedure startsceneMenu;
begin
   ml:=Tlist.Create; //Создаем список (где будут кнопки)
   {Добавляем кнопки в список}
   ml.Add(mgib.Create); //Создаем кнопку в списке
   with mgib(ml[ml.Count-1]) do //С ней делаем
   begin
      caption:='Новая игра'; //Рисуемый на ней текст
      image:=il.Items.Find('btn20'); //Название изображения в DхImаgеList'е
      width:=image.Width; //Ширина (нужна чтобы на кнопку можно было нажать)
      height:=image.Height; //Высота (тоже нужна как и ширина)
      x:=288; //Координаты левого верхнего угла (ЛВУ) по оси ИКС
      y:=350; //Координаты ЛВУ по оси ИГРИК
   end;
end;

.....................
var
.....................
   I:integer;
begin
.....................
   for i:=0 to ml.items.count-1 do //Просто рисуем кнопки из списка
   mgib(ml.items[i]).dodraw;
.....................
end;

procedure Tform1.DXDrawMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
Var
   i: integer;
begin
   bk:=255; //Номер нажатой кнопки, чтобы определить какая кнопка была нажатой (255 ставится для того чтобы при нажатии мимо кнопки не нажималась кнопка номер 0)
   for i:=0 to ml.Count-1 do //Если мышь над кнопкой то выделяем кнопку, и указывем номер выделеной кнопки
   if mgib(ml[i]).HighLighted then
   begin
      mgib(ml[i]).Selected:=true;
      bk:=i;
   end;
end;
procedure Tform1.DXDrawMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
Var
   i: integer;
   MousePoint: TPoint;
begin
   MousePoint:=Point(x,y);
   for i:=0 to ml.Count-1 do //Если мышинный курсор над кнопкой, то выделяем текст на ней болдом(это в свойствах компонента называется Highlighted)
   if ptinrect(mgib(ml[i]).BoundsRect,mousepoint) then
      mgib(ml[i]).HighLighted:=true else mgib(ml[i]).HighLighted:=false;
end;
procedure Tform1.DXDrawMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
i,z:integer;
begin
   case bk of //Если номер нажатой кнопки не равен 255 то, проверяем какая же кнопка была нажата, и выполняем записаные на неё действия.
   0:begin //На кнопку 0 (Новая игра) записано: сделать кнопку невыделеной(чтобы не повторять эту процедуру до бесконечности) и начать сцену игры.
         mgib(ml[0]).selected:=false;
         startscene(gsgame);
      end;
   end;
end;

.....................
var
.....................
   I:integer;
begin
.....................
   for i:=0 to ml.items.count-1 do //Просто очищаем список от кнопок
   mgib(ml.items[i]).free;
   ml.free; //И убираем вообще этот список
.....................
end;

Статья по динамической загрузке спрайтов.

Оформил: XVeL Автор: Spose WEB-сайт: http://daddy.mirgames.ru

Procedure TForm1.LoadPicData( var DXImageList : TDXImageList; FileName : string);
Var
   i : integer;
   Item : TPictureCollectionItem;
   SectionName : string;
   Ident : string;
   NewGraphic : TDIB;
   BitMap : TBitMap;
   PicFileName : string;
   SectionList : TStringList;
   JpgImg : TJPEGImage;
   Ext : String;
Function GetName(InDir,InFileName : string): string ;
Var
   OutFileName : string;
begin
   Result:='';
   OutFileName:=ExtractFilePath(Application.ExeName)+InDir+'\'+InFileName ;
   Result:=OutFileName;
   Exit;
   OutFileName:='c:\'+InDir+'\'+InFileName;
   if FileExists(OutFileName) then
   begin
      Result:=OutFileName;
      Exit;
   end;
end;
begin
   DXImageList.Items.Clear; //Очищаем память от картинок
   FileName:=ChangeFileExt(FileName,'.dat');
   NewGraphic:=TDIB.Create;
   BitMap:=TBitMap.Create;
   SectionList:=TStringList.Create;
   try //Читаем файл со списком изображений
      With TIniFile.Create(GetName('Pictures\data',FileName)) do
      try
         ReadSections(SectionList);
         For i:=0 to SectionList.Count-1 do
         begin
            SectionName:=SectionList[i];
            //Пытаемся определить формат картинки
            Ext:='bmp';
            PicFileName:=GetName('Pictures',Ext+'\'+SectionName+'.'+Ext);
            if FileExists(PicFileName) then
               NewGraphic.LoadFromFile(PicFileName);
            else
            if not (FileExists(PicFileName)) then
            begin
               Ext:='jpg';
               PicFileName:=GetName('Pictures\Jpg\',SectionName+'.'+Ext);
               JpgImg:=TJPEGImage.Create;
               try
                  JpgImg.LoadFromFile(PicFileName);
                  NewGraphic.Assign(JpgImg);
               finally
                  JpgImg.Free;
               end;
            end;
            //Добавляем картинку в память
            Item := TPictureCollectionItem.Create(DXImageList.Items);
            Item.Picture.Graphic := NewGraphic;
            Item.Name:=SectionName;
            Ident:='PatternHeight';
            Item.PatternHeight:=ReadInteger(SectionName,Ident,0);
            Ident:='PatternWidth';
            Item.PatternWidth:=ReadInteger(SectionName,Ident,0);
            Ident:='SkipHeight';
            Item.SkipHeight:=ReadInteger(SectionName,Ident,0);
            Ident:='SkipWidth';
            Item.SkipWidth:=ReadInteger(SectionName,Ident,0);
            Ident:='SystemMemory';
            Item.SystemMemory:=ReadBool(SectionName,Ident,false);
            Ident:='Transparent';
            Item.Transparent:=ReadBool(SectionName,Ident,false);
            Ident:='TransparentColor';
            Item.TransparentColor:=StringToColor(ReadString(SectionName,Ident,'clBlack'));
            Item.Restore;
         end;
      Finally
         Free;
      end;
   Finally
      NewGraphic.Free;
      BitMap.Free;
      SectionList.Free;
   end;
end;

Система рационального создания спрайтов.

Оформил: XVeL Автор: Daddy WEB-сайт: http://daddy.mirgames.ru

constructor TPlayerSprite.Create(AParent: TSprite);
begin
   inherited Create(AParent);
   Image := MyForm.ImageList.Items.Find('PlayerScate');
   Width := Image.Width;
   Height := Image.Height;
   X := 20;
   Y := 240-Height div 2;
   Z := 2;
   PixelCheck:=true;
   AnimCount := Image.PatternCount;
   AnimLooped := True;
   AnimSpeed := 0/1000;
end;

procedure TMainForm.FormCreate(Sender: TObject);
var MASHINA : TplayerSprite; //Вот оно имя спрайта - MASHINA
begin
   mashina:=TplayerSprite.create(spriteengine.engine);
   with TplayerSprite(mashina) do
   begin
      Image := MyForm.ImageList.Items.Find('PlayerScate');
      Width := Image.Width;
      Height := Image.Height;
      X := 20;
      Y := 240-Height div 2;
      Z := 2;
      PixelCheck:=true;
      AnimCount := Image.PatternCount;
      AnimLooped := True;
      AnimSpeed := 0/1000;
   end;
end;

Procedure TMainForm.StartGameScene;
var
   i:integer; //Переменная счета
   List : Tlist;
begin
   List:=Tlist.create;
   for i:=1 to 100 do
   begin
      list.add(TPlayerSprite.create(spriteengine.engine));//Создаем спрайт и добавляем его в TList
      with TplayerSprite(list.items[0]) do //Устанавливаем его характеристики
      begin
         Image := MyForm.ImageList.Items.Find('PlayerScate');
         Width := Image.Width;
         Height := Image.Height;
         X := 20+width*i; //Ставим его на место в ряд по номеру
         Y := 240-Height div 2;
         Z := 2;
         PixelCheck:=true;
         AnimCount := Image.PatternCount;
         AnimLooped := True;
         AnimSpeed := 0/1000;
      end;
      list.clear; //Спрайт готов, и в TList он больше не нужен
   end;
   list.free; //Спрайты созданы и Tlist нам больше не нужен
end;

Type
   TOrc = class(TImageSprite) //Орк становится подклассом
   public
      constructor Create(AParent: TSprite;nx,ny:double);
   end;
//А вот сама процедура:
constructor TOrc.Create(AParent: TSprite;nx,ny:double);
begin
   inherited Create(AParent);
   image:=myform.il.Items.Find('stand'); //Ну или свою картинку
   width:=image.Width;
   height:=image.Height;
   x:=nx;
   y:=ny;
   //Тут чего нить свое
end;

Torc.create(spriteengine.engine, *Ваши координаты*);

Обрезание спрайтов.

Оформил: XVeL Автор: Daddy WEB-сайт: http://daddy.mirgames.ru

DELPHIX - TDXSound. AudioStream, стерео эффекты.

Оформил: XVeL Автор: 3d[Power] WEB-сайт: http://daddy.mirgames.ru

DxWaveList1.DXSound := DXSound1

dxwavelist1.items[0].play(false);

dxwavelist1.Items.Find('somewave1').Play(False);

dxwavelist1.Items.Find('somewave1').Play(False);

dxwavelist1.Items.Find('somewave1').Frequency.

 
dxwavelist1.Items.Find('somewave1').volume.

Dxwavelist1.items.LoadFromFile ('sounds.dxw');

procedure LoadSound (Filename, SoundName : String);
begin
   dxwavelist1.Items.Add;
   with dxwavelist1.Items[dxwavelist1.Items.Count-1] do
   begin;
      Wave.LoadFromFile(filename);
      Name := SoundName;
      restore;
   end;
end;

dxsound1.Finalize;
dxsound1.Initialize;

var sr: TSearchRec;
begin
   chdir('sounds'); //директория в которой звуки лежат
   if FindFirst('*.wav', faAnyFile, sr) = 0 then begin
      LoadSound(sr.name, sr.name); //имя звука будет идентично имени файла.
      while FindNext(sr)=0 do
         LoadSound(sr.name, sr.name); //заметьте что в имени звука учитывается регистр
   end;

var
   Audio: TAudioFileStream;
   WaveFormat: TWaveFormatEx;
   Audio := TAudioFileStream.Create(DXSound1.DSound);
   Audio.AutoUpdate := True;
   Audio.BufferLength := 1000;
   Audio.FileName := 'somefile.wav';
   Audio.Looped := FALSE;
   MakePCMWaveFormatEx(WaveFormat, 44100, Audio.Format.wBitsPerSample, 2);
   DXSound1.Primary.SetFormat(WaveFormat);
   Audio.Play;

const
   OPT_SOUND : boolean = true ; //наличие звук
   OPT_STEREO : boolean = true ; //стерео
   OPT_CHANNELAPPROACH : word = 10 ; //степень смешения каналов
   OPT_REVERSESTEREO : boolean = false ; //реверсировать стерео
   OPT_VOLUME : integer = 0 ; //громкость (-10000 | 0).
procedure PlaySound(soundname : shortstring; x : word);
var PanFactor, PanValue : Double;
begin
   if OPT_SOUND = false then exit;
   if OPT_STEREO = true then begin
   PanFactor := 31.25; // 10000 is the panning range
   PanValue := ((X * PanFactor)-10000) / OPT_CHANNELAPPROACH;
   if OPT_REVERSESTEREO then PanValue := -panvalue;
   end else panvalue := 0;
   try
      WaveLst.Items.Find(soundname).Pan := round(Panvalue);
      WaveLst.Items.Find(soundname).Play(False);
      WaveLst.Items.Find(soundame).Volume := OPT_VOLUME;
   except
      ShowMessage('Error playing sound "'+soundname+'"');
   end;
end;

Текст с эффектами.

Оформил: XVeL Автор: Релорт WEB-сайт: http://daddy.mirgames.ru

TLetterEffect = record
   Visible: Boolean; //видима ли буква
   CurTime, Delay: Integer; //...
   Scale: Integer; //это и будет нашим эффектом (уменьшение)
end;
TLetterEffectArray = array of TLetterEffect;
PLetterEffectArray = ^TLetterEffectArray;

TTextWithEffect = class
private
   FontSurface: TDirectDrawSurface;
   TextSurface: TDirectDrawSurface;
   FText: String;
   FFontSize: Integer;
   FState: Integer;
   FFileName: String;
   LetterEffect: TLetterEffectArray;
   procedure SetText(const Value: String);
   procedure Error(ErrorType: Integer);
   procedure SetFontSize(const Value: Integer);
   procedure SetFileName(const Value: String);
public
   property Text: String read FText write SetText;
   property FontSize: Integer read FFontSize write SetFontSize;
   property FileName: String read FFileName write SetFileName;
   procedure Draw(Surface: PDirectDrawSurface);
   constructor Create(DD: PDirectDraw);
   destructor Destroy;
end;

//Эффект
procedure ScaleDown(L: PLetterEffectArray);
var
   i: Integer;
begin
   for i:=0 to High(L^) do
   begin
      if L^[i].Scale < 0 then
      begin
         inc(L^[i].CurTime);
         if L^[i].CurTime <= L^[i].Delay then
         dec(L^[i].Scale, 1);
         exit;
      end;
   end;
end;
// ну и отрисовка
procedure TTextWithEffect.Draw(Surface: PDirectDrawSurface);
var
   i: Integer;
   rc: TRect;
   rc1: Trect;
   s: Integer;
begin
   if FontSurface = nil then exit;
   if FText = '' then exit;
   // рисуем текст без эффекта
   Surface^.Draw(32, 32, TextSurface.ClientRect, TextSurface, True);
   // вносим изменения в эффект
   ScaleDown(@LetterEffect);
   // и выводим текст с эффектом побуквенно
   for i:=0 to High(LetterWithEffect) do
   begin
      s := LetterEffect[i].Scale;
      if s = 32 then exit;
      rc1 := Rect(i*16,0,(i+1)*16,16);
      if s < 0 then
      begin
         rc := Rect(i*16+32-s, 64-s, ((i+1)*16)+32+s, 80+s);
         Surface^.StretchDraw(rc, rc1, TextSurface, True);
      end
      else Surface^.Draw(i*16+32, 64, rc1, TextSurface, True)
   end;
end;

Туториал по DelphiX.

Оформил: XVeL Автор: Daddy WEB-сайт: http://daddy.mirgames.ru

1. DXDraw

Align...................allClient	
AutoSize................True
Display
   FixedBitCount........True
   Fixedratio...........True	
   Fixedsize............False
Options
   DoFullScreen.........True
   doFlip...............True
   Rest.................False

procedure TForm1.WindowMode;
begin
   DXDraw1.Finalize;
   RestoreWindow;
   DXDraw1.Options := DXDraw1.Options - [doFullScreen];
   DXDraw1.Display.Width := 640;
   DXDraw1.Display.Height := 480;
   DXDraw1.Display.BitCount := 8;
   DXDraw1.Initialize;
end;
DXDraw.Align := alClient;
Form.ClientWidth := … // Установка ширины Формы/DХDrаw
Form.ClientHeight := … // Установка высоты Формы

procedure TForm1.FullScreenMode;
begin
   DXDraw1.Finalize;
   StoreWindow;
   DXDraw1.Options := DXDraw1.Options + [doFullScreen];
   DXDraw1.Display.Width := 640;
   DXDraw1.Display.Height := 480;
   DXDraw1.Display.BitCount := 8;
   DXDraw1.Initialize;
End;
// Set mode in non-Windows GUI Disable windows-controls-< purely graphics screen (very fast)
DXDraw.Options := DXDraw.Options + [doFlip];
// Enable Windows controls
DXDraw.Options := DXDraw.Options - [doFlip];
Screen.Cursor := CrNone; // Спрятать курсор
Form1.BorderStyle := bsSingle; // Спрятать бордюр формы

2. DXImageList

procedure LoadImage (Filename, NameImage : String; PatWidth, PatHeight : Integer; Transp : Boolean; TranspColor : TColor);
begin
   DXImageList.Items.Add;
   with DXImageList.Items[DXImageList.Items.Count-1] do
   begin
      Picture.LoadFromFile (FileName);
      Name := NameImage;
      PatternWidth := PatWidth;
      PatternHeight := PatHeight;
      SkipHeight := 0;
      SkipWidth := 0;
      SystemMemory := False;
      Transparent := Transp;
      TransparentColor := TranspColor;
      Restore;
   end;
end;

ImageList.Items.MakeColorTable;
DXDraw.ColorTable := ImageList.Items.ColorTable;
DXDraw.DefColorTable := ImageList.Items.ColorTable;
DXDraw.UpdatePalette;

Var Pal : TRGBQuad;
Pal.rgbRed := 16;
Pal.rgbGreen := 0;
Pal.rgbBlue := 0;
Pal.rgbReserved := 0;
DXDraw1.ColorTable[i] := Pal;

function ComposeColor(Dest,Src:TRGBQuad;Percent:Integer):TRGBQuad;
begin
   with Result do
   begin
      rgbRed :=Src.rgbRed+((Dest.rgbRed-Src.rgbRed)*Percent div256);
      rgbGreen :=Src.rgbGreen+((Dest.rgbGreen-Src.rgbGreen)*Percent div256);
      rgbBlue :=Src.rgbBlue+((Dest.rgbBlue-Src.rgbBlue)*Percent div256);
      rgbReserved :=0;
   end;
end;

Var Col : Integer;
for i:=0 to 255 do
   DXDraw1.ColorTable[i] := ComposeColor (RGBQuad(GetRValue(Col), GetGValue(Col), GetBValue(Col) ), DXDraw1.DefColorTable[i], p);
DXDraw1.UpdatePalette;

3. DXSpriteEngine

 
Sprite.Moved	= Допускать перемещение; да или нет
Sprite.Collisioned = Обнаруживать столкновение; да или нет

DXSpriteEngine.X := ...
DXSpriteEngine.Y := ...

X := ... // Новое значение X спрайта
Y := ... // Новое значение Y спрайта
DXSpriteEngine.X := -X + (DXSpriteEngine.Width div 2) - (Width div 2);
DXSpriteEngine.Y := -Y + (DXSpriteEngine.Height div 2) - (Height div 2);

TBackground = class (TBackgroundsprite)
public
   procedure DoMove (MoveCount : Integer); override;
end;
SBackground := TBackground.Create (DXSpriteEngine1.Engine);
with SBackground do
begin
   image := DXImageList1.Items.Find('image1');
   image.Transparent := false;
   SetMapSize(1,1);
   Z := -10;
   Tile := false;
end;
var SBackground : TBackground;

											
TBackground = class (TBackgroundsprite)
public
   procedure DoMove (MoveCount : Integer); override;
end;
procedure TBackground.DoMove (MoveCount : Integer);
begin
   inherited DoMove (MoveCount);
   X := X-1;
end;

MapWidth := 4; MapHeight := 4;
SBackground.Chips[0,0] to [3,3]
Randomize;
SBackground := TBackground.Create (DXSpriteEngine1.Engine);
with SBackground do
begin
   image := DXImageList1.Items.Find('backgr');
   image.Transparent := false;
   SetMapSize(4,4);
   Z := -10;
   for i := 0 to MapHeight-1 do
      for j := 0 to MapWidth-1 do
         Chips[j,i] := random(2);
   Tile := false;
end;

Chips[j,i] := -1; // тайл [j,i] будет без картинки

Randomize;
SBackground := TBackground.Create (DXSpriteEngine1.Engine);
with SBackground do
begin
   image := DXImageList1.Items.Find('backgr');
   image.Transparent := false;
   SetMapSize(5,5);
   Collisioned := True; //Не забудьте, иначе столкновения учитываться не будут!
   Z := -10;
   for i := 0 to MapHeight-1 do
       for j := 0 to MapWidth-1 do
       begin
          Chips[j,i] := random(2); // Выбирается случайный Тайл
          CollisionMap [j,i] := false; // Все Collisions отключены
       end;
   Tile := false;
end;
SBackground.CollisionMap [3,3] := true; // Тайл [3,3] "чувствует" столкновения

									
AnimPos		  текущий кадр анимации
AnimStart	  стартовый кадр
AnimCount	  количество кадров анимации (берется из PatternCount)
AnimLooped  для повтора анимации (по кругу)
AnimSpeed = (DXTimer.Interval / 1000) * FPS (напр.: Interval=1 и FPS=2 а 2/1000)

4. DXTimer

procedure TForm1.DXTimer1Timer(Sender: TObject; LagCount: Integer);
begin
   if not DXDraw1.CanDraw then Exit;
   DXDraw1.Surface.Fill (0);
   DXSpriteEngine1.Move (1);
   DXSpriteEngine1.Draw;
   DXDraw1.Flip;
end;

DXTimer1.Interval := 1000 div 60; // 60 раз в секунду вызываем метод OnTimer
LagCount is the (?). frequence +1 // частота = кол-во исполнений 'OnTimer'

DXSpriteEngine.Move(LagCount);
X := X+ 0.7*MoveCount; { Вы можете делать значение MoveCount таким-же, как и LagCount.
Вы можете посылать это значение через параметры метода но не надо
(Вы можете дать ваше собственное значение MoveCount) }

5. DXInput

//Получить текущее состояние
DXInput.Update;
//Текущее состояние джойстика
DXInput.Joystick.X;
DXInput.Joystick.Y;
//Определение движения джойстика:
if ((DXInput.Joystick.X><0) or (DXInput.Joystick.Y><0)) then
   ...
//Интервал осей
DXInput.Joystick.RangeX := ... // RangeX =10 то интервал: от-10 до +10
DXInput.Joystick.RangeY := ...
DXInput.Joystick.RangeZ := ...
//Определение состояния клавиатуры
if isLeft in DXInput.States then // Нажата кнопка влево.
   .....
if isRight in DXInput.States then
   ....
if isUp in DXInput.States then
   ....
if isDown in DXInput.States then
   ....
//Возможно, что DXInput.States содержит и IsUp и IsRight (вверх, вправо).
DXInput1.States := DXInput.States - [isButton1]; //Отключение 1 кнопки
DXInput1.States := DXInput.States + [isButton2]; //Включение 2 кнопки
//Кнопки
procedure TForm1. FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
   if Key = VK_ESCAPE then
      Close;
   if key = ord('B') then
      ...
end;
VK_ESCAPE
Ord (Ascii)
VK_F1 t/m VK_F10
VK_SPACE
VK_UP
VK_DOWN
VK_LEFT
VK_RIGHT

function GetDXVersion : String;
begin
   with tregistry.Create do
      try
         rootkey:=HKEY_LOCAL_MACHINE;
         if OpenKey( '\SOFTWARE\Microsoft\DirectX', False) then
            result:= copy(Readstring('Version'),4,3)
         else result:='DirectX не установлен';
      finally
         free;
      end;
end;

procedure Tform1.DXSound1Initialize(Sender: TObject);
var fmt:TWaveFormatEx;
begin
   try       // Set up the DXSound object to use high quality samples
      with Fmt do
      begin
         wFormatTag := WAVE_FORMAT_PCM;
         nSamplesPerSec := 44100;
         nChannels := 2;
         wBitsPerSample := 16;
         nBlockAlign := wBitsPerSample div 8 * nChannels;
         nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
      end;
      // must be in exclusive to set the format
      DXSound1.Options := DXSound1.Options + [soExclusive];
      DXSound1.Primary.SetFormat(Fmt);
   except       // Error
   end;
end;

with DXDraw1.Surface.Canvas do
begin
   Brush.Style := bsClear;
   Font.Size := 12;
   Font.Color := clRed;
   TextOut(0,0, ’Some Text’);
   Release;
end;

												
procedure TForm1.DXDrawMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);

Видео формат для использования в играх. Со звуком формата WAV (скоро будет MP3).

Оформил: XVeL Автор: Spose WEB-сайт: http://daddy.mirgames.ru

TIMHeader = record
   Face:array[1..5] of char; //Это типа мой идентификатор
   fps:byte; //Количество кадров в секунду
   Pictures:integer; //Количество картинок в файле
   width,height:integer; //Ширина и высота картинок
   sound:byte; //Если 1 то звук есть, если 0 то звука нет
   soundsize:int64; //Размер звукового файла
end;
//А в поле VAR пишем:
var
   schet:integer=1; //Количество картинок-schet=кадров осталось до конца
   fs:tfilestream; //Компонент необходимый для чтения файлов
   f:TImHeader; //Собственно заголовок Видео Файла
   center,str:boolean; //1е - елси нужно ровнять по центру, 2е-растянуть
   jpg:TjpegImage;//Картинка Jpeg
Теперь идет процедура типа StartScene:
fs:=tfilestream.Create('Имя файла',fmOpenRead); //Открываем видео файл
fs.Read(f,sizeof(f)); //Читаем заголовок
if f.sound=1 then
begin
   m:=tmemorystream.Create;
   m.CopyFrom(fs,f.soundsize);
   m.Position:=0;
   wl.Items.Find('sound').Wave.LoadFromStream(m);
   wl.Items.Find('sound').Restore;
end;
timer.Interval:=1000 div f.fps; //Устанавливаем скорость отрисовки картинок(кадры в секунду)
dximagelist.items.clear; //Отчищаем Имэйдж Лист от картинок, для освобождения памяти
dximagelist.Items.Add; //Добавляем один Итэм в Имэйдж Лист (в нем будет лежать каждый кадр видеоролика)
if (f.width=640) or (f.height=480) then //Если картинка например 640х240 то рисуем по центру
   center:=true
else
begin
   if (f.width=320) and (f.height=240) then //Если картинка пропорциональна 640хЧ80 то растягиваем
   str:=true;
end;
jpg:=tjpegimage.create;
dxtimer.Enabled:=true; //Начинаем отрисовку
end;

var //Объявляем переменные
   size:int64; //Размер изображения в Видео Файле
   memo:tmemorystream; //Временый участок памяти под картинку
begin
   if not ddraw.CanDraw then exit;
   if (schet=1) and (f.sound=1) then //Начинаем с первого кадра играть звук
      if dxsound.Initialized then wl.Items.Find('sound').Play(false);
   if schet<f.Pictures then //Если картинки в Видео Файле закончились
   begin //ТО:
      fs.Free; //Закрываем видео файл
      endscene; //Конец сцены (процедура типа EndScene)
      jpg.free; //Картинку тоже отчищаем
      exit; // Далее не продолжаем
   end else //А если картинки не закончились то:
   inc(schet); //Schet увеличиваем на единицу
   memo:=tmemorystream.Create; //Выделяем участок в памяти
   fs.Read(size,sizeof(size)); //Читаем из Видео Файла размер изображения
   memo.CopyFrom(fs,size); //Загружаем это изображение в память
   memo.Position:=0;
   jpg.LoadFromStream(memo); //Загружаем в нее изображение
   dximagelist.items.Items[0].Picture.Assign(jpg); //Засовываем картинку в Имэйдж Лист
   dximagelist.Items.Items[0].Restore; //принимаем изменения
   ddraw.Surface.Fill(0); //Заливаем фон черным(в случае если видео непрозрачное или на весь экран, можно не писать)
   {Далее 8 строк, проверяем на центрированость и на растяг, потом орисовываем картинку}
   if center then
   begin
      x:=(640-f.width)div 2;
      y:=(480-f.height)div 2;
      il.Items.Items[0].draw(ddraw.Surface,x,y,0);
   end;
   if str then il.Items.Items[0].stretchdraw(ddraw.Surface,bounds(0,0,640,480),0);
   memo.Free; //Отчищаем память от нарисованой картинки
   ddraw.flip; //Переключаем страницу видеопамяти (если эта процедура типа Scene, то можно не писать)

Игра отражений.

Оформил: DeeCo

Автор: Владимир Волосенков.

Музыку любите, а на инструменте неприличное слово нацарапали. "Республика ШКИД".

object := TMyObject.Create. // где-то в начале
  //....
object.Free; // где-то в конце

TComponentClass = class of TComponent; //ссылка на класс
function CreateAny(AType: TComponentClass): TComponent;
begin
  Result := AType.Create(nil);
end;
…
Form1.InsertComponent(CreateAny(TButton));
// Создали кнопку
Form1.InsertComponent(CreateAny(Edit1.ClassType));
// Создали еще одно поле редактирования

ТСоmр1ех*  c=new TComplex(1,1)

c = new TComplex(1,1); // выделяется память под TComplex и вызывается его конструктор с параметрами.
delete c; // освобождаем память предварительно вызвав деструктор Tcomplex

   class TChild : public TMama,TPapa{ // :o)
     TMemberOne member_1_;
     TMembarTwo member_2_;
   public:
     TChild() { cout<<"TChild created!"; }
   }

class E: public A,B {
     C* c_;
     D* d_;
   public:  
      E(); // реализацию см.ниже
     ~E() { delete d_; delete c_; }
   }
   E::E() // конструктор класса E
   try
      : A(1), B(1), c_( new C ), d_( new D ) // список инициализации
   { //начало тела конструктора
     cout<<"Constructor body";
   } // конец тела конструктора
   catch(...){ // ловим любое исключение
        A::~A();
        B::~B();
        delete c_;
        delete d_;
   }

function TSomething.Create(IsClassRef: boolean): TSomething;
begin
  if IsClassRef then
  try
    Self := TSomthing.NewInstance;
    InitInstance(Self);
    Self.Create(False); // Тело конструктора,
    // написанное разработчиком
    Self.AfterConstruction;
  except
    Self.Destroy; // Если что - харакири :)
  end
  else
    Self.Create(False); // Тело конструктора
  Result := Self;
end;

procedure TSomething.Destroy(Deallocate: boolean);
begin
  if Deallocate then
    Self.BeforeDestruction;
  Self.Destroy(False);
  if Deallocate then
  begin
    Self.CleanupInstance;
    Self.FreeInstance;
  end;
end;

   E::E() // конструктор класса E
   try
      : A(1), B(1), c_( NULL ), d_( NULL ) // список инициализации
      { //начало тела конструктора
     try{ 
         c_ = new C;
         d_ = new D;
         cout<<"Constructor body";
     }
     catch(...){
         if(c_) delete C;
         if(d_) delete D;
         throw;
     }
   } // конец тела конструктора
   catch(...){ // ловим любое исключение
        throw E_ErrorCreate();
   }

if Assigned(MyObject1) then
  FreeAndNil(MyObject1);
if Assigned(MyObject2) then
  FreeAndNil(MyObject2);

if (С ! = NULL) // что надо сделать с С

(КоТ: "Врать не надо по телефону" (с) Булгаков).

TItem = record …
end;
TArray = class
public
  property Items[Index: integer]: TItem
  read GetItem
    write SetItem;
  default;
end;

(Кот: я очень надеюсь, что у нас научатся, наконец, считать "Итого", а не только недостатки и достоинства отдельно).

typedef int Count;

type
  Count = type int64; // другой тип
  Alias = int64; // синоним

long FileSize = 256 * 1024;

(КоТ: плохо выглядит).

#ifndef _MYHEADER_H
#define _MYHEADER_H
… body of the header …
#endif

Гамма распределение.

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

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Гамма распределение
Возвращает случайное число, распределенное по закону Гамма-распределения
Зависимости: system
Автор:       Алексей Перов, aperov@rambler.ru, ICQ:102661702, Караганда
Copyright:   Лабораторные работы по курсу "Моделирование информационных систем", КарГТУ
Дата:        25 апреля 2002 г.
***************************************************** }
function RandomGamma(k, a: Extended): Extended;
{ гамма распределение }
var
  tr: Extended;
  i: Integer;
begin
  tr := 1;
  for i := 1 to Round(k) do
    tr := tr * random;
  Result := -ln(tr) / a
end;

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

x := RandomGamma(10, 5); 

Гауссово размывание (Gaussian Blur) в Delphi.

Во всяком случае вы можете сделать так:

unit GBlur2;
interface
uses Windows, Graphics;
type
  PRGBTriple = ^TRGBTriple;
  TRGBTriple = packed record
    b: byte; //легче для использования чем типа rgbtBlue...
    g: byte;
    r: byte;
  end;
  PRow = ^TRow;
  TRow = array[0..1000000] of TRGBTriple;
  PPRows = ^TPRows;
  TPRows = array[0..1000000] of PRow;
const
  MaxKernelSize = 100;
type
  TKernelSize = 1..MaxKernelSize;
  TKernel = record
    Size: TKernelSize;
    Weights: array[-MaxKernelSize..MaxKernelSize] of single;
  end;
  //идея заключается в том, что при использовании TKernel мы игнорируем
  //Weights (вес), за исключением Weights в диапазоне -Size..Size.
procedure GBlur(theBitmap: TBitmap; radius: double);
implementation
uses SysUtils;
procedure MakeGaussianKernel(var K: TKernel; radius: double;
  MaxData, DataGranularity: double);
//Делаем K (гауссово зерно) со среднеквадратичным отклонением = radius.
//Для текущего приложения мы устанавливаем переменные MaxData = 255,
//DataGranularity = 1. Теперь в процедуре установим значение
//K.Size так, что при использовании K мы будем игнорировать Weights (вес)
//с наименее возможными значениями. (Малый размер нам на пользу,
//поскольку время выполнения напрямую зависит от
//значения K.Size.)
var
  j: integer;
  temp, delta: double;
  KernelSize: TKernelSize;
begin
  for j := Low(K.Weights) to High(K.Weights) do
  begin
    temp := j / radius;
    K.Weights[j] := exp(-temp * temp / 2);
  end;
  //делаем так, чтобы sum(Weights) = 1:
  temp := 0;
  for j := Low(K.Weights) to High(K.Weights) do
    temp := temp + K.Weights[j];
  for j := Low(K.Weights) to High(K.Weights) do
    K.Weights[j] := K.Weights[j] / temp;
  //теперь отбрасываем (или делаем отметку "игнорировать"
  //для переменной Size) данные, имеющие относительно небольшое значение -
  //это важно, в противном случае смазавание происходим с малым радиусом и
  //той области, которая "захватывается" большим радиусом...
  KernelSize := MaxKernelSize;
  delta := DataGranularity / (2 * MaxData);
  temp := 0;
  while (temp < delta) and (KernelSize > 1) do
  begin
    temp := temp + 2 * K.Weights[KernelSize];
    dec(KernelSize);
  end;
  K.Size := KernelSize;
  //теперь для корректности возвращаемого результата проводим ту же
  //операцию с K.Size, так, чтобы сумма всех данных была равна единице:
  temp := 0;
  for j := -K.Size to K.Size do
    temp := temp + K.Weights[j];
  for j := -K.Size to K.Size do
    K.Weights[j] := K.Weights[j] / temp;
end;
function TrimInt(Lower, Upper, theInteger: integer): integer;
begin
  if (theInteger <= Upper) and (theInteger >= Lower) then
    result := theInteger
  else if theInteger > Upper then
    result := Upper
  else
    result := Lower;
end;
function TrimReal(Lower, Upper: integer; x: double): integer;
begin
  if (x < upper) and (x >= lower) then
    result := trunc(x)
  else if x > Upper then
    result := Upper
  else
    result := Lower;
end;
procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
var
  j, n, LocalRow: integer;
  tr, tg, tb: double; //tempRed и др.
  w: double;
begin
  for j := 0 to High(theRow) do
  begin
    tb := 0;
    tg := 0;
    tr := 0;
    for n := -K.Size to K.Size do
    begin
      w := K.Weights[n];
      //TrimInt задает отступ от края строки...
      with theRow[TrimInt(0, High(theRow), j - n)] do
      begin
        tb := tb + w * b;
        tg := tg + w * g;
        tr := tr + w * r;
      end;
    end;
    with P[j] do
    begin
      b := TrimReal(0, 255, tb);
      g := TrimReal(0, 255, tg);
      r := TrimReal(0, 255, tr);
    end;
  end;
  Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple));
end;
procedure GBlur(theBitmap: TBitmap; radius: double);
var
  Row, Col: integer;
  theRows: PPRows;
  K: TKernel;
  ACol: PRow;
  P: PRow;
begin
  if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then
    raise
      exception.Create('GBlur может работать только с 24-битными изображениями');
  MakeGaussianKernel(K, radius, 255, 1);
  GetMem(theRows, theBitmap.Height * SizeOf(PRow));
  GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));
  //запись позиции данных изображения:
  for Row := 0 to theBitmap.Height - 1 do
    theRows[Row] := theBitmap.Scanline[Row];
  //размываем каждую строчку:
  P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
  for Row := 0 to theBitmap.Height - 1 do
    BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
  //теперь размываем каждую колонку
  ReAllocMem(P, theBitmap.Height * SizeOf(TRGBTriple));
  for Col := 0 to theBitmap.Width - 1 do
  begin
    //- считываем первую колонку в TRow:
    for Row := 0 to theBitmap.Height - 1 do
      ACol[Row] := theRows[Row][Col];
    BlurRow(Slice(ACol^, theBitmap.Height), K, P);
    //теперь помещаем обработанный столбец на свое место в данные изображения:
    for Row := 0 to theBitmap.Height - 1 do
      theRows[Row][Col] := ACol[Row];
  end;
  FreeMem(theRows);
  FreeMem(ACol);
  ReAllocMem(P, 0);
end;
end.

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

procedure TForm1.Button1Click(Sender: TObject);
var
  b: TBitmap;
begin
  if not openDialog1.Execute then
    exit;
  b := TBitmap.Create;
  b.LoadFromFile(OpenDialog1.Filename);
  b.PixelFormat := pf24Bit;
  Canvas.Draw(0, 0, b);
  GBlur(b, StrToFloat(Edit1.text));
  Canvas.Draw(b.Width, 0, b);
  b.Free;
end;

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

Гауссово размывание (Gaussian Blur) в Delphi (продолжение) - Создание тени у метки.

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

ShowFade(CaptionLabel);
//или
ShowFadeWithParam(CaptionLabel,3,3,2,clGray);

Blur.pas.

unit blur;
interface
uses
  Classes, graphics, stdctrls, gblur2;
const
  add_width = 4;
  add_height = 5;
type
  TBlurThread = class(TThread)
  private
    { Private declarations }
    text_position: Integer;
    FadeLabel: TLabel;
    Temp_Bitmap: TBitmap;
    procedure ShowBlur;
    procedure SetSize;
  protected
    F_width, F_X, F_Y: Integer;
    F_color: TColor;
    procedure Execute; override;
  public
    constructor Create(Sender: TLabel; Fade_width: integer; Fade_X: Integer;
      Fade_Y: Integer; Fade_color: TColor);
    destructor Destroy;
  end;
procedure ShowFade(Sender: TLabel);
procedure ShowFadeWithParam(Sender: TLabel; Fade_width: integer; Fade_X:
  Integer; Fade_Y: Integer; Fade_color: TColor);
implementation
procedure ShowFadeWithParam(Sender: TLabel; Fade_width: integer; Fade_X:
  Integer; Fade_Y: Integer; Fade_color: TColor);
var
  SlowThread: TBlurThread;
begin
  SlowThread := TBlurThread.Create(Sender, Fade_width, Fade_X, Fade_Y,
    Fade_color);
  SlowThread.Priority := tpIdle;
  SlowThread.Resume;
end;
procedure ShowFade;
var
  SlowThread: TBlurThread;
begin
  SlowThread := TBlurThread.Create(Sender, 3, 3, 3, clBlack);
  SlowThread.Priority := tpIdle;
  //SlowThread.Priority:=tpLowest;
  //SlowThread.Priority:=tpTimeCritical;
  SlowThread.Resume;
end;
constructor TBlurThread.Create(Sender: TLabel; Fade_width: integer; Fade_X:
  Integer; Fade_Y: Integer; Fade_color: TColor);
begin
  Temp_Bitmap := TBitmap.Create;
  Temp_Bitmap.Canvas.Font := Sender.Font;
  FadeLabel := Sender;
  F_width := Fade_width;
  F_X := Fade_X;
  F_Y := Fade_Y;
  F_color := Fade_color;
  inherited Create(True);
end;
destructor TBlurThread.Destroy;
begin
  Temp_Bitmap.Free;
  inherited Destroy;
end;
procedure TBlurThread.ShowBlur;
begin
  FadeLabel.Canvas.Draw(text_position + F_X, F_Y, Temp_Bitmap);
  FadeLabel.Canvas.TextOut(text_position, 0, FadeLabel.Caption);
end;
procedure TBlurThread.SetSize;
begin
  if FadeLabel.Width < (Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) + F_width
    + F_X {add_width}) then
  begin
    FadeLabel.Width := Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) + F_width
      + F_X {add_width};
    FadeLabel.Tag := 2;
  end
  else
    FadeLabel.Tag := 0;
  if FadeLabel.Height < (Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption) +
    F_width + F_Y {add_height}) then
  begin
    FadeLabel.Height := Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption) +
      F_width + F_Y {add_height};
    FadeLabel.Tag := 1;
  end
  else if FadeLabel.Tag <> 2 then
    FadeLabel.Tag := 0;
end;
{ TBlurThread }
procedure TBlurThread.Execute;
begin
  { Place thread code here }
  Synchronize(SetSize);
  if FadeLabel.Tag = 0 then
  begin
    Temp_Bitmap.Width := FadeLabel.Width;
    Temp_Bitmap.Height := FadeLabel.Height;
    Temp_Bitmap.Canvas.Brush.Color := FadeLabel.Color;
    Temp_Bitmap.Canvas.FillRect(FadeLabel.ClientRect);
    Temp_Bitmap.Canvas.Font.Color := F_color; //clBlack
    if FadeLabel.Alignment = taRightJustify then
      text_position := FadeLabel.Width -
        Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) - F_width - F_X {add_width}
    else if FadeLabel.Alignment = taCenter then
      text_position := (FadeLabel.Width -
        Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) - F_width - F_X
        {add_width}) div 2
    else
      text_position := 0;
    Temp_Bitmap.Canvas.TextOut(0, 0, FadeLabel.Caption);
    Temp_Bitmap.PixelFormat := pf24Bit;
    GBlur(Temp_Bitmap, F_width);
    //Temp_Bitmap.SaveToFile('a.bmp');
    Synchronize(ShowBlur);
  end;
end;
end.

GDI - графика в Delphi.

А теперь самое время приступить к рассмотрению того, как устроен GDI. Ниже, в таблице, представлены некоторые важные классы:

Ниже приведены две функции, которые используются для рисования линий и обе принадлежат TCanvas:

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

procedure TForm1.FormCreate(Sender: TObject);
begin
  // инициализируем генератор
  // случайных чисел
  Randomize;
end;
const
  NUM_LINES = 2000;
procedure TForm1.DrawLines;
var
  i: Integer;
begin
  for i := 0 to NUM_LINES - 1 do
  begin
    Canvas.Pen.Color :=
      RGB(Random(256),
      Random(256),
      Random(256));
    Canvas.LineTo
      (Random(ClientWidth),
      Random(ClientHeight));
  end;
end;

Процедура DrawLines вызывается из обработчика кнопки OnClick. Количество линий задаётся в константе NUM_LINES. Между прочим, функция RGB, составляет цвет каждой линии из трёх основных составляющих: красного, зелёного и синего (значения от 0 до 255) и возвращает нам цвет в виде TColor. О цветах поговорим немного позже, а вот так выглядит нарисованный пейзаж:

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

Ещё есть очень нужная функция TextOut, которая позволяет рисовать текст, используя шрифт, заданный в канвасе:

Ниже представлен пример, который рисует случайным образом различные фигуры:

const
  NUM_SHAPES = 200;
procedure TForm1.DrawShapes;
var
  i, ShapeLeft, ShapeTop: Integer;
begin
  for i := 0 to NUM_SHAPES - 1 do
  begin
    Canvas.Brush.Color :=
      RGB(Random(256),
      Random(256),
      Random(256));
    ShapeLeft := Random(ClientWidth);
    ShapeTop := Random(ClientHeight);
    // теперь, случайным образом, решаем что рисовать
    case Random(3) of
      0: Canvas.Rectangle(ShapeLeft,
          ShapeTop,
          ShapeLeft + Random(50),
          ShapeTop + Random(50));
      1: Canvas.Ellipse(ShapeLeft,
          ShapeTop,
          ShapeLeft + Random(50),
          ShapeTop + Random(50));
      2:
        begin
          Canvas.Font.Size := 10 + Random(7); // от 10 до 16
          Canvas.TextOut(ShapeLeft, ShapeTop, 'Some text');
        end;
    end;
  end;
end;

Для примера, поместите следующий код в проект:

procedure TForm1.DrawSomeText;
begin
  Canvas.TextOut(10, 10, 'Some text');
end;

Ради интереса можно взглянуть на таблицу, в которой представлены примеры вызовов некоторых функций из VCL и их аналогов из Windows API.

Битмапы можно рисовать не только на форме, но и по всему экрану. Может это и может показаться немного странным, но иногда это бывает полезно, особенно при создании скринсейвера. Однако, сначала нам необходимо разобраться с тем, как работать с битмапами. Вот небольшой пример:

procedure Form1.DrawBitmap(const Filename: string; const x, y: Integer);
var
  Bmp: TBitmap;
begin
  // Сперва убедимся, что файл существует!
  if not FileExists(Filename) then
  begin
    ShowMessage('The bitmap ' + Filename + ' was not found!');
    Exit;
  end;
  Bmp := TBitmap.Create;
  try
    Bmp.LoadFromFile(Filename);
    Canvas.Draw(x, y, Bmp);
  finally
    Bmp.Free;
  end;
end;

Все эти функции являются методами TCanvas.

TCanvas.Draw является обёрткой для API функции BitBlt:

function BitBlt(
  hdcDest: HDC; // дескриптор конечного контекста устройства
  nXDest, // коорд. x верхнего левого угла конечного прямоугольника
  nYDest, // коорд. y верхнего левого угла конечного прямоугольника
  nWidth, // ширина конечного прямоугольника
  nHeight: Integer; // высота конечного прямоугольника
  hdcSrc: HDC; // дескриптор исходного контекста устройства
  nXSrc, // коорд. x верхнего левого угла исходного прямоугольника
  nYSrc: Integer; // коорд. y верхнего левого угла исходного прямоугольника
  dwRop: DWORD // код растровой операции
  ): Boolean;

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

Генетические алгоритмы.

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

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Генетические алгоритмы
Класс, реализующий генетический алгоритм.
Зависимости: Classes, SysUtils, Windows, Math
Автор:       Mystic, mystic2000@newmail.ru, ICQ:125905046, Харьков
Copyright:   Mystic
Дата:        25 апреля 2002 г.
***************************************************** }
unit Genes;
interface
uses {Fuzzy,}  Classes, SysUtils, Windows, Math;
type
  TGeneAlgorithm = class;
  TExtendedArray = array of Extended;
  TEstimateEvent = procedure(Sender: TObject; const X: TExtendedArray; var Y:
    Extended) of object;
  TIterationEvent = procedure(Sender: TObject; Iteration: Integer);
  TBestChangeEvent = procedure(Sender: TObject; BestEstimate: Extended);
  EGeneError = class(Exception)
  end;
  TCardinalArray = array of Cardinal;
  TGeneRecord = record
    Bits: TCardinalArray;
    Values: TExtendedArray;
    Estimate: Extended;
  end;
  TGeneRecords = array of TGeneRecord;
  TSolutionThread = class(TThread)
  private
    FOwner: TGeneAlgorithm;
  protected
    procedure Execute; override;
    property Owner: TGeneAlgorithm read FOwner;
  public
    constructor Create(AOwner: TGeneAlgorithm);
  end;
  TGeneState = (gsExecute, gsSuspend, gsTune);
  TGeneAlgorithm = class
  private
    FData: array of TGeneRecord; // Algorithm data
    FLock: TRTLCriticalSection;
    FLowValues: TExtendedArray;
    FHighValues: TExtendedArray;
    FSolutionThread: TSolutionThread;
    FMutation: Extended;
    FInversion: Extended;
    FCrossover: Extended;
    FMaxPopulation: Integer;
    FBitPerNumber: Integer;
    FMinPopulation: Integer;
    FDimCount: Integer;
    FOnBestChange: TBestChangeEvent;
    FOnEstimate: TEstimateEvent;
    FOnIteration: TIterationEvent;
    FIteration: Integer;
    // FBestEstimate: Extended;
    FState: TGeneState;
    BitSize: Integer;
    function GetBestEstimate: Extended;
    function GetHighValues(I: Integer): Extended;
    function GetIteration: Integer;
    function GetLowValues(I: Integer): Extended;
    procedure SetBitPerNumber(const Value: Integer);
    procedure SetCrossover(const Value: Extended);
    procedure SetDimCount(const Value: Integer);
    procedure SetHighValues(I: Integer; const Value: Extended);
    procedure SetInversion(const Value: Extended);
    procedure SetLowValues(I: Integer; const Value: Extended);
    procedure SetMaxPopulation(const Value: Integer);
    procedure SetMinPopulation(const Value: Integer);
    procedure SetMutation(const Value: Extended);
    procedure SetOnBestChange(const Value: TBestChangeEvent);
    procedure SetOnEstimate(const Value: TEstimateEvent);
    procedure SetOnIteration(const Value: TIterationEvent);
    procedure Lock;
    procedure Unlock;
    function GetBestX(I: Integer): Extended;
    function GetState: TGeneState;
    procedure DoCrossover(N: Integer);
    procedure DoMutation(N: Integer);
    procedure DoInversion(N: Integer);
    procedure EstimatePopulation(StartIndex: Integer);
    procedure SortPopulation;
    procedure MakeChild;
  public
    // Creation & destroying
    constructor Create;
    destructor Destroy; override;
    // Running / stopping
    procedure Run;
    procedure Abort;
    procedure Suspend;
    procedure Resume;
    // Saving / opening
    procedure LoadFromStream(S: TStream);
    procedure SaveToStream(S: TStream);
    // Algorithm param
    property BitPerNumber: Integer read FBitPerNumber write SetBitPerNumber;
    property MaxPopulation: Integer read FMaxPopulation write SetMaxPopulation;
    property MinPopulation: Integer read FMinPopulation write SetMinPopulation;
    property Crossover: Extended read FCrossover write SetCrossover;
    property Mutation: Extended read FMutation write SetMutation;
    property Inversion: Extended read FInversion write SetInversion;
    property DimCount: Integer read FDimCount write SetDimCount;
    property LowValues[I: Integer]: Extended read GetLowValues write
      SetLowValues;
    property HighValues[I: Integer]: Extended read GetHighValues write
      SetHighValues;
    // Info property
    property Iteration: Integer read GetIteration;
    property BestX[I: Integer]: Extended read GetBestX;
    property BestEstimate: Extended read GetBestEstimate;
    property State: TGeneState read GetState;
    // Events
    property OnEstimate: TEstimateEvent read FOnEstimate write SetOnEstimate;
    property OnIteration: TIterationEvent read FOnIteration write
      SetOnIteration;
    property OnBestChange: TBestChangeEvent read FOnBestChange write
      SetOnBestChange;
  end;
implementation
resourcestring
  SCannotSetParam = 'Невозможно установить параметр %s в состоянии %s';
  SCannotGetParam = 'Невозможно прочитать параметр %s в состоянии %s';
  SInvalidParam = 'Параметр %s не может быть %s (%d).';
  SNonPositive = 'отрицательным или нулевым';
  SInvalidProbality = 'вероятность %s должна быть в диапазоне 0..1 (%f).';
  SLess2 = 'меньше двух';
  SEmpty =
    'Неправильный индекс при обращении к %s (%d) при нулевом количества элементов.';
  SInvalidIndex =
    'Неправильный индекс при обращении к %s (%d). Индекс должен лежать в диапазоне от %d до %d';
  SNonEstimate = 'Не задана функция оценки.';
const
  SState: array[TGeneState] of string = (
    'настройки параметров алгоритма',
    'работы алгоритма',
    'остановки алгоритма');
  { TGeneAlgorithm }
procedure TGeneAlgorithm.Abort;
var
  I: Integer;
begin
  if FState = gsExecute then
  begin
    FSolutionThread.Terminate;
    FSolutionThread.WaitFor;
  end;
  Lock;
  try
    for I := 0 to Length(FData) - 1 do
    begin
      SetLength(FData[I].Bits, 0);
      SetLength(FData[I].Values, 0);
    end;
    SetLength(FData, 0);
    FState := gsTune;
  finally
    Unlock;
  end;
end;
constructor TGeneAlgorithm.Create;
begin
  InitializeCriticalSection(FLock);
  FBitPerNumber := 8;
  FMinPopulation := 5000;
  FMaxPopulation := 10000;
  FMutation := 0.1;
  FCrossover := 0.89;
  FInversion := 0.01;
  FDimCount := 0;
  FState := gsTune;
end;
destructor TGeneAlgorithm.Destroy;
begin
  Abort;
  DeleteCriticalSection(FLock);
  SetLength(FLowValues, 0);
  SetLength(FHighValues, 0);
  inherited;
end;
procedure TGeneAlgorithm.DoCrossover(N: Integer);
var
  I: Integer;
  Parent1, Parent2: Integer;
  Bit, ByteCount: Integer;
  BitPos: Byte;
  Mask: Integer;
begin
  Parent1 := Random(FMinPopulation);
  Parent2 := Random(FMinPopulation);
  Bit := Random(FDimCount * FBitPerNumber - 1);
  ByteCount := Bit div 32;
  for I := 0 to ByteCount - 1 do
    FData[N].Bits[I] := FData[Parent1].Bits[I];
  for I := ByteCount + 1 to BitSize - 1 do
    FData[N].Bits[I] := FData[Parent2].Bits[I];
  BitPos := Bit - 32 * ByteCount;
  asm
    MOV CL, BitPos
    MOV EAX, -1
    SHL EAX, CL
    MOV Mask, EAX
  end;
  FData[N].Bits[ByteCount] :=
    (FData[Parent1].Bits[ByteCount] and not Mask) or
    (FData[Parent2].Bits[ByteCount] and Mask);
end;
procedure TGeneAlgorithm.DoInversion(N: Integer);
  function GetBit(Addr: Pointer; No: Integer): Byte; assembler;
  asm
  MOV EAX, Addr
  MOV ECX, No
  BT [EAX], ECX
  SBB EAX, EAX
  AND EAX, 1
  end;
  procedure SetBit(Addr: Pointer; No: Integer; Value: Byte); assembler;
  asm
  MOV EAX, Addr
  OR Value,Value
  JZ @@1
  BTS [EAX], No
  RET
@@1:
  BTR [EAX], No
  RET
  end;
var
  Parent, Bit, I: Integer;
  B: Byte;
begin
  Parent := Random(FMinPopulation);
  Bit := Random(FDimCount * FBitPerNumber - 1);
  FData[N].Bits := FData[Parent].Bits;
  repeat
    B := GetBit(FData[N].Bits, 0);
    for I := 0 to FDimCount * FBitPerNumber - 2 do
      SetBit(FData[N].Bits, I, GetBit(FData[N].Bits, I + 1));
    SetBit(FData[N].Bits, FDimCount * FBitPerNumber - 1, B);
    if Bit = 0 then
      Break;
    Bit := Bit - 1;
  until False;
end;
procedure TGeneAlgorithm.DoMutation(N: Integer);
var
  Parent: Integer;
  Bit, BitPos, ByteCount: Integer;
  Mask: Cardinal;
begin
  Parent := Random(FMinPopulation);
  Bit := Random(FDimCount * FBitPerNumber);
  ByteCount := Bit div 32;
  BitPos := Bit - 32 * ByteCount;
  Mask := 1 shl BitPos;
  FData[N].Bits := FData[Parent].Bits;
  FData[N].Bits[ByteCount] := FData[N].Bits[ByteCount] xor Mask;
end;
procedure TGeneAlgorithm.EstimatePopulation(StartIndex: Integer);
var
  I, J, K, Index: Integer;
  P, Q, Y: Extended;
  MaxWeight, Weight: Extended;
  Addr: Pointer;
  GrayBit, BinBit: Cardinal;
begin
  MaxWeight := Power(2, FBitPerNumber);
  for I := StartIndex to Length(FData) - 1 do
  begin
    Index := 0;
    Addr := FData[I].Bits;
    for J := 0 to FDimCount - 1 do
    begin
      Weight := 0.5 * MaxWeight;
      P := 0.0;
      BinBit := 0;
      for K := 0 to FBitPerNumber - 1 do
      begin
        asm
          MOV EAX, Addr
          MOV ECX, Index
          BT [EAX], ECX
          SBB EAX, EAX
          AND EAX, 1
          MOV GrayBit, EAX
          INC Index
        end;
        BinBit := BinBit xor GrayBit;
        if BinBit = 1 then
          P := P + Weight;
        Weight := 0.5 * Weight;
      end;
      P := P / MaxWeight;
      Q := 1 - P;
      FData[I].Values[J] := P * FHighValues[J] + Q * FLowValues[J];
    end;
    Y := 0;
    FOnEstimate(Self, FData[I].Values, Y);
    FData[I].Estimate := Y;
  end;
end;
function TGeneAlgorithm.GetBestEstimate: Extended;
begin
  Lock;
  try
    Result := 0.0; //Kill warning
    if FState = gsTune then
      raise EGeneError.CreateFmt(SCannotGetParam, ['BestEstimate',
        SState[FState]]);
    Result := FData[0].Estimate;
  finally
    Unlock;
  end;
end;
function TGeneAlgorithm.GetBestX(I: Integer): Extended;
begin
  Lock;
  try
    Result := 0.0; // Kill warning
    if FState = gsTune then
      raise EGeneError.CreateFmt(SCannotGetParam, ['BestX', SState[FState]]);
    if (FDimCount = 0) then
      raise EGeneError.CreateFmt(SEmpty, ['BestX', I]);
    if (I < 0) or (I >= FDimCount) then
      raise EGeneError.CreateFmt(SInvalidIndex, ['BestX', I, 0, DimCount]);
    Result := FData[0].Values[I];
  finally
    Unlock;
  end;
end;
function TGeneAlgorithm.GetHighValues(I: Integer): Extended;
begin
  Lock;
  try
    Result := 0.0; // Kill warning
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotGetParam, ['HighValues',
        SState[FState]]);
    if (FDimCount = 0) then
      raise EGeneError.CreateFmt(SEmpty, ['HighValues', I]);
    if (I < 0) or (I >= FDimCount) then
      raise EGeneError.CreateFmt(SInvalidIndex, ['HighValues', I, 0, DimCount]);
    Result := FHighValues[I];
  finally
    Unlock;
  end;
end;
function TGeneAlgorithm.GetIteration: Integer;
begin
  Lock;
  try
    Result := 0; // Kill warning
    if FState = gsTune then
      raise EGeneError.CreateFmt(SCannotGetParam, ['Iteration',
        SState[FState]]);
    Result := FIteration;
  finally
    Unlock;
  end;
end;
function TGeneAlgorithm.GetLowValues(I: Integer): Extended;
begin
  Lock;
  try
    Result := 0.0; // Kill warning
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotGetParam, ['LowValues',
        SState[FState]]);
    if (FDimCount = 0) then
      raise EGeneError.CreateFmt(SEmpty, ['LowValues', I]);
    if (I < 0) or (I >= FDimCount) then
      raise EGeneError.CreateFmt(SInvalidIndex, ['LowValues', I, 0, DimCount]);
    Result := FLowValues[I];
  finally
    Unlock;
  end;
end;
function TGeneAlgorithm.GetState: TGeneState;
begin
  Lock;
  try
    Result := FState;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.LoadFromStream(S: TStream);
begin
end;
procedure TGeneAlgorithm.Lock;
begin
  EnterCriticalSection(FLock);
end;
procedure TGeneAlgorithm.MakeChild;
var
  I: Integer;
  RandomValue: Extended;
begin
  for I := FMinPopulation to FMaxPopulation - 1 do
  begin
    RandomValue := Random;
    if RandomValue < FCrossover then
      DoCrossover(I)
    else if RandomValue < FCrossover + FMutation then
      DoMutation(I)
    else
      DoInversion(I);
  end;
end;
procedure TGeneAlgorithm.Resume;
begin
  if FState <> gsSuspend then
    raise EGeneError.Create('Прежде чем возобновить, надо начать!');
  FSolutionThread.Create(Self);
  FState := gsExecute;
end;
procedure TGeneAlgorithm.Run;
var
  I, J: Integer;
  b1, b2: Cardinal;
begin
  Lock;
  try
    if not Assigned(FOnEstimate) then
      raise EGeneError.Create(SNonEstimate);
    Abort;
    try
      // Getting memory
      SetLength(FData, FMaxPopulation);
      for I := 0 to Length(FData) - 1 do
      begin
        FData[I].Values := nil;
        FData[I].bits := nil;
      end;
      BitSize := FDimCount * FBitPerNumber + 31;
      BitSize := BitSize and not 31;
      BitSize := BitSize div 32;
      for I := 0 to Length(FData) - 1 do
      begin
        SetLength(FData[I].Values, DimCount);
        SetLength(FData[I].Bits, BitSize);
      end;
      // Initializing Population
      for I := 0 to Length(FData) - 1 do
      begin
        for J := 0 to BitSize - 1 do
        begin
          b1 := Random(35536);
          b2 := Random(35536);
          FData[I].Bits[J] := b1 shl 16 + b2;
        end;
      end;
      EstimatePopulation(0);
      SortPopulation;
      FIteration := 0;
      FState := gsExecute;
      FSolutionThread := TSolutionThread.Create(Self);
    except
      Abort;
    end;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SaveToStream(S: TStream);
begin
end;
procedure TGeneAlgorithm.SetBitPerNumber(const Value: Integer);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['BitPerNumber',
        SState[FState]]);
    if Value <= 0 then
      raise EGeneError.CreateFmt(SInvalidParam, ['BitPerNumber', SNonPositive,
        Value]);
    FBitPerNumber := Value;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SetCrossover(const Value: Extended);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['Crossover',
        SState[FState]]);
    if (Value < 0) or (Value > 1) then
      raise EGeneError.CreateFmt(SInvalidProbality, ['кроссовера', Value]);
    FCrossover := Value;
    if FCrossover + FMutation > 1.0 then
    begin
      FMutation := 1.0 - FCrossover;
      FInversion := 0.0;
    end
    else
    begin
      FInversion := 1.0 - FMutation - FCrossover;
    end;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SetDimCount(const Value: Integer);
var
  I: Integer;
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['DimCount', SState[FState]]);
    if FDimCount = Value then
      Exit;
    if Value <= 0 then
      raise EGeneError.CreateFmt(SInvalidParam, ['DimCount', SNonPositive,
        Value]);
    SetLength(FLowValues, Value);
    SetLength(FHighValues, Value);
    for I := FDimCount to Value - 1 do
    begin
      FLowValues[I] := 0.0;
      FHighValues[I] := 1.0;
    end;
    FDimCount := Value;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SetHighValues(I: Integer; const Value: Extended);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['HighValues',
        SState[FState]]);
    if (FDimCount = 0) then
      raise EGeneError.CreateFmt(SEmpty, ['HighValues', Value]);
    if (I < 0) or (I >= FDimCount) then
      raise EGeneError.CreateFmt(SInvalidIndex, ['HighValues', Value, 0,
        DimCount]);
    FHighValues[I] := Value;
    if FLowValues[I] > FHighValues[I] then
      FLowValues[I] := FHighValues[I];
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SetInversion(const Value: Extended);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['Crossover',
        SState[FState]]);
    if (Value < 0) or (Value > 1) then
      raise EGeneError.CreateFmt(SInvalidProbality, ['инверсии', Value]);
    FInversion := Value;
    if FCrossover + FInversion > 1.0 then
    begin
      FCrossover := 1.0 - FInversion;
      FMutation := 0.0;
    end
    else
    begin
      FMutation := 1.0 - FInversion - FCrossover;
    end;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SetLowValues(I: Integer; const Value: Extended);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['LowValues',
        SState[FState]]);
    if (FDimCount = 0) then
      raise EGeneError.CreateFmt(SEmpty, ['LowValues', Value]);
    if (I < 0) or (I >= FDimCount) then
      raise EGeneError.CreateFmt(SInvalidIndex, ['LowValues', Value, 0,
        DimCount]);
    FLowValues[I] := Value;
    if FHighValues[I] < FLowValues[I] then
      FHighValues[I] := FLowValues[I];
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SetMaxPopulation(const Value: Integer);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['MaxPopulation',
        SState[FState]]);
    if Value < 2 then
      raise EGeneError.CreateFmt(SInvalidParam, ['MaxPopulation', SLess2,
        Value]);
    FMaxPopulation := Value;
    if FMinPopulation >= FMaxPopulation then
      FMinPopulation := FMaxPopulation - 1;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SetMinPopulation(const Value: Integer);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['MinPopulation',
        SState[FState]]);
    if Value <= 0 then
      raise EGeneError.CreateFmt(SInvalidParam, ['MinPopulation', SNonPositive,
        Value]);
    FMinPopulation := Value;
    if FMinPopulation >= FMaxPopulation then
      FMaxPopulation := FMinPopulation + 1;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SetMutation(const Value: Extended);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['Crossover',
        SState[FState]]);
    if (Value < 0) or (Value > 1) then
      raise EGeneError.CreateFmt(SInvalidProbality, ['мутации', Value]);
    FMutation := Value;
    if FCrossover + FMutation > 1.0 then
    begin
      FCrossover := 1.0 - FMutation;
      FInversion := 0.0;
    end
    else
    begin
      FInversion := 1.0 - FMutation - FCrossover;
    end;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SetOnBestChange(const Value: TBestChangeEvent);
begin
  Lock;
  try
    FOnBestChange := Value;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SetOnEstimate(const Value: TEstimateEvent);
begin
  Lock;
  try
    if FState <> gsTune then
      raise EGeneError.CreateFmt(SCannotSetParam, ['OnEstimate',
        SState[FState]]);
    FOnEstimate := Value;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SetOnIteration(const Value: TIterationEvent);
begin
  Lock;
  try
    FOnIteration := Value;
  finally
    Unlock;
  end;
end;
procedure TGeneAlgorithm.SortPopulation;
  procedure QuickSort(L, R: Integer);
  var
    I, J: Integer;
    P: Extended;
    T: TGeneRecord;
  begin
    repeat
      I := L;
      J := R;
      P := FData[(L + R) shr 1].Estimate;
      repeat
        while FData[I].Estimate > P do
          Inc(I);
        while FData[J].Estimate < P do
          Dec(J);
        if I <= J then
        begin
          if (I = 0) or (J = 0) then
            Lock;
          try
            T := FData[I];
            FData[I] := FData[J];
            FData[J] := T;
          finally
            if (I = 0) or (J = 0) then
              UnLock;
          end;
          Inc(I);
          Dec(J);
        end;
      until I > J;
      if L < J then
        QuickSort(L, J);
      L := I;
    until I >= R;
  end;
begin
  QuickSort(0, Length(FData) - 1);
end;
procedure TGeneAlgorithm.Suspend;
begin
  if FState <> gsExecute then
    raise EGeneError.Create('Прежде чем остановить, надо запустить!');
  FSolutionThread.Terminate;
  // FSolutionThread.WaitFor;
  FState := gsSuspend;
end;
procedure TGeneAlgorithm.Unlock;
begin
  LeaveCriticalSection(FLock);
end;
{ TSolutionThread }
constructor TSolutionThread.Create(AOwner: TGeneAlgorithm);
begin
  FOwner := AOwner;
  FreeOnTerminate := True;
  inherited Create(False);
end;
procedure TSolutionThread.Execute;
begin
  repeat
    Owner.MakeChild;
    Owner.EstimatePopulation(Owner.FMinPopulation);
    Owner.SortPopulation;
    Inc(Owner.FIteration);
  until Terminated;
  Sleep(10);
end;
end.

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

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Genes, ExtCtrls, Grids;
type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Edit4: TEdit;
    Button4: TButton;
    Button5: TButton;
    Timer1: TTimer;
    Button7: TButton;
    Label1: TLabel;
    Grid: TStringGrid;
    Label2: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    procedure Refresh;
    procedure GeneEstimate(Sender: TObject; const X: TExtendedArray; var Y:
      Extended);
  public
    FGene: TGeneAlgorithm;
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
  DecimalSeparator := '.';
  FGene := TGeneAlgorithm.Create;
  Refresh;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
  FGene.Free;
end;
procedure TForm1.Refresh;
begin
  Edit1.Text := FloaTtoStr(FGene.Crossover);
  Edit2.Text := FloatToStr(FGene.Mutation);
  Edit3.Text := FloatToStr(FGene.Inversion);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  FGene.Crossover := StrTofloat(Edit1.Text);
  Refresh;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
  FGene.Mutation := StrTofloat(Edit2.Text);
  Refresh;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
  FGene.Inversion := StrTofloat(Edit3.Text);
  Refresh;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
  FGene.BitPerNumber := StrToInt(Edit4.Text);
  Edit4.Text := IntToStr(FGene.BitPerNumber);
end;
procedure TForm1.Button5Click(Sender: TObject);
var
  I: Integer;
begin
  Randomize;
  FGene.DimCount := 5;
  FGene.MaxPopulation := 10000;
  FGene.MinPopulation := 5000;
  FGene.OnEstimate := GeneEstimate;
  for I := 0 to 4 do
  begin
    FGene.LowValues[I] := 0;
    FGene.HighValues[I] := 10;
  end;
  FGene.Run;
  Timer1.Enabled := True;
end;
procedure TForm1.GeneEstimate(Sender: TObject; const X: TExtendedArray;
  var Y: Extended);
var
  I: Integer;
begin
  Y := 0;
  for I := Low(X) to High(X) do
    Y := Y + Sqr(X[I] - I);
  Y := -Y;
end;
procedure TForm1.Button7Click(Sender: TObject);
var
  I: Integer;
begin
  Timer1.Enabled := False;
  Label1.Caption := '';
  FGene.Suspend;
  Grid.RowCount := FGene.DimCount + 1;
  for I := 0 to FGene.DimCount - 1 do
    Grid.Cells[0, I + 1] := FloattoStr(FGene.BestX[I]);
  FGene.Abort;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Label1.Caption := FloatToStr(FGene.BestEstimate);
end;
end.

Генерация звукого сигнала на встроенном динамике.

procedure Sound(Frequency, Duration: Integer);
asm
   push edx
   push eax
   mov eax, Win32Platform
   cmp eax, VER_PLATFORM_WIN32_NT
   jne @@9X
   call Windows.Beep
   ret
@@9X:
   pop eax
   pop edx
   push ebx
   push edx
   mov bx, ax
   mov ax, 34DDh
   mov dx, 0012h
   cmp dx, bx
   jnc @@2
   div bx
   mov bx, ax
   in al, 61h
   test al, 3
   jnz @@1
   or al, 3
   out 61h, al
   mov al, 0B6h
   out 43h, al
@@1:
   mov al, bl
   out 42h, al
   mov al, bh
   out 42h, al
   call Windows.Sleep
   in al, 61h
   and al, 0FCh
   out 61h, al
   jmp @@3
@@2:
   pop edx 
@@3:
   pop ebx
end;

Создание уникального ID для новой записи.

Table Name A (первичный ключ)
Last Id N

TableBeforePost(Sender: TObject)
var
  Id: Integer;
begin
  with TTable(Sender) do
  begin
    {проверяем, существует ли ID для этой записи}
    if Field[0].AsInteger = 0 then
    begin
      {ищем имя таблицы в ID-Таблице}
      IDTable.FindKey[Name]
        {извлекаем последний Id - подразумеваем блокировку записи}
      Id := IDTable.FieldByName['Last Id'].AsInteger;
      Inc(Id);
      {записываем новый Id в ID-таблицу - подразумеваем разблокировку таблицы}
      IDTable.FieldByName['Last Id'].AsInteger := Id;
      IDTable.Post;
      {записываем извлеченный ID в вашу таблицу}
      Field[0].AsInteger := Id;
    end;
  end;
end;

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

Генерация случайного пароля.

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

function RandomPassword(PLen: Integer): string;
 var
   str: string;
 begin
   Randomize;
   //string with all possible chars 
  str    := 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
   Result := '';
   repeat
     Result := Result + str[Random(Length(str)) + 1];
   until (Length(Result) = PLen)
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   //generate a password with 10 chars 
  label1.Caption := RandomPassword(10);
 end;
 // Another function from ReNoiZer /=RNZ=/; renoizer@mail.ru 
function RandomWord(dictSize, lngStepSize, wordLen, minWordLen: Integer): string;
 begin
   Result := '';
   if (wordLen < minWordLen) and (minWordLen > 0) then
     wordLen := minWordLen
   else if (wordLen < 1) and (minWordLen < 1) then wordLen := 1;
   repeat
     Result := Result + Chr(Random(dictSize) + lngStepSize);
   until (Length(Result) = wordLen);
 end;
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   //generate a password with 10 chars 
  Caption := RandomWord(33, 54, Random(12), 2);
 end;

Как сгенерировать случайный пароль.

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

Пароль создаётся из символов, содержащихся в таблице.

Внимание: Длина пароля должна быть меньше, чем длина таблицы!

Запускаем генератор случайных чисел (только при старте приложения).

procedure TForm1.FormCreate(Sender: TObject);
begin
  Randomize;    
end;

Описываем функцию:

function RandomPwd(PWLen: integer): string;
// таблица символов, используемых в пароле
const StrTable: string =
  '!#$%&/()=?@<>|{[]}\*~+#;:.-_' +
    'ABCDEFGHIJKLMabcdefghijklm' +
    '0123456789' +
    'ДЦЬдцьЯ' +
    'NOPQRSTUVWXYZnopqrstuvwxyz';
var
  N, K, X, Y: integer;
begin
  // проверяем максимальную длину пароля
  if (PWlen > Length(StrTable)) then
    K := Length(StrTable)-1
  else
    K := PWLen;
  SetLength(result, K);              // устанавливаем длину конечной строки
  Y := Length(StrTable);             // Длина Таблицы для внутреннего цикла
  N := 0;                            // начальное значение цикла
  while N do                     // цикл для создания K символов
  begin
    X := Random(Y) + 1;              // берём следующий случайный символ
    // проверяем присутствие этого символа в конечной строке
    if (pos(StrTable[X], result) = 0) then
    begin
      inc(N);                        // символ не найден
      Result[N] := StrTable[X];      // теперь его сохраняем
    end;
  end;
end;

Ну и обработчик нажатия кнопки будет выглядеть так:

procedure TForm1.Button1Click(Sender: TObject);
var
  cPwd: string;
begin
  // вызываем функцию генерации пароля из 30 символов
  cPwd := RandomPwd(30);
  // ...
end;

Генератор SQL-запросов Insert, Update.

Вам ещё не надоело динамически генерировать SQL запросы insert и update ? Давайте посмотрим, как можно раз и навсегда упростить этот процесс.

Допустим Вы создавали запрос следующим образом (типы параметров Data1:string Data2: integer Data3:TdateTime).

SqlCmd := 'insert into MyTable (Field1,Field2,Field2) values (' +
QuotedStr(Data1) + ',' + IntToStr(Data2) + ',' + 'to_date(' +
QuotedStr(FormatdateTime('dd/mm/yyyy',Data3)) + ',' +
QuotedStr('dd/mm/yyyy') + '))';
{Ужасно! ещё хуже, когда количество колонок увеличивается} 

А если сделать функцию типа:

SqlCmd := SqlInsert([Data1, Data2, Variant(Data3)],
'MyTable', ['Field1','Field2','Field3']);

Она эмулирует строку запроса наподобие:

insert into MyTable(Fields1, Field2, Field3)
values ('Sweets', 934, to_date('21/05/2001', 'dd/mm/yyyy'))

Неправда ли она более проста в использовании ?

Здесь представлены функции SqlInsert и SqlUpdate. Вы наверное заметили, что я передаю TDateTime приведённый как Variant. Причина кроется в том, что VType в array of const не имеете TDateTime типа и даты просто представлены как vtExtended.

Функция SqlInsert имеет 2 переопределённых вызова, которые позволяют Вам включить или выполнить массив имён колонок.

Посмотрим, как выглядят эти функции:

interface
const
  // Возврат и перевод каретки
  CrLf = #13#10;
// Прототипы функций
function SqlInsert(Values : array of const;
TableName : string; ColNames : array of string) : string; overload;
function SqlInsert(Values : array of const;
TableName : string) : string; overload;
function SqlUpdate(Values : array of const; TableName : string;
ColNames : array of string; WhereClause : string) : string;
implementation
// Помещаем TDateTime в Values (array of const)
// Представлен как Variant
function SqlInsert(Values : array of const;
TableName : string; ColNames : array of string) : string;
var
  RetVar : string;
  i : integer;
begin
  RetVar := 'insert into ' + TableName + CrLf + '(' + ColNames[0];
  for i := 1 to High(ColNames) do
    RetVar := RetVar + ',' + ColNames[i];
  RetVar := RetVar + ')' + CrLf;
  RetVar := RetVar + 'values (';
  for i := 0 to High(Values) do
  begin
    case Values[i].VType of
      vtInteger, vtInt64 :
        RetVar := RetVar + IntToStr(Values[i].VInteger);
      vtChar :
        RetVar := RetVar + QuotedStr(Values[i].VChar);
      vtString :
        RetVar := RetVar + QuotedStr(Values[i].VString^);
      vtPChar :
        RetVar := RetVar + QuotedStr(Values[i].VPChar);
      vtExtended :
        RetVar := RetVar + FloatToStr(Values[i].VExtended^);
      vtAnsiString :
        RetVar := RetVar + QuotedStr(string(Values[i].VAnsiString));
      // TDateTime - иначе получаем как vtExtended
      vtVariant :
        RetVar := RetVar + 'to_date(' + QuotedStr(FormatdateTime('dd/mm/yyyy',
        TDateTime(Values[i].VVariant^))) + ',' + QuotedStr('dd/mm/yyyy') + ')';
      else
        RetVar := RetVar + '??????';
    end;
    RetVar := RetVar + ',';
  end;
  Delete(RetVar,length(RetVar),1);
  RetVar := RetVar + ')';
  if High(Values) then
    ShowMessage('SQL Insert - Not enough values.');
  if High(Values) > High(ColNames) then
    ShowMessage('SQL Insert - Too many values.');
  Result := RetVar;
end;
function SqlInsert(Values : array of const;
TableName : string) : string; overload;
var
  RetVar : string;
  i : integer;
begin
  RetVar := 'insert into ' + TableName + CrLf;
  RetVar := RetVar + 'values (';
  for i := 0 to High(Values) do
  begin
    case Values[i].VType of
    vtInteger, vtInt64 :
      RetVar := RetVar + IntToStr(Values[i].VInteger);
    vtChar :
      RetVar := RetVar + QuotedStr(Values[i].VChar);
    vtString :
      RetVar := RetVar + QuotedStr(Values[i].VString^);
    vtPChar :
      RetVar := RetVar + QuotedStr(Values[i].VPChar);
    vtExtended :
      RetVar := RetVar + FloatToStr(Values[i].VExtended^);
    vtAnsiString :
      RetVar := RetVar + QuotedStr(string(Values[i].VAnsiString));
    // TDateTime - иначе получаем как vtExtended
    vtVariant :
      RetVar := RetVar + 'to_date(' + QuotedStr(FormatdateTime('dd/mm/yyyy',
      TDateTime(Values[i].VVariant^))) + ',' + QuotedStr('dd/mm/yyyy') + ')';
    else
      RetVar := RetVar + '??????';
    end;
    RetVar := RetVar + ',';
  end;
  Delete(RetVar,length(RetVar),1);
  RetVar := RetVar + ')';
  Result := RetVar;
end;
function SqlUpdate(Values : array of const; TableName : string;
ColNames : array of string; WhereClause : string) : string;
var
  RetVar, Parm : string;
  i : integer;
begin
  RetVar := 'update ' + TableName + ' set' + CrLf;
  for i := 0 to Min(High(Values),High(ColNames)) do
  begin
    case Values[i].VType of
      vtInteger, vtInt64 :
        Parm := IntToStr(Values[i].VInteger);
      vtChar :
        Parm := QuotedStr(Values[i].VChar);
      vtString :
        Parm := QuotedStr(Values[i].VString^);
      vtPChar :
        Parm := QuotedStr(Values[i].VPChar);
      vtExtended :
        Parm := FloatToStr(Values[i].VExtended^);
      vtAnsiString :
        Parm := QuotedStr(string(Values[i].VAnsiString));
      // TDateTime - иначе получаем как vtExtended
      vtVariant : Parm := 'to_date(' + QuotedStr(FormatdateTime('dd/mm/yyyy',
        TDateTime(Values[i].VVariant^))) + ',' + QuotedStr('dd/mm/yyyy') + ')';
      else
        Parm := '??????';
    end;
    RetVar := RetVar + ColNames[i] + '=' + Parm + ',';
  end;
  Delete(RetVar,length(RetVar),1);
  RetVar := RetVar + CrLf + 'where ' + WhereClause;
  if High(Values) then
    ShowMessage('SQL Update - Not enough values.');
  if High(Values) > High(ColNames) then
    ShowMessage('SQL Update - Too many values.');
  Result := RetVar;
end;

Гипергеометрическое распределение.

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

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Гипергеометрическое распределение
Возвращает случайное число, распределенное по гипергеометрическому закону
распределения
Зависимости: system
Автор:       Алексей Перов, aperov@rambler.ru, ICQ:102661702, Караганда
Copyright:   Лабораторные работы по курсу "Моделирование информационных систем", КарГТУ
Дата:        26 апреля 2002 г.
***************************************************** }
function RandomGipgeo(tn, ns, p: Extended): Extended;
{ гипергеометрическое распределение }
var
  x, s: Extended;
  i: Integer;
begin
  x := 0;
  for i := 1 to Round(ns) do
  begin
    if Random - p <= 0 then
    begin
      s := 1;
      x := x + 1
    end
    else
      s := 0;
    p := (tn * p - s) / (tn - 1)
  end;
  Result := x
end;

x := RandomGipgeo(2.5, 3, 0.4); 

Вычисление немецких праздников.

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

unit Feiertage;
 // Unit Holidays; 
interface
 uses
   Windows, SysUtils;
 // Declare a structure to hold the Information 
// Deklarieren der Struktur, um die Feiertage abzuspeichern 
type
   THoliday = record
     Date: TDateTime;
     Name: string;
   end;
   THolidayTable = array of THoliday;
 // Function to call to get the Holiday Table with all Holidays of a year 
// Der Funktionsaufruf, um die Feiertage eines Jahres abzufragen 
function GetHolidayTable(Year: Word): THolidayTable;
 implementation
 function TUrlaubsForm.GetHolidayTable(Year: Word): THolidayTable;
   // Function to add a holiday by Day and Month 
  // Funktion, um einen Feiertag uber seinen Tag\Monat hinzuzufugen 
  procedure AddHoliday(DD, MM: Word; HDName: string); overload;
   begin
     SetLength(Result, High(Result) + 2);
     with Result[High(Result)] do
     begin
       Date := EncodeDate(Year, MM, DD);
       Name := HDName;
     end;
   end;
   //Function to add holiday by date serial 
  //Funktion, um den Feiertag uber die Datumsseriennummer hinzuzufugen 
  procedure AddHoliday(HDDate: TDateTime; HDName: string); overload;
   begin
     SetLength(Result, High(Result) + 2);
     with Result[High(Result)] do
     begin
       Date := HDDate;
       Name := HDName;
     end;
   end;
   // Function to get easter sunday 
  // Function zur Berechnung des Ostersonntags 
  function GetEasterDate(YYYY: Word): TDateTime;
   var
     A, B, C, D, E, F, G, H, I, K, L, M, N, P: Word;
     DD, MM: Word;
   begin
     a := YYYY mod 19;
     b := YYYY div 100;
     c := YYYY mod 100;
     d := b div 4;
     e := b mod 4;
     f := (b + 8) div 25;
     g := (b - f + 1) div 3;
     h := (19 * a + b - d - g + 15) mod 30;
     i := c div 4;
     k := c mod 4;
     l := (32 + 2 * e + 2 * i - h - k) mod 7;
     m := (a + 11 * h + 22 * l) div 451;
     n := (h + l - 7 * m + 114) div 31;
     p := (h + l - 7 * m + 114) mod 31 + 1;
     DD := p;
     MM := n;
     Result := EncodeDate(YYYY, MM, DD);
   end;
    var
   EDate: TDateTime;
 begin
   // Add fixed holidays 
  // Hinzufugen der festen Feiertage 
  AddHoliday(1, 1, 'Neujahr');
   AddHoliday(1, 5, 'Tag der Arbeit');
   AddHoliday(3, 10, 'Tag der deutschen Einheit');
   AddHoliday(31, 10, 'Reformationstag');
   // AddHoliday(24, 12, 'Heiligabend'); 
  AddHoliday(25, 12, '1. Weihnachtsfeiertag');
   AddHoliday(26, 12, '2. Weihnachtsfeiertag');
   // AddHoliday(31, 12, 'Silvester'); 
  // Add holidays relative to easter sunday 
  // Hinzufugen der Feiertage, die von Ostern abhangen 
  EDate := GetEasterDate(Year);
   AddHoliday(EDate, 'Ostersonntag');
   AddHoliday(EDate - 2, 'Karfreitag');
   AddHoliday(EDate + 1, 'Ostermontag');
   AddHoliday(EDate + 39, 'Christi Himmelfahrt');
   AddHoliday(EDate + 49, 'Pfingstsonntag');
   AddHoliday(EDate + 50, 'Pfingstmontag');
   // Gets 3rd Wednesday in November 
  // Ermittelt den 3. Mitwoch im November 
  EDate := EncodeDate(Year, 11, 1);
   EDate := EDate + ((11 - DayOfWeek(EDate)) mod 7) + 14;
   AddHoliday(EDate, 'Bu?- und Bettag');
 end;
 end.
 // This Units works since the year 1584 
// Diese Unit arbeitet mit Jahreszahlen nach 1584 

Узнать существущие имена таблиц БД Access.

procedure....
var
  x: TStrings;
begin
  x:=TstringList.Create;
  ADOConnection.GetTableNames(x, false или true) // <- почитай Help
  операции с x...
  x.Free;
end;

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

uses 
  Psapi, tlhelp32; 
procedure CreateWin9xProcessList(List: TstringList); 
var 
  hSnapShot: THandle; 
  ProcInfo: TProcessEntry32; 
begin 
  if List = nil then Exit; 
  hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0); 
  if (hSnapShot <> THandle(-1)) then 
  begin 
    ProcInfo.dwSize := SizeOf(ProcInfo); 
    if (Process32First(hSnapshot, ProcInfo)) then 
    begin 
      List.Add(ProcInfo.szExeFile); 
      while (Process32Next(hSnapShot, ProcInfo)) do 
        List.Add(ProcInfo.szExeFile); 
    end; 
    CloseHandle(hSnapShot); 
  end; 
end; 
procedure CreateWinNTProcessList(List: TstringList); 
var 
  PIDArray: array [0..1023] of DWORD; 
  cb: DWORD; 
  I: Integer; 
  ProcCount: Integer; 
  hMod: HMODULE; 
  hProcess: THandle; 
  ModuleName: array [0..300] of Char; 
begin 
  if List = nil then Exit; 
  EnumProcesses(@PIDArray, SizeOf(PIDArray), cb); 
  ProcCount := cb div SizeOf(DWORD); 
  for I := 0 to ProcCount - 1 do 
  begin 
    hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or 
      PROCESS_VM_READ, 
      False, 
      PIDArray[I]); 
    if (hProcess <> 0) then 
    begin 
      EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb); 
      GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName)); 
      List.Add(ModuleName); 
      CloseHandle(hProcess); 
    end; 
  end; 
end; 
procedure GetProcessList(var List: TstringList); 
var 
  ovi: TOSVersionInfo; 
begin 
  if List = nil then Exit; 
  ovi.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); 
  GetVersionEx(ovi); 
  case ovi.dwPlatformId of 
    VER_PLATFORM_WIN32_WINDOWS: CreateWin9xProcessList(List); 
    VER_PLATFORM_WIN32_NT: CreateWinNTProcessList(List); 
  end 
end; 
function EXE_Running(FileName: string; bFullpath: Boolean): Boolean; 
var 
  i: Integer; 
  MyProcList: TstringList; 
begin 
  MyProcList := TStringList.Create; 
  try 
    GetProcessList(MyProcList); 
    Result := False; 
    if MyProcList = nil then Exit; 
    for i := 0 to MyProcList.Count - 1 do 
    begin 
      if not bFullpath then 
      begin 
        if CompareText(ExtractFileName(MyProcList.Strings[i]), FileName) = 0 then 
          Result := True 
      end 
      else if CompareText(MyProcList.strings[i], FileName) = 0 then Result := True; 
      if Result then Break; 
    end; 
  finally 
    MyProcList.Free; 
  end; 
end; 
// Example 1: Is a Exe-File running ? 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  if EXE_Running('Notepad.exe', False) then 
    ShowMessage('EXE is running') 
  else 
    ShowMessage('EXE is not running'); 
end; 
// Example 2: List running Exe-Files 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  i: Integer; 
  MyProcList: TstringList; 
begin 
  MyProcList := TStringList.Create; 
  try 
    GetProcessList(MyProcList); 
    if MyProcList = nil then Exit; 
    for i := 0 to MyProcList.Count - 1 do 
      ListBox1.Items.Add(MyProcList.Strings[i]); 
  finally 
    MyProcList.Free; 
  end; 
end;

Определение активного подключения.

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

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Определение активного подключения
Возвращает название активного интернет-соединения
Зависимости: RAS
Автор:       Ajax, ajax@mail.kz
Copyright:   Ajax
Дата:        27 мая 2002 г.
***************************************************** }
function CheckRASConnections: string;
const
  MaxEntries = 100;
var
  BufSize: Integer;
  NumEntries: Integer;
  Entries: array[1..MaxEntries] of TRasConn;
begin
  Entries[1].dwSize := SizeOf(TRasConn);
  Bufsize := SizeOf(TRasConn) * MaxEntries;
  RasEnumConnections(@Entries[1], BufSize, NumEntries);
  if numentries > 0 then
    result := strpas(@Entries[1].szEntryName)
  else
    Result := 'Disconnected';
end;

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

ShowMessage(CheckRASConnections); 

Как узнать, какой язык активен в Windows.

function WhichLanguage:string;
var 
  ID: LangID;
  Language: array [0..100] of char;
begin
  ID := GetSystemDefaultLangID;
  VerLanguageName(ID, Language, 100);
  Result := string(Language);
end;
...
procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text := WhichLanguage;
end;

Ошибка EOLESYS..OPERATION UNAVAILABLE (операция недоступна) при использовании GETACTIVEOLEOBJECT.

Это происходит при использовании сервера автоматизации Delphi, или когда сервер автоматизации (например, word.basic) не запущен.

procedure TForm1.Button1Click(Sender: TObject);
var
  V: OleVariant;
begin
  V := GetActiveOleObject('Word.Basic');
  V.FileNew;
  V.Insert('тест');
end;

GetActiveOleObject определен в ComObj.pas. Он преобразует имя класса в guid и передает его при вызове Windows api функции GetActiveObject.

function GetActiveOleObject(const ClassName: string): IDispatch;
var
  ClassID: TCLSID;
  Unknown: IUnknown;
begin
  ClassID := ProgIDToClassID(ClassName);
  OleCheck(GetActiveObject(ClassID, nil, Unknown));
  OleCheck(Unknown.QueryInterface(IDispatch, Result));
end;

GetActiveOleObject использует интерфейс с именем IRunningObjectTable. Мы не регистрируем это автоматически в таблице, поэтому, чтобы воспользоваться его функциональным назначением, вы должны получить этот интерфейс и использовать его методы для регистрации.

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

В реестре есть раздел HKEY_DYN_DATA. Основная информация о системе хранится в ключе PerfStats.

О получении информации,например, о загруженности процессора, необходимо проделать следующие шаги:

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

Например.

Просто считываем значение ключа 'PerfStats\StartStat\KERNEL\CPUusage' в секции HKEY_DYN_DATA. данное действие запускает счётчик. После этого в ключе 'PerfStats\StatData\KERNEL\CPUusage' будет храниться значение в процентах о загруженности процессора.

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

По завершении, Ваша программа должна остановить счётчик в реестре. Для этого просто считай ключ 'PerfStats\StopStat\KERNEL\CPUusage'.Это остановит счётчик.

Так же в системе есть много других счётчиков. Весь список счётчиков можно посмотреть в ключе PerfStats\StatData, используя редактор реестра.

Представленный ниже исходник получает значения всех счётчиков, расположенных в секции HKEY_DYN_DATA.

unit SystemInfo;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs,extctrls;
//Информация о Dialup адаптере
type TDialupAdapterInfo = record
  alignment:dword;
  buffer:dword;
  bytesrecieved:dword;
  bytesXmit:dword;
  ConnectSpeed:dword;
  CRC:dword;
  framesrecieved:dword;
  FramesXmit:dword;
  Framing:dword;
  runts:dword;
  Overrun:dword;
  timeout:dword;
  totalbytesrecieved:dword;
  totalbytesXmit:dword;
end;
type TKernelInfo = record
  CpuUsagePcnt:dword;
  Numthreads:dword;
  NumVMS:dword;
end;
type TVCACHEInfo = record
  ccurpages:dword;
  cMacPages:dword;
  cminpages:dword;
  FailedRecycles:dword;
  Hits:dword;
  LRUBuffers:dword;
  LRURecycles:dword;
  Misses:dword;
  RandomRecycles:dword;
end;
type TFATInfo = record
  BreadsSec:dword;
  BwritesSec:dword;
  Dirtydata:dword;
  ReadsSec:dword;
  WritesSec:dword;
end;
type TVMMInfo = record
  CDiscards:dword;
  CInstancefaults:dword;
  CPageFaults:dword;
  cPageIns:dword;
  cPageOuts:dword;
  cpgCommit:dword;
  cpgDiskCache:dword;
  cpgDiskCacheMac:dword;
  cpgDiskCacheMid:dword;
  cpgDiskCacheMin:dword;
  cpgfree:dword;
  cpglocked:dword;
  cpglockedNoncache:dword;
  cpgother:dword;
  cpgsharedpages:dword;
  cpgswap:dword;
  cpgswapfile:dword;
  cpgswapfiledefective:dword;
  cpgswapfileinuse:dword;
end;
type
  TSysInfo = class(TComponent)
  private
    fDialupAdapterInfo:TDialupAdapterInfo;
    fKernelInfo:TKernelInfo;
    fVCACHEInfo:TVCACHEInfo;
    fFATInfo:TFATInfo;
    fVMMInfo:TVMMInfo;
    ftimer:TTimer;
    fupdateinterval:integer;
    tmp:dword;
    vsize:dword;
    pkey:hkey;
    regtype:pdword;
    fstopped:boolean;
    procedure fupdatinginfo(sender:tobject);
    procedure fsetupdateinterval(aupdateinterval:integer);
  protected
    fsysInfoChanged:TNotifyEvent;
  public
    constructor Create(Aowner:Tcomponent);override;
    destructor Destroy;override;
    property DialupAdapterInfo: TDialupAdapterInfo read fDialupAdapterInfo;
    property KernelInfo: TKernelInfo read fKernelInfo;
    property VCACHEInfo: TVCACHEInfo read fVCACHEInfo;
    property FATInfo: TFATInfo read fFATInfo;
    property VMMInfo: TVMMInfo read fVMMInfo;
    procedure StartRecievingInfo;
    procedure StopRecievingInfo;
  published
    property SysInfoChanged:TNotifyEvent read fsysInfoChanged write
    fsysInfoChanged;//Это событие вызывается после определённого интервала времени.
    property UpdateInterval:integer read fupdateInterval write
    fsetupdateinterval default 5000;
end;
procedure register;
implementation
constructor TSysInfo.Create(Aowner:Tcomponent);
begin
  inherited;
  ftimer:=ttimer.Create(self);
  ftimer.enabled:=false;
  ftimer.OnTimer:=fupdatinginfo;
  vsize:=4;
  fstopped:=true;
end;
procedure TSysInfo.startrecievingInfo;
var
  res:integer;
begin
  res:=RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStats\StartStat',0,KEY_ALL_ACCESS,pkey);
  if res<>0 then
    raise exception.Create('Could not open registry key');
  fstopped:=false;
  // Для Dial Up Адаптера
  RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@tmp,@vsize);
  // Для VCACHE
  RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
  //Для VFAT
  RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@tmp,@vsize);
  //Для VMM
  RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@tmp,@vsize);
  //Для KERNEL
  RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@tmp,@vsize);
  RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@tmp,@vsize);
  RegCloseKey(pkey);
  ftimer.enabled:=true;
end;
procedure tsysinfo.fupdatinginfo(sender:tobject);
var
  res:integer;
begin
  res:=RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStats\StatData',0,KEY_ALL_ACCESS,pkey);
  if res<>0 then
    raise exception.Create('Could not open registry key');
  //Для Dial Up Адаптера
  RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@fDialupAdapterInfo.alignment,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@fDialupAdapterInfo.buffer,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@fDialupAdapterInfo.framing,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@fDialupAdapterInfo.overrun,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@fDialupAdapterInfo.timeout,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype, @fDialupAdapterInfo.crc,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@fDialupAdapterInfo.runts,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@fDialupAdapterInfo.framesxmit,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype, @fDialupAdapterInfo.framesrecieved,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@fDialupAdapterInfo.bytesxmit,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype, @fDialupAdapterInfo.bytesrecieved,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype, @fDialupAdapterInfo.totalbytesxmit,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype, @fDialupAdapterInfo.totalbytesrecieved,@vsize);
  RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype, @fDialupAdapterInfo.connectspeed,@vsize);
  // Для VCACHE
  RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype, @fVCACHEInfo.lrubuffers,@vsize);
  RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype, @fVCACHEInfo.failedrecycles,@vsize);
  RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype, @fVCACHEInfo.randomrecycles,@vsize);
  RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype, @fVCACHEInfo.lrurecycles,@vsize);
  RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype, @fVCACHEInfo.misses,@vsize);
  RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@fVCACHEInfo.hits,@vsize);
  RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype, @fVCACHEInfo.cmacpages,@vsize);
  RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype, @fVCACHEInfo.cminpages,@vsize);
  RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype, @fVCACHEInfo.ccurpages,@vsize);
  //Для VFAT
  RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype, @ffatinfo.dirtydata,@vsize);
  RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype, @ffatinfo.breadssec,@vsize);
  RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype, @ffatinfo.bwritessec,@vsize);
  RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype, @ffatinfo.readssec,@vsize);
  RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype, @ffatinfo.writessec,@vsize);
  //Для VMM
  RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype, @fvmminfo.cpglockednoncache,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype, @fvmminfo.cpgcommit,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype, @fvmminfo.cpgsharedpages,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype, @fvmminfo.cpgdiskcacheMid,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype, @fvmminfo.cpgdiskcacheMac,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype, @fvmminfo.cpgdiskcacheMin,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype, @fvmminfo.cpgdiskcache,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype, @fvmminfo.cpgswapfiledefective,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype, @fvmminfo.cpgswapfileinuse,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype, @fvmminfo.cpgswapfile,@vsize);
  RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype, @fvmminfo.cdiscards,@vsize);
  RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype, @fvmminfo.cpageouts,@vsize);
  RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype, @fvmminfo.cpageins,@vsize);
  RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype, @fvmminfo.cinstancefaults,@vsize);
  RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype, @fvmminfo.cpagefaults,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype, @fvmminfo.cpgother,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype, @fvmminfo.cpgswap,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype, @fvmminfo.cpglocked,@vsize);
  RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype, @fvmminfo.cpgfree,@vsize);
  //Для KERNEL
  RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype, @fkernelinfo.cpuusagepcnt,@vsize);
  RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@fkernelinfo.numvms,@vsize);
  RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype, @fkernelinfo.numThreads,@vsize);
  RegCloseKey(pkey);
  if assigned(SysInfoChanged) then
    SysInfoChanged(self);
end;
procedure TSysInfo.stoprecievingInfo;
var
  res:integer;
begin
  res:=RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStats\StopStat',0,KEY_ALL_ACCESS,pkey);
  if not fstopped then
  begin
    if res<>0 then
      raise exception.Create('Could not open registry key');
    //Для Dial Up Адаптера
    RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@tmp,@vsize);
    // Для VCACHE
    RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
    //Для VFAT
    RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@tmp,@vsize);
    //Для VMM
    RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@tmp,@vsize);
    //Для KERNEL
    RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@tmp,@vsize);
    RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@tmp,@vsize);
    RegCloseKey(pkey);
    ftimer.enabled:=false;
    fstopped:=true;
  end;
end;
procedure tsysinfo.fsetupdateinterval(aupdateinterval:integer);
begin
  if (ftimer<>nil) and(aupdateinterval>0) then
  begin
    ftimer.Interval:=aupdateinterval;
    fupdateinterval:=aupdateinterval;
  end;
  if (ftimer<>nil) and(aupdateinterval=0) then
  begin
    ftimer.Interval:=500;
    fupdateinterval:=500;
  end;
end;
destructor tsysinfo.Destroy;
begin
  StopRecievingInfo;
  ftimer.Destroy;
  inherited;
end;
procedure register;
begin
  RegisterComponents('Samples', [TSysInfo]);
end;
end.

Скопируйте это в файл .pas и проинсталлируйте его.

Получить позицию активного окна.

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

procedure TForm1.Button1Click(Sender: TObject);
 var
   hWindow: HWnd;
   r:       TRect;
 begin
   hWindow := GetForegroundWindow;
   GetWindowRect(hWindow, r);
   Memo1.Clear;
   with Memo1.Lines do
   begin
     Add('Top   : ' + IntToStr(r.Top));
     Add('Left  : ' + IntToStr(r.Left));
     Add('Bottom: ' + IntToStr(r.Bottom));
     Add('Right : ' + IntToStr(r.Right));
   end;
 end;

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

Автор: Ревенко Алексей.

DecodeDate(DM.Table.FieldByName('Born').AsDateTime, Year, Month, Day); // Дата рождения
DecodeDate(Date, YYYY, MM, DD); // Текущая дата
if (MM >= Month) and (DD >= Day) then
  Edit2.Text := IntToStr((YYYY - Year))
else
  Edit2.Text := IntToStr((YYYY - Year) - 1);

Получение информации об альясах.

uses DB, DBTables, DBITypes, DBIProcs; 
procedure TForm1.FormCreate(Sender: TObject); 
begin  
  Session.GetAliasNames(ListBox1.Items); 
end; 
procedure TForm1.ListBox1Click(Sender: TObject); 
var 
  tStr: array[0..100] of char; 
  Desc: DBDesc; 
{ 
 The DBDesc structure describes a database, using the following fields: 
 szName     DBINAME  Specifies the database alias name. 
 szText     DBINAME  Descriptive text. 
 szPhyName  DBIPATH  Specifies the physical name/path. 
 szDbType   DBINAME  Specifies the database type. 
} 
begin 
  if ListBox1.Items.Count = 0 then 
    exit; 
  StrPLCopy(tStr, ListBox1.Items.Strings[ListBox1.ItemIndex], High(tStr)); 
  DbiGetDatabaseDesc(tStr, @Desc); 
  with Desc do 
  begin 
    Label1.Caption := StrPas(Desc.szName); 
    Label2.Caption := StrPas(Desc.szPhyName); 
    Label3.Caption := StrPas(Desc.szDbType); 
    Label4.Caption := StrPas(Desc.szText); 
  end; 
end;

Отображение всех псевдонимов в ComboBox.

Автор: GromovRV@Bashneft.Bashnet.ru.

//Для этого надо в Uses добавить ExtCtrls
Session.GetAliasNames(ComboBox1.Items);

Получение пути псевдонима и таблицы.

Есть три способа сделать это... No1 годится только для постоянных псевдонимов BDE. No2 работает с BDE и локальными псевдонимами, и No3 работает с BDE и локальными псевдонимами, используя "тяжелый" путь, через вызовы DBI.

function GetDBPath1(AliasName: string): TFileName;
var
  ParamList: TStringList;
begin
  ParamList := TStringList.Create;
  with Session do
  try
    GetAliasParams(AliasName, ParamList);
    Result := UpperCase(ParamList.Values['PATH']) + '\';
  finally
    Paramlist.Free;
  end;
end;
function GetDBPath2(AliasName: string): TFileName;
var
  ParamList: TStringList;
  i: integer;
begin
  ParamList := TStringList.Create;
  with Session do
  try
    try
      GetAliasParams(AliasName, ParamList);
    except
      for i := 0 to pred(DatabaseCount) do
        if (Databases[i].DatabaseName = AliasName) then
          ParamList.Assign(Databases[i].Params);
    end;
    Result := UpperCase(ParamList.Values['PATH']) + '\';
  finally
    Paramlist.Free;
  end;
end;
function GetDBPath3(ATable: TTable): TFileName;
var
  TblProps: CURProps;
  pTblName, pFullName: DBITblName;
begin
  with ATable do
  begin
    AnsiToNative(Locale, TableName, pTblName, 255);
    Check(DBIGetCursorProps(Handle, TblProps));
    Check(DBIFormFullName(DBHandle,
      pTblName,
      TblProps.szTableType,
      pFullName));
    Result := ExtractFilePath(StrPas(pFullName));
  end;
end;

Получение пути псевдонима и таблицы 2.

Вот маленький примерчик того, как в Delphi можно получить информацию о псевдонимах. Для начала создайте новый проект с ListBox и тремя метками (с именамиListВох1, Label1, Label2 и Label3). Затем создайте обработчик события формы OnCreate с примерно следующим кодом:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Session.GetAliasNames(ListBox1.Items);
end;

Теперь создайте обработчик OnClick для ListBox:

procedure TForm1.ListBox1Click(Sender: TObject);
var
  tStr: array[0..100] of char;
  Desc: DBDesc;
begin
  if ListBox1.Items.Count = 0 then
    exit;
  StrPLCopy(tStr, ListBox1.Items.Strings[ListBox1.ItemIndex], High(tStr));
  DbiGetDatabaseDesc(tStr, @Desc);
  with Desc do
  begin
    Label1.Caption := StrPas(Desc.szName);
    Label2.Caption := StrPas(Desc.szPhyName);
    Label3.Caption := StrPas(Desc.szDbType);
  end;
end;

Добавьте следующие модули в секцию 'uses' в верхней части модуля:

DB, DBTables, DBITypes, DBIProcs; 

Теперь вы можете увидеть путь для всех ваших стандартных псевдонимов (Paradox и dBase).

Получение пути псевдонима и таблицы 3.

Используйте Session.GetAliasParams. В ответ вы получите объект Tstrings, откуда вы можете получить значение для переменной 'PATH". Для получения дополнительной информации обратитесь к электронной справке к разделу, описывающему TSession. Объект Session объявлен в модуле DB.

uses  db;
var
  aliaspath: string[128];
begin
  aliaspath := Session.GetAliasParams['MyAlias'].values['PATH'];
end;

uses SysUtils,DbiProcs, DBiTypes;
...
function GetDataBaseDir(const Alias : string): String;
(* Возвращает каталог базы данных, на которую
ссылается псевдним (без конечного обратного слеша) *)
var
  sp: PChar;
  Res: pDBDesc;
begin
  try
    New(Res);
    sp := StrAlloc(length(Alias)+1);
    StrPCopy(sp,Alias);
    if DbiGetDatabaseDesc(sp,Res) =  0 then 
      Result := StrPas(Res^.szPhyName)
    else 
      Result := '';
  finally
    StrDispose(sp);
    Dispose(Res);
  end;
end;

Получение пути псевдонима и таблицы 4.

Примечание: Database можно создать явно, если нет, Дельфи сама его создаст, доступ к ней по Table(Query).Database.

uses DbiProcs;
function GetDirByDatabase( Database: TDatabase ): string;
var
  pszDir: PChar;
begin
  pszDir := StrAlloc( 255 );
  try
    DbiGetDirectory( Database.Handle, True, pszDir );
    Result := StrPas( pszDir );
  finally
    StrDispose( pszDir );
  end;
end;

По алиасу.

function GetPhNameByAlias( sAlias: string ): string;
var
  Database: TDatabase;
  pszDir: PChar;
begin
  Database := TDatabase.Create( nil ); {allocate memory}
  pszDir := StrAlloc( 255 );
  try
    Database.AliasName := sAlias;
    Database.DatabaseName := 'TEMP'; {requires a name -- is ignored}
    Database.Connected := True; {connect without opening any table}
    DbiGetDirectory( Database.Handle, True, pszDir ); {get the dir.}
    Database.Connected := False; {disconnect}
    Result := StrPas( pszDir ); {convert to a string}
  finally
    Database.Free; {free memory}
    StrDispose( pszDir );
  end;
end; 

Получить все возможные разрешения экрана.

procedure TForm1.Button1Click(Sender: TObject);
var 
  DC: THandle;      // display context
  Bits: integer;    // bits per pixel
  HRes: integer;    // horizontal resolution
  VRes: integer;    // vertical resolution
  DM: TDevMode;     // to Save EnumDisplaySettings
  ModeNum: longint; // video mode number
  Ok: Bool;
  fre: integer;     // refresh rate 
begin 
  DC   := GetDC(Handle); 
  Bits := GetDeviceCaps(DC, BITSPIXEL); 
  HRes := GetDeviceCaps(DC, HORZRES); 
  VRes := GetDeviceCaps(DC, VERTRES); 
  fre  := GetDeviceCaps(DC, VREFRESH); 
  // Show Current Resolution 
  Edit1.Text := Format('%d bit, %d x %d', [Bits, HRes, VRes]); 
  ReleaseDC(Handle, DC); // Show all modes available ModeNum := 0;  // The 1st one 
  EnumDisplaySettings(nil, ModeNum, DM); 
  ListBox1.Items.Add(Format('%d bit, %d x %d bei %d Hz', [DM.dmBitsPerPel, 
    DM.dmPelsWidth, DM.dmPelsHeight, Dm.dmDisplayFrequency])); 
  Ok := True; 
  while Ok do 
  begin 
    Inc(ModeNum); // Get next one 
    Ok := EnumDisplaySettings(nil, ModeNum, DM); 
    ListBox1.Items.Add(Format('%d bit, %d x %d bei %d Hz', [DM.dmBitsPerPel, 
      DM.dmPelsWidth, DM.dmPelsHeight, Dm.dmDisplayFrequency])); 
  end; 
end;

Как получить все Dial-Up соединения.

Способ 1 - из реестра:

uses Registry;
function DUNGetConnections(out OutList: TStringList): Boolean;
  var Reg: TRegistry;
begin
  OutList.Clear;
  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_CURRENT_USER;
  if Reg.OpenKey('\RemoteAccess\Profile', False) then
  begin
    Reg.GetKeyNames(OutList);
    Result := True;
  end
  else
    Result := False;
  Reg.Free;
end;

Способ 2 - через RASApi:

Для этого воспользуемся функцией Use RASEnumConnections.

Далее можно определить состояние каждого соединения при помощи RASGetConnectStatus.

Так же можно использовать RASEnumEntries для получения всех сервисов из определённой телефонной книжки.

Толька для этого потребуется преобразовать заголовочный файл RAS.h в эквивалент Delphi.

Получаем всю информацию о файле.

Данный объект может быть использован для получения исчерпывающей информации о любом файле. Так же включена функция выполнения файла Execute().

Использование: создайте объект с именем файла или путём.

unit FileInfo;
interface
uses
  forms, shellapi, windows, sysutils;
type
  EFileInfo = exception;
  TLangInfoBuffer = array [1..4] of SmallInt;
  TFileInfo = class
  private
    f : TSearchRec;
    fVerBlk : TVSFixedFileInfo;
    fFileName : string;
    function GetFileVersion( AFileName : string ) : boolean;
  public
    constructor Create( AFileName : string ); // Создаём объект
    destructor Destroy; override;
    function Execute : integer; // Открывает файл в программе, связанной с ним
    function VersionString : string; // Версия файла. Строка пустая, если строка не найдена
    function OS : string; // Операционная система
    function Path : string; // Путь файла
    function FileName : string; // Имя файла
    function name : string; // Имя файла без расширения
    function DosFileName : string; // Имя файла в DOS
    function FileExt : string; // Расширение файла
    function FileType : string; // Тип файла
    function FileSize : longint; // Размер файла
    function isDebugBuild : boolean; // True если флаг отладки (debug build) установлен
    function isPreRelease : boolean; // True если флаг prerelease установлен
    function isPrivateBuild : boolean; // True если флаг private установлен
    function isSpecialBuild : boolean; // True если флаг special build установлен
    function isDirectory : boolean; // True если файл является директорией
    function isHidden : boolean; // True если файл является скрытым (hidden)
    function isSystemFile : boolean; // True если файл является системным
    function isVolumeId : boolean; // True если файл является меткой тома
    function isArchive : boolean; // True если файл является архивом
    function CreationTime : TDateTime; // Время создания файла
    function LastAccessed : TDateTime; // Время последнего доступа к файлу
    function LastWritten : TDateTime; // Время последней записи в файл
end;
implementation
constructor TFileInfo.Create(AFileName: string);
var
  ret: integer;
begin
  inherited Create;
  fFileName := AFileName;
  ret := FindFirst( AFileName, faReadOnly + faHidden+ faSysFile +
    faVolumeID + faDirectory + faArchive + faAnyFile, f );
  if ret <> 0 then
    SysUtils.RaiseLastWin32Error;
end;
destructor TFileInfo.Destroy;
begin
  FindClose( f );
end;
function TFileInfo.GetFileVersion(AFileName: string): boolean;
var
  InfoSize, puLen: DWord;
  Pt, InfoPtr: Pointer;
begin
  InfoSize := GetFileVersionInfoSize( PChar(AFileName), puLen );
  fillchar( fVerBlk, sizeof(TVSFixedFileInfo), 0);
  if InfoSize > 0 then
  begin
    GetMem(Pt,InfoSize);
    GetFileVersionInfo( PChar(AFileName), 0, InfoSize, Pt);
    VerQueryValue(Pt,'\',InfoPtr,puLen);
    move(InfoPtr^, fVerBlk, sizeof(TVSFixedFileInfo) );
    FreeMem(Pt);
    result := true;
  end
  else
    result := false;
end;
function TFileInfo.VersionString: string;
begin
  if GetFileVersion( fFileName ) then
    result := Format('%u.%u.%u.%u',
    [HiWord(fVerBlk.dwProductVersionMS),
    LoWord(fVerBlk.dwProductVersionMS),
    HiWord(fVerBlk.dwProductVersionLS),
    LoWord(fVerBlk.dwProductVersionLS)])
  else
    result := '';
end;
function TFileInfo.isDebugBuild : boolean;
begin
  result := FALSE;
  if GetFileVersion( fFileName ) then
    result := (fVerBlk.dwFileFlagsMask and fVerBlk.dwFileFlags and
    VS_FF_DEBUG) <> 0
end;
function TFIleInfo.isPreRelease : boolean;
begin
  result := FALSE;
  if GetFileVersion( fFileName ) then
    result := (fVerBlk.dwFileFlagsMask and fVerBlk.dwFileFlags and
    VS_FF_PRERELEASE) <> 0
end;
function TFIleInfo.isPrivateBuild : boolean;
begin
  result := FALSE;
  if GetFileVersion( fFileName ) then
    result := (fVerBlk.dwFileFlagsMask and fVerBlk.dwFileFlags and
    VS_FF_PRIVATEBUILD) <> 0
end;
function TFIleInfo.isSpecialBuild : boolean;
begin
  result := FALSE;
  if GetFileVersion( fFileName ) then
    result := (fVerBlk.dwFileFlagsMask and fVerBlk.dwFileFlags and
    VS_FF_SPECIALBUILD) <> 0
end;
function TFileInfo.OS : string;
begin
  if GetFileVersion( fFileName ) then
    case fVerBlk.dwFileOS of
      VOS_DOS_WINDOWS16 : result := 'MS-DOS or 16 bit Windows';
      VOS_DOS_WINDOWS32 : result := '32 bit Windows';
      VOS_OS216_PM16 : result := '16 bit OS/2';
      VOS_OS232_PM32 : result := '32 bit OS/2';
      VOS_NT_WINDOWS32 : result := 'Win32 or Windows NT';
      else
        result := 'Unknown OS';
    end
  else
    result := '';
end;
function TFileInfo.FileType : string;
var
  S: string;
begin
  S := '';
  if GetFileVersion( fFileName ) then
  begin
    case fVerBlk.dwFileType of
      VFT_APP : S := 'Application';
      VFT_DLL : S := 'Dynamic Link Library (DLL)';
      VFT_DRV :
      begin
        S := 'Device Driver - ';
        case fVerBlk.dwFileSubtype of
          VFT2_DRV_PRINTER : S := S + 'Printer';
          VFT2_DRV_KEYBOARD : S := S + 'Keyboard';
          VFT2_DRV_LANGUAGE : S := S + 'Language';
          VFT2_DRV_DISPLAY : S := S + 'Display';
          VFT2_DRV_MOUSE : S := S + 'Mouse';
          VFT2_DRV_NETWORK : S := S + 'Network';
          VFT2_DRV_SYSTEM : S := S + 'System';
          VFT2_DRV_INSTALLABLE : S := S + 'Installable';
          VFT2_DRV_SOUND : S := S + 'Sound';
          else
            S := S + 'Unknown';
        end;
      end;
      VFT_FONT :
      begin
        S := 'Font File - ';
        case fVerBlk.dwFileSubType of
          VFT2_FONT_RASTER : S := S + 'Raster';
          VFT2_FONT_VECTOR : S := S + 'Vector';
          VFT2_FONT_TRUETYPE : S := S + 'TrueType';
          else
            S := S + 'Unknown';
        end;
      end;
      VFT_VXD : S := 'Virtual Device';
      VFT_STATIC_LIB : S := 'Static Link Library';
      else
        S := 'Unknown File Type';
    end;
  end;
  Result := S;
end;
function TFileInfo.Path : string;
begin
  result := ExtractFilePath( fFileName );
end;
function TFileInfo.FileName : string;
begin
  result := ExtractFileName( fFileName );
end;
function TFileInfo.name : string;
begin
  if Pos( FileExt, FileName ) > 0 then
    result := Copy( FileName, 0, pos( FileExt, FileName )-1 )
  else
    result := FileName;
end;
function TFileInfo.DosFileName : string;
begin
  result := StrPas( f.FindData.cAlternateFileName )
end;
function TFileInfo.FileExt : string;
begin
  result := ExtractFileExt( fFileName );
end;
function TFileInfo.isDirectory : boolean;
begin
  result := f.Attr and faDirectory = faDirectory;
end;
function TFileInfo.isHidden : boolean;
begin
  result := f.Attr and faHidden = faHidden;
end;
function TFileInfo.isSystemFile : boolean;
begin
  result := f.Attr and faSysFile = faSysFile;
end;
function TFileInfo.isVolumeId : boolean;
begin
  result := f.Attr and faVolumeId = faVolumeId;
end;
function TFileInfo.isArchive : boolean;
begin
  result := f.Attr and faArchive = faArchive;
end;
function TFileInfo.FileSize : longint;
begin
  result := f.Size;
end;
function TFileInfo.CreationTime : TDateTime;
var
  LTime: TFileTime;
  Systemtime: TSystemtime;
begin
  FileTimeToLocalFileTime( f.FindData.ftCreationTime, LTime);
  FileTimeToSystemTime( LTime, SystemTime );
  result := SystemTimeToDateTime( SystemTime);
end;
function TFileInfo.LastAccessed : TDateTime;
var
  LTime : TFileTime;
  Systemtime : TSystemtime;
begin
  FileTimeToLocalFileTime( f.FindData.ftLastAccessTime, LTime);
  FileTimeToSystemTime( LTime, SystemTime );
  result := SystemTimeToDateTime( SystemTime);
end;
function TFileInfo.LastWritten : TDateTime;
var
  LTime : TFileTime;
  Systemtime : TSystemtime;
begin
  FileTimeToLocalFileTime( f.FindData.ftLastWriteTime, LTime);
  FileTimeToSystemTime( LTime, SystemTime );
  result := SystemTimeToDateTime( SystemTime);
end;
function TFileInfo.Execute : integer;
begin
  result := shellapi.ShellExecute( Application.Handle, 'open',
    pChar( fFileName ), '', pChar(Path), SW_SHOWDEFAULT );
  case result of
    0 :
      raise Exception.Create( 'Недостаточно памяти или ресурсов.' );
    ERROR_FILE_NOT_FOUND :
      raise Exception.Create( 'Указанный файл не найден.' );
    ERROR_PATH_NOT_FOUND :
      raise Exception.Create( 'Указанный путь не найден.' );
    ERROR_BAD_FORMAT :
      raise Exception.Create( 'Ошибка файла .EXE (не -Win32 .EXE или ошибка ' + 'в .EXE).' );
    SE_ERR_ACCESSDENIED :
      raise Exception.Create( 'Доступ к файлу запрещён.' );
    SE_ERR_ASSOCINCOMPLETE :
      raise Exception.Create( 'The filename association is incomplete or invalid.' );
    SE_ERR_DDEBUSY :
      raise Exception.Create( 'Транзакция DDE не может быть завершена, потому что ' +
      'другая транзакция DDE находится в процессе выполнения.' );
    SE_ERR_DDEFAIL :
      raise Exception.Create( 'Ошибка транзакции DDE.' );
    SE_ERR_DDETIMEOUT :
      raise Exception.Create( 'DDE транзакция не может быть завершина из-за тайм-аута.' );
    SE_ERR_DLLNOTFOUND :
      raise Exception.Create( 'Указанная dynamic-link library не найдена.' );
    SE_ERR_NOASSOC :
      raise Exception.Create( 'Не найдено приложение связанной с данным расширением файла.' );
    SE_ERR_OOM :
      raise Exception.Create( 'Недостаточно памяти для завершения операции.' );
    SE_ERR_SHARE :
      raise Exception.Create( 'Файл используется другим приложением.' );
    else
  end;
end;
end.