RealICQClient/Includes/VFW/Videocap.pas

unit Videocap;

interface

 uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,stdctrls,
  ExtCtrls, vfw, mmsystem,syncobjs;

 ///////////////////////////////////////////////////////////////////////////////
// Video Capturing

type
// Types for audio-settings
 TChannel = (Stereo, Mono);
 TFrequency = (f8000Hz, f11025Hz, f22050Hz, f44100Hz);
 TResolution  = (r8Bit, r16Bit);


// Types for event-procedures
type
  TCapStatusProc = procedure(Sender: TObject) of object;
  TCapStatusCallback = procedure (Sender:TObject;nID:integer;status:string) of object;
  TVideoStream = procedure (sender:TObject;lpVhdr:PVIDEOHDR) of object;
  TAudioStream = procedure (sender:TObject;lpWHdr:PWAVEHDR) of object;
  TError       = procedure (sender:TObject;nID:integer; errorstr:string) of object;


// Exceptions
type ENoDriverException      = class(Exception);
type ENoCapWindowException   = class(Exception);
type ENotConnectException    = class(Exception);
type ENoOverlayException     = class(Exception);
type EFalseFormat            = class(Exception);
type ENotOpen                = class(Exception);
type EBufferFileError        = class(Exception);


type
TAudioFormat = class (TPersistent)
   private
    FChannels :TChannel;
    FFrequency:TFrequency;
    FRes      :TResolution;
  private
    procedure SetAudio(handle:Thandle); // Setting Audio Data to Capture Window

  public
   constructor create;

   published
     property Channels: TChannel read FChannels write Fchannels     default Mono;
     property Frequency: TFrequency read FFrequency write fFrequency default f8000Hz;
     property Resolution : TResolution read FRes write FRes         default r8Bit;
 end;





