1

我在这个过程中使用了 Delphi7 和 VFrames (TVideoImage)

uses  VFrames;
....
procedure TForm1.snapshot;
var
cam:TVideoImage;
strlst:TStringList;
BMP:TBitmap;
begin
strlst := TStringList.Create ; 
cam :=TVideoImage.Create;
cam.GetListOfDevices(strlst);
cam.VideoStart(strlst.Strings[0]); //specify a cam by number
//get snapshot
BMP := TBitmap.Create;
cam.GetBitmap(BMP);
BMP.SaveToFile('test.bmp');
cam.VideoStop;
BMP.Free;
end;

结果空白位图文件。

4

2 回答 2

3

由于GetBitmapTVideoImage 的函数在调用 之后直接调用可能会传递空图像VideoStart，因此可能需要创建TVideoImage添加OnNewVideoFrame事件以获取图像可用的信息。所以步骤是：

  1. 创建并启动
  2. 等待图像并采取它
  3. 自由的

由于问题是要求单次解决方案和线程或空闲循环在VideoStart不起作用后，我将提供一个解决方案来封装上述步骤。

电话是：

procedure TMyForm.FormCreate(Sender: TObject);
begin
  ReportMemoryLeaksOnShutDown := true;
end;

procedure TMyForm.ImgCallBack(BMP:TBitMap);
begin
    Image1.Picture.Assign(BMP);
end;

procedure TMyForm.Button3Click(Sender: TObject);
begin
    With TGrabClass.Create do GetImage(ImgCallBack);
end;

TGrabClass 的基本实现为：

unit u_GrabOnlyBitMap;

interface
uses
  Classes,
  Messages,
  Windows,
  Graphics,
  VSample,
  VFrames;
  type

  TImageCallBack=Procedure(bmp:TBitMap) of Object;

  TGrabClass=Class
     FReady:Boolean;
     FVideo:TVideoImage;
     FBitMap:TBitMap;
     Handle:THandle;
     FImageCallBack:TImageCallBack;
     Procedure GetImage(cb:TImageCallBack);
     Constructor Create;
     Destructor Destroy;Override;
  private
    procedure NewVideoFrameEvent(Sender: TObject; Width, Height: integer;
      DataPtr: pointer);
    procedure WndMethod(var Msg: TMessage);
    procedure Suicide;
  End;
implementation

const
WM_MyKill=WM_user + 666;


// Called by asnc PostMessage with WM_MyKill to free
Procedure TGrabClass.WndMethod(var Msg: TMessage);
begin
   if Msg.Msg = WM_MyKill  then
   begin
     Msg.Result := -1;
     Free;
   end
   else
    Msg.Result := DefWindowProc(Handle, Msg.Msg, Msg.wParam, Msg.lParam);
end;


constructor TGrabClass.Create;
var
 sl:TStringList;
begin
  inherited;
  Handle :=  AllocateHWnd(WndMethod);
  sl:=TStringList.Create;
  FVideo:=TVideoImage.Create;
  FBitMap := TBitmap.Create;
  FVideo.OnNewVideoFrame := NewVideoFrameEvent;
  FVideo.GetListOfDevices(sl);
  FReady := sl.Count > 0;
  if FReady then FVideo.VideoStart(sl[0])
  else Suicide;
  sl.Free;
end;

destructor TGrabClass.Destroy;
begin
  DeallocateHWnd(Handle);
  FVideo.VideoStop;
  FVideo.Free;
  FBitMap.Free;
  inherited;
end;

Procedure TGrabClass.Suicide;
begin
  // No device found Callback with empty image and Postmessage for freeing
  if Assigned(FImageCallBack) then FImageCallBack(FBitMap);
  PostMessage(handle,WM_MyKill,0,0);
end;

Procedure TGrabClass.NewVideoFrameEvent(Sender : TObject; Width, Height: integer; DataPtr: pointer);
begin  // we got a bitmap
   FVideo.OnNewVideoFrame := Nil;
   FVideo.GetBitmap(FBitMap);
   if Assigned(FImageCallBack) then FImageCallBack(FBitMap);
   PostMessage(handle,WM_MyKill,0,0);
