Logo Questions Linux Laravel Mysql Ubuntu Git Menu
HTML CSS JAVASCRIPT SQL PYTHON PHP BOOTSTRAP JAVA JQUERY R React Kotlin
 

Getting a snapshot from a webcam with Delphi

Tags:

callback

video-capture

delphi

webcam

vfw

I need to get a regular snapshot from a webcam in Delphi. Speed is not a problem (once a second is fine). I have tried demo code from based on stuff from http://delphi.pjh2.de but I can't get it to work. It compiles and runs OK but the callback function never fires.

I don't have a real webcam but am running instead a simulator. The simulator works (I can see the video using Skype) but not with the test app. I don't really know where to start looking...

Can anyone be bothered to try this code? (Apologies for the voluminous post - couldn't find how or if you can attach files - a zip file is available here.)

Alternatively, any webcam demo code would be appreciated, preferably with a known good EXE as well as source.

program WebCamTest;

uses
  Forms,
  WebCamMainForm in 'WebCamMainForm.pas' {Form1},
  yuvconverts in 'yuvconverts.pas';

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.


unit WebCamMainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, YUVConverts, StdCtrls, JPeg {, TntStdCtrls} ;

const
  WM_CAP_START = WM_USER;
  WM_CAP_DRIVER_CONNECT       = WM_CAP_START+ 10;

  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    = 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;
  SUBLINEHEIGHT= 18;
  EXTRAHEIGHT= 400;

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)
    Timer1: TTimer;
    Panel1: TPanel;
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    FCapHandle: THandle;
    FCodec: TVideoCodec;
    FBuf1, FBuf2: array[1..PICHEIGHT] of DWordDim;
    FBitmap: TBitmap;
    FJpeg: TJPegImage;
    { 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';


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

  with form1 do begin
  try
    ConvertCodecToRGB(FCodec, VideoHDR^.lpData, @FBuf2, PICWIDTH, PICHEIGHT);

    for I:= 1 to PICHEIGHT do FBuf1[I]:= FBuf2[PICHEIGHT- (I- 1)];
    SetBitmapBits(FBitmap.Handle, PICWIDTH* PICHEIGHT* SizeOf(DWord), @FBuf1);

    FBitmap.Canvas.Brush.Color:= clWhite;
    FBitmap.Canvas.Font.Color:= clRed;

    FJpeg.Assign(FBitmap);

    FJpeg.CompressionQuality:= 85;
    FJpeg.ProgressiveEncoding:= true;
    FJpeg.SaveToFile('c:\webcam.jpg');

    SendMessage(FCapHandle, WM_CAP_SET_CALLBACK_FRAME, 0, 0);
  except
  end;
  end;
end;

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

procedure TForm1.FormCreate(Sender: TObject);
var  BitmapInfo: TBitmapInfo;
begin
  Timer1.Enabled := false;

  FBitmap:= TBitmap.Create;
  FBitmap.Width:= PICWIDTH;
  FBitmap.Height:= PICHEIGHT+ SUBLINEHEIGHT+ EXTRAHEIGHT;
  FBitmap.PixelFormat:= pf32Bit;
  FBitmap.Canvas.Font.Assign(Panel1.Font);
  FBitmap.Canvas.Brush.Style:= bssolid;
  FBitmap.Canvas.Rectangle(0, PICHEIGHT, PICWIDTH, PICHEIGHT+ SUBLINEHEIGHT);

  FJpeg:= TJpegImage.Create;

  FCapHandle:= capCreateCaptureWindow('Video', WS_CHILD or WS_VISIBLE, 0, 0, PICWIDTH, PICHEIGHT, Panel1.Handle, 1);
  SendMessage(FCapHandle, WM_CAP_DRIVER_CONNECT, 0, 0);
  SendMessage(FCapHandle, WM_CAP_SET_PREVIEWRATE, 15000, 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);     // -this was commented out

  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
    Timer1.Enabled:= true;
  end;
end;


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


procedure TForm1.FormActivate(Sender: TObject);
begin
  if FCodec= vcUnknown then
    showMessage('unknown compression');
  FBitmap.Height:= PICHEIGHT+ SUBLINEHEIGHT;
end;

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

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  SendMessage(FCapHandle, WM_CAP_SET_CALLBACK_FRAME, 0, integer(@FrameCallbackFunction));
  SendMessage(FCapHandle, WM_CAP_GRAB_FRAME_NOSTOP, 1, 0); // ist hintergrundlauff盲hig
end;

end.

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 301
  ClientWidth = 562
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnActivate = FormActivate
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    Left = 48
    Top = 16
    Width = 185
    Height = 145
    Caption = 'Panel1'
    TabOrder = 0
  end
  object Timer1: TTimer
    OnTimer = Timer1Timer
    Left = 464
    Top = 24
  end
end

{**************************************************************************************************}
{                                                                                                  }
{  YUVConverts                                                                                     }
{                                                                                                  }
{  The contents of this file are subject to the Y Library Public License Version 1.0 (the          }
{  "License"); you may not use this file except in compliance with the License. You may obtain a   }
{  copy of the License at http://delphi.pjh2.de/                                                   }
{                                                                                                  }
{  Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF  }
{  ANY KIND, either express or implied. See the License for the specific language governing        }
{  rights and limitations under the License.                                                       }
{                                                                                                  }
{  The Original Code is: YUVConverts.pas, part of CapDemoC.dpr.                                    }
{  The Initial Developer of the Original Code is Peter J. Haas ([email protected]). Portions created    }
{  by Peter J. Haas are Copyright (C) 2000-2005 Peter J. Haas. All Rights Reserved.                }
{                                                                                                  }
{  Contributor(s):                                                                                 }
{                                                                                                  }
{  You may retrieve the latest version of this file at the homepage of Peter J. Haas, located at   }
{  http://delphi.pjh2.de/                                                                          }
{                                                                                                  }
{**************************************************************************************************}

// For history see end of file

{$ALIGN ON, $BOOLEVAL OFF, $LONGSTRINGS ON, $IOCHECKS ON, $WRITEABLECONST OFF, $OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF, $TYPEDADDRESS ON, $MINENUMSIZE 1}

unit yuvconverts;

interface
uses
  Windows;

type
  TVideoCodec = (vcUnknown, vcRGB, vcYUY2, vcUYVY, vcBTYUV, vcYVU9, vcYUV12, vcY8, vcY211);

const
  BI_YUY2  = $32595559;  // 'YUY2'
  BI_UYVY  = $59565955;  // 'UYVY'
  BI_BTYUV = $50313459;  // 'Y41P'
  BI_YVU9  = $39555659;  // 'YVU9'  planar
  BI_YUV12 = $30323449;  // 'I420'  planar
  BI_Y8    = $20203859;  // 'Y8  '
  BI_Y211  = $31313259;  // 'Y211'

function BICompressionToVideoCodec(Value: DWord): TVideoCodec;

function ConvertCodecToRGB(Codec: TVideoCodec; Src, Dst: Pointer; AWidth, AHeight: Integer): Boolean;

implementation

function BICompressionToVideoCodec(Value: DWord): TVideoCodec;
begin
  case Value of
    BI_RGB, BI_BITFIELDS: Result := vcRGB;   // no RLE
    BI_YUY2:              Result := vcYUY2 ;
    BI_UYVY:              Result := vcUYVY ;
    BI_BTYUV:             Result := vcBTYUV;
    BI_YVU9:              Result := vcYVU9;
    BI_YUV12:             Result := vcYUV12;
    BI_Y8:                Result := vcY8;
    BI_Y211:              Result := vcY211;
  else
    Result := vcUnknown;
  end;
end;

const
  // RGB255 ColorFAQ
  fY  =  298.082 / 256;
  fRU =  0;
  fGU = -100.291 / 256;
  fBU =  516.411 / 256;
  fRV =  408.583 / 256;
  fGV = -208.120 / 256;
  fBV =  0;

{  // RGB219 ColorFAQ           too dark
  fY  =  256 / 256;
  fRU =  0;
  fGU =  -86.132 / 256;
  fBU =  443.506 / 256;
  fRV =  350.901 / 256;
  fGV = -178.738 / 256;
  fBV =  0; }

{  // Earl            same like RGB255
  fY  =  1.164;
  fRU =  0;
  fGU = -0.392;
  fBU =  2.017;
  fRV =  1.596;
  fGV = -0.813;
  fBV =  0;
}

// |R|   |fY fRU fRV|   |Y|   | 16|
// |G| = |fY fGU fGV| * |U| - |128|
// |B|   |fY fBU fBV|   |V|   |128|

type
  TYUV = packed record
    Y, U, V, F1: Byte;
  end;

  PBGR32 = ^TBGR32;
  TBGR32 = packed record
    B, G, R, A: Byte;
  end;

function YUVtoBGRAPixel(AYUV: DWord): DWord;
var
  ValueY, ValueU, ValueV: Integer;
  ValueB, ValueG, ValueR: Integer;
begin
  ValueY := TYUV(AYUV).Y - 16;
  ValueU := TYUV(AYUV).U - 128;
  ValueV := TYUV(AYUV).V - 128;

  ValueB := Trunc(fY * ValueY + fBU * ValueU);  // fBV = 0
  if ValueB > 255 then
    ValueB := 255;
  if ValueB <   0 then
    ValueB :=   0;

  ValueG := Trunc(fY * ValueY + fGU * ValueU + fGV * ValueV);
  if ValueG > 255 then
    ValueG := 255;
  if ValueG <   0 then
    ValueG :=   0;

  ValueR := Trunc(fY * ValueY + fRV * ValueV);  // fRU = 0
  if ValueR > 255 then
    ValueR := 255;
  if ValueR <   0 then
    ValueR :=   0;

  with TBGR32(Result) do begin
    B := ValueB;
    G := ValueG;
    R := ValueR;
    A := 0;
  end;
end;

type
  TDWordRec = packed record
  case Integer of
    0: (B0, B1, B2, B3: Byte);
    1: (W0, W1: Word);
  end;

// UYVY
// YUV 4:2:2 (Y sample at every pixel, U and V sampled at every second pixel
// horizontally on each line). A macropixel contains 2 pixels in 1 DWord.
// 16 Bits per Pixel, 4 Byte Macropixel
// U0 Y0 V0 Y1
procedure UYVYtoRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
type
  PUYVY = ^TUYVY;
  TUYVY = packed record
    U, Y0, V, Y1: Byte;
  end;

var
  x, y: Integer;
  w: Integer;
  SrcPtr: PDWord;
  DstPtr: PDWord;
  SrcLineSize: Integer;
  DstLineSize: Integer;
  YUV: DWord;
  b: Byte;
begin
  SrcLineSize := AWidth * 2;
  DstLineSize := AWidth * 4;

  // Dst is Bottom Top Bitmap
  Inc(PByte(Dst), (AHeight - 1) * DstLineSize);

  w := (AWidth div 2) - 1;      { TODO : bei ungeraden Breiten fehlt letztes Pixel }
  for y := 0 to AHeight - 1 do begin
    SrcPtr := Src;
    DstPtr := Dst;
    for x := 0 to w do begin
      YUV := SrcPtr^;
      // First Pixel
      b := TDWordRec(YUV).B0;
      TDWordRec(YUV).B0 := TDWordRec(YUV).B1;
      TDWordRec(YUV).B1 := b;

      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);
      // Second Pixel
      TDWordRec(YUV).B0 := TDWordRec(YUV).B3;
      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);
      Inc(SrcPtr);
    end;
    Dec(PByte(Dst), DstLineSize);
    Inc(PByte(Src), SrcLineSize);
  end;
end;

// YUY2, YUNV, V422
// YUV 4:2:2 as for UYVY but with different component ordering within the DWord
// macropixel.
// 16 Bits per Pixel, 4 Byte Macropixel
// Y0 U0 Y1 V0
procedure YUY2toRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
var
  x, y: Integer;
  w: Integer;
  SrcPtr: PDWord;
  DstPtr: PDWord;
  SrcLineSize: Integer;
  DstLineSize: Integer;
  YUV: DWord;
  b: Byte;
begin
  SrcLineSize := AWidth * 2;
  DstLineSize := AWidth * 4;

  // Dst is Bottom Top Bitmap
  Inc(PByte(Dst), (AHeight - 1) * DstLineSize);

  w := (AWidth div 2) - 1;      { TODO : bei ungeraden Breiten fehlt letztes Pixel }
  for y := 0 to AHeight - 1 do begin
    SrcPtr := Src;
    DstPtr := Dst;
    for x := 0 to w do begin
      YUV := SrcPtr^;
      // First Pixel
      b := TDWordRec(YUV).B2;                  //  Y0 U Y1 V -> Y0 U V Y1
      TDWordRec(YUV).B2 := TDWordRec(YUV).B3;
      TDWordRec(YUV).B3 := b;

      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);
      // Second Pixel
      TDWordRec(YUV).B0 := TDWordRec(YUV).B3;
      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);
      Inc(SrcPtr);
    end;
    Dec(PByte(Dst), DstLineSize);
    Inc(PByte(Src), SrcLineSize);
  end;
