Rückumwandlung eines gegrabten Frames (Webcam) in Bitmap

[TStringlist]

Hi (hoffe das Ganze hier ist nicht zu lang).

>> Wie wandle ich das Rohmaterial eines gegrabten Frames (von einer Webcam) wieder in ein korrektes Bitmap um?

Es geht also wieder mal um das Auslesen einer Webcam, bzw. wie man davon z.B. jede Sekunde ein Bild (Frame) "abzweigt" (etwa um es danach untersuchen zu können) ...und was insgesamt auch dann funktionieren sollte, wenn das Prog. im Hintergrund läuft und man das Clipboard für andere Applications freizuhalten hat.

Code-mäßig aufgebaut habe ich meinen Versuch dabei auf diesen Thread hier bzw. das was Ultimator dort anfangs postete. Im Unterschied zu diesem Verfahren benutze ich jetzt aber nicht das Clipboard, sondern eine (Frame-) Callback-Funktion, welche mittels dieser WM installiert wird:

WM_CAP_SET_CALLBACK_FRAME = WM_User + 5; ..plus nochmal dem Creator mit der dazugehörenden SendMessage-Zeile:

Delphi-Quellcode:

procedure TForm1.FormCreate(Sender: TObject);
begin
  GrabFrameFlag := false;

  VHandle := capCreateCaptureWindow('Video',ws_child+ws_visible, 0, 0,
  640, 480, Panel1.Handle, 1);
  SendMessage(VHandle, WM_CAP_DRIVER_CONNECT, 0, 0);
  SendMessage(VHandle, WM_CAP_SET_PREVIEWRATE, 15, 0);
  sendMessage(VHandle, WM_CAP_SET_OVERLAY, 1, 0);
  SendMessage(VHandle, wm_cap_set_preview, 1, 0);

  SendMessage(VHandle, WM_CAP_SET_CALLBACK_FRAME, 0, integer(@FrameCallbackFunction));

  SendMessage(VHandle,WM_CAP_DLG_VIDEOFORMAT,1,0);

  VDC := getDC(VHandle);
  hCompatibleBitmap := CreateCompatibleBitmap(VDC,640,480);
end;

Wie man am Ende des Creators sieht, versuche ich dort noch ein zum CaptureWindow kompatibles Bitmap zu erstellen, in welches ich in der Callback-Funktion dann das Rohmaterial des Frames hineinzuladen versuche.


...und schließlich also die Callback-Funktion selbst (plus einem Recordtyp, nötig für den zweiten Parameter der Parameterliste: "lpVHdr: pointer to struct containing captured frame information")

Delphi-Quellcode:

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;

function FrameCallbackFunction(AHandle : hWnd; VIDEOHDR : TVideoHDRPtr): bool; stdcall;
var ACount : integer;
begin
  result := true;

  // da diese Callback-Funktion sonst bei jedem Preview-Frame ganz durchlaufen werden würde:
  // jetzt nur noch mehr dann, wenn draußen GrabFrameFlag auf TRUE gesetzt wurde PLUS, für die
  // Hintergrundlaufbarkeit: SendMessage(VHandle, WM_CAP_GRAB_FRAME_NOSTOP, 1, 0);
  if GrabFrameFlag = false then exit;
  GrabFrameFlag := false;

  windows.beep(1000,10);  // nur nochmal zum akustischen Besuchs-Check

  ACount := SetBitmapBits(hCompatibleBitmap,VideoHDR^.dwBufferLength,VideoHDR^.lpData);
  with form2 do begin
    FBitmap.Handle := hCompatibleBitmap;
    PaintBox1.Repaint;   // hier wird dann der Inhalt von FBitmap auf form2.PaintBox1 ausgegeben.
  end;
end;

Wie man am Code in der Callback-Funktion sieht, versuche ich dort jetzt mittels der ApiFunktion 'SetBitmapBits' das Rohmaterial des Frames in ein zum CaptureWindow compatibles Bitmap zu laden. Anschließend übertrage ich es dann Handle-mäßig auf ein VCL-Bitmap (FBitmap), welches schließlich in einer Paintbox ausgegeben wird. NUR – kann man das alles überhaupt so machen? (Oder/aber, warum eigentlich auch wieder nicht, bzw. wie sonst?)