end;


procedure TGrabClass.GetImage(cb: TImageCallBack);
begin
    FImageCallBack := cb;
end;

end.
于 2014-10-08T18:12:53.473 回答
3

VFrames我为/做了一个小包装类VSample：

unit u_class_webcam;

interface

uses
  Jpeg,
  Forms,
  VSample,
  VFrames,
  Classes,
  Graphics,
  SysUtils;


type
  TWebcam = class
  private
    Video       : TVideoImage;
    Devices     : TStringList;
    Resolutions : TStringList;
    function GetDeviceReady: Boolean;
    function GetHeight: Integer;
    function GetWidth: Integer;
    function GetActiveDevice: String;
  public
    constructor Create;
    destructor Destroy; override;
    procedure SetDisplayCanvas(const Canvas : TCanvas);
    procedure TakeSnapshot(const Filename : String);
    function TakeSnapshotToBmp : TBitmap;
    procedure Start;
    procedure Stop;
    property DeviceReady : Boolean read GetDeviceReady;
    property Width : Integer read GetWidth;
    property Height : Integer read GetHeight;
    property ActiveDevice : String read GetActiveDevice;
  end;

// webcam singleton
var
  Webcam : TWebcam;

implementation

{ TWebcam }
function TWebcam.GetActiveDevice: String;
begin
 Result := '';
 if Devices.Count > 0 then
  Result := Devices[0];
end;

function TWebcam.GetHeight: Integer;
begin
 Result := Video.VideoHeight;
end;

function TWebcam.GetWidth: Integer;
begin
 Result := Video.VideoWidth;
end;

function TWebcam.GetDeviceReady: Boolean;
begin
 Video.GetListOfDevices(Devices);
 Result := Devices.Count > 0;
end;

procedure TWebcam.SetDisplayCanvas(const Canvas : TCanvas);
begin
 Video.SetDisplayCanvas(Canvas);
end;

function TWebcam.TakeSnapshotToBmp : TBitmap;
begin
 Result := TBitmap.Create;
 Bitmap.PixelFormat := pf24bit;
 Video.GetBitmap(Result);
end;

procedure TWebcam.TakeSnapshot(const Filename: String);

var
  Bitmap : TBitmap;
  Jpeg   : TJpegImage;

begin
 Bitmap := TBitmap.Create;
 JPeg := TJpegImage.Create;
 try
  Bitmap.PixelFormat := pf24bit;
  Video.GetBitmap(Bitmap);
  JPeg.Assign(Bitmap);
  JPeg.SaveToFile(Filename);
 finally
  Bitmap.Free;
  JPeg.Free;
 end;
end;

procedure TWebcam.Start;
begin
 if DeviceReady then
  begin
   Video.VideoStart(Devices[0]);
   Video.GetListOfSupportedVideoSizes(Resolutions);
   Video.SetResolutionByIndex(Resolutions.Count-1);
  end;
end;

procedure TWebcam.Stop;
begin
 if Video.VideoRunning then
  Video.VideoStop;
end;

constructor TWebcam.Create;
begin
 Devices := TStringList.Create;
 Resolutions := TStringList.Create;
 Video := TVideoImage.Create;
end;

destructor TWebcam.Destroy;
begin
 Stop;
 Devices.Free;
 Resolutions.Free;
 Application.ProcessMessages;
 Video.Free;
end;

end.

用法：

procedure TForm1.TestIt;

var Bmp : TBitmap;

begin
 WebCam := TWebCam.Create;
 try
  WebCam.Start;
  WebCam.SetDisplayCanvas(Self.Canvas); 
  Bmp := WebCam.TakeSnapShotToBmp;
  // do something with BMP
  Bmp.Free;
  WebCam.Stop;
 finally
  WebCam.Free;
 end;
end;
于 2013-11-01T12:31:13.067 回答