WebCam with Free Pascal

{***************************************************************

* Name:      VideoTest
* Author:    Denis Gottardello (info@denisgottardello.it)
* Created:   2010-08-12
* Copyright: Denis Gottardello (www.denisgottardello.it)
* License:
**************************************************************}

unit TFMainForm;

{$mode objfpc}{$H+}

interface

uses

 Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, TFCamera,
 ComCtrls, Buttons, StdCtrls, ExtCtrls, VFW;

type RVideoCapDevice= record

 szDeviceName: array[0..79] of Char;
 szDeviceVersion: array[0..79] of Char;

end;

type AImageIn= array of Byte; type PAImageIn= ^AImageIn; type Av_capability= array of RVideoCapDevice;

type

 { TMainForm }

 TMainForm = class(TForm)
   BitBtn1: TBitBtn;
   TBBCamera: TBitBtn;
   GroupBox2: TGroupBox;
   TMLog: TMemo;
   TEDriver: TEdit;
   TECard: TEdit;
   TEBusInfo: TEdit;
   TEVersion: TEdit;
   TECapabilities: TEdit;
   TEReserved: TEdit;
   GroupBox1: TGroupBox;
   Label1: TLabel;
   Label2: TLabel;
   Label3: TLabel;
   Label4: TLabel;
   Label5: TLabel;
   Label6: TLabel;
   TLBVideoCards: TListBox;
   StatusBar1: TStatusBar;
   procedure FormCreate(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
   procedure TBBCameraClick(Sender: TObject);
   procedure FormShow(Sender: TObject);
   procedure TLBVideoCardsClick(Sender: TObject);
 private
   AAv_capability: Av_capability;
   TSLInterfacesList: TStringList;
   Camera: TCamera;
   IsCameraConnected: Boolean;
   FHandle: Integer;
 public
   { public declarations }
 end; 

var

 MainForm: TMainForm;

implementation

uses

 Windows;

{ TMainForm }

procedure TMainForm.FormShow(Sender: TObject); var

 VideoCapDevice: RVideoCapDevice;
 I: Integer;

begin

 SetLength(AAv_capability, 0);
 for I:= 0 to 99 do begin
   if capGetDriverDescription(I, @VideoCapDevice.szDeviceName, sizeof(VideoCapDevice.szDeviceName), @VideoCapDevice.szDeviceVersion, sizeof(VideoCapDevice.szDeviceVersion)) then begin
     SetLength(AAv_capability, Length(AAv_capability)+ 1);
     AAv_capability[Length(AAv_capability)- 1]:= VideoCapDevice;
     TLBVideoCards.Items.Append(VideoCapDevice.szDeviceName +', '+ VideoCapDevice.szDeviceVersion);
   end;
 end;

end;

procedure TMainForm.TBBCameraClick(Sender: TObject); var

 FDriverCaps: TCapDriverCaps;

begin

 if not IsCameraConnected then begin
   Camera:= TCamera.Create(Self);
   Camera.FHandle:= @FHandle;
   FHandle:= capCreateCaptureWindow(nil, WS_CHILDWINDOW or WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS , Camera.TPCamera.Left+ 5, Camera.TPCamera.Top+ 5, Camera.TPCamera.Width- 10, Camera.TPCamera.Height-10, Camera.TPCamera.Handle, 0);
   if (FHandle<> 0) and capDriverConnect(FHandle, TLBVideoCards.ItemIndex) then begin
     if capDriverGetCaps(FHandle, @FDriverCaps, SizeOf(TCapDriverCaps)) then begin
       if FDriverCaps.fHasOverlay then begin
         TMLog.Lines.Append('Driver connected, accepts overlay');
         if not capPreviewRate(FHandle, 0) then TMLog.Lines.Append('Error capPreviewRate(FHandle, 0)!');
         if capOverlay(FHandle, True) then TMLog.Lines.Append('Video Capture - Overlay (Hardware)');
       end else begin
         TMLog.Lines.Append('Driver connected, software rendering');
         if not capPreviewRate(FHandle, 33) then TMLog.Lines.Append('Error capPreviewRate(FHandle, 33)!');
         if capPreview(FHandle, True) then TMLog.Lines.Append('Video Capture - Preview (Software)');
       end;
       IsCameraConnected:= true;
       TBBCamera.Caption:= 'Stop';
     end;
   end;
   Camera.Show();
 end else begin
   if capCaptureStop(FHandle) and capDriverDisconnect(FHandle) then begin
     Camera.Free;
     IsCameraConnected:= false;
     TBBCamera.Caption:= 'Start';
   end;
 end;

end;

procedure TMainForm.FormCreate(Sender: TObject); begin

 TSLInterfacesList:= TStringList.Create();
 IsCameraConnected:= false;

end;

procedure TMainForm.FormDestroy(Sender: TObject); begin

 TSLInterfacesList.Free;

end;

procedure TMainForm.TLBVideoCardsClick(Sender: TObject); begin

 if (TLBVideoCards.ItemIndex> -1) and (TLBVideoCards.ItemIndex< TLBVideoCards.Items.Count) then begin
   TEDriver.Text:= AAv_capability[TLBVideoCards.ItemIndex].szDeviceName;
   TEVersion.Text:= AAv_capability[TLBVideoCards.ItemIndex].szDeviceVersion;
   TBBCamera.Enabled:= true;
 end;

end;

initialization

 {$I TFMainForm.lrs}

end.