www.pudn.com > VideoCam.rar > 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
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;
// ·µ»ØÊÓƵÁ÷
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.fcapFrameCallback ) 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;
// Callback for Error
function ErrorCallbackProc(hwnd:HWND;nId:integer;lzError:Pchar):longint;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('²»Äܽ¨Á¢ÁÙʱÎļþ! ');
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('É豸ûÓдò¿ª! ');
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('É豸ûÓдò¿ª! ');
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('²»Ö§³ÖµÄ¸ñʽ! ' );
raise e;
end;
Exit;
end;
e := ENotOpen.Create('É豸ûÓдò¿ª! ');
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('É豸ûÓдò¿ª! ');
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('²»Ö§³ÖµÄ¸ñʽ! ');
raise e;
end;
Exit;
end
else
begin
e := ENotOpen.Create('É豸ûÓдò¿ª! ');
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('ûÓÐÑ¡ÔñÏÔʾÉ豸! ');
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('²»Äܽ¨Á¢ÏÔʾ´°¿Ú! ');
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('ÏÔʾ´°¿Ú²»ÄÜÁ¬½ÓÏÔʾÉ豸! ');
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('Çý¶¯²»Ö§³Ö¸²¸Ç·½Ê½! ');
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.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('É豸ûÓдò¿ª! ');
raise E;
Exit;
end;
Result := CapCaptureSingleFrameClose(fhcapWnd);
end;
function TVideoCap.CapSingleFrame: Boolean;
var
E: Exception;
begin
if not driverOpen then
begin
E := ENotOpen.Create('É豸ûÓдò¿ª! ');
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('²»Ö§³ÖDIB¸ñʽ! ');
raise Ex ;
end;
with Bitmap do
GetDiBits(canvas.handle,handle,0,BitmapInfo.bmiHeader.biheight,FrameBuffer,BitmapInfo,DIB_RGB_COLORS);
end;
procedure Register;
begin
RegisterComponents( 'Video', [TVideoCap]);
end;
end.