我在这个程序中使用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;
结果空白位图文件.
解决方法
我为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;