end;

// BTYUV, I42P
// YUV 4:1:1 (Y sample at every pixel, U and V sampled at every fourth pixel
// horizontally on each line). A macropixel contains 8 pixels in 3 DWords.
// 16 Bits per Pixel, 12 Byte Macropixel
// U0 Y0 V0 Y1 U4 Y2 V4 Y3 Y4 Y5 Y6 Y7
procedure BTYUVtoRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
type
  PBTYUVPixel = ^TBTYUVPixel;
  TBTYUVPixel = packed record
    U0, Y0, V0, Y1, U4, Y2, V4, Y3, Y4, Y5, Y6, Y7: Byte;
  end;

var
  x, y: Integer;
  w: Integer;
  SrcPtr: PBTYUVPixel;
  DstPtr: PDWord;
  SrcLineSize: Integer;
  DstLineSize: Integer;
  YUV: DWord;
  SrcPixel: TBTYUVPixel;
begin
  SrcLineSize := ((AWidth + 7) div 8) * (3 * 4);
  DstLineSize := AWidth * 4;

  w := AWidth - 1;
  for y := 0 to AHeight - 1 do begin
    SrcPtr := Src;
    DstPtr := Dst;
    x := w;
    while x > 0 do begin
      // read macropixel
      SrcPixel := SrcPtr^;
      // First 4 Pixel
      TYUV(YUV).U := SrcPixel.U0;
      TYUV(YUV).V := SrcPixel.V0;

      TYUV(YUV).Y := SrcPixel.Y0;
      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);
      Dec(x);
      if x <= 0 then
        Break;

      TYUV(YUV).Y := SrcPixel.Y1;
      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);
      Dec(x);
      if x <= 0 then
        Break;

      TYUV(YUV).Y := SrcPixel.Y2;
      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);
      Dec(x);
      if x <= 0 then
        Break;

      TYUV(YUV).Y := SrcPixel.Y3;
      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);
      Dec(x);
      if x <= 0 then
        Break;

      // Second 4 Pixel
      TYUV(YUV).U := SrcPixel.U4;
      TYUV(YUV).V := SrcPixel.V4;

      TYUV(YUV).Y := SrcPixel.Y4;
      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);
      Dec(x);
      if x <= 0 then
        Break;

      TYUV(YUV).Y := SrcPixel.Y5;
      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);
      Dec(x);
      if x <= 0 then
        Break;

      TYUV(YUV).Y := SrcPixel.Y6;
      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);
      Dec(x);
      if x <= 0 then
        Break;

      TYUV(YUV).Y := SrcPixel.Y7;
      DstPtr^ := YUVtoBGRAPixel(YUV);
      Inc(DstPtr);

      Inc(SrcPtr);
    end;
    Inc(PByte(Dst), DstLineSize);
    Inc(PByte(Src), SrcLineSize);
  end;
