One block Tetris for Delphi

Here is a Tetris for Delphi example which used buffered GDI graphics.

Tetris Delphi

Controls:

  • LEFT, RIGHT flash arrows – moves
  • DOWN arrow – speed up the block
  • ESC – exit
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
const
  n = 10; // количество строк
  m = 5;  // количество столбцов
  z = 50; // длина стороны квадрата ячейки на поле
  normal_timer = 600; // значение интервала таймера по умолчанию
  speed_timer = 100;   // значение интервала таймера при ускорении
type
  player = record
              x:integer;
              y:integer;
            end;
            // тип запись, для фиксирования положения кубика игрока
var
  cols: array [1..n, 1..m] of boolean; // матрица состояний ячеек поля
                                    // true - кубик есть
                                    // false - кубика нет
  p: player; // летящий вниз кубик
  i,j: integer; // счетчики
  counter: integer;

procedure verify_line;
var
  last_line_full: boolean;
begin
  last_line_full := true; // флаг указывающий на заполнение последней линии

  for i:=1 to m do
  begin
    // проверяем последнюю линию (строку)
    if not cols[n,i] then // если какого-то кубика в линии нет, то говорим, что линия не заполнена и выходим из цикла
    begin
      last_line_full := false;
      break;
    end;
  end;


  // если поледняя линия заполнена, то необходимо сдвинуть все строки на одну ниже
  if last_line_full then
  begin
    counter := counter + 1; // раз заполнили линию , добавляем очки
    for i:=n downto 2 do
    begin
      for j:=1 to m do
      begin
        cols[i,j] := cols[i-1, j]; // заменяем строки которые ниже, строками которые выше
      end;
    end;

    // первую строку очищаем
    for i:=1 to m do
      cols[1, i] := false;
  end;

  Form1.Caption := 'Tetris. count = ' + IntToStr(counter); // выводим результат игрока в заголовок

  // т.к. у нас кубик 1 на 1 клетку, то достаточно проверить заполненность линии 1 раз
  // были бы другие объекты большей высоты, не обходимо было бы проверять, до тех пор
  // пока последняя линия не стала бы незаполненной
end;

procedure new_player;
begin
  // если было ускорение, и даже если его не было
  // возвращаем значение интервала таймера в исходное
  Form1.Timer1.Interval := normal_timer;

  // т.к. процедура new_player не объявлена в классе TForm1,
  // то, чтобы обратиться к объектам на форме
  // нужно перед ними писать Form1.

  // начальное положение игрока
  randomize;
  p.x := Random(m-1)+1; // случайное число от 1 до m
  p.y := 1; // первая строка сверху
end;

procedure  verify_player;
begin
  // проверяем, чтобы кубик не вылетел за границы поля
  if (p.x <= 1) then p.x := 1 else if (p.x >= m) then p.x := m;

  if (cols[p.y, p.x]) then
  begin
    Form1.Timer1.Enabled := false;
    ShowMessage('Игра Окончена!');
  end;

  // если кубик упал до самого низа или если кубик упал на другой кубик
  if (p.y >= n) or (cols[p.y+1, p.x]) then begin
    cols[p.y, p.x] := true;  // отмечаем упавший кубик на поле
    new_player; // возвращаем падающий кубик в начало пути
  end;
end;

//отображает игровое поле
procedure print_m;
var
  b: TBitmap;   // будем использовать двойную буфферизацию
                // поэтому создаем переменную типа TBitmap
                // смысл в том, что сначало рисуем "в памяти",
                // а потом выводим на экран

begin

  verify_line;  // проверим последнюю линию ( строку ) на заполненность
  verify_player; // проверяем координаты игрока
  b := TBitmap.Create; // создаем объект заданного типа


  b.Width := Form1.Width; // устанавливаем ширину рисунка в памяти
  b.Height := Form1.Height; // устанавливаем высоту рисунка в памяти

  // рисуем кубики которые уже упали
  for i:=1 to n do
    for j:=1 to m do
    begin
      if cols[i,j] then
      begin
        b.Canvas.Brush.Color := clRed;  // если есть, то рисуем красным
      end
      else
      begin
        b.Canvas.Brush.Color := clWhite; // если нет, то рисуем белым
      end;

      b.Canvas.FillRect(Rect((j-1)*z,(i-1)*z, (j-1)*z+z, (i-1)*z+z)); // отображаем ячейку
      // обращаем внимание j - это столбцы, оно меняет координату x
      // i - строки, меняет координату y
    end;

  b.Canvas.Brush.Color := clRed; // цвет падающего кубика
  b.Canvas.FillRect(Rect((p.x-1)*z,(p.y-1)*z, (p.x-1)*z+z, (p.y-1)*z+z)); // отображаем ячейку

  // из всех координат на поле вычитаем единичку
  // потому что размер поля например 5 на 10, но в графике это 250 на 500 (потомучто если кубик будет со стороной 1 пиксель его никто не увидит)
  // и в графике координаты начинаються с нуля, т.е. кубик с координатами на поле 1,1 , это прямоугольник (Rect(0,0,50,50))

  // копируем картинку из памяти в картинку на экране,
  // по человечески говоря - отображаем
  Form1.Canvas.CopyRect(Rect(0,0, Form1.Width, Form1.Height), b.Canvas, Rect(0,0,b.Width, b.Height));

  // если не использовать двойной буфер, то все b заменили бы на Form1 (или Image1)
  // удалили бы строки связанные с TBitmap.Create, b.Width, b.Height, Form1.CopyRect

  b.Free; // очищаем память, от временной картинки