type
  TVideoCap = class(TCustomControl)
  private

   fdriverIndex:integer;   // Videodriver index
   fVideoDriverName     : string;  // name of videodriver
   fhCapWnd             : THandle;  // handle for CAP-Window
   fpDrivercaps         : PCapDriverCaps; // propertys of videodriver
   fpDriverStatus       : pCapStatus; // status of capdriver
   fscale               : boolean;  // window scaling
   fprop                : boolean;  // proportional scaling
   fpreviewrate         : word;  // Frames p. sec during preview
   fmicrosecpframe      : cardinal; // framerate as microsconds
   fCapVideoFileName    : string; // name of the capture file
   fTempFileName        : String; // Name of temporary avi-file
   fTempFileSize        : word; // size of Tmp- File in MB

   fCapSingleImageFileName : string; // name of the file for a single image
   fcapAudio               :boolean; // Capture also audio stream
   fcapTimeLimit           :word;    // Time limit for captureing
   fIndexSize             :cardinal; // size of the index in the capture file
   fcapToFile             : boolean;  // Write frames to file druing capturing
   FAudioFormat           : TAudioFormat;// Audio Format
   fCapStatusProcedure     : TCapStatusProc;      // Event procedure for internal component status
   fcapStatusCallBack      : TCapStatusCallback;  // Event procedure for status of then driver
   fcapVideoStream         : TVideoStream;        // Event procedure for each Video frame during capturing
   fcapAudioStream         : TAudiostream;        // Event procedure for each Audio buffer
   fcapFrameCallback       : TVideoStream;        // Event procedure for each Video frame during preview
   fcapError               : TError;              // Event procedure for Error




   procedure setsize(var msg:TMessage); message WM_SIZE;  // Changing size of cap window
   function GetDriverCaps:boolean;                        // get driver capitiyties
   procedure DeleteDriverProps;                           // delete driver capitilyites
   procedure CreateTmpFile(drvopn:boolean); // Create or delete a temp avi?file

   function GetDriverStatus(callback:boolean):boolean; // Getting state of driver
   Procedure SetDriverOpen(value:boolean) ;         // Open and Close the driver
   function GetDriverOpen:boolean;                        // is Driver open ?
   function GetPreview:boolean;   // previwe mode
   function GetOverlay:Boolean;   // overlay eode;
   procedure SizeCap;             // calc size of the Capture Window
   procedure Setprop(value:Boolean); // Stretch Picture proportional to Window Size
   procedure SetMicroSecPerFrame(value:cardinal);    // micro seconds between two frames
   procedure setFrameRate(value:word);               // Setting Frames p. second
   function  GetFrameRate:word;                      // Getting Frames p. second.

  

    // Handlers for Propertys

   procedure SetDriverIndex(value:integer);// Select Driver by setting driver index
   function CreateCapWindow:boolean;       // Opening driver, create capture window
   procedure DestroyCapwindow;             //  Closing Driver, destrying capture window
    function GetCapWidth:word;              // Width and Heigth of Video-Frame
    function GetCapHeight:word;
    function  GetHasDlgVFormat  : Boolean;  // Driver has a format dialog
    function  GetHasDlgVDisplay : Boolean;  // Driver has a display dialog
    function  GetHasDlgVSource  : Boolean;  // Driver has a source dialog
    function  GetHasVideoOverlay: Boolean;  // Driver has overlay mode
    procedure Setoverlay(value:boolean);  // Driver will use overlay mode
    procedure SetPreview(value:boolean);  // Driver will use preview mode
    procedure SetScale(value:Boolean);   //  Stretching Frame to component size
    procedure SetpreviewRate(value:word); // Setting preview frame rate
    function GetCapInProgress:boolean;    // Capturing  in progress
    procedure SetIndexSize(value:cardinal); // Setting index size in capture file
    function GetBitMapInfoNP:TBITMAPINFO; //  Bitmapinfo Without Palette
    function GetBitmapHeader:TBitmapInfoHeader; //Get only Header;
    procedure SetBitmapHeader(Header:TBitmapInfoHeader); // Set only Header
    procedure SetBufferFileSize(value:word); // Setting of Tmp-File


  // Setting callbacks as events
    procedure SetStatCallBack(value:TCapStatusCallback);
    procedure SetCapVideoStream(value:TVideoStream);
    procedure SetCapAudioStream(value:TAudioStream);
    procedure SetCapFrameCallback(value:TVideoStream);
    procedure SetCapError(value:TError);

  public
     procedure SetDriverName(value:String); // Select Driver by setting driver name

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    property  HasDlgFormat:Boolean read GetHasDlgVFormat;    // Driver has a format dialog
    property  HasDlgDisplay:Boolean read GetHasDlgVDisplay;  // Driver has a display dialog
    property  HasDlgSource:Boolean read GetHasDlgVSource;    // Driver has a sourve dialog
    property  HasVideoOverlay:boolean read GetHasVideoOverlay;  // Driver has overlay mode
    property  CapWidth: word read GetCapWidth;                  // Width of the captured frames
    property  CapHeight: word read GetCapHeight;                // Hight of the captured frames
    property  CapInProgess: boolean read getCapinProgress;      /// capturing is progress
    property  BitMapInfo:TBitmapinfo read GetBitmapInfoNP;      // Get the Bitmapinfo of the frames wiht no legal palette
   //Header of the Bitmapinfo
    function DlgVFormat:Boolean;                              // Shows VideoFormat dialog of the Driver
    function DlgVDisplay:boolean;                            // Shows VideoDisplay dialog of the Driver
    function DlgVSource:boolean;                           // Shows   VideoSource  dialog of the Driver
    function DlgVCompression:Boolean;                      // Shows  VideoCompression dialog from VfW
    function GrabFrame:boolean;                          // Capture one Frame and stops overlay or preview mode
    function GrabFrameNoStop:boolean;                    // Capture one frame without stoppin overlay or preview
    function SaveAsDIB:Boolean;                          // saves actual frame as DIB
    function SaveToClipboard:Boolean;                    // Puts actual fasme to then Clipboard
    function StartCapture:Boolean;                       // Starts Capturing
    function StopCapture:Boolean;                        // Stops capturing
    function GetBitmapInfo(var p:Pointer):integer;       // The whole Bitmap-Info with complete palette
    procedure SetBitmapInfo(p:Pointer;size:integer);    // Setting whole Bitmap-Info with complete palette
    property  BitMapInfoHeader:TBitmapInfoHeader read GetBitmapHeader write SetBitmapHeader;
    function SaveCap:boolean;                            // Saves Avi-File if Bufferfile is used
    function CapSingleFramesOpen:boolean;                // Opens AVI-File for Singe Image Capturing
    function CapSingleFramesClose:boolean;                // Close AVI-File after Singe Image Capturing
    function CapSingleFrame:boolean;                     // Captures a Single frame to File

 published
   property align;
   property color;
   property visible;
   property DriverOpen: boolean read getDriveropen write setDriverOpen; // Opens the Driver / or is Driver open
   property DriverIndex:integer read fdriverindex write SetDriverIndex;  // Index of driver
   property DriverName: string read fVideoDriverName write SetDrivername;    // Name of the Driver
   property VideoOverlay:boolean read GetOverlay write SetOverlay;   // Overlay - Mode
   property VideoPreview:boolean read GetPreview write SetPreview;  // Preview - Mode
   property PreviewScaleToWindow:boolean read fscale write Setscale; // Stretching Frame to component size
   property PreviewScaleProportional:boolean read  fprop write Setprop; // Stretching Frame poportional to original size
   property PreviewRate:word read fpreviewrate write SetpreviewRate;    //Preview frame rate
   property MicroSecPerFrame:cardinal read  fmicrosecpframe write SetMicroSecPerFrame;  //micro seconds between two frames
   property FrameRate:word read  getFramerate write setFrameRate; //Frames p. second
   Property CapAudio:Boolean read fcapAudio write fcapAudio;  // Captue audio stream to
   property VideoFileName:string read fCapVideoFileName   write fCapVideoFileName  ; // Name of capture file
   property SingleImageFile:string read FCapSingleImageFileName write FCapSingleImageFileName;  // Name of file for single image
   property CapTimeLimit:word read fCapTimeLimit write fCapTimeLimit; // time limit for Capturing
   property CapIndexSize:cardinal read findexSize write setIndexSize; // Size of the index for capture file
   property CapToFile:boolean read fcaptoFile write fcapToFile;       // Write Frames to capture file
   property CapAudioFormat:TAudioformat read FAudioformat write FAudioFormat; // Format of captuing Audiodata
   property BufferFileSize:word read ftempfilesize write SetBufferFileSize; // Size of Bufferfile in MB
  // Internal Events and Callbacks as Events
   property OnStatus:TCapStatusProc read fCapStatusProcedure write FCapStatusProcedure;
   property OnStatusCallback:TCapStatusCallback read fcapStatuscallback write SetStatCallback;
   property OnVideoStream:TVideoStream read fcapVideoStream write SetCapVideoStream;
   property OnFrameCallback:TVideoStream read FcapFramecallback write SetCapFrameCallback;
   property OnAudioStream:TAudioStream read fcapAudioStream write SetCapAudioStream;
   property OnError:TError read fcapError write SetCapError;
   property OnMouseMove;
   property OnMouseUp;
   property OnMouseDown;
   property OnClick;
   Property OnDblClick;
 end;



Function GetDriverList:TStringList;  // Fill stringlist with names and versioninfo of all installed capture drivers
procedure FrameToBitmap(Bitmap:TBitmap;FrameBuffer:pointer; BitmapInfo:TBitmapInfo);  // Make a TBitmap from a Frame
procedure BitmapToFrame(Bitmap:TBitmap; FrameBuffer:pointer; BitmapInfo:TBitmapInfo); // Make a Frame form a Bitmap
function FrametobgrFrame(FrameBuffer:pointer; bgrFrameBuffer:pointer; BitmapInfo:TBitmapInfo): boolean;