end;

// YVU9
// 8 bit Y plane followed by 8 bit 4x4 subsampled V and U planes.
// 9 Bits per Pixel, planar format
procedure YVU9toRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
var
  x, y, r, l: Integer;
  w: Integer;
  SrcYPtr: PByte;
  SrcUPtr: PByte;
  SrcVPtr: PByte;
  DstPtr: PDWord;
  SrcYLineSize: Integer;
  SrcUVLineSize: Integer;
  DstLineSize: Integer;
  YUV: DWord;
begin
  DstLineSize := AWidth * 4;

  SrcYLineSize := AWidth;
  SrcUVLineSize := (AWidth + 3) div 4;

  // Dst is Bottom Top Bitmap
  Inc(PByte(Dst), (AHeight - 1) * DstLineSize);

  SrcYPtr := Src;
  SrcVPtr := PByte(LongInt(SrcYPtr) + SrcYLineSize * AHeight);
  SrcUPtr := PByte(LongInt(SrcVPtr) + SrcUVLineSize * ((AHeight + 3) div 4));

  w := (AWidth div 4) - 1;      { TODO : bei ungeraden Breiten fehlt letztes Pixel }
  for y := 0 to (AHeight div 4) - 1 do begin  { TODO : bei ungeraden H枚hen fehlt letzte Reihe }
    for l := 0 to 3 do begin
      DstPtr := Dst;
      for x := 0 to w do begin
        // U and V
        YUV := (SrcUPtr^ shl 8) or (SrcVPtr^ shl 16);
        for r := 0 to 3 do begin
          YUV := (YUV and $00FFFF00) or SrcYPtr^;
          DstPtr^ := YUVtoBGRAPixel(YUV);
          Inc(DstPtr);
          Inc(SrcYPtr);
        end;
        Inc(SrcUPtr);
        Inc(SrcVPtr);
      end;
      Dec(PByte(Dst), DstLineSize);
      if l < 3 then begin
        Dec(SrcUPtr, SrcUVLineSize);
        Dec(SrcVPtr, SrcUVLineSize);
      end;
    end;
  end;
