Difference between revisions of "WebCam with Free Pascal"

From Free Pascal wiki
Jump to navigationJump to search
Line 1: Line 1:
−
===Webcam with Freepascal on Windows===
+
{***************************************************************
 +
* Name:      VideoTest
 +
* Author:    Denis Gottardello (info@denisgottardello.it)
 +
* Created:  2010-08-12
 +
* Copyright: Denis Gottardello (www.denisgottardello.it)
 +
* License:
 +
**************************************************************}
  
−
unit TFMainForm;
+
unit TFMainForm;
  
−
{$mode objfpc}{$H+}
+
{$mode objfpc}{$H+}
  
−
interface
+
interface
  
−
uses
+
uses
 
   Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, TFCamera,
 
   Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, TFCamera,
 
   ComCtrls, Buttons, StdCtrls, ExtCtrls, VFW;
 
   ComCtrls, Buttons, StdCtrls, ExtCtrls, VFW;
  
−
type RVideoCapDevice= record
+
type RVideoCapDevice= record
 
   szDeviceName: array[0..79] of Char;
 
   szDeviceName: array[0..79] of Char;
 
   szDeviceVersion: array[0..79] of Char;
 
   szDeviceVersion: array[0..79] of Char;
−
end;
+
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.

Revision as of 17:37, 12 August 2010

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

* 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.

Retrieved from "http://wiki.freepascal.org/index.php?title=WebCam_with_Free_Pascal&oldid=43978"