end;



procedure TForm1.FormCreate(Sender: TObject);
begin
  // в этой процедуре всегда все сбрасываем на исходные позиции



  counter := 0; // счетчик очков в ноль
  new_player;

  // очищаем поле
  for i:=1 to n do
    for j:=1 to m do
      cols[i,j] := false;

  // устанавливаем размеры окна
  Form1.ClientWidth := m * z;
  Form1.ClientHeight := n * z;
  // используються размеры с приставкой Client потомучто, без неё это размер окна
  // с учетом всех рамок, отступов и в зависимости от установленного стиля
  // графической оболочки виндовс просто размеры Width и Height разные!
  // а ClientWidth и    ClientHeight постоянны всегда и гарантируют нам нужный размер рабочего поля

end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if ( not Timer1.Enabled ) then // если игра окончена
  begin
    exit; // то - не обрабатываем клавиши
  end;

  // если была нажата клавиша влево
  if (Key = VK_LEFT) then
  begin
    p.x := p.x - 1;
    print_m; // если что-то поменялось, сразу отображаем изменения
  end
  // иначе если нажата клавиша вправо
  else if (Key = VK_RIGHT) then
  begin
    p.x := p.x + 1;
    print_m;
  end
  // если нажата клавиша вниз, делаем ускорение
  else if (Key  = VK_DOWN) then
  begin
    Timer1.Interval := speed_timer;
  end
  // если пользователь нажал ESC, то выходим
  else if (Key = VK_ESCAPE) then
    close;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  p.y := p.y + 1; // опускаем кубик вниз
  print_m; // отображаем игровое поле
end;

end.

Web-cam in Delphi 7

To use web-cam in Delphi, we are going to use:

To import and use WinAPI functions in Delphi we need to use ShellAPI module

Uses
  ... , ShellAPI

For AVICap we need to define some constants and function signatures (for C++ version you can just include vfw.hwhich already have all needed functions and constants):

const
WM_CAP_START = WM_USER;
WM_CAP_STOP = WM_CAP_START + 68;
WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;
WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11;
WM_CAP_SAVEDIB = WM_CAP_START + 25;
WM_CAP_GRAB_FRAME = WM_CAP_START + 60;
WM_CAP_SEQUENCE = WM_CAP_START + 62;
WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20;
 
function capCreateCaptureWindowA(lpszWindowName : PCHAR;
dwStyle : longint;
x : integer;
y : integer;
nWidth : integer;
nHeight : integer;
ParentWin : HWND;
nId : integer): HWND; stdcall external 'AVICAP32.DLL';
 
var hWndC : THandle;

Code for the function which start capturing the video from web-cam:

procedure TForm1.Button1Click(Sender: TObject);
begin
 hWndC := capCreateCaptureWindowA('My Own Capture Window',
WS_CHILD or WS_VISIBLE ,
0,
0,
Panel1.Width,
Panel1.Height,
Panel1.Handle,
0); // using Panel object to output our image from webcams
 
if hWndC <> 0 then // if Panel object is available and there were not errors during capCreateCaptureWindowA call
    SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);  // starting capturing
 
end;

Here you need to find a correct ID of your web-cam device. It could be 0,1,2,… depends on how many web-cams or other capturing devices you have installed.

SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, <device-number>, 0);

To finish:

procedure TForm1.Button2Click(Sender: TObject);
begin
  if hWndC <> 0 then
  begin
    SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0);  // finish capturing
    hWndC := 0;
  end;
end;

Capture the image and show on Panel by Timer:

procedure TForm1.Timer1Timer(Sender: TObject);
begin
if hWndC <> 0 then SendMessage(hWndC, WM_CAP_GRAB_FRAME, 0, 0);
end;

One thing to mention, Panel object does not have Bitmap property, so if you want to work with image with classic GDI tools you need to use other component. For example, you can use Form component:

{…}
hWndC := capCreateCaptureWindowA(‘My Own Capture Window’,
     WS_CHILD or WS_VISIBLE ,
     0,
     0,
     Form1.Width,
     Form1.Height,
     Form1.Handle,
     0);

{…}
var
   bmp: TBitmap;
{…}
begin
{…}
   bmp := TBitmap.Create;
   bmp.Width := Form1.Width;
   bmp.Height:=Form1.Height;
   bmp.Canvas.CopyRect(Rect(0,0,Form1.Width, Form1.Height), Form1.Canvas, 
   Rect(0,0,Form1.Width, Form1.Height));
   bmp.SaveToFile('path for BMP file');
end;
{…}