Получение моментального снимка с веб-камеры с помощью Delphi

Мне нужно получить обычный снимок с веб-камеры в Delphi. Скорость не является проблемой (один раз в секунду). Я пробовал демо-код на основе материала из http://delphi.pjh2.de, но я не могу заставить его работать. Он компилируется и работает нормально, но функция обратного вызова никогда не срабатывает.

У меня нет реальной веб-камеры, но вместо этого я запускаю симулятор. Симулятор работает (я вижу видео с помощью Skype), но не с тестовым приложением. Я не знаю, с чего начать...

Кто-нибудь может потрудиться, чтобы попробовать этот код? (Извинения за объемный пост - не удалось найти, как или если вы можете прикреплять файлы - доступен zip файл здесь.)

Альтернативно, любой демо-код веб-камеры будет оценен, предпочтительно с известным хорошим EXE, а также с источником.

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 ([removed_email]). 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;
 ******, ValueG, ValueR: Integer;
begin
 ValueY := TYUV(AYUV).Y - 16;
 ValueU := TYUV(AYUV).U - 128;
 ValueV := TYUV(AYUV).V - 128;
 ****** := Trunc(fY * ValueY + fBU * ValueU); // fBV = 0
 if ****** > 255 then
 ****** := 255;
 if ****** < 0 then
 ****** := 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 := ******;
 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.

Некоторые результаты сообщений:

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;
3 ответа

Ваша программа работает для меня на Win7 32bits с D2010.

Что он делает, хотя создает исключение:

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

который можно исправить, изменив

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

к

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

Кроме того, он не отображает все доступное изображение, вам нужно будет увеличить панель, повторно разместить или сжать вывод веб-камеры.

Обновить с некоторыми изменениями кода, которые заставили бы его работать с вашими комментариями...

// 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;
[...]


Если вы хотите использовать DirectX API вместо устаревшего API для видео для Windows (VFW): http://www.delphibasics.info/home/delphibasicsprojects/directxdelphiwebcamcaptureexample

Вот ссылка на более крупный проект, реализующий приведенный ниже код: http://www.delphibasics.info/home/delphibasicssnippets/delphiwebcamcaptureexample

Обмен строк, обозначенных примечанием комментария, как вы пожелаете.

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.


Я использую компонент, называемый TVideoCap. Это для 3, 4 и 5, но включает источник, поэтому его легко обновить. Он будет делать именно то, что вы хотите. Просто выполните поиск "TVideoCap".

licensed under cc by-sa 3.0 with attribution.