1. Inicio
  2. Pregunta y respuesta
  3. Obtener una instantánea de una cámara web con Delphi

Obtener una instantánea de una cámara web con Delphi

2010-08-11 13 views
6

Necesito obtener una instantánea regular de una cámara web en Delphi. La velocidad no es un problema (una vez por segundo está bien). He intentado el código de demostración basado en cosas del http://delphi.pjh2.de pero no puedo hacerlo funcionar. Se compila y funciona bien, pero la función de devolución de llamada nunca se dispara.Obtener una instantánea de una cámara web con Delphi

No tengo una cámara web real, pero estoy ejecutando en su lugar un simulador. El simulador funciona (puedo ver el video usando Skype) pero no con la aplicación de prueba. Realmente no sé por dónde empezar a buscar ...

¿Alguien puede molestarse en probar este código? (Disculpas por la voluminosa publicación: no se pudo encontrar cómo o si se pueden adjuntar archivos; un archivo comprimido está disponible here.)

Como alternativa, se apreciará cualquier código de demostración de la cámara web, preferiblemente con un buen EXE conocido y fuente.

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.

Algunos resultados de mensajes:

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;

Fuente

2010-08-11 rossmcm

+0

¿Alguno de los mensajes WM_CAP ... devuelve errores? –

+0

Hola, Remy, mira mis ediciones a la pregunta - los resultados del mensaje son comentarios a la derecha. Gracias. R. – rossmcm

Respuesta

5

Su programa funciona para mí en Win7 32bits con D2010.

Lo que sin embargo no está levantando una excepción:

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

que se puede corregir cambiando

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

a

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

Y también, que no muestra la totalidad imagen disponible, tendría que agrandar su Panel, volver a centrar o reducir la salida de la cámara web.

actualización con algunas modificaciones de código que lo harían funcionar por sus comentarios ...

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

Fuente

2010-08-11 06:01:33

+0

En mi sistema, da como resultado el mensaje que recibe son: WM_CAP_DRIVER_CONNECTMsgResult = false WM_CAP_SET_PREVIEWRATEMsgResult = true WM_CAP_SET_OVERLAYMsgResult = false WM_CAP_SET_PREVIEWMsgResult = false WM_CAP_SET_CALLBACK_FRAMEMsgResult = true WM_CAP_GRAB_FRAME_NOSTOPMsgResult = false y FrameCallbackFunction nunca se dispara . Parece que no está conectando. – rossmcm

+0

Claramente no puedes conectarte a la cámara web. ¿Has probado con un controlador de captura que no sea 0? Puede ser de 0 a 9. ¿Quizás tienes más de 1 y la cámara web no es el índice 0? 'MsgResult: = SendMessage (FCapHandle, WM_CAP_DRIVER_CONNECT, x, 0);' –

+0

Gracias François. En este momento no tengo cámaras web, solo un simulador. El simulador parece ir en que Skype puede ver la "cámara" OK. Intenté llamar a SendMessage (FCapHandle, WM_CAP_DRIVER_CONNECT, x, 0); con x = 0 a 9 y todos devolvieron falso. Por cierto, ¿cómo fue posible formatear el texto como código en el comentario? – rossmcm

0

que utilizan un componente llamado TVideoCap. Es para 3, 4 y 5, pero incluye fuente, por lo que es fácil de actualizar. Hará exactamente lo que quieras. Solo haz una búsqueda de 'TVideoCap'.

Fuente

2010-08-11 03:48:12 David

+0

Gracias, lo comprobaré. ¿Tiene algún EXE que haya producido utilizando esta unidad que pueda darme que funcione? Solo quiero verificar que no haya nada intrínsecamente incorrecto en mi sistema.R – rossmcm

+0

Hola David, descargué VideoCap e instalé una cámara web real, mis resultados son los mismos que en la respuesta anterior, ahora que tengo una cámara web real, luego trato de conectarme a un controlador, el cuadro de diálogo se abre y me pide que seleccione la fuente, pero la conexión no puede ser de todos modos – rossmcm

1

Si desea utilizar la API DirectX en lugar de vídeo obsoleto para Windows (VFW) API: http://www.delphibasics.info/home/delphibasicsprojects/directxdelphiwebcamcaptureexample

Aquí hay un enlace a un proyecto más amplio de desarrollo del código se detalla a continuación: http://www.delphibasics.info/home/delphibasicssnippets/delphiwebcamcaptureexample

Líneas de intercambio indicadas por notación de comentario como lo desee.

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.

Fuente

2014-05-03 19:26:13

+0

Gracias Danny. Esos enlaces parecen que hay algunas cosas buenas allí. – rossmcm

Cuestiones relacionadas

 Cuestiones relacionadas