Delphi и веб-камера

KapKan · #1 09.02.2008, 15:21

Всем Здраствуйте.
Вопрос который я встречал на многих сайтах да собственно и сам им задовался: с помощью чего произвести захват картинки с веб-камеры?
Ответ я нашел, как мне козалось, в журнале Хакер №103 - Программерская сигнализация. В итоге после написания кода, программа почему то не выводила картинку. Программа основана на компоненте DSpack. Помогите разобраться.

Вот собственно сам код:

Код:

unit Camera;

interface

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

type
  TForm1 = class(TForm)
    FilterGraph: TFilterGraph;
    VideoWindow1: TVideoWindow;
    Filter1: TFilter;
    SampleGrabber1: TSampleGrabber;
    ComboBox1: TComboBoxEx;
    Label1: TLabel;
    ButtonStopPlay: TButton;
    Button1: TButton;
    Image1: TImage;
    Image2: TImage;
    CheckBox1: TCheckBox;
    Timer1: TTimer;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure ButtonStopPlayClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  VideoDevice: TSysDevEnum;

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);
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
 FilterGraph.ClearGraph;
 FilterGraph.Active := false;
 Filter1.BaseFilter.Moniker := VideoDevice.GetMoniker(ComboBox1.ItemIndex);
 FilterGraph.Active := true;
 with FilterGraph as ICaptureGraphBuilder2 do
 RenderStream(@PIN_CATEGORY_PREVIEW, nil, Filter1 as IBaseFilter, SampleGrabber1 as IBaseFilter, VideoWindow1 as IbaseFilter);
 FilterGraph.Play;
 ButtonStopPlay.Enabled:=True;
end;

procedure TForm1.ButtonStopPlayClick(Sender: TObject);
begin
 if ButtonStopPlay.Caption='Смотреть' then
  begin
   FilterGraph.Play;
   ButtonStopPlay.Caption:='Остановить';
  end
 else
  begin
   FilterGraph.Stop;
   ButtonStopPlay.Caption:='Смотреть';
  end;
end;




procedure TForm1.Button1Click(Sender: TObject);
begin
  SampleGrabber1.GetBitmap(Image1.Picture.Bitmap);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
 i:integer;
 j:integer;
 k:integer;
 r1,g1,b1:Byte;
 r2,g2,b2:Byte;
 FirstColor,SecondColor:Integer;
 Color:TColor;
 PriznakChange:byte;
begin
 if Timer1.Tag=0 then
  begin
   SampleGrabber1.GetBitmap(Image1.Picture.Bitmap);
   Timer1.Tag:=1;
   exit;
  end;
 SampleGrabber1.GetBitmap(Image2.Picture.Bitmap);
 Timer1.Tag:=0;
 k:=0;
 for i := 1 to Image1.Picture.Bitmap.Height do
  begin
   for j := 1 to Image1.Picture.Bitmap.Width do
    begin
     PriznakChange:=0;
     FirstColor:=Image1.Picture.Bitmap.Canvas.Pixels[i,j];
     r1:=GetRValue(FirstColor);
     g1:=GetGValue(FirstColor);
     b1:=GetBValue(FirstColor);
     SecondColor:=Image2.Picture.Bitmap.Canvas.Pixels[i,j];
     r2:=GetRValue(SecondColor);
     g2:=GetGValue(SecondColor);
     b2:=GetBValue(SecondColor);
     if Abs(r1-r2)>20 then inc(PriznakChange);
     if Abs(g1-g2)>20 then inc(PriznakChange);
     if Abs(b1-b2)>20 then inc(PriznakChange);
     if PriznakChange=3 then k:=k+1;
     Application.ProcessMessages;
    end;
  end;
 if k>2000 then
  begin
   Memo1.Lines.Add(FormatDateTime('hh:nn:ss',Now)+' Зафиксированы изменения по периметру! ');
   Image2.Picture.Bitmap.SaveToFile('log\'+FormatDateTime('hhnnss',Now)+'.bmp');
  end;
end;


end.

Admin · #2 09.02.2008, 15:30

Не забываем читать Правила форума и выделять код тегом [СODE]...[/СODE].

KapKan · #3 09.02.2008, 18:19

Спасибо учту

KapKan · #4 10.02.2008, 08:45

Я так понимаю никто не сталкивался с программированием для веб-камеры?

moo2k · #5 10.02.2008, 09:28

Вот подправил ошибки, которые нашел. У меня работает. Компилил на D2007.

KapKan · #6 20.02.2008, 08:25

попробую разобраться спасибо!
Теперь другой вопрос: с помщью демок, которые шли вместе с DSpack
пытаюсь записывать с камеры в файл AVI и при этом снять картинку и сохранить в отдельный файл (не останавливая запись), но че то не получается. Если кто-нибудь сталкивался подскажите методы. Пока пробую с помощью samplegrabber.

RomanGreb · #7 24.10.2011, 13:30

Цитата:

Сообщение от moo2k

Вот подправил ошибки, которые нашел. У меня работает. Компилил на D2007.

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

Насчет проблемы с появлением ошибки external exception c0000008 при работе с web камерой (если вдруг кому потребуется).
Решается так:
Tools -> Options -> Borland Debuggers -> Native OS Exceptions -> Ищите там свою ошибку Invalid Handle ($C0000008) и ставите в атрибутах On resume - Run handled. Компилируете и наслаждаетесь картинкой с камеры.

Edos · #8 12.01.2011, 20:11

Блин а как DSPack добавить в 9 делфи???... он скотина выкоблучивается))) не хочет... или я вася)!

