video.pas

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

unit Video;

interface



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

///////////////////////////////////////////////////////////////////////////////
// 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;


// Property Editor for driver selection
type TDrivereditor= class (TPropertyEditor)
  function GetAttributes:TPropertyAttributes;override;
  procedure GetValues(Proc: TGetStrProc);override;
  function GetValue:string;override;
  procedure SetValue(const Value: string);override;
end;
// 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
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
   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

   procedure setsize(var msg:TMessage); message WM_SIZE;  // Changing size of cap window
   function GetDriverCaps:boolean;                        // get driver capitiyties
   procedure DeleteDriverProps;                           // delete driver capitilyites
   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 SetDriverName(value:String); // Select Driver by setting driver name
   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

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

  public
    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;

 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

  // 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 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


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

type ENoHDD  = class(Exception);



type
  TVideoDisp = class(TCustomControl)
   private
    Hdd:HDrawDib;   // Handle of the DrawDibDC
    fBitmapInfoHeader:TBitmapinfoHeader; // Info Header of Frames
    fstreaming:Boolean; // True when Video Stream is running
    frate:integer; // Streaming Rate
    fscale:boolean;   // Scale Bitmap to window
    fprop:boolean;
    fBiWidth:integer; // Height and Width for DrawDibDraw
    fbiHeight:integer;
    procedure SetInfoHeader(Header:TBitmapInfoHeader);  // Setting BitmapInfo Header
    procedure SetStreaming(streaming:Boolean);    // Streaming On / Off
    procedure SetRate(rate:integer);            // Rate of Streaming
    procedure SetSize(var Msg:TMessage); message wm_size; // Handling Sizing
    procedure calcSize(w,h:integer);  // calc size of Output
    procedure SetScale(scaling:Boolean);  // Set Scaling
    procedure SetProp(prop:Boolean);


  public
    constructor Create(AOwner: TComponent); override;
    destructor destroy; override;
    procedure DrawStream(Frame:Pointer; KeyFrame:Boolean);
    property  BitMapInfoHeader:TBitmapInfoHeader read fbitmapInfoHeader write SetInfoHeader;
    property  Streaming:boolean read fstreaming write SetStreaming;


  published
    property ScaleToWindow:boolean read FScale write setScale;
    property StreamRate:integer read frate write setRate;
    property ScaleProportional:boolean read fprop  write SetProp;

    property align;
    property color;
    property visible;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseDown;
    property OnClick;
    Property OnDblClick;
 end;



procedure Register;


implementation

// Callback for status of video captures
function StatusCallbackProc(hWnd : HWND; nID : Integer; lpsz : Pchar): LongInt; 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):longint; 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):longint;stdcall;
var Control:TVideoCap;

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


// Callback for audio stream
function AudioStreamCallbackProc(hwnd:HWND;lpWHdr:PWaveHdr):longInt; 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;





// 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;

 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;





(*---------------------------------------------------------------*)
// 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;