Webcam con Delphi ( III )

Continuando con el proyecto de manejo de una webcam con Delphi os presento el procedimiento para detener la grabación de una secuencia de video:

Tenéis que crear un tButton llamado "PararVideo" y en el evento Onclick teclear lo siguiente:

PROCEDURE TForm1.PararVideoClick(Sender: TObject);
BEGIN
IF ventana <> 0 THEN
BEGIN
SendMessage(ventana, WM_CAP_STOP, 0, 0);
END;
END;



UNIT WEBCAM
============

unit Webcam;
interface
uses
  Windows, Messages;
type
  TWebcam = class
    constructor Create(
      const WindowName: String = '';
      ParentWnd: Hwnd = 0;
      Left: Integer = 0;
      Top: Integer = 0;
      Width: Integer = 0;
      height: Integer = 0;
      Style: Cardinal = WS_CHILD or WS_VISIBLE;
      WebcamID: Integer = 0);
    public
      const
        WM_Connect     = WM_USER + 10;
        WM_Disconnect  = WM_USER + 11;
        WM_GrabFrame   = WM_USER + 60;
        WM_SaveDIB     = WM_USER + 25;
        WM_Preview     = WM_USER + 50;
        WM_PreviewRate = WM_USER + 52;
        WM_Configure   = WM_USER + 41;
    public
      procedure Connect;
      procedure Disconnect;
      procedure GrabFrame;
      procedure SaveDIB(const FileName: String = 'webcam.bmp');
      procedure Preview(&on: Boolean = True);
      procedure PreviewRate(Rate: Integer = 42);
      procedure Configure;
    private
      CaptureWnd: HWnd;
  end;
implementation
function capCreateCaptureWindowA(
  WindowName: PChar;
  dwStyle: Cardinal;
  x,y,width,height: Integer;
  ParentWin: HWnd;
  WebcamID: Integer): Hwnd; stdcall external 'AVICAP32.dll';
{ TWebcam }
procedure TWebcam.Configure;
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_Configure, 0, 0);
end;
procedure TWebcam.Connect;
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_Connect, 0, 0);
end;
constructor TWebcam.Create(const WindowName: String; ParentWnd: Hwnd; Left, Top,
  Width, height: Integer; Style: Cardinal; WebcamID: Integer);
begin
  CaptureWnd := capCreateCaptureWindowA(PChar(WindowName), Style, Left, Top, Width, Height,
    ParentWnd, WebcamID);
end;
procedure TWebcam.Disconnect;
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_Disconnect, 0, 0);
end;
procedure TWebcam.GrabFrame;
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_GrabFrame, 0, 0);
end;
procedure TWebcam.Preview(&on: Boolean);
begin
  if CaptureWnd <> 0 then
    if &on then
      SendMessage(CaptureWnd, WM_Preview, 1, 0)
    else
      SendMessage(CaptureWnd, WM_Preview, 0, 0);
end;
procedure TWebcam.PreviewRate(Rate: Integer);
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_PreviewRate, Rate, 0);
end;
procedure TWebcam.SaveDIB(const FileName: String);
begin
  if CaptureWnd <> 0 then
    SendMessage(CaptureWnd, WM_SaveDIB, 0, Cardinal(PChar(FileName)));
end;
end.
 
=================
EJEMPLO DE USO
===============
 
en el evento OnCreate:
... 
  private
    { Private declarations }
  public
    { Public declarations }
    camera: TWebcam;
  end;
var
  Form1: TForm1;
implementation
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  camera := TWebcam.Create('WebCaptured', Panel1.Handle, 0, 0,
    1000, 1000);
end;
 
 
 
ENCENDIDO Y APAGADO DE LA CAMARA:
================================= 
procedure TForm1.Button1Click(Sender: TObject);
const
  str_Connect = 'Encender la camara';
  str_Disconn = 'Apagar la camara';
begin
  if (Sender as TButton).Caption = str_Connect then  begin
    camera.Connect;
    camera.Preview(true);
    Camera.PreviewRate(4);
    (Sender as TButton).Caption:=str_Disconn;
  end
  else begin
    camera.Disconnect;
    (Sender as TButton).Caption:=str_Connect;
  end;
end; 



CAPTURA DE LA FOTO
==================
procedure TForm1.Button2Click(Sender: TObject);
var
  PanelDC: HDC;
begin
if not Assigned(Image1.Picture.Bitmap) then
    Image1.Picture.Bitmap := TBitmap.Create
  else
  begin
    Image1.Picture.Bitmap.Free;
    Image1.picture.Bitmap := TBitmap.Create;
  end;
  Image1.Picture.Bitmap.Height := Panel1.Height;
  Image1.Picture.Bitmap.Width  := Panel1.Width;
  Image1.Stretch := True;
  PanelDC := GetDC(Panel1.Handle);
  try
    BitBlt(Image1.Picture.Bitmap.Canvas.Handle,
      0,0,Panel1.Width, Panel1.Height, PanelDC, 0,0, SRCCOPY);
  finally
    ReleaseDC(Handle, PanelDC);
  end;
end;
 
Links relacionados

Webcam con Delphi ( I )


Webcam con Delphi ( II )

6 comentarios:

  1. Erickson Rodrigues6 de junio de 2014, 21:08

    y el mejor poste en la webcam he sido testigo a lo largo de mi carrera de programación.

    Muchas gracias

    Erickson Rodrigues

    ericksonrodrigues@msn.com / Manaus-AM/ Brasil

    ResponderEliminar
    Respuestas
    1. Erick te ha funcionado el ejemplo sin pantalla negra?

      Eliminar
  2. Bueno, felicidades, si lo mejoras te agradezco que publiques esas mejoras

    ResponderEliminar
  3. Panel1 es el contenedor de Image1

    ResponderEliminar
  4. Panel1:tPanel;
    Image1:tImage;

    ResponderEliminar