Jedenfalls besteht das dabei herauskommende Bild dann aber leider nur aus irgendwelchen Farbschlieren und ist im unteren Drittel völlig schwarz. Besonders auch letzteres legt dann irgendwie die Vermutung nahe, dass das Frame-Rohmaterial vor oder während des Transfers wahrscheinlich wenigstens noch hätte dekomprimiert werden müssen.

In einem aufrufbaren Dialog-Window (bzgl. des einstellbaren (Frame-) Formates) wird ja dann auch zufällig noch mit angezeigt, dass die Komprimierung vom Typ I420 ist und ein Bild 460800 Bytes groß. Das hieße also bei 640*480 Pixels pro Pixel 12 Bits?!?

Frage wäre hier also vor allem auch: Wie kann man für das so vorliegendes Rohmaterial eine Dekomprimierung durchführen??? Oder wo könnten sonst Fehler in der Art sein, wie ich das oben insgesamt versuche? Bzw. gibt es sonst noch irgendwelche einfacheren Alternativen dazu?

Irgendwelche Ideen?

[Phantom1]

In irgendeinem Header steht das Format was zu bei Komprimierung benutzt wurde. Da du es jedoch schon weißt, das es sich hierbei um I420 (YUV12) handelt, macht es die Sache einfacher. Ich hab hier eine Unit für dich, mit der du das Bild ziemlich einfach dekomprimieren kannst. Die Unit stammt von http://delphi.pjh2.de

mfg
Phantom1

[TStringlist]

Hallo, und Besten Dank!

Ich werde mich gleich mal dran versuchen

[TStringlist]

So, hier nochmal eine kleine Zusammenfassung des kurzen Codes, welcher (wenigstens bei mir) ohne Probleme läuft.

(...und mit dem man nun mittels eines im Hintergund laufenden Programms der Webcam alle Sekunde z.B. ein Bild 'abnehmen' kann, um dieses danach wie auch immer zu untersuchen. Das Clipboard bleibt dabei jetzt unberührt).

Delphi-Quellcode:

Uses ...,
     YUVConverts, // zur Dekomprimierung des Frame-Rohmaterials, aus Phantom1's Post
     ...;

const 
  WM_CAP_DRIVER_CONNECT = WM_USER + 10; 
  WM_CAP_EDIT_COPY = WM_USER + 30; 
  WM_CAP_SET_PREVIEW = WM_USER + 50; 
  WM_CAP_SET_OVERLAY = WM_USER + 51; 
  WM_CAP_SET_PREVIEWRATE = WM_USER + 52;
  WM_CAP_GRAB_FRAME_NOSTOP = WM_User + 61;
  WM_CAP_SET_CALLBACK_FRAME = WM_User + 5;

  WM_CAP_DLG_VIDEOFORMAT          = WM_USER+41;   //Formatauswahl 
  WM_CAP_DLG_VIDEOSOURCE          = WM_USER+42;   //Einstellungen 
  WM_CAP_DLG_VIDEOCOMPRESSION     = WM_USER+46;   //Kompression

  PicWidth = 640;
  PicHeight = 480;

type 
  ...
  DWordDim = array[1..PicWidth] of DWord;

var
  Form1: TForm1;
  VHandle : THandle;
  GrabFrameFlag : Boolean;
  Buf1,Buf2 : array[1..PicHeight] of DWordDim;
  FBitmap : TBitmap;

.
.
.

//Dann brauchst du noch das hier
function capCreateCaptureWindow(lpszWindowName: LPCSTR;
  dwStyle: DWORD;
  x, y,
  nWidth,
  nHeight: integer;
  hwndParent: HWND;
  nID: integer): HWND; stdcall;
  external 'AVICAP32.DLL' name 'capCreateCaptureWindowA';


//------------------------------------------------------------------------------

procedure TForm1.FormCreate(Sender: TObject);
begin
  VHandle := capCreateCaptureWindow('Video',ws_child+ws_visible, 0, 0,
  PicWidth, PicHeight, Panel1.Handle, 1);
  SendMessage(VHandle, WM_CAP_DRIVER_CONNECT, 0, 0);
  SendMessage(VHandle, WM_CAP_SET_PREVIEWRATE, 15, 0);
  sendMessage(VHandle, WM_CAP_SET_OVERLAY, 1, 0);
  SendMessage(VHandle, wm_cap_set_preview, 1, 0);

  SendMessage(VHandle, WM_CAP_SET_CALLBACK_FRAME, 0, integer(@FrameCallbackFunction));

  SendMessage(VHandle,WM_CAP_DLG_VIDEOFORMAT,1,0);

  FBitmap := TBitmap.Create;
  FBitmap.Width := PicWidth;
  FBitmap.Height := PicHeight;
  FBitmap.PixelFormat := pf32Bit;

  GrabFrameFlag := false;