M.A.D.M.A.N. · #9 12.01.2011, 20:27

Все нормально устанавливается.

Bargest · #10 12.01.2011, 21:13

Когда я пытался поставить DSPack в свою Delphi10, он мне выдал около десятка ошибок. Пришлось их править: сидеть и вникать, что же хотел написать автор. В итоге запустил...
Но мое личное ИМХО - игра не стоит свеч. Для работы с веб-камерой пользую AVICAP32.DLL (стандартная библа винды) и счастлив

Правда не знаю, можно ли им сохранить видео.

Edos · #11 12.01.2011, 23:18

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

Код:

    SaveDialog1: TSaveDialog;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    hWndC: THandle;
    CapturingAVI: bool;

  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
const
  WM_CAP_START = WM_USER;
const
  WM_CAP_STOP = WM_CAP_START + 68;
const
  WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;
const
  WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11;
const
  WM_CAP_SAVEDIB = WM_CAP_START + 25;
const
  WM_CAP_GRAB_FRAME = WM_CAP_START + 60;
const
  WM_CAP_SEQUENCE = WM_CAP_START + 62;
const
  WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20;


{$R *.dfm}
function capCreateCaptureWindowA(lpszWindowName: PCHAR;
  dwStyle: longint;
  x: integer;
  y: integer;
  nWidth: integer;
  nHeight: integer;
  ParentWin: HWND;
  nId: integer): HWND;
  stdcall external'AVICAP32.DLL';


procedure TForm1.Button1Click(Sender: TObject);
begin
 hWndC := capCreateCaptureWindowA('My Own Capture Window',
    WS_CHILD or WS_VISIBLE,
    Panel1.Left,
    Panel1.Top,
    Panel1.Width,
    Panel1.Height,
    Form1.Handle, 0);
  if hWndC <> 0 then
    SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);
    timer1.Enabled:=true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
if hWndC <> 0 then
    SendMessage(hWndC, WM_CAP_GRAB_FRAME, 0, 0); тут это типо картинку каждый раз обнавляет...
end;

Админ: Пользуемся тегами!

Bargest · #12 12.01.2011, 23:30

А дрова для камеры точно есть?

Обычно они проводят всю работу перед тем, как вывести изображение на экран.
Вообще есть такая штука:

Код:

const
  AVICAPDLL = 'AVICAP32.DLL';
  WM_CAP_START = WM_USER;
  WM_CAP_SET_CALLBACK_FRAME = WM_CAP_START + 5;
  WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;
  WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11;
  WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START + 41;
  WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44;
  WM_CAP_SET_VIDEOFORMAT = WM_CAP_START + 45;
  WM_CAP_GET_STATUS = WM_CAP_START + 54;
  WM_CAP_GRAB_FRAME = WM_CAP_START + 60;
  WM_CAP_STOP = WM_CAP_START + 68;
  WM_CAP_SET_PREVIEW = WM_CAP_START + 50;
  WM_CAP_SET_PREVIEWRATE = WM_CAP_START + 52;
  WM_CAP_SET_SCALE = WM_CAP_START + 53;
  WM_CAP_EDIT_COPY = WM_CAP_START + 30;
  WM_CAP_SET_CALLBACK_YIELD = WM_CAP_START + 4;
  WM_CAP_SET_CALLBACK_VIDEOSTREAM = WM_CAP_START + 6;
  WM_CAP_DLG_VIDEODISPLAY = WM_CAP_START + 43;
...
// Устанавливаем параметры предпросмотра
    SendMessage(h_cam, WM_CAP_SET_SCALE, 1, 0);
    SendMessage(h_cam, WM_CAP_SET_PREVIEWRATE, 40, 0);
    SendMessage(h_cam, WM_CAP_SET_PREVIEW, 1, 0);
    SendMessage(h_cam, WM_CAP_SET_CALLBACK_FRAME, 0, Integer(@FrameCallback));

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

После этого не понадобится даже таймер, а изображение будет автоматически рисоваться в окне камеры через каждые 40 миллисекунд (только далеко не все камеры поддерживают 25 кадров/сек, у моей например максимум 15)

VladIsLove · #13 29.03.2011, 14:59

Мне надо обрабатывать кадры с камеры несколько раз в секунду... если выставить в таймере (прога котурую выложыл moo2k) значение <100 то тут начинаютса баги:
1) Постепенное выделение оперативной памяти
2) Если потрясти окном программы то оно или зависнит, или выскочит ошибка
Впринцыпе я думаю что ето баг самого DSPack, потому что если взять его родной пример PlayVideoCap и также бешено потрясти окном

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

ЗЫ: Если что, извините за плохой руский

Delphin00b · #14 25.02.2012, 18:01

Кто-нибудь может дать уже скомпилированную программу?)
У меня ошибками всё засыпалось. Поделитесь, пожалуйста

Опции темы	Поиск в этой теме
Версия для печати Отправить на Email	Поиск в этой теме: Расширенный поиск
Опции просмотра
Линейный вид Комбинированный вид Древовидный вид

	Сайт	Форум	FAQ	Соглашения	Прочее
	Новости Исходники Компоненты Статьи Добавить исходник Поиск	Правила Поиск Сообщения за сегодня Пользователи Кто на форуме?	Delphi FAQ - 5000 статей DRKB - 4500 статей (ZIP-архив) Справочник функций и процедур Delphi Delphi Programming Guide Indy in Depth. Глубины Indy	Конфиденциальность Соглашение пользователя Правила обработки cookie	О сайте Donate Контакты