procedure Register;

implementation

 // Callback for status of video captures
function StatusCallbackProc(hWnd : HWND; nID : Integer; lpsz : Pchar): DWord; stdcall;
var Control:TVideoCap;
begin
  control:=TVideoCap(capGetUserData(hwnd));
  if assigned(control) then
   begin
       if assigned(control.fcapStatusCallBack) then
              control.fcapStatusCallBack(control,nId,strPas(lpsz));
   end;
  result:= 1;
end;

// Callback for video stream
function VideoStreamCallbackProc(hWnd:Hwnd; lpVHdr:PVIDEOHDR):DWORD; stdcall;
 var Control:TVideoCap;
begin
   control:= TVideoCap(capGetUserData(hwnd));
  if assigned(control) then
   begin
    if assigned(control.fcapVideoStream ) then
         control.fcapVideoStream(control,lpvHdr);
   end;
 result:= 1;
end;

//Callback for Frames during Preview
function FrameCallbackProc(hwnd:Hwnd; lpvhdr:PVideoHdr):DWord;stdcall;
var Control:TVideoCap;

begin
  control:= TVideoCap(capGetUserData(hwnd));
  if assigned(control) then
   begin
    if assigned(control.fcapFrameCallback ) then
         control.fcapFrameCallback(control,lpvHdr);
   end;
 result:= 1;
end;


// Callback for audio stream
function AudioStreamCallbackProc(hwnd:HWND;lpWHdr:PWaveHdr):DWORD; stdcall;
var control:TVideoCap;
begin
 control:= TVideoCap(capGetUserData(hwnd));
 if assigned(control) then
  if assigned(control.fcapAudioStream) then
    begin
     control.fcapAudioStream(control,lpwhdr);
    end;
 result:= 1;
end;

// Callback for Error
function ErrorCallbackProc(hwnd:HWND;nId:integer;lzError:Pchar):DWord;stdcall;

var Control:TVideoCap;

 begin
 control:= TVideoCap(capGetUserData(hwnd));
 if assigned(control) then
  if assigned(control.fcaperror) then
    begin
     control.fcapError(control,nId,StrPas(lzError));
    end;
 result:= 1;
end;







// New Window-Procedure for CaputreWindow to post messages like WM_MouseMove to Component

function WCapproc(hw:THandle;messa:DWord; w:wParam; l:lParam):integer;stdcall;
 var oldwndProc:Pointer;
     parentWnd:Thandle;
 begin
    oldwndproc:=Pointer(GetWindowLong(hw,GWL_USERDATA));
    case Messa of
     WM_MOUSEMOVE,
     WM_LBUTTONDBLCLK,
     WM_LBUTTONDOWN,WM_RBUTTONDOWN,WM_MBUTTONDOWN ,
     WM_LBUTTONUP,WM_RBUTTONUP,WM_MBUTTONUP:
       begin
        ParentWnd:=Thandle(GetWindowLong(hw,GWL_HWNDPARENT));
        sendMessage(ParentWnd,messa,w,l);
        result := integer(true);
       end
    else
       result:= callWindowProc(oldwndproc,hw,messa,w,l);
   end;

 end;

(*---------------------------------------------------------------*)
// constructor and Destructor
constructor TVideoCap.Create(aowner:TComponent);

begin
 inherited create(aowner);
 height                  := 100;
 width                   := 100;
 Color                   :=clblack;
 fVideoDriverName        := '';
 fdriverindex            := -1 ;
 fhCapWnd                := 0;
 fCapVideoFileName       := 'Video.avi';
 fCapSingleImageFileName := 'Capture.bmp';
 fscale                  := false;
 fprop                   := false;
 fpreviewrate            := 30;
 fmicrosecpframe         := 66667;
 fpDrivercaps            := nil;
 fpDriverStatus          := nil;
 fcapToFile              := true;
 findexSize              := 0;
 ftempFileSize           := 0;
 fCapStatusProcedure     := nil;
 fcapStatusCallBack      := nil;
 fcapVideoStream         := nil;
 fcapAudioStream         := nil;

 FAudioformat:=TAudioFormat.Create;

end;

 destructor TVideoCap.destroy;
  begin
    DestroyCapWindow;
    deleteDriverProps;
    fAudioformat.free;
    inherited destroy;
  end;




(*---------------------------------------------------------------*)
// Messagehandler for sizing the capture window
 procedure TVideoCap.SetSize(var msg:TMessage);
  begin
  if (fhCapWnd <> 0) and (Fscale) then
    begin
     if msg.msg = WM_SIZE then SizeCap;
    end;
  end;


// Sizing capture window
 procedure TVideoCap.SizeCap;
 var h,w:integer;
     f,cf:single;
 begin
  if not fscale then
      MoveWindow(fhcapWnd,0,0,Capwidth,capheight,true)
    else
      begin
       if fprop then
        begin
        f:= Width/height;
        cf:= CapWidth/CapHeight;
        if f >  cf then
         begin
          h:= height;
          w:= round(h*cf);
         end
        else
          begin
          w:= width;
          h:= round(w*1/cf);
         end
        end
       else
        begin
         h:= height;
         w:= Width;
       end;
       MoveWindow(fhcapWnd,0,0,w, h,true);
     end;
 end;


  (*---------------------------------------------------------------*)
// Delete driver infos
procedure TVideoCap.DeleteDriverProps;
 begin
   if assigned(fpDrivercaps) then
    begin
      dispose(fpDrivercaps);
      fpDriverCaps:= nil;
    end;
    if assigned(fpDriverStatus) then
     begin
       dispose(fpDriverStatus);
       fpDriverStatus:= nil;
     end;

 end;


