delphi - 使用 Delphi 从网络摄像头获取快照

Question

我需要从 Delphi 中的网络摄像头获取常规快照。速度不是问题(每秒一次就可以了)。我已经尝试过基于 http://delphi.pjh2.de 中的内容的演示代码但我无法让它发挥作用。它编译并运行正常，但回调函数永远不会触发。

我没有真正的网络摄像头，但运行的是模拟器。模拟器可以工作(我可以使用 Skype 观看视频)，但不能与测试应用程序一起使用。我真的不知道从哪里开始寻找......

有人愿意尝试一下这段代码吗？ (对冗长的帖子表示歉意 - 找不到如何或是否可以附加文件 - 可以使用 zip 文件 here 。)

或者，任何网络摄像头演示代码都将受到赞赏，最好具有已知的良好 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 (libs@pjh2.de). 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.

一些消息结果:

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;

Answer 1

你的程序适用于我的 Win7 32 位和 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;
[...]