video.pas

采用delphi语言实现了智能监视系统。使用了access数据库。

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));
   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.fAbortLeftMouse  := FALSE;
   CapParms.fAbortRightMouse := FALSE;
   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;

 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;


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


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;






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




function TDriverEditor.GetAttributes:TPropertyAttributes;
begin
 result :=[paRevertable,paValueList];
end;


procedure TDriverEditor.GetValues(Proc: TGetStrProc);
var i:integer;
    name:array[0..80] of char;
    ver :array[0..80] of char;
    s:string;

begin
 for i:= 0 to 9 do
  begin
   if capGetDriverDescription( i,name,80,ver,80) then
      s:=strpas(name)
   else
      s:='' ;
   proc(s);
  end;

end;



function TDriverEditor.GetValue:string;
begin
 with Getcomponent(0) as TVideoCap do
   result:= fVideoDrivername;
end;



procedure TDriverEditor.SetValue(const Value: string);
begin
  with Getcomponent(0) as TVideoCap do
    SetDrivername( value) ;
  Modified;
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; //  result.add('');
 end;

procedure FrameToBitmap(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
 begin
  Width:= BitmapInfo.bmiHeader.biWidth;      // New size of Bitmap
  Height:=Bitmapinfo.bmiHeader.biHeight;
  setDiBits(canvas.handle,handle,0,BitmapInfo.bmiHeader.biheight,FrameBuffer,BitmapInfo,DIB_RGB_COLORS);
 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;



///////////////////////////////////////////////////////////////////////////////
// Video Display


constructor TVideoDisp.Create(AOwner: TComponent);
var e:Exception;
 begin
   inherited Create(aOwner);
   Width:= 100;
   height:=75;
   color := clblack;
   fstreaming:= false;
   frate:= 66667;
   hdd:=DrawDibOpen;
   fbitmapinfoheader.biWidth := 100;
   fbitmapinfoheader.biHeight:= 100;
   fbitmapInfoHeader.biSize:=0;
   if hdd = 0 then
    begin
     e:=ENoHDD.Create('Can not Create HDRAWDIB');
     raise e;
    end;
  end;


destructor TVideoDisp.Destroy;
begin
 DrawDibClose(hdd);
 inherited Destroy;
end;

procedure TVideoDisp.SetInfoHeader(Header:TBitmapInfoHeader);
begin
 fBitmapInfoHeader:= header;
 calcSize(width,height);
end;


// Draw a new Picture of the Frame

procedure TVideoDisp.DrawStream(Frame:Pointer;KeyFrame:Boolean);

var Flags:word;
  //  e:Exception;

begin
 if bitmapinfoHeader.bisize = 0 then exit;
 flags := DDF_SAME_HDC or DDF_SAME_DRAW;
 if not Keyframe then Flags:= flags or DDF_NOTKEYFRAME  ;
 DrawDibDraw(hdd,canvas.handle,0,0,fbiwidth,fbiheight,@fBitmapInfoHeader,
             frame,0,0,fBitmapInfoHeader.biWidth,fbitmapInfoHeader.biheight,flags);

end;

// Set Streaming Rate
procedure TVideoDisp.SetRate(rate:integer);
begin
  if fstreaming then DrawDibStop(hdd);
  frate := rate;
  if Streaming then DrawDibStart(hdd,frate);
end;

// Toggeling Streaming mode
 procedure TVideoDisp.SetStreaming(streaming:boolean);
 begin
   if streaming = fstreaming then exit;
   if fstreaming then
     DrawDibStop(hdd)
   else
     DrawDibStart(hdd,frate);
    fstreaming := streaming;
 end;

procedure TVideoDisp.SetSize(var Msg:TMessage);

begin
   calcsize(LOWORD(msg.lParam),HIWORD(msg.lParam));
end;


procedure TVideoDisp.calcSize(w,h:integer);
 var f,cf:double;
begin
 if fscale then
   begin
     if fprop then
        begin
        f:= W/h;
        cf:= fBitmapInfoHeader.biWidth/fbitmapInfoHeader.biHeight;
        if cf  <  f then
         begin
          fbiWidth:= round(h*cf);
          fbiHeight:= h;
         end
        else
          begin
          fbiWidth:= w;
          fbiHeight:= round(w*1/cf);
         end
   end
   else
    begin
     fbiheight:= h;
     fbiwidth:=  w;
    end
  end
   else
     begin
      fbiheight:=fbitmapInfoHeader.biHeight;
      fbiwidth:= fbitmapInfoHeader.biWidth;
    end;
  if fbitmapInfoHeader.biSize <> 0 then
   DrawDibBegin(hdd,canvas.handle,fbiwidth,fbiheight,@fBitmapInfoHeader,
            fBitmapInfoHeader.biWidth,fbitmapInfoHeader.biheight,0);
end;

procedure TVideoDisp.SetScale(scaling:Boolean);
 begin
  if scaling = fscale then exit;
  fscale:= scaling;
  calcSize(width,height);
end;


procedure TVideoDisp.SetProp(prop:Boolean);
 begin
  if fprop = prop then exit;
  fprop:=prop;
  calcSize(width,height);
end;


{BOOL DrawDibDraw( HDRAWDIB hdd,
HDC hdc,
int xDst,
int yDst,
int dxDst,
int dyDst,
LPBITMAPINFOHEADER lpbi,
LPVOID lpBits,
int xSrc,
int ySrc,
int dxSrc,
int dySrc,
UINT wFlags   }






procedure Register;
begin
  RegisterComponents( 'Video', [TVideoCap,TVideoDisp]);
  RegisterPropertyEditor(TypeInfo(string),TVideoCap,'DriverName',TDriverEditor);
end;

end.