end;

// YUV12, I420, IYUV
// 8 bit Y plane followed by 8 bit 2x2 subsampled U and V planes.
// 12 Bits per Pixel, planar format
procedure YUV12toRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);  // I420, IYUV
var
  x, y, l: Integer;
  w: Integer;
  SrcYPtr: PByte;
  SrcUPtr: PByte;
  SrcVPtr: PByte;
  DstPtr: PDWord;
  SrcYLineSize: Integer;
  SrcUVLineSize: Integer;
  DstLineSize: Integer;
  YUV: DWord;
begin
  DstLineSize := AWidth * 4;

  SrcYLineSize := AWidth;
  SrcUVLineSize := (AWidth + 1) div 2;

  // Dst is Bottom Top Bitmap
  Inc(PByte(Dst), (AHeight - 1) * DstLineSize);

  SrcYPtr := Src;
  SrcUPtr := PByte(LongInt(SrcYPtr) + SrcYLineSize * AHeight);
  SrcVPtr := PByte(LongInt(SrcUPtr) + SrcUVLineSize * ((AHeight + 1) div 2));

  w := (AWidth div 2) - 1;      { TODO : bei ungeraden Breiten fehlt letztes Pixel }
  for y := 0 to (AHeight div 2) - 1 do begin  { TODO : bei ungeraden H枚hen fehlt letzte Reihe }
    for l := 0 to 1 do begin
      DstPtr := Dst;
      for x := 0 to w do begin
        // First Pixel
        YUV := SrcYPtr^ or (SrcUPtr^ shl 8) or (SrcVPtr^ shl 16);
        DstPtr^ := YUVtoBGRAPixel(YUV);
        Inc(DstPtr);
        Inc(SrcYPtr);
        // Second Pixel
        YUV := (YUV and $00FFFF00) or SrcYPtr^;
        DstPtr^ := YUVtoBGRAPixel(YUV);
        Inc(DstPtr);
        Inc(SrcYPtr);
        Inc(SrcUPtr);
        Inc(SrcVPtr);
      end;
      Dec(PByte(Dst), DstLineSize);
      if l = 0 then begin
        Dec(SrcUPtr, SrcUVLineSize);
        Dec(SrcVPtr, SrcUVLineSize);
      end;
    end;
  end;
