unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, mmSystem;
const
// Video Capture Messages
WM_CAP_START = WM_USER;
WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;
// WM_CAP_SET_PREVIEW ist NICHT hintergrundlauffähig
WM_CAP_SET_PREVIEW = WM_CAP_START + 50;
WM_CAP_SET_PREVIEWRATE = WM_CAP_START + 52;
// WM_CAP_GRAB_FRAME_NOSTOP ist hintergrundlauffähig !!!
WM_CAP_GRAB_FRAME_NOSTOP = WM_CAP_START + 61;
WM_CAP_SET_CALLBACK_FRAME = WM_CAP_START + 5;
WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44;
WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START+41;
// - - - - - - - -
// Messages for installable Compressors
ICM_USER = (DRV_USER+$0000) ;
ICM_DECOMPRESS_QUERY = (ICM_USER+11) ;
// query support for decompress
ICM_DECOMPRESS_BEGIN = (ICM_USER+12) ;
// start a series of decompress calls
ICM_DECOMPRESS_END = (ICM_USER+14) ;
// end a series of decompress calls
ICTYPE_VIDEO = ord ('
v') +
ord ('
i')
shl 8 +
ord ('
d')
shl 16 +
ord ('
c')
shl 24;
ICMODE_COMPRESS = 1;
ICMODE_DECOMPRESS = 2;
ICMODE_FASTDECOMPRESS = 3;
ICMODE_QUERY = 4;
ICMODE_FASTCOMPRESS = 5;
ICMODE_DRAW = 8;
ICMODE_CONST = ICMODE_FASTDECOMPRESS;
ICDECOMPRESS_HURRYUP = $80000000;
// don't draw just buffer (hurry up!)
ICDECOMPRESS_UPDATE = $40000000;
// don't draw just update
ICDECOMPRESS_PREROLL = $20000000;
// this frame is before real start
ICDECOMPRESS_NULLFRAME = $10000000;
// repeat last frame
ICDECOMPRESS_NOTKEYFRAME = $08000000;
// this frame is not a key frame
ICDECOMPRESS_CONST = ICDECOMPRESS_UPDATE;
ICERR_OK = 0 ;
type
HIC = THandle;
PVOID = Pointer;
// enthält Information über den gegrabbten Frame
TVIDEOHDR =
record
lpData : PBYTE;
// address of video buffer
dwBufferLength : DWORD;
// size, in bytes, of the Data buffer
dwBytesUsed : DWORD;
// Bytes actually used
dwTimeCaptured : DWORD;
// Milliseconds from start of stream
dwUser : DWORD;
// user-specific data
dwFlags : DWORD;
// assorted flags (see defines)
dwReserved :
array[0..3]
of DWORD;
// reserved for driver
end;
PVIDEOHDR = ^TVideoHDR;
// enthält Informationen über den De/Compressor
TICInfo =
packed record
dwSize,
fccType,
fccHandler,
dwFlags,
dwVersio,
dwVersionICM : DWORD;
szName :
array [0..15]
of wchar;
szDescription :
array [0..127]
of wchar;
szDriver :
array [0..127]
of wchar;
end;
TForm1 =
class(TForm)
Panel1: TPanel;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure AppException (Sender: TObject; E:
Exception);
procedure Timer1Timer(Sender: TObject);
private
FCapHandle : THandle;
// Handle des CapWindows
FfccType, FfccHandler : DWord;
// 'fcc-Kennung' des Codecs
FICHandle : THandle;
// Handle des Codecs
FGrabFrameFlag : Boolean;
// 'Zu/Auf-macher' der Callback-Funk
FPicHeight, FPicWidth : integer;
FBitmap, FBitmap2 : TBitmap;
FBuf2 : Pointer;
// ^Bit-Buffer von FBitmap2
FCapBitmapInfo,
// BitmapInfo des PREVIEW FRAMES
FBitmapInfo2 : TBitmapInfo;
// BitmapInfo von FBitmap2
function EnumerateAndAskVideoCodecs : Boolean;
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
// zuerst einige Functions die external deklariert sind:
function capCreateCaptureWindow(
lpszWindowName : LPCSTR;
dwStyle : DWORD;
x, y : integer;
nWidth, nHeight : integer;
hwndParent : HWND;
nID : integer): HWND;
stdcall;
external '
AVICAP32.DLL'
name '
capCreateCaptureWindowA';
function ICInfo (fccType, fccHandler : DWORD;
var ICInfo: TICInfo): BOOL;
stdcall;
external '
msvfw32.dll';
function ICOpen (fccType, fccHandler : DWORD; wMode: UINT): THandle;
stdcall;
external '
msvfw32.dll';
function ICClose (
Handle: THandle): LRESULT;
stdcall;
external '
msvfw32.dll';
function ICSendMessage(hic: HIC; msg: UINT; dw1, dw2: DWORD) : DWORD;
stdcall;
external '
msvfw32.dll';
function ICDecompress(
// decompress a single frame
hic : HIC;
dwFlags : DWORD;
// flags (from AVI index...)
lpbiFormat : PBITMAPINFOHEADER;
// BITMAPINFO of compressed data
lpData : PVOID;
// source data pointer
lpbi : PBITMAPINFOHEADER;
// DIB to decompress to
lpBits : PVOID): DWORD;
// destination data pointer
cdecl;
external '
MSVFW32.DLL';
//=============================================================
// die Callback-Function in der dann jeder Frame vorbeigereicht wird
function FrameCallbackFunction(AHandle : hWnd; VIDEOHDRPtr : PVIDEOHDR): bool;
stdcall;
var I : integer;
AColor :
array[1..4]
of byte;
begin
result := true;
with form1
do begin
// da diese Callback-Funk sonst auch bei jedem Preview-Frame ganz durchlaufen werden würde:
// Freigabe nur per FGrabFrameFlag; wird in der Timer-Proc zuvor jeweils auf TRUE gesetzt
if FGrabFrameFlag = false
then exit;
FGrabFrameFlag := false;
// dekomprimieren der Frame-Rohdaten durch den schon im Creater geöffneten Codec
ICSendMessage(FICHandle, ICM_DECOMPRESS_BEGIN, integer(@FCapBitmapInfo), integer(@FBitmapInfo2));
I := ICDecompress(FICHandle,ICDECOMPRESS_CONST, @FCapBitmapInfo,VIDEOHDRPtr^.lpData,
@FBitmapInfo2,FBuf2);
if I <> ICERR_OK
then windows.beep(2000,20);
// nur nochmal 'ne "Ohrenkontrolle"
ICSendMessage(FICHandle, ICM_DECOMPRESS_END, 0, 0);
// laden der DIB-Bits in das normale (DDB-)FBitmap zur weiteren ganz normalen Bildbearbeitung
SetDIBits(FBitmap2.Canvas.Handle,FBitmap.Handle,0,FPicHeight,FBuf2,FBitmapInfo2,DIB_RGB_COLORS);
// + Code zur Untersuchung der Bildes, z.B.: Wenn ein bestimmter Pixel X/Y
// (=0/0) des Pictures rot ist, dann schlage Alarm... (oder so)
DWord(AColor) := FBitmap.Canvas.Pixels[0,0];
if (AColor[1] >= AColor[2]+50)
and (AColor[1] >= AColor[3]+50)
then beep;
end;
end;
// bewirkt das periodisches Grabben eines WebCam-Frames
procedure TForm1.Timer1Timer(Sender: TObject);
begin
FGrabFrameFlag := true;
SendMessage(FCapHandle, WM_CAP_GRAB_FRAME_NOSTOP, 1, 0);
end;
//================================================================
// befragt alle auffindbaren Video-Codecs
function TForm1.EnumerateAndAskVideoCodecs : Boolean;
var
Counter : integer;
ICInfoRec : TICInfo;
Ahic : THandle;
begin
result := false;
Counter := 0;
// solange noch kein passender Video-Codec gefunden wurde, wird weitergesucht
while (result = false)
and ICInfo(ICTYPE_VIDEO, counter, ICInfoRec)
do begin
// Versuch den Codec zur Befragung zu öffnen
Ahic := ICOpen(ICInfoRec.fccType, ICInfoRec.fccHandler, ICMODE_QUERY);
if Ahic<>0
then begin
// befragen des Codecs ob er die Dekomprimierung ausführen kann
if ICSendMessage(Ahic, ICM_DECOMPRESS_QUERY, integer(@FCapBitmapInfo), integer(@FBitmapInfo2)) = ICERR_OK
then begin
// wenn ja, dann: Speichern der Codec-"fcc-Kennung" + Abbruch der Codec-Suche
FfccType := ICInfoRec.fccType;
FfccHandler := ICInfoRec.fccHandler;
result := true;
end;
ICClose(Ahic);
end;
inc(counter);
end;
end;
//-------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
var ImgHdrSize,ImgSize : DWord;
begin
Application.OnException := AppException;
Timer1.Enabled := false;
FGrabFrameFlag := false;
// reguliert die "Freigabe" der Callback-Funktion
// Anweisungen zum Schalten des PREVIEWs der WebCam-Frames
FCapHandle := capCreateCaptureWindow('
Video',ws_child+ws_visible, 0, 0,
Panel1.Width, Panel1.Height, Panel1.Handle, 1);
SendMessage(FCapHandle, WM_CAP_DRIVER_CONNECT, 0, 0);
SendMessage(FCapHandle, WM_CAP_SET_PREVIEWRATE, 15, 0);
SendMessage(FCapHandle, WM_CAP_SET_PREVIEW, 1, 0);
// Eingabe-Dialog fürs Format und die Comprimierung des PREVIEWs
// (beides auch gleichzeitig gültig für die gegrabbten Frames)
SendMessage(FCapHandle, WM_CAP_DLG_VIDEOFORMAT,1,0);
// das BitmapInfo der PREVIEW FRAMES muss beschafft werden
FillChar(FCapBitmapInfo, SizeOf(FCapBitmapInfo), 0);
SendMessage(FCapHandle, WM_CAP_GET_VIDEOFORMAT, SizeOf(FCapBitmapInfo), Integer(@FCapBitmapInfo));
// nach dem Format der PREVIEW FRAMES richtet sich weiteres
FPicWidth := FCapBitmapInfo.bmiHeader.biWidth;
FPicHeight := FCapBitmapInfo.bmiHeader.biHeight;
Panel1.Width := FPicWidth;
Panel1.Height := FPicHeight;
// Endempfänger des jeweils gegrabbten und dekomprimierten Frames
FBitmap := TBitmap.Create;
FBitmap.Width := FPicWidth;
FBitmap.Height := FPicHeight;
FBitmap.PixelFormat := pf24Bit;
// ein zweites zu FBitmap kompatibles TBitmap, welches gleich in ein
// DIB umgewandelt wird. Das BitmapInfo, das dadurch anfallen wird, ist
// dann für die Suche eines Codecs und die Dekomprimierung essentiell.
FBitmap2 := TBitmap.Create;
FBitmap2.Width := FPicWidth;
FBitmap2.Height := FPicHeight;
FBitmap2.PixelFormat := pf24Bit;
// Umwandlung von FBitmap2 in ein DIB
GetDIBSizes(FBitmap2.Handle,ImgHdrSize,ImgSize);
GetMem(FBuf2,ImgSize);
GetDIB(FBitmap2.Handle, FBitmap2.Palette, FBitmapInfo2, FBuf2^);
// Suche nach einem passenden Codec ...
if EnumerateAndAskVideoCodecs = false
// ist die Codec-Suche erfolglos...
then raise Exception.Create('
Kein passender Codec gefunden')
// Prog-Ende
else begin // sonst wird alles fürs Frame-Grabben & Decompressen eingeschaltet
FICHandle := ICOpen(FfccType, FfccHandler, ICMODE_CONST);
SendMessage(FCapHandle, WM_CAP_SET_CALLBACK_FRAME, 0, integer(@FrameCallbackFunction));
Timer1.Enabled := true;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
ICClose(FICHandle);
FreeMem(FBuf2);
FBitmap2.Free;
FBitmap.Free;
end;
// Bei irgendwelchen Exceptions: E.Message-Output & Prog-Ende
procedure TForm1.AppException (Sender: TObject; E:
Exception);
begin
showMessage('
Fehler!' +#13#13+
E.
Message + #13#13 +
'
Programm wird abgebrochen.');
Application.Terminate;
end;
end.