如何使用VFrame(TVideoImage)使用Delphi7从网络摄像头获取快照

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;