unit Unit1;

interface

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

type
   TForm1 = class(TForm)
     Panel1: TPanel;
     Button1: TButton;
     Timer1: TTimer;
     procedure Button1Click(Sender: TObject);
     procedure Timer1Timer(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;

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
   Form1: TForm1;
   hWnd:THandle;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  hWnd := capCreateCaptureWindowA('Capture Window',
WS_CHILD or WS_VISIBLE ,
0,
0,
Panel1.Width,
Panel1.Height,
Panel1.Handle,
0); //создаем область для вывода получаемых в будущем картинок =)

if hWnd <> 0 then //если при создании области ошибок не возникло, то сопкойно начинаем забирать данный с веб-камеры
SendMessage(hWnd, WM_CAP_DRIVER_CONNECT, 0, 0);  //забираем картинку с вебкамеры

Timer1.Enabled:=True;
end;

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

end.

unit Unit1;

interface

uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, DSPack,DSUtil,DirectShow9, StdCtrls, ExtCtrls;

type
PPixelArray = ^TpixelArray;//указатель на масив байтов
TPixelArray = array [0..0] of byte;//масив байтов

type
   TForm1 = class(TForm)
     FilterGraph1: TFilterGraph;
     VideoWindow1: TVideoWindow;
     Filter1: TFilter;
     SampleGrabber1: TSampleGrabber;
     ComboBox1: TComboBox;
     Timer1: TTimer;
     Button2: TButton;
     Button3: TButton;
     procedure FormCreate(Sender: TObject);
     procedure ComboBox1Change(Sender: TObject);
     procedure Timer1Timer(Sender: TObject);
     procedure Button2Click(Sender: TObject);
     procedure Button3Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;

var
   Form1: TForm1;
   VideoDevice:TSysDevEnum;
   OldPixelsBuf:PPixelArray;
   SelectedX:integer;
   SelectedY:integer;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
i:integer;
begin
VideoDevice := TSysDevEnum.Create(CLSID_VideoInputDeviceCategory);//получаем список устров с которых можно принять видео поток(получаем список веб камер)
if VideoDevice.CountFilters > 0 then//если есть хоть один девайс
for i:=0 to VideoDevice.CountFilters - 1 do// то добавляем девайсы в список для выбора
ComboBox1.Items.Add(VideoDevice.Filters[i].FriendlyName);

FilterGraph1.ClearGraph;//настраеваем фильтр
FilterGraph1.Active := false;
Filter1.BaseFilter.Moniker:=VideoDevice.GetMoniker(0);//выводим изображение с первого девайса
FilterGraph1.Active := true;

//задайом что откуда нужно получать и что куда должно выводится
with FilterGraph1 as ICaptureGraphBuilder2 do
RenderStream(@PIN_CATEGORY_PREVIEW,nil,
Filter1 as IBaseFilter,
SampleGrabber1 as IBaseFilter,
VideoWindow1 as IbaseFilter);

//выводим изображение
FilterGraph1.Play;
//VideoWindow1.Visible := false;
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
FilterGraph1.ClearGraph;
FilterGraph1.Active := false;
Filter1.BaseFilter.Moniker:=VideoDevice.GetMoniker(ComboBox1.ItemIndex);//меняем девайс на выбранный
FilterGraph1.Active := true;
//Ica

with FilterGraph1 as ICaptureGraphBuilder2 do
RenderStream(@PIN_CATEGORY_PREVIEW,nil,
Filter1 as IBaseFilter,
SampleGrabber1 as IBaseFilter,
VideoWindow1 as IbaseFilter);

FilterGraph1.Play;

OldPixelsBuf := nil;
end;

Function GetPixelsArrayFromBitmap(h:HBITMAP;Width,Height:integer):PPixelArray;//функция получения масива пикселей из битмапа
var
n:integer;
TempByte:Byte;
i:integer;
BMInfo:TBitmapInfo;
Buf: PPixelArray;
MemDC:hdc;
begin
FillChar(BMInfo,SizeOf(BMInfo),0);
BMInfo.bmiHeader.biSize:=SizeOf(TBitmapInfoHeader);
BMInfo.bmiHeader.biBitCount := 24;
BMInfo.bmiHeader.biWidth := Width;
BMInfo.bmiHeader.biHeight := Height;
n := BMInfo.bmiHeader.biWidth * BMInfo.bmiHeader.biHeight;
BMInfo.bmiHeader.biPlanes := 1;
BMInfo.bmiHeader.biCompression := BI_RGB;

MemDC := CreateCompatibleDC(0);
GetMem(Buf,n*3);
GetDIBits(MemDC,h,0,BMInfo.bmiHeader.biHeight,Buf,BMInfo,DIB_RGB_COLORS);
for i:=0 to n do begin
TempByte := Buf[i*3];
Buf[i*3] := Buf[i*3 + 2];
Buf[i*3 + 2] := TempByte;
end;

Result := Buf;
end;

procedure TForm1.Timer1Timer(Sender: TObject);//процедура таймера
var
b:tbitmap;
n:integer;//кол-во пикселей
PixelsAreChanged:integer;//количество измененных пикселей
i:integer;
PixelsBuf: PPixelArray;//масив пикселей

r1,g1,b1:byte;//RGB текущего кадра
r2,g2,b2:byte;//RGB перведущего кадра
begin
b:=TBitmap.Create;//создайом битмап
SampleGrabber1.GetBitmap(b);//получаем битмап из битмап из текущего кадра

PixelsBuf:=GetPixelsArrayFromBitmap(b.Handle,b.Width,b.Height);//получаем масив пикселей этого битмапа(можно конечноже использовать и b.Canvas.Pixels[x,y] но это негативно скажется на быстродействии программы)
n:=b.Width*b.Height;//считаем кол-во пикселов

PixelsAreChanged := 0;
if OldPixelsBuf <> nil then//если преведущий кадр существует то
for i := 0 to n do//начинаем сравнивать текущий кадр с преведущим
begin
   r1:=PixelsBuf[i*3];
   g1:=PixelsBuf[i*3 + 1];
   b1:=PixelsBuf[i*3 + 2];

   r2:=OldPixelsBuf[i*3];
   g2:=OldPixelsBuf[i*3 + 1];
   b2:=OldPixelsBuf[i*3 + 2];

   if (r1-r2)>20 then Inc(PixelsAreChanged);//если произошли изменеия то увеличеваем счетчик изменений
   if (g1-g2)>20 then Inc(PixelsAreChanged);
   if (b1-b2)>20 then Inc(PixelsAreChanged);
end;

FreeMem(OldPixelsBuf);//освобождаем память старого масива пикселей
OldPixelsBuf:=PixelsBuf;//текущий масив пикселей(пиксели текущего кадра) становится старым масивом

if PixelsAreChanged > 2000 then//проверяем сколько произошло изменений
MessageBeep(MB_OK);//если изменений произошло больше нормы то подайом звуковой сигнал

b.Free;//освобождаем битмап
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Timer1.Enabled := true;//старт
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
Timer1.Enabled:=false;//стоп
end;

end.