end;


procedure TForm1.FormDestroy(Sender: TObject);
begin
  FBitmap.free;
end;

Die eigentliche Frame-Callback-Funktion (sollte dann allerdings überm Creator stehen, sonst ist dort ihre Adresse noch nicht bekannt):

Delphi-Quellcode:

Type
TVIDEOHDR = record  // lpVHdr, aus dem INet herausgefischt
  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;

function FrameCallbackFunction(AHandle : hWnd; VIDEOHDR : TVideoHDRPtr): bool; stdcall;
var I : integer;
  AColor : array[1..4] of byte;
begin
  result := true;

  // da diese Callback-Funktion sonst bei jedem Preview-Frame ganz durchlaufen werden würde:
  if GrabFrameFlag = false then exit;
  GrabFrameFlag := false;

  // dekomprimieren der Frame-Rohdaten
{ TVideoCodec = (vcUnknown, vcRGB, vcYUY2, vcUYVY, vcBTYUV, vcYVU9, vcYUV12, vcY8, vcY211); }
  ConvertCodecToRGB(vcYUV12,VideoHDR^.lpData,@Buf2,PicWidth,PicHeight);

  // da zu einem bottom-up-bitmap dekomprimiert wird, drehe ich die Daten nochmal rum
  for I := 1 to PicHeight do Buf1[I] := Buf2[PicHeight -(I-1)];

  // laden der fertigen Pixel-Daten nach FBitmap
  SetBitmapBits(FBitmap.Handle,PicWidth*PicHeight*SizeOf(DWord),@Buf1);

{
  // ...Code zur Untersuchung der Bildes, z.B.:
  DWord(AColor) := FBitmap.Canvas.Pixels[X,Y];
  // ist der Rot-Wert an einem bestimmten X/Y > als Z dann schlage Alarm...(oder so)
  if AColor[1] > Z then beep;
}

end;

Und schließlich noch die TimerProc, zur periodischen Webcam-Bildbearbeitung:

Delphi-Quellcode:

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  GrabFrameFlag := true;
  SendMessage(VHandle, WM_CAP_GRAB_FRAME_NOSTOP, 1, 0); // für die Hintergrundlaufbarkeit
end;

[dragi]

Hallo,

ich habe den oben abgebildeten Code mal ausprobiert, bekomme aber eine Exception (Lesen von Adresse 000000) bei der Methode

Code:

  SetBitmapBits(FBitmap.Handle,PicWidth*PicHeight*SizeOf(DWord),@Buf1);

in der Funktion FrameCallbackFunction. Kann mir vielleicht jemand sagen wo bei mir der Fehler ist?
Hier der Versuch das oben abgebildete in eine Unit zu packen:

Code:

unit frm_MTMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, YUVConverts, ExtCtrls;

const
  WM_CAP_DRIVER_CONNECT           = WM_USER + 10;
  WM_CAP_EDIT_COPY                = WM_USER + 30;
  WM_CAP_SET_PREVIEW              = WM_USER + 50;
  WM_CAP_SET_OVERLAY              = WM_USER + 51;
  WM_CAP_SET_PREVIEWRATE          = WM_USER + 52;
  WM_CAP_GRAB_FRAME_NOSTOP        = WM_User + 61;
  WM_CAP_SET_CALLBACK_FRAME       = WM_User + 5;
  WM_CAP_DLG_VIDEOFORMAT          = WM_USER+41;   //Formatauswahl
  WM_CAP_DLG_VIDEOSOURCE          = WM_USER+42;   //Einstellungen
  WM_CAP_DLG_VIDEOCOMPRESSION     = WM_USER+46;   //Kompression
  PicWidth                        = 640;
  PicHeight                       = 480;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Timer1: TTimer;
    procedure Timer1Timer(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private-Deklarationen }
  public
  end;

type
  DWordDim = array[1..PicWidth] of DWord;

Type
  TVIDEOHDR = record  // lpVHdr, aus dem INet herausgefischt
  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;