(*---------------------------------------------------------------*)
// Buffer File
procedure TVideoCap.CreateTmpFile(drvOpn:boolean);
 var s,f:array [0..MAX_PATH] of char;
    size:word;
    ok:boolean;
    e:Exception;

 begin
   if (ftempFileName ='') and (ftempFileSize = 0) then exit;
   if drvOpn then Size := ftempFileSize else size:=0;
   if fTempFileName = '' then
     begin
       GetTempPath(sizeof(s),@s);
       GetTempFileName(s,'cap',0,f);
       ftempfilename := f;
     end;
   if size <> 0 then
    begin
       capFileSetCaptureFile(fhCapWnd,strpCopy(f,ftempfilename));
       ok:=capFileAlloc(fhcapWnd,1024*1024* ftempFileSize);
      if not ok then
       begin
         e:= EBufferFileError.Create('Could not create tmp file');
         raise e;
       end;
    end
   else
    begin
     capFileSetCaptureFile(fhCapWnd,strpCopy(f, fCapVideoFileName));
     DeleteFile(fTempfileName);
     fTempFileName:= '';
    end;
 end;

procedure TVideoCap.SetBufferFileSize(Value:word);

 begin
   if value = fTempFilesize then exit;
   ftempFileSize:=value;
   if DriverOpen Then CreateTmpFile(true);
 end;




(*---------------------------------------------------------------*)
// Capitilies of the Driver

 function TVideoCap.GetDriverCaps:boolean;
 var savestat : integer;

 begin
   result:= false;
   if assigned(fpDrivercaps) then
     begin
       result:= true;
       exit;
     end;
   if fdriverIndex = -1 then exit;
   savestat := fhCapwnd;  // save state of the window
   if fhCapWnd = 0 then CreateCapWindow;
   if fhCapWnd = 0 then exit;
   new(fpDrivercaps);
   if capDriverGetCaps(fhCapWnd, fpDriverCaps, sizeof(TCapDriverCaps)) then
    begin
     result:= true;
     if savestat = 0 then destroyCapWindow;
     exit;
    end;
   dispose(fpDriverCaps);  // Error can't open then Driver
   fpDriverCaps := nil;
   if savestat = 0 then destroyCapWindow;
 end;

(*---------------------------------------------------------------*)
 // BitmapInfo without a Palette
function TVideoCap.GetBitMapInfoNp:TBitmapinfo;
 var  e:Exception;
 begin
  if driveropen then
   begin
     capGetVideoFormat(fhcapWnd, @result,sizeof(TBitmapInfo));
     exit;
   end ;

  fillchar(result,sizeof(TBitmapInfo),0);
  e:= ENotOpen.Create('Driver not Open');
  raise e;
 end;

// Whole BitmapInfo
function TVideoCap.GetBitMapInfo(var p:Pointer):integer;
var size:integer;
    e:Exception;

begin
  p:=nil;
  if driverOpen then
    begin
      size:= capGetVideoFormat(fhcapWnd,p,0);
      getmem(p,size);
      capGetVideoFormat(fhcapwnd,p,size);
      result:=size;
      exit;
    end;
 e:= ENotOpen.Create('Driver not Open');
 raise e;
end;

// Setting whole BitmapInfo
procedure TVideoCap.SetBitmapInfo(p:Pointer;size:integer);
var e:Exception;
    supported:boolean;
begin
 if driverOpen then
  begin
    supported:=capSetVideoFormat(fhcapWnd,p,size);
    if not supported then
    begin
     e:=EFalseFormat.Create('Not supported Frame Format' );
     raise e;
    end;
   exit;
  end;
 e:= ENotOpen.Create('Driver not Open');
 raise e;
end;

// Only Header of BitmapInfo

function TVideoCap.GetBitMapHeader:TBitmapinfoHeader;
 var e:Exception;
 begin
  if driveropen then
   begin
    capGetVideoFormat(fhcapWnd, @result,sizeof(TBitmapInfoHeader));
    exit;
   end ;
 fillchar(result,sizeof(TBitmapInfoHeader),0);
 e:= ENotOpen.Create('Driver not Open');
 raise e;
end;

procedure TVideoCap.SetBitMapHeader(header:TBitmapInfoHeader);
 var e:exception;

 begin
  if driveropen then
   begin
    if not capSetVideoFormat(fhcapWnd,@header,sizeof(TBitmapInfoHeader)) then
     begin
      e:= EFalseFormat.Create('Not supported Frame Format');
      raise e;
     end;
    exit;
   end
  else
   begin
    e:= ENotOpen.Create('Driver not Open');
    raise e;
   end;
 end;


 (*---------------------------------------------------------------*)

function TVideoCap.getDriverStatus(callback:boolean):boolean;
begin
  result := false;
  if fhCapWnd <> 0 then
  begin
  if not assigned(fpDriverstatus) then new(fpDriverStatus);
  if capGetStatus(fhCapWnd,fpdriverstatus, sizeof(TCapStatus)) then
   begin
     result:= true;
  end;
  end;
 if assigned(fCapStatusProcedure)and callback then fcapStatusProcedure ( self);
end;



(*---------------------------------------------------------------*)
// Setting name of driver

procedure TVideoCap.SetDrivername(value:string);
var i:integer;
    name:array[0..80] of char;
    ver :array[0..80] of char;
begin
 if fVideoDrivername = value then exit;
 for i:= 0 to 9 do
  if capGetDriverDescription( i,name,80,ver,80) then
    if strpas(name) = value then
     begin
      fVideoDriverName := value;
      Driverindex:= i;
      exit;
    end;
 fVideoDrivername:= '';
 DriverIndex:= -1;
end;
(*---------------------------------------------------------------*)
procedure TVideoCap.SetDriverIndex(value:integer);
var  name:array[0..80] of char;
     ver :array[0..80] of char;

