使用Delphi从网络摄像头获取快照
我需要从Delphi中的网络摄像头获取定期快照。速度不是问题（每秒一次就可以了）。我已经尝试了基于的东西演示代码，但我不能让它工作。它编译并运行正常，但回调函数从不启动 我没有一个真正的网络摄像头，而是一个模拟器。模拟器可以工作（我可以使用Skype查看视频），但测试应用程序无法工作。我真的不知道从哪里开始找 有人愿意尝试这个代码吗？（对于大量的帖子表示歉意-无法找到如何或是否可以附加文件-zip文件可用。） 或者，任何网络摄像头演示代码都将受到欢迎，最好是具有已知良好的EXE和源代码使用Delphi从网络摄像头获取快照,delphi,callback,webcam,video-capture,vfw,Delphi,Callback,Webcam,Video Capture,Vfw,我需要从Delphi中的网络摄像头获取定期快照。速度不是问题（每秒一次就可以了）。我已经尝试了基于的东西演示代码，但我不能让它工作。它编译并运行正常，但回调函数从不启动 我没有一个真正的网络摄像头，而是一个模拟器。模拟器可以工作（我可以使用Skype查看视频），但测试应用程序无法工作。我真的不知道从哪里开始找 有人愿意尝试这个代码吗？（对于大量的帖子表示歉意-无法找到如何或是否可以附加文件-zip文件可用。） 或者，任何网络摄像头演示代码都将受到欢迎，最好是具有已知良好的EXE和源代码 prog
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.
程序网络摄像头测试；
使用
形式，
“WebCamMainForm.pas”{Form1}中的WebCamMainForm，
“yuvconverts.pas”中的yuvconverts；
{$R*.res}
开始
应用程序初始化；
Application.CreateForm（TForm1，Form1）；
应用程序。运行；
结束。
单位网络摄像机；
接口
使用
窗口、消息、系统、类、图形、控件、窗体、，
对话框，ExtCtrls，YUVConverts，StdCtrls，JPeg{，TntStdCtrls}；
常数
WM\U CAP\U START=WM\U用户；
WM_CAP_DRIVER_CONNECT=WM_CAP_START+10；
WM_CAP_SET_PREVIEW=WM_CAP_START+50；
WM\U CAP\U SET\U OVERLAY=WM\U CAP\U START+51；
WM\U CAP\U SET\U PREVIEWRATE=WM\U CAP\U 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；
皮宽=640；
皮高=480；
次线高=18；
超高=400；
类型
TVIDEOHDR=记录
lpData:指针；//视频缓冲区地址
dwBufferLength:DWord；//数据缓冲区的大小（字节）
使用的DWBYTESSED:DWord；//见下文
dwTimeCaptured:DWord；//见下文
dwUser:DWord；//用户特定数据
dwFlags:DWord；//见下文
dwReserved1、dwReserved2、dwReserved3:DWord；//保留的；不要使用
结束；
TVIDEOHDRPtr=^TVideoHDR；
DWordDim=DWord的数组[1..PICWIDTH]；
TForm1=类（TForm）
定时器1:TTimer；
小组1：TPanel；
销毁程序表（发送方：TObject）；
过程表单创建（发送方：ToObject）；
激活程序（发送方：TObject）；
程序定时器1定时器（发送方：TObject）；
私有的
FCA手柄：THandle；
FCodec:TVideoCodec；
FBuf1，FBuf2:DWordDim的数组[1..PICHEIGHT]；
FBitmap:TBitmap；
FJpeg:tjpeg图像；
{私营部门}
公众的
{公共部门}
结束；
变量
表1:TForm1；
实施
{$R*.dfm}
函数capCreateCaptureWindow（lpszWindowName:LPCSTR；
dwStyle:DWORD；
x、 y,，
第十四届，
nHeight：整数；
hwndParent:HWND；
nID：整数）：HWND；stdcall；
外部“AVICAP32.DLL”名称“capCreateCaptureWindowA”；
函数帧调用函数（AHandle:hWnd；VIDEOHDR:tvideohdrpter）：bool；stdcall；
变量
I：整数；
开始
结果：=真；
从form1开始
尝试
ConvertCodecToRGB（FCodec，VideoHDR^.lpData，@FBuf2，PICWIDTH，PICHEIGHT）；
对于I:=1到微微高度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.压缩质量：=85；
FJpeg.ProgressiveEncoding:=真；
保存文件（'c:\webcam.jpg'）；
SendMessage（FCapHandle，WM\u CAP\u SET\u CALLBACK\u FRAME，0,0）；
除了
结束；
结束；
结束；
//------------------------------------------------------------------------------
过程TForm1.FormCreate（发送方：TObject）；
变量BitmapInfo:TBitmapInfo；
开始
Timer1.Enabled:=false；
FBitmap:=TBitmap.Create；
FBitmap.Width:=PICWIDTH；
FBitmap.Height:=皮高+次线高+超高；
FBitmap.PixelFormat:=PF32位；
FBitmap.Canvas.Font.Assign（Panel1.Font）；
FBitmap.Canvas.Brush.Style:=bssolid；
FBitmap.Canvas.Rectangle（0，PICHEIGHT，PICWIDTH，PICHEIGHT+子行高）；
FJpeg:=TJpegImage.Create；
FCapHandle:=capCreateCaptureWindow（“视频”，WS_子对象或WS_可见，0，0，PICWIDTH，PICHEIGHT，Panel1.句柄，1）；
发送消息（FCapHandle，WM\u CAP\u DRIVER\u CONNECT，0,0）；
发送消息（FCapHandle，WM\U CAP\U SET\U PREVIEWRATE，15000，0）；
sendMessage（FCapHandle，WM_CAP_SET_OVERLAY，1,0）；
发送消息（FCapHandle，WM\u CAP\u SET\u预览，1，0）；
//发送消息（FCapHandle，WM_CAP_DLG_VIDEOFORMAT，1,0）；//-这被评论掉了
FillChar（BitmapInfo，SizeOf（BitmapInfo），0）；
SendMessage（FCapHandle，WM_CAP_GET_VIDEOFORMAT，SizeOf（BitmapInfo），Integer（@BitmapInfo））；
FCodec:=bicompressionVideoCodec（bitmapinfo.bmiHeader.biCompression）；
如果FCodec vcUnknown，则开始
Timer1.Enabled:=真；
结束；
结束；
程序TForm1.FormDestroy（发送方：ToObject）；
开始
免费；
FJpeg.免费；
结束；
程序TForm1.FormActivate（发送方：ToObject）；
开始
如果FCodec=vcUnknown，则
showMessage（“未知压缩”）；
FBitmap.Height:=皮高+子线高；
结束；
//------------------------------------------------------------------------------
程序TForm1.Timer1Timer（发送方：TObject）；
开始
SendMessage（FCapHandle，WM_CAP_SET_CALLBACK_FRAME，0，integer（@FrameCallbackFunction））；
发送消息（FCapHandle，WM_CAP_GRAB_FRAME_NOSTOP，1，0）；//希特格伦德拉夫酒店盲高
结束；
结束。
对象窗体1:TForm1
左=0
Top=0
标题='Form1'
ClientHeight=301
ClientWidth=562
颜色=clBtnFace
Font.Charset=默认字符集
Font.Color=clWindowText
字体高度=-11
Font.Name='Tahoma'
Font.Style=[]
OldCreateOrder=False
OnActivate=FormActivate
OnCreate=FormCreate
OnDestroy=FormDestroy
PixelsPerInch=96
text高度=13
对象面板1:TPanel
左=48
Top=16
宽度=185
高度=145
标题='Panel1'
TabOrder=0
结束
对象计时器1:TTimer
OnTimer=Timer1Timer
左=464
Top=24
结束
结束
{**************
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;
---------------------------
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;
[...]
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.