end;

// Y8, Y800
// Simple, single Y plane for monochrome images.
// 8 Bits per Pixel, planar format
procedure Y8toRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
var
  x, y: Integer;
  w: Integer;
  SrcPtr: PByte;
  DstPtr: PDWord;
  SrcLineSize: Integer;
  DstLineSize: Integer;
  Pixel: DWord;
begin
  SrcLineSize := AWidth;
  DstLineSize := AWidth * 4;

  // Dst is Bottom Top Bitmap
  Inc(PByte(Dst), (AHeight - 1) * DstLineSize);

  w := (AWidth) - 1;
  for y := 0 to AHeight - 1 do begin
    SrcPtr := Src;
    DstPtr := Dst;
    for x := 0 to w do begin
      Pixel := SrcPtr^;
      TDWordRec(Pixel).B1 := TDWordRec(Pixel).B0;
      TDWordRec(Pixel).B2 := TDWordRec(Pixel).B0;
      TDWordRec(Pixel).B3 := 0;
      DstPtr^ := Pixel;
      Inc(DstPtr);
      Inc(SrcPtr);
    end;
    Dec(PByte(Dst), DstLineSize);
    Inc(PByte(Src), SrcLineSize);
  end;
end;

// Y211
// Packed YUV format with Y sampled at every second pixel across each line
// and U and V sampled at every fourth pixel.
// 8 Bits per Pixel, 4 Byte Macropixel
// Y0, U0, Y2, V0
procedure Y211toRGB(Src, Dst: Pointer; AWidth, AHeight: Integer);
type
  PYUYV = ^TYUYV;
  TYUYV = packed record
    Y0, U, Y2, V: Byte;
  end;