begin
  if value = fdriverindex then exit;
  destroyCapWindow;
  deleteDriverProps;  // Alte Treiberfähigkeiten Löschen
  if value > -1 then
    begin
     if capGetDriverDescription(value,name,80,ver,80) then
        fVideoDriverName:= StrPas(name)
     else
       value:= -1;
   end;
 if value = -1 then  fvideoDriverName:= '';
 fdriverindex:= value;
end;

(*---------------------------------------------------------------*)
function TVideoCap.CreateCapWindow;
 var Ex:Exception;
     savewndproc:integer;
 begin
    if fhCapWnd <> 0 then
     begin
      result:= true;
      exit;
    end;

   if fdriverIndex = -1 then
    begin
     Ex := ENoDriverException.Create('No capture driver selected');
     GetDriverStatus(true);
     raise ex;
     exit;
    end;
   fhCapWnd := capCreateCaptureWindow( PChar(Name),
              WS_CHILD or WS_VISIBLE , 0, 0,
               Width, Height,
              Handle, 5001);
   if fhCapWnd =0 then
     begin
       Ex:= ENoCapWindowException.Create('Can not create capture window');
       GetDriverStatus(true);
       raise ex;
       exit;
      end;

// Set our own Adress to the CapWindow
 capSetUserData(fhCapwnd,integer(self));
// Set our own window procedure to Capture-Window
 savewndproc:=SetWindowLong(fhcapWnd,GWL_WNDPROC,integer(@WCapProc));
// User Data for old WndProc adress
 SetWindowLong(fhcapWnd,GWL_USERDATA,savewndProc);
 // Setting callbacks as events
if assigned(fcapStatusCallBack ) then
  capSetCallbackOnStatus(fhcapWnd ,StatusCallbackProc);
if assigned(fcapFrameCallback) then
  capSetCallbackOnFrame(fhcapWnd,FrameCallbackProc);
if assigned(fcapError) then
   capSetCallbackOnError(fhcapWnd,ErrorCallBackProc);


if assigned(fcapVideoStream) then
   capSetCallbackOnVideoStream(fhcapwnd,VideoStreamCallbackProc);
if assigned(fcapAudioStream) then
       capSetCallbackOnWaveStream(fhcapWnd,AudioStreamCallbackProc);

 if not capDriverConnect(fhCapWnd, fdriverIndex) then
     begin
       Ex:= ENotConnectException.Create('Can not connect capture driver with capture window');
       Destroycapwindow;
       GetDriverStatus(true);
       raise ex;
       exit;
   end;

 CreateTmpFile(True);
 capPreviewScale(fhCapWnd, fscale);
 capPreviewRate(fhCapWnd, round( 1/fpreviewrate*1000));
 GetDriverStatus(true);
 Sizecap;
 result:= true;
end;

(*------------------------------------------------------------------------*)
// Setting callbacks as events

procedure TVideoCap.SetStatCallBack(value:TCapStatusCallback);
begin
 fcapStatusCallBack := value;
 if DriverOpen then
   if assigned(fcapStatusCallBack) then
      capSetCallbackOnStatus(fhcapWnd ,StatusCallbackProc)
   else
    capSetCallbackOnStatus(fhcapWnd ,nil);
end;


procedure TVideoCap.SetCapVideoStream(value:TVideoStream);
 begin
  fcapVideoStream:= value;
  if DriverOpen then
   if assigned(fcapVideoStream) then
     capSetCallbackOnVideoStream(fhcapwnd,VideoStreamCallbackProc)
   else
    capSetCallbackOnVideoStream(fhcapwnd, nil);
 end;

procedure TVideoCap.SetCapFrameCallback(value:TVideoStream);
begin
 fcapframeCallback:= value;
 if DriverOpen then
   if assigned(fcapFrameCallback) then
     capSetCallbackOnFrame(fhcapwnd,FrameCallBackProc)
   else
    capSetCallbackOnFrame(fhcapwnd, nil);
 end;



procedure TVideoCap.SetCapAudioStream(value:TAudioStream);
  begin
   fcapAudioStream:= value;
    if DriverOpen then
     if assigned(fcapAudioStream) then
       capSetCallbackOnWaveStream(fhcapWnd,AudioStreamCallbackProc)
     else
      capSetCallbackOnWaveStream(fhcapWnd,nil);
  end;


 procedure TVideoCap.SetCapError(value:TError);
 begin
  fcapError:= value;
  if DriverOpen then
     if assigned(fcapError) then
       capSetCallbackOnError(fhcapWnd,ErrorCallbackProc)
     else
      capSetCallbackOnError(fhcapWnd,nil);
 end;



(*---------------------------------------------------------------*)
procedure TVideoCap.DestroyCapWindow;
begin
  if fhCapWnd = 0 then exit;
  CreateTmpFile(False);
  CapDriverDisconnect(fhCapWnd);
  SetWindowLong(fhcapWnd,GWL_WNDPROC,GetWindowLong(fhcapwnd,GWL_USERDATA)); // Old windowproc
  DestroyWindow( fhCapWnd ) ;
  fhCapWnd := 0;
end;

(*---------------------------------------------------------------*)
function  TVideoCap.GetHasVideoOverlay:Boolean;

begin
   if getDriverCaps then
     Result := fpDriverCaps^.fHasOverlay
   else
     result:= false;
 end;

(*---------------------------------------------------------------*)

function  TVideoCap.GetHasDlgVFormat:Boolean;
begin
  if getDriverCaps then
     Result := fpDriverCaps^.fHasDlgVideoFormat
   else
     result:= false;
end;

(*---------------------------------------------------------------*)
function  TVideoCap.GetHasDlgVDisplay : Boolean;

begin
  if getDriverCaps then
     Result := fpDriverCaps^.fHasDlgVideoDisplay
   else
     result:= false;
end;

