unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, YUVConverts;
const
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_OVERLAY = WM_CAP_START + 51;
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;
PicWidth = 640;
PicHeight = 480;
type
TVIDEOHDR =
record
lpData : Pointer;
// address of video buffer
dwBufferLength : DWord;
// size, in bytes, of the Data buffer
dwBytesUsed : DWord;
// see below
dwTimeCaptured : DWord;
// see below
dwUser : DWord;
// user-specific data
dwFlags : DWord;
// see below
dwReserved1, dwReserved2, dwReserved3 : DWord;
// reserved; do not use
end;
TVIDEOHDRPtr = ^TVideoHDR;
DWordDim =
array[1..PicWidth]
of DWord;
TForm1 =
class(TForm)
Panel1: TPanel;
Timer1: TTimer;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
FCapHandle : THandle;
FCodec : TVideoCodec;
FGrabFrameFlag : Boolean;
FBuf1,FBuf2 :
array[1..PicHeight]
of DWordDim;
FBitmap : TBitmap;
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function capCreateCaptureWindow(lpszWindowName: LPCSTR;
dwStyle: DWORD;
x, y,
nWidth,
nHeight: integer;
hwndParent: HWND;
nID: integer): HWND;
stdcall;
external '
AVICAP32.DLL'
name '
capCreateCaptureWindowA';
//------------------------------------------------------------------------------
// FrameCallbackFunction
function FrameCallbackFunction(AHandle : hWnd; VIDEOHDR : TVideoHDRPtr): 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; dabei mögliche FCodec-Values (gemäß der
// YUVConverts-Unit): vcRGB, vcYUY2, vcUYVY, vcBTYUV, vcYVU9, vcYUV12, vcY8, vcY211
ConvertCodecToRGB(FCodec, VideoHDR^.lpData, @FBuf2,PicWidth, PicHeight);
// da zu einem bottom-up-bitmap dekomprimiert wird, drehe ich die Daten nochmal rum
for I := 1
to PicHeight
do FBuf1[I] := FBuf2[PicHeight -(I-1)];
// laden der fertigen Pixel-Daten nach FBitmap
SetBitmapBits(FBitmap.Handle,PicWidth*PicHeight*SizeOf(DWord),@FBuf1);
// + 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] > 150)
and (AColor[2] < 100)
and (AColor[3] < 100)
then beep;
end;
end;
//------------------------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
var BitmapInfo: TBitmapInfo;
begin
Timer1.Enabled := false;
FBitmap := TBitmap.Create;
FBitmap.Width := PicWidth;
FBitmap.Height := PicHeight;
FBitmap.PixelFormat := pf32Bit;
FCapHandle := capCreateCaptureWindow('
Video',ws_child+ws_visible, 0, 0,
PicWidth, PicHeight, Panel1.Handle, 1);
SendMessage(FCapHandle, WM_CAP_DRIVER_CONNECT, 0, 0);
SendMessage(FCapHandle, WM_CAP_SET_PREVIEWRATE, 15, 0);
sendMessage(FCapHandle, WM_CAP_SET_OVERLAY, 1, 0);
SendMessage(FCapHandle, WM_CAP_SET_PREVIEW, 1, 0);
SendMessage(FCapHandle,WM_CAP_DLG_VIDEOFORMAT,1,0);
FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
SendMessage(FCapHandle, WM_CAP_GET_VIDEOFORMAT, SizeOf(BitmapInfo), Integer(@BitmapInfo));
FCodec := BICompressionToVideoCodec(bitmapinfo.bmiHeader.biCompression);
if FCodec <> vcUnknown
then begin
FGrabFrameFlag := false;
SendMessage(FCapHandle, WM_CAP_SET_CALLBACK_FRAME, 0, integer(@FrameCallbackFunction));
Timer1.Enabled := true;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FBitmap.free;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
if FCodec = vcUnknown
then
showMessage('
Die WebCam verwendet leider eine unbekannte Komprimierungsart:'#13+
'
Frame-Grabbing wurde nicht aktiviert!');
end;
//------------------------------------------------------------------------------
procedure TForm1.Timer1Timer(Sender: TObject);
begin
FGrabFrameFlag := true;
SendMessage(FCapHandle, WM_CAP_GRAB_FRAME_NOSTOP, 1, 0);
// ist hintergrundlauffähig
end;
end.