Einzelnen Beitrag anzeigen

TStringlist

Registriert seit: 1. Dez 2003
360 Beiträge
 
Turbo Delphi für Win32
 
#10

Re: Rückumwandlung eines gegrabten Frames (Webcam) in Bitmap

  Alt 4. Dez 2005, 17:28
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.DLLname '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.
MfG (& Thx ggf.)
  Mit Zitat antworten Zitat