(*---------------------------------------------------------------*)
function  TVideoCap.GetHasDlgVSource  : Boolean;
begin
  if getDriverCaps then
     Result := fpDriverCaps^.fHasDlgVideoSource
   else
     result:= false;
end;

(*---------------------------------------------------------------*)
function TVideoCap.DlgVFormat:boolean;
var    savestat : integer;
begin
   result:= false;
   if fdriverIndex = -1 then exit;
   savestat := fhCapwnd;
   if fhCapWnd = 0 then
        if not CreateCapWindow then exit;
   result :=capDlgVideoFormat(fhCapWnd);
   if result then GetDriverStatus(true);
   if savestat = 0 then destroyCapWindow;
   if result then
   begin
    Sizecap;
    Repaint;
  end;
 end;

(*---------------------------------------------------------------*)
function TVideoCap.DlgVDisplay:boolean;
var savestat : integer;
begin
   result:= false;
   if fdriverIndex = -1 then exit;
   savestat := fhCapwnd;
   if fhCapWnd = 0 then
       if not CreateCapWindow then exit;
   result:=capDlgVideoDisplay(fhCapWnd) ;
   if result then GetDriverStatus(true);
   if savestat = 0 then destroyCapWindow;
   if result then
   begin
    SizeCap;
    Repaint;
  end;
end;

(*---------------------------------------------------------------*)
function TVideoCap.DlgVSource:boolean;
var savestat : integer;

begin
 result:= false;
 if fdriverIndex = -1 then exit;
  savestat := fhCapwnd;
  if fhCapWnd = 0 then
   if not createCapWindow then exit;
  result:= capDlgVideoSource(fhCapWnd);
  if result then GetDriverStatus(true);
  if savestat = 0 then destroyCapWindow;
  if result then
  begin
   SizeCap;
   Repaint;
 end;
end;
(*---------------------------------------------------------------*)
function TVideoCap.DlgVCompression;
var savestat : integer;

begin
 result:= false;
 if fdriverIndex = -1 then exit;
  savestat := fhCapwnd;
  if fhCapWnd = 0 then
   if not createCapWindow then exit;
   result:=capDlgVideoCompression(fhCapWnd);
  if savestat = 0 then destroyCapWindow;
 end;


(*---------------------------------------------------------------*)
 // Single Frame Grabbling
 function TVideoCap.GrabFrame:boolean;
 begin
  result:= false;
  if not DriverOpen then exit;
  Result:= capGrabFrame(fhcapwnd);
  if result then GetDriverStatus(true);
 end;

 function TVideoCap.GrabFrameNoStop:boolean;
 begin
  result:= false;
  if not DriverOpen then exit;
  Result:= capGrabFrameNoStop(fhcapwnd);
  if result then GetDriverStatus(true);
 end;

 (*---------------------------------------------------------------*)
// save frame as DIP
function TVideoCap.SaveAsDIB:Boolean;
  var s:array[0..MAX_PATH] of char;
begin
   result:= false;
   if not DriverOpen then exit;
   result := capFileSaveDIB(fhcapwnd,strpCopy(s,fCapSingleImageFileName));
end;

function  TVideoCap.SaveToClipboard:boolean;
begin
 result:= false;
 if not Driveropen then exit;
 result:= capeditCopy(fhcapwnd);
end;


(*---------------------------------------------------------------*)

procedure TVideoCap.Setoverlay(value:boolean);
var ex:Exception;
begin
 if value = GetOverlay then exit;
 if gethasVideoOverlay = false then
   begin
    Ex:= ENoOverlayException.Create('Driver has no overlay mode');
    raise ex;
    exit;
   end;
 if value = true then
  begin
   if fhcapWnd = 0 then  CreateCapWindow;
   GrabFrame;
  end;

 capOverlay(fhCapWnd,value);
 GetDriverStatus(true);
 invalidate;
 end;

function TVideoCap.GetOverlay:boolean;
begin
 if fhcapWnd = 0 then result := false
 else
  result:= fpDriverStatus^.fOverlayWindow;
end;



(*---------------------------------------------------------------*)

procedure TVideoCap.SetPreview(value:boolean);
begin
 if value = GetPreview then exit;
 if value = true then
   if fhcapWnd = 0 then  CreateCapWindow;
 capPreview(fhCapWnd,value);
 GetDriverStatus(true);
 invalidate;
end;

function TVideoCap.GetPreview:boolean;
begin
 if fhcapWnd = 0 then result := false
 else
  result:= fpDriverStatus^.fLiveWindow;
end;



procedure TVideoCap.SetPreviewRate(value:word);
begin
 if value = fpreviewrate then exit;
 if value < 1 then value := 1;
 if value > 30 then value := 30;
 fpreviewrate:= value;
 if DriverOpen then capPreviewRate(fhCapWnd, round( 1/fpreviewrate*1000));
end;

(*---------------------------------------------------------------*)

procedure TVideoCap.SetMicroSecPerFrame(value:cardinal);
 begin
  if value =  fmicrosecpframe then exit;
  if value < 33333 then value := 33333;
   fmicrosecpframe := value;
end;



procedure TVideoCap.setFrameRate(value:word);
begin
 if value <> 0 then fmicrosecpframe:= round(1.0/value*1000000.0);
end;

function  TVideoCap.GetFrameRate:word;
begin
 if fmicrosecpFrame > 0   then
   result:= round(1./ fmicrosecpframe * 1000000.0)
else
  result:= 0;
end;