var
  Form1: TForm1;
  VHandle : THandle; 
  GrabFrameFlag : Boolean; 
  Buf1,Buf2 : array[1..PicHeight] of DWordDim;
  FBitmap : TBitmap;

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

function FrameCallbackFunction(AHandle : hWnd; VIDEOHDR : TVideoHDRPtr): bool; stdcall;
var I : integer;
  AColor : array[1..4] of byte;
begin
  result := true;
  // da diese Callback-Funktion sonst bei jedem Preview-Frame ganz durchlaufen werden würde:
  if GrabFrameFlag = false then exit;
  GrabFrameFlag := false;
  // dekomprimieren der Frame-Rohdaten
  { TVideoCodec = (vcUnknown, vcRGB, vcYUY2, vcUYVY, vcBTYUV, vcYVU9, vcYUV12, vcY8, vcY211); }
  ConvertCodecToRGB(vcYUV12,VideoHDR^.lpData,@Buf2,PicWidth,PicHeight);
  // da zu einem bottom-up-bitmap dekomprimiert wird, drehe ich die Daten nochmal rum
  for I := 1 to PicHeight do Buf1[I] := Buf2[PicHeight -(I-1)];
  // laden der fertigen Pixel-Daten nach FBitmap
  SetBitmapBits(FBitmap.Handle,PicWidth*PicHeight*SizeOf(DWord),@Buf1);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  VHandle := capCreateCaptureWindow('Video',ws_child+ws_visible, 0, 0,
  PicWidth, PicHeight, Panel1.Handle, 1);
  SendMessage(VHandle, WM_CAP_DRIVER_CONNECT, 0, 0); 
  SendMessage(VHandle, WM_CAP_SET_PREVIEWRATE, 15, 0); 
  sendMessage(VHandle, WM_CAP_SET_OVERLAY, 1, 0); 
  SendMessage(VHandle, wm_cap_set_preview, 1, 0);
  SendMessage(VHandle, WM_CAP_SET_CALLBACK_FRAME, 0, integer(@FrameCallbackFunction));
  SendMessage(VHandle,WM_CAP_DLG_VIDEOFORMAT,1,0);
  FBitmap := TBitmap.Create;
  FBitmap.Width := PicWidth;
  FBitmap.Height := PicHeight;
  FBitmap.PixelFormat := pf32Bit;
  GrabFrameFlag := false;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FBitmap.free;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  GrabFrameFlag := true; 
  SendMessage(VHandle, WM_CAP_GRAB_FRAME_NOSTOP, 1, 0); // für die Hintergrundlaufbarkeit
end;

end.

[TStringlist]

Hallo,

also, da hatte ich den Code wohl doch etwas zu sehr "ausgemistet" .

In meinem eigentlichen Programm existierte nämlich noch ein Button, mittels dem ich die ganze Sache überhaupt erst startete, sprich den Timer eingeschaltet habe. Wenn der jetzt aber einfach so von Anfang an schon läuft, dann wird der Aufruf dieser Callbackfunktion nämlich insgesamt schon vor dem Aufbau des VideoFormat-Dialogs angestoßen, also ohne dass ich in diesem Dialog schon irgendetwas einstellen konnte. Und das ist auch erstmal der primäre Grund dafür, warum es bei dir dort eine Exception gibt. Wenn du im Creater die "WM_CAP_SET_CALLBACK_FRAME"-Zeile eines tiefer setzt, also unter die, durch die der Dialog aufgerufen wird, dann sollte wenigstens dieser Fehler erstmal verschwunden sein (bis wahrscheinlich nach dem Dialog ).

In diesem Dialog selbst müsstest du dann aber sehen können, was für Komprimierungen die WebCam überhaupt anbietet. Wichtig ist für dich dabei, dass dort im Dialog jetzt eine solche Komprimierung auswählbar ist, zu der in der YUVConverts-Unit auch eine Dekomprimierung angeboten wird, bzw. eine solche dann auch in der "ConvertCodecToRGB"-Zeile einstellbar ist.

[Phantom1]

Zitat von TStringlist:

In diesem Dialog selbst müsstest du dann aber sehen können, was für Komprimierungen die WebCam überhaupt anbietet. Wichtig ist für dich dabei, dass dort im Dialog jetzt eine solche Komprimierung auswählbar ist, zu der in der YUVConverts-Unit auch eine Dekomprimierung angeboten wird, bzw. eine solche dann auch in der "ConvertCodecToRGB"-Zeile einstellbar ist.