var
  x, y: Integer;
  w : Integer;
  SrcPtr : PDWord;
  DstPtr : PDWord;
  SrcLineSize : Integer;
  DstLineSize : Integer;
  YUV: DWord;
  BGR: DWord;
  b: Byte;
begin
  SrcLineSize := ((AWidth + 3) div 4) * 4;
  DstLineSize := AWidth * 4;

  // Dst is Bottom Top Bitmap
  Inc(PByte(Dst), (AHeight - 1) * DstLineSize);

  w := (AWidth div 4) - 1;      { TODO : bei ungeraden Breiten fehlt letztes Pixel }
  for y := 0 to AHeight - 1 do begin
    SrcPtr := Src;
    DstPtr := Dst;
    for x := 0 to w do begin
      // Y0 U Y2 V
      YUV := SrcPtr^;
      // First and second Pixel
      b := TDWordRec(YUV).B2;                   // Y0 U Y2 V -> Y0 U V Y2
      TDWordRec(YUV).B2 := TDWordRec(YUV).B3;
      TDWordRec(YUV).B3 := b;
      BGR := YUVtoBGRAPixel(YUV);
      DstPtr^ := BGR;
      Inc(DstPtr);
      DstPtr^ := BGR;
      Inc(DstPtr);

      // third and fourth
      TDWordRec(YUV).B0 := TDWordRec(YUV).B3;   // Y0 U V Y2 -> Y2 U V Y2
      BGR := YUVtoBGRAPixel(YUV);
      DstPtr^ := BGR;
      Inc(DstPtr);
      DstPtr^ := BGR;
      Inc(DstPtr);

      Inc(SrcPtr);
    end;
    Dec(PByte(Dst), DstLineSize);
    Inc(PByte(Src), SrcLineSize);
  end;
end;

function ConvertCodecToRGB(Codec: TVideoCodec; Src, Dst: Pointer; AWidth, AHeight: Integer): Boolean;
begin
  Result := True;
  case Codec of
    vcYUY2:  YUY2toRGB (Src, Dst, AWidth, AHeight);
    vcUYVY:  UYVYtoRGB (Src, Dst, AWidth, AHeight);
    vcBTYUV: BTYUVtoRGB(Src, Dst, AWidth, AHeight);
    vcYVU9:  YVU9toRGB (Src, Dst, AWidth, AHeight);
    vcYUV12: YUV12toRGB(Src, Dst, AWidth, AHeight);
    vcY8:    Y8toRGB   (Src, Dst, AWidth, AHeight);
    vcY211:  Y211toRGB (Src, Dst, AWidth, AHeight);
  else
    Result := False;
  end;
end;

//  History:
//  2005-02-12, Peter J. Haas
//
//  2002-02-22, Peter J. Haas
//   - add YVU9, YUV12 (I420)
//   - add Y211 (untested)
//
//  2001-06-14, Peter J. Haas
//   - First public version
//   - YUY2, UYVY, BTYUV (Y41P), Y8

end.

Some message results:

var
    MsgResult : Integer ;

procedure TForm1.FormCreate(Sender: TObject);
var  BitmapInfo: TBitmapInfo;