function TVideoCap.StartCapture;
var CapParms:TCAPTUREPARMS;
    name:array[0..MAX_PATH] of char;

 begin
   result := false;
   if not DriverOpen then exit;
   capCaptureGetSetup(fhCapWnd, @CapParms, sizeof(TCAPTUREPARMS));

  if ftempfilename='' then
   capFileSetCaptureFile(fhCapWnd,strpCopy(name, fCapVideoFileName));


   CapParms.dwRequestMicroSecPerFrame := fmicrosecpframe;
   CapParms.fLimitEnabled    := BOOL(FCapTimeLimit);
   CapParms.wTimeLimit       := fCapTimeLimit;
   CapParms.fCaptureAudio    := fCapAudio;
   CapParms.fMCIControl      := FALSE;
   CapParms.fYield           := TRUE;
   //CapParms.vKeyAbort        := VK_ESCAPE;
   CapParms.vKeyAbort        := 0;
   CapParms.fAbortLeftMouse  := FALSE;
   CapParms.fAbortRightMouse := FALSE;
   if CapParms.fLimitEnabled then // Calculate Indexsize
     begin
       CapParms.dwIndexSize:= frameRate*FCapTimeLimit; // For Video Frames
       If fCapAudio then
         CapParms.dwIndexSize := CapParms.dwIndexSize + 5*FCapTimeLimit; // Additional Buffer for Audio
      end
    else
      begin
        If CapParms.dwIndexSize = 0 then     // Default Value
          CapParms.DwIndexSize := 100000 // Value bigger then default for larger Videos
        else
          CapParms.dwIndexSize := findexSize; // IndexSize by user
      end;
   if CapParms.dwIndexSize < 1800 then CapParms.dwIndexSize:= 1800;  // Limit Control
   If CapParms.dwIndexSize > 324000 then CapParms.dwIndexSize:= 324000;

   capCaptureSetSetup(fhCapWnd, @CapParms, sizeof(TCAPTUREPARMS));
   if fCapAudio then FAudioformat.SetAudio(fhcapWnd);
   if CapToFile then
    result:= capCaptureSequence(fhCapWnd)
   else
    result := capCaptureSequenceNoFile(fhCapWnd);
   GetDriverStatus(true);
 end;


function TVideoCap.StopCapture;
begin
 result:=false;
 if not DriverOpen then exit;
 result:=CapCaptureStop(fhcapwnd);
 GetDriverStatus(true);

end;

function TVideoCap.SaveCap:Boolean;
var name:array[0..MAX_PATH] of char;
 begin
  result := capFileSaveAs(fhcapwnd,strPCopy(name,fCapVideoFileName)); // strpCopy(name, fCapVideoFileName));
end;


procedure TVideoCap.SetIndexSize(value:cardinal);
  begin
   if value = 0 then
    begin
      findexSize:= 0;
      exit;
    end;
   if value < 1800 then value := 1800;
   if value > 324000 then value := 324000;
  findexsize:= value;

 end;


function TVideoCap.GetCapInProgress:boolean;
  begin
   result:= false;
   if not DriverOpen then exit;
   GetDriverStatus(false);
   result:= fpDriverStatus^.fCapturingNow ;
 end;
 (*---------------------------------------------------------------*)

Procedure TVideoCap.SetScale(value:boolean);

begin
 if value = fscale then  exit;
 fscale:= value;
 if DriverOpen then
   begin
    capPreviewScale(fhCapWnd, fscale);
    SizeCap;
   end;
 Repaint;
end;

Procedure TVideoCap.Setprop(value:Boolean);
begin
 if value = fprop then exit;
 fprop:=value;
 if DriverOpen then Sizecap;
 Repaint;
end;


(*---------------------------------------------------------------*)
function TVideoCap.GetCapWidth;

begin
 if assigned(fpDriverStatus) then
   result:= fpDriverStatus^.uiImageWidth
else
   result:= 0;
end;

function TVideoCap.GetCapHeight;

begin
 if assigned(fpDriverStatus) then
   result:= fpDriverStatus^.uiImageHeight
else
   result:= 0;
end;



(*---------------------------------------------------------------*)
 Procedure TVideoCap.SetDriverOpen(value:boolean);
 begin
   if value = GetDriverOpen then exit;
   if value = false then DestroyCapWindow;
   if value = true then CreateCapWindow;
 end;


function TVideoCap.GetDriverOpen:boolean;
begin
  result := fhcapWnd <> 0;
end;

(*---------------------------------------------------------------*)
// Singele frame Capturing

function TVideoCap.CapSingleFramesOpen:boolean;
 var name :array [0..MAX_PATH] of char;
     CapParms:TCAPTUREPARMS;

 begin
   result := false;
   if not DriverOpen then exit;

   capCaptureGetSetup(fhCapWnd, @CapParms, sizeof(TCAPTUREPARMS));
   if ftempfilename='' then
    capFileSetCaptureFile(fhCapWnd,strpCopy(name, fCapVideoFileName));

   CapParms.dwRequestMicroSecPerFrame := fmicrosecpframe;
   CapParms.fLimitEnabled    := BOOL(0);
   CapParms.fCaptureAudio    := false;
   CapParms.fMCIControl      := FALSE;
   CapParms.fYield           := TRUE;
   CapParms.vKeyAbort        := VK_ESCAPE;
   CapParms.dwIndexSize := findexSize; // IndexSize by user
   if CapParms.dwIndexSize < 1800 then CapParms.dwIndexSize:= 1800;  // Limit Control
   If CapParms.dwIndexSize > 324000 then CapParms.dwIndexSize:= 324000;
   capCaptureSetSetup(fhCapWnd, @CapParms, sizeof(TCAPTUREPARMS));

   result:= capCaptureSingleFrameOpen(fhcapWnd);
end;

function TVideoCap.CapSingleFramesClose:boolean;
 var E:Exception;
 begin
   if not driverOpen then
     begin
        e:= ENotOpen.Create('Driver not Open');
        raise e;
        exit;
      end;
    result:= CapCaptureSingleFrameClose(fhcapWnd);
 end;


function TVideoCap.CapSingleFrame:boolean;
 var E:Exception;
