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.