Ich würde es etwas einfacher machen, anstatt:

Zitat:

ConvertCodecToRGB(vcYUV12,VideoHDR^.lpData,@Buf2,P icWidth,PicHeight);

so hier:

Delphi-Quellcode:

var
  BitmapInfo: TBitmapInfo;
begin
//...
FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
SendMessage(CapHandle, WM_CAP_GET_VIDEOFORMAT, SizeOf(BitmapInfo), Integer(@BitmapInfo));
ConvertCodecToRGB(BICompressionToVideoCodec(bitmapinfo.bmiHeader.biCompression), VideoHDR^.lpData, @Buf2,PicWidth, PicHeight);

Hatt den Vorteil das der richtige Codec automatisch gewählt wird.

[TStringlist]

Zitat von Phantom1:

Delphi-Quellcode:

var
  BitmapInfo: TBitmapInfo;
begin
//...
FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
SendMessage(CapHandle, WM_CAP_GET_VIDEOFORMAT, SizeOf(BitmapInfo), Integer(@BitmapInfo));
ConvertCodecToRGB(BICompressionToVideoCodec(bitmapinfo.bmiHeader.biCompression), VideoHDR^.lpData, @Buf2,PicWidth, PicHeight);

Hatt den Vorteil das der richtige Codec automatisch gewählt wird.

Cool! ...war allerdings für meine Exkursion in dieses Thema hinein nicht notwendig, aber trotzdem: Sehr praktisch! Besonders dann natürlich, wenn man so ein Prog auch mal weitergeben möchte.

Sind eigentlich in dieser YUVConverts-Unit alle so möglichen Codecs auch +/- vollständig berücksichtigt? Ich hatte letztens nämlich mal 2 WebCams deren gegrabte Frames sich damit nicht dekomprimieren ließen. Da konnte man alle Codecs dieser Unit der Reihe nach hoch und runter durchprobieren (auch mal ganz ohne Dekomprimierung inklusive), nichts half leider.

[Phantom1]

Zitat von TStringlist:

Sind eigentlich in dieser YUVConverts-Unit alle so möglichen Codecs auch +/- vollständig berücksichtigt? Ich hatte letztens nämlich mal 2 WebCams deren gegrabte Frames sich damit nicht dekomprimieren ließen. Da konnte man alle Codecs dieser Unit der Reihe nach hoch und runter durchprobieren (auch mal ganz ohne Dekomprimierung inklusive), nichts half leider.

In dieser Unit sind nur die gebräuchstlichen Codec's enthalten, eine halbwegs komplette liste findet man hier: Fourcc.org

Falls der Codec wirklich nicht dabei sein sollte, hilft der FourCC (bitmapinfo.bmiHeader.biCompression) weiter. Ermitteln kann man ihn recht einfach:

Delphi-Quellcode:

function GETFOURCC(c: LongWord): String;
type TCodec = packed record a, b, c, d: Byte end;
begin
  with TCodec(c) do
    Result:=Chr(a)+Chr(b)+Chr(c)+Chr(d);
end;

[TStringlist]

Also hier dann doch noch einmal eine neue optimierte Version zum unkomplizierteren Ausprobieren des Ganzen.

(Dazu nötig: Nur ein Panel (640*480) und einen Timer auf die Form ziehen. Dann jeweils einen Doppelklick auf das OnCreate, OnActivate und OnDestroy der Form u. einen auf das OnTimer des Timers. Anschließend die gesamte Unit1 per copy&paste durch diese hier ersetzen. Dann noch von oben die YUVConverts-Unit downloaden. ...And last but not least: Man halte danach irgendeinen roten Gegenstand in die linke obere Bildecke und lasse durch das Prog ALARM schlagen )

Delphi-Quellcode:

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.

Edit:
Nur um im Falle der Meldung "Frame-Grabbing wurde nicht aktiviert!" irgendwelchen Irritationen gleich zuvorzukommen: Das auch dann trotzdem laufende Bild wird durch das WM_CAP_SET_PREVIEW geschaltet und benötigt dafür natürlich kein FrameGrabbing und auch keine FrameCallback-Funktion mit dieser darin dann extra ausgeführten Dekomprimierung. Beim PREVIEW läuft das alles intern und automatisch ab, ohne das man also an das dekomprimierte Bild herankäme oder das PREVIEW noch feuern würde, wenn das Prog im Hintergrund verschwindet.