begin
  if not driverOpen then
     begin
        e:= ENotOpen.Create('Driver not Open');
        raise e;
        exit;
     end;
    result:= CapCaptureSingleFrame(fhcapWnd);
 end;

///////////////////////////////////////////////////////////////////////////


constructor TAudioFormat.create;
begin
     inherited create;
     FChannels:=Mono;
     FFrequency:=f8000Hz;
     Fres:=r8Bit;
end;



procedure TAudioFormat.SetAudio(handle:Thandle);
Var WAVEFORMATEX:TWAVEFORMATEX;

begin
     if handle= 0 then exit;  // No CapWindow
     capGetAudioFormat(handle,@WAVEFORMATEX, SizeOf(TWAVEFORMATEX));
     case FFrequency of
          f8000hz  :WAVEFORMATEX.nSamplesPerSec:=8000;
          f11025Hz:WAVEFORMATEX.nSamplesPerSec:=11025;
          f22050Hz:WAVEFORMATEX.nSamplesPerSec:=22050;
          f44100Hz:WAVEFORMATEX.nSamplesPerSec:=44100;
     end;
     WAVEFORMATEX.nAvgBytesPerSec:= WAVEFORMATEX.nSamplesPerSec;
     if FChannels=Mono then
          WAVEFORMATEX.nChannels:=1
     else
          WAVEFORMATEX.nChannels:=2;
     if FRes=r8Bit then
        WAVEFORMATEX.wBitsPerSample:=8
     else
        WAVEFORMATEX.wBitsPerSample:=16;
     capSetAudioFormat(handle,@WAVEFORMATEX, SizeOf(TWAVEFORMATEX));
end;


///////////////////////////////////////////////////////////////////////////


// Creating a list with capture drivers
Function GetDriverList:TStringList;
var i:integer;
    name:array[0..80] of char;
    ver :array[0..80] of char;
begin
 result:= TStringList.Create;
 result.Capacity:= 10;
 result.Sorted:= false;
 for i:= 0 to 9 do
   if capGetDriverDescription( i,name,80,ver,80) then
      result.Add(StrPas(name)+ ' '+strpas(ver))
   else
     break;
 end;

procedure FrameToBitmap(Bitmap:TBitmap;FrameBuffer:pointer; BitmapInfo:TBitmapInfo);
 var  hdd:Thandle;
begin
 with Bitmap  do
 begin
  Width:= BitmapInfo.bmiHeader.biWidth;      // New size of Bitmap
  Height:=Bitmapinfo.bmiHeader.biHeight;
  hdd:= DrawDibOpen;
  DrawDibDraw(hdd,canvas.handle,0,0,BitmapInfo.BmiHeader.biwidth,BitmapInfo.bmiheader.biheight,@BitmapInfo.bmiHeader,
                  frameBuffer,0,0,bitmapInfo.bmiHeader.biWidth,bitmapInfo.bmiHeader.biheight,0);
  DrawDibClose(hdd);
  end;
end;

procedure BitmapToFrame(Bitmap:TBitmap; FrameBuffer:pointer; BitmapInfo:TBitmapInfo);
 var ex:Exception;
begin
  if bitmapInfo.bmiHeader.BiCompression <> bi_RGB then
  begin
    ex:=  EFalseFormat.Create('Not Supported DIB format');
    raise ex ;
  end;
  with Bitmap do
   GetDiBits(canvas.handle,handle,0,BitmapInfo.bmiHeader.biheight,FrameBuffer,BitmapInfo,DIB_RGB_COLORS);
end;

function FrametobgrFrame(FrameBuffer:pointer; bgrFrameBuffer:pointer; BitmapInfo:TBitmapInfo): boolean;
//const
//  init: boolean=false;
var
  ic: HIC;
  info: TBitmapInfoHeader;
  r: Integer;
  hdd:Thandle;
  ex:Exception;
begin
//  if not init then
    info := BitmapInfo.bmiHeader;
    info.biCompression := BI_RGB;
    info.biBitCount := 24;
    info.biSizeImage := info.biWidth*info.biHeight*3;
    ic := ICLocate(ICTYPE_VIDEO, 0, @BitmapInfo.bmiHeader, @info,ICMODE_FASTDECOMPRESS);
    ICDecompressBegin(ic, @BitmapInfo.bmiHeader, @info);
    R := ICDecompress(ic, ICDECOMPRESS_HURRYUP{}, @BitmapInfo.bmiHeader, FrameBuffer, @info,bgrFrameBuffer);
    ICDecompressEnd(ic);
    ICClose(ic);
    Result := true; //R=ICERR_OK;
//    ICClose(ic);{}{
  with Tbitmap.Create  do
  try
    Width := BitmapInfo.bmiHeader.biWidth;      // New size of Bitmap
    Height := BitmapInfo.bmiHeader.biheight;
    PixelFormat := pf24bit;
    hdd:= DrawDibOpen;
    Result := DrawDibDraw(hdd,canvas.handle,0,0,BitmapInfo.bmiHeader.biWidth,BitmapInfo.bmiHeader.biheight, @BitmapInfo.bmiHeader,
                    frameBuffer,0,0,BitmapInfo.bmiHeader.biWidth,BitmapInfo.bmiHeader.biheight,0);
    DrawDibClose(hdd);
    if Result then
    begin
      BitmapInfo.bmiHeader.biCompression := BI_RGB;
      BitmapInfo.bmiHeader.biBitCount := 24;
      BitmapInfo.bmiHeader.biSizeImage := BitmapInfo.bmiHeader.biWidth*BitmapInfo.bmiHeader.biHeight*3;
      GetDiBits(canvas.handle,handle,0,BitmapInfo.bmiHeader.biheight,bgrFrameBuffer,BitmapInfo,DIB_RGB_COLORS);
    end;
  finally
    Free;
  end;   {}
end;

procedure Register;
begin
  RegisterComponents( 'Video', [TVideoCap]);
end;



end.