video.pas

**智能监视系统*** 程序运行时需要视频捕捉设备

     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;
  result:=0;
  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鋒igkeiten L鰏chen
  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
 result:= false;
   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 ouwer own Adress to the CapWindow
 capSetUserData(fhCapwnd,integer(self));
// Set ouer 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(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');
     //  MessageDlg('Can not connect capture driver with capture window',mterror,[mbOK],0);
       Destroycapwindow;
       GetDriverStatus(true);
       raise ex;
       exit;
   end;
 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.DestroyCapWindow;
begin
  if fhCapWnd = 0 then exit;
  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;
    //MessageDlg('Treiber kann kein Overlay',mtError,[mbOK],0);
    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);