我用VIDEOCAP控件做图象采集,请问有哪个函数可以将图象保存到内存中,本人很急会在线等待,(100分)

请各位多多帮忙啊!!!!!![]

各位帮忙啊!!!!

怎么没有人帮我回答呢?请各位一定要帮我解决啊!!!!!!

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, Video,
Vfw;

type
TForm1 = class(TForm)
VideoCap1: TVideoCap;
Image1: TImage;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure VideoCap1VideoStream(sender: TObject; lpVhdr: PVIDEOHDR);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

var
info: PBitmapInfo;

procedure TForm1.Button1Click(Sender: TObject);
begin
with VideoCap1 do
begin
DriverIndex := 0;
VideoPreview := true;
PreviewScaleToWindow := true;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
VideoCap1.GetBitmapInfo(Pointer(info));
Image1.Picture.Bitmap.Width := info.bmiHeader.biWidth;
Image1.Picture.Bitmap.Height := info.bmiHeader.biHeight;

VideoCap1.OnFrameCallback := VideoCap1VideoStream;
end;

procedure FrameToBitmap(Bitmap: TBitmap; FrameBuffer: pointer; BitmapInfo: TBitmapInfo);
begin
if bitmapInfo.bmiHeader.BiCompression = bi_RGB then
with Bitmap do
setDiBits(canvas.handle, handle, 0, BitmapInfo.bmiHeader.biheight,
FrameBuffer, BitmapInfo, DIB_RGB_COLORS);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
VideoCap1.OnFrameCallback := nil;
end;

procedure TForm1.VideoCap1VideoStream(sender: TObject; lpVhdr: PVIDEOHDR);
begin
FrameToBitmap(Image1.Picture.Bitmap, lpvhdr^.lpData, info^);
Image1.Invalidate;
end;

end.

帮楼主up

up

to huazai;


Video.pas去哪儿找？

unit Video;

interface



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

///////////////////////////////////////////////////////////////////////////////
// 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;lpVhdrVIDEOHDR) of object;
TAudioStream = procedure (sender:TObject;lpWHdrWAVEHDR) 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
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
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
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

// 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 pointer):integer; // The whole Bitmap-Info with complete palette
procedure SetBitmapInfo(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 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;FrameBufferointer; BitmapInfo:TBitmapInfo); // Make a TBitmap from a Frame
procedure BitmapToFrame(Bitmap:TBitmap; FrameBufferointer; 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(Frameointer; 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; lpVHdrVIDEOHDR):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; lpvhdrVideoHdr):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;lpWHdrWaveHdr):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;

// Callback for Error
function ErrorCallbackProc(hwnd:HWND;nId:integer;lzErrorchar):longint;stdcall;

var Control:TVideoCap;

begin
control:= TVideoCap(capGetUserData(hwnd));
if assigned(control) then
if assigned(control.fcapAudioStream) 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;messaWord; w:wParam; l:lParam):integer;stdcall;
var oldwndProcointer;
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;
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 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(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(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');
// 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.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;
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);
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;






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






// 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;FrameBufferointer; BitmapInfo:TBitmapInfo);
var ex:Exception;
hdd:Thandle;

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;
// if bitmapInfo.bmiHeader.BiCompression <> bi_RGB then
// setDiBits(canvas.handle,handle,0,BitmapInfo.bmiHeader.biheight,FrameBuffer,BitmapInfo,DIB_RGB_COLORS)
// else
// begin
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;
end;



procedure BitmapToFrame(Bitmap:TBitmap; FrameBufferointer; 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(Frameointer;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;





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

end.

vfw,mmsystem,是什么?