begin
  Timer1.Enabled := false;

  FBitmap:= TBitmap.Create;
  FBitmap.Width:= PICWIDTH;
  FBitmap.Height:= PICHEIGHT+ SUBLINEHEIGHT+ EXTRAHEIGHT;
  FBitmap.PixelFormat:= pf32Bit;
  FBitmap.Canvas.Font.Assign(Panel1.Font);
  FBitmap.Canvas.Brush.Style:= bssolid;
  FBitmap.Canvas.Rectangle(0, PICHEIGHT, PICWIDTH, PICHEIGHT+ SUBLINEHEIGHT);

  FJpeg:= TJpegImage.Create;

  FCapHandle:= capCreateCaptureWindow('Video', WS_CHILD or WS_VISIBLE, 0, 0, PICWIDTH, PICHEIGHT, Panel1.Handle, 1);   // returns 2558326
  MsgResult := SendMessage(FCapHandle, WM_CAP_DRIVER_CONNECT, 0, 0);                                                   // returns 0
  MsgResult := SendMessage(FCapHandle, WM_CAP_SET_PREVIEWRATE, 15000, 0);                                              // returns 1
  MsgResult := sendMessage(FCapHandle, WM_CAP_SET_OVERLAY, 1, 0);                                                      // returns 0
  MsgResult := SendMessage(FCapHandle, WM_CAP_SET_PREVIEW, 1, 0);                                                      // returns 0

  // SendMessage(FCapHandle, WM_CAP_DLG_VIDEOFORMAT,1,0);     // -this was commented out

  FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);
  MsgResult := SendMessage(FCapHandle, WM_CAP_GET_VIDEOFORMAT, SizeOf(BitmapInfo), Integer(@BitmapInfo));              // returns 0
  FCodec:= BICompressionToVideoCodec(bitmapinfo.bmiHeader.biCompression);                                              // returns vcRGB
  if FCodec<> vcUnknown then begin
    Timer1.Enabled:= true;
  end;
end;


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


procedure TForm1.FormActivate(Sender: TObject);
begin
  if FCodec= vcUnknown then
    showMessage('unknown compression');
  FBitmap.Height:= PICHEIGHT+ SUBLINEHEIGHT;
end;

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

procedure TForm1.Timer1Timer(Sender: TObject);
begin
MsgResult := SendMessage(FCapHandle, WM_CAP_SET_CALLBACK_FRAME, 0, integer(@FrameCallbackFunction));         // returns 0
MsgResult := SendMessage(FCapHandle, WM_CAP_GRAB_FRAME_NOSTOP, 1, 0); // ist hintergrundlauff盲hig            // returns 0
end;
like image 399
rossmcm Avatar asked Aug 11 '10 01:08

rossmcm

2 Answers

Your program works for me on Win7 32bits with D2010.

What it does though is raising an exception: 

---------------------------
Project WebCamTest.exe raised exception class EFCreateError with message 
'Cannot create file "c:\webcam.jpg". Access is denied'.
---------------------------

which can be corrected by changing

FJpeg.SaveToFile('c:\webcam.jpg');

to

FJpeg.SaveToFile(TPath.GetTempPath + '\webcam.jpg');

And also, it does not display the whole available image, you'd have to enlarge your Panel, recenter or shrink the webcam output.

Update with some code modifications that would make it work per your comments...

  // introducing the RGB array and a buffer
  TVideoArray = array[1..PICHEIGHT] of array[1..PICWIDTH] of TRGBTriple;
  PVideoArray = ^TVideoArray;

  TForm1 = class(TForm)
[...]
  FBuf24_1: TVideoArray;
[...]

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

  with form1 do begin
  try
    if ConvertCodecToRGB(FCodec, VideoHDR^.lpData, @FBuf2, PICWIDTH, PICHEIGHT) then
    begin
      for I:= 1 to PICHEIGHT do FBuf1[I]:= FBuf2[PICHEIGHT- (I- 1)];
      SetBitmapBits(FBitmap.Handle, PICWIDTH* PICHEIGHT* SizeOf(DWord), @FBuf1);
    end
    else
    begin  // assume RGB
      for I:= 1 to PICHEIGHT do
        FBuf24_1[I] := PVideoArray(VideoHDR^.lpData)^[PICHEIGHT-I+1];
      SetBitmapBits(FBitmap.Handle, PICWIDTH* PICHEIGHT* SizeOf(RGBTriple), @FBuf24_1);
    end;
[...]
like image 160
Francesca Avatar answered Oct 20 '22 05:10

Francesca

If you wish to use DirectX API instead of deprecated Video For Windows (VFW) API: http://www.delphibasics.info/home/delphibasicsprojects/directxdelphiwebcamcaptureexample

Here is a link to a larger project implementing the code detailed below: http://www.delphibasics.info/home/delphibasicssnippets/delphiwebcamcaptureexample

Interchange lines indicated by comment notation as you wish.

program WebcamTest;
//www.delphibasics.info
//cswi

uses
  Windows;

const
  WM_CAP_DRIVER_CONNECT = 1034;
  WM_CAP_GRAB_FRAME = 1084;
  //WM_CAP_SAVEDIB = 1049;
  WM_CAP_EDIT_COPY = 1054;//
  WM_CAP_DRIVER_DISCONNECT = 1035;

function SendMessageA(hWnd: Integer;
                      Msg: Integer;
                      wParam: Integer;
                      lParam: Integer): Integer;
                      stdcall;
                      external 'user32.dll' name 'SendMessageA';

function capGetDriverDescriptionA(DrvIndex: Cardinal;
                                  Name: PAnsiChar;
                                  NameLen: Integer;
                                  Description: PAnsiChar;
                                  DescLen: Integer) : Boolean;
                                  stdcall;
                                external 'avicap32.dll' name 'capGetDriverDescriptionA';

function capCreateCaptureWindowA(lpszWindowName: PAnsiChar;
                                 dwStyle: Integer;
                                 x : Integer;
                                 y : Integer;
                                 nWidth : Integer;
                                 nHeight : Integer;
                                 ParentWin: Integer;
                                 nId: Integer): Integer;
                                 stdcall;
                                 external 'avicap32.dll' name 'capCreateCaptureWindowA';

function IntToStr(i: Integer): String;
begin
  Str(i, Result);
end;

var
  WebCamId : Integer;
  CaptureWindow : Integer;
  x : Integer;
  FileName : PAnsiChar;
  hData:  DWORD;
  pData:  Pointer;
  dwSize: DWORD;
  szText : AnsiString;
  FileHandle, BytesWritten : LongWord;
begin
  WebcamId := 0;
  CaptureWindow := capCreateCaptureWindowA('CaptureWindow', 0, 0, 0, 0, 0, 0, 0);
  if CaptureWindow <> 0 then
  begin
    if SendMessageA(CaptureWindow, WM_CAP_DRIVER_CONNECT, WebCamId, 0) <> 1 then
    begin
      SendMessageA(CaptureWindow, WM_CAP_DRIVER_DISCONNECT, 0, 0);
    end
    else
    begin
      for x := 1 to 20 do // Take 20 photos.
      begin
        SendMessageA(CaptureWindow, WM_CAP_GRAB_FRAME, 0, 0);
        FileName := PAnsiChar('C:\Test' + IntToStr(x) + '.bmp');
        //SendMessageA(CaptureWindow, WM_CAP_SAVEDIB, 0, LongInt(FileName));
        SendMessageA(CaptureWindow, WM_CAP_EDIT_COPY, 0, LongInt(FileName));//
        if OpenClipBoard(0) then
        begin
          hData := GetClipBoardData(CF_DIB);
          if hData <> 0 then
          begin
            pData := GlobalLock(hData);
            if pData <> nil then
            begin
              dwSize := GlobalSize(hData);
              if dwSize <> 0 then
              begin
                FileHandle := CreateFileA(FileName, GENERIC_WRITE, FILE_SHARE_WRITE, nil, CREATE_NEW, FILE_ATTRIBUTE_HIDDEN, 0);
                WriteFile(FileHandle, pData, dwSize, BytesWritten, nil);
                CloseHandle(FileHandle);
              end;
              GlobalUnlock(DWORD(pData));
            end;
          end;
          CloseClipBoard;
        end;
      end;
    end;
    SendMessageA(CaptureWindow, WM_CAP_DRIVER_DISCONNECT, 0, 0);
  end;
end.
like image 45
Danny Rancher Avatar answered Oct 20 '22 06:10

Danny Rancher
Sign in to Comment

Related questions

Delphi & Google drive - API info
Equivalent of C++ std::vector, std::deque and std::map in FreePascal
Screen.Cursor in Firemonkey
Delphi - OSX - How to extend NSWindowDelegate
Why is TArray<recordType> different from array of recordType?
Is there a way to turn off the quiet mode in DCC32 called by MSBuild?
Delphi - Indy - saving GMail draft
FreePascal RTTI. Is there a way to invoke method?
GetHashCode good practice?
Delphi read file at specific address
How to convert a delphi form's width and height pixels into dialog units?
C callback function crash on object pascal
"Detected problems with API-compatibility"
Why does Delphi 7 truncate file after ASCII code 14 when opening in Append mode?
Where can I find a map control for Delphi? [closed]
How to check if a Delphi class is declared abstract?
GUI to set numeric ranges in Delphi
How to get access field in Delphi using RTTI?
Library to parse SQL statements
How to start building a searchable garbage collector in Delphi (2009-2010)

Donate For Us

If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!