wvideo.pas

Delphi开发高质量频视频捕捉和播放源码。

unit WVideo;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Grids, Buttons, ComCtrls,
  VideoCap, VideoMci, MMSystem;

const
  VIDEO_FILE_NAME = 'VIDEO.AVI';

type
  TVideo = class(TForm)
    Label1: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label6: TLabel;
    Panel1: TPanel;
    VideoArea: TPanel;
    Image1: TImage;
    CancelBtn: TBitBtn;
    StartVideoBtn: TBitBtn;
    StopVideoBtn: TBitBtn;
    Edit1: TEdit;
    UpDown1: TUpDown;
    SingleImageBtn: TBitBtn;
    StartDspBtn: TBitBtn;
    StopDspBtn: TBitBtn;
    VideoFormatBtn: TBitBtn;
    VideoDisplayBtn: TBitBtn;
    VideoSourceBtn: TBitBtn;
    VideoTBar: TTrackBar;
    StoreVideoFrameBBtn: TBitBtn;
    CapRBtn: TRadioButton;
    MciRBtn: TRadioButton;
    LoopCBox: TCheckBox;
    Label2: TLabel;
    Label7: TLabel;
    VideoLabel: TLabel;
    procedure CancelBtnClick(Sender: TObject);
    procedure StartVideoBtnClick(Sender: TObject);
    procedure StopVideoBtnClick(Sender: TObject);
    procedure VideoSourceBtnClick(Sender: TObject);
    procedure VideoDisplayBtnClick(Sender: TObject);
    procedure SingleImageBtnClick(Sender: TObject);
    procedure VideoFormatBtnClick(Sender: TObject);
    procedure CapRBtnClick(Sender: TObject);
    procedure MciRBtnClick(Sender: TObject);
    procedure StartDspBtnClick(Sender: TObject);
    procedure StopDspBtnClick(Sender: TObject);
		procedure CapStatus(Sender: TObject);
    procedure StoreVideoFrameBBtnClick(Sender: TObject);
    procedure VideoTBarChange(Sender: TObject);
		procedure MciStatus(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
    procedure MciNotify ( var Msg:TMessage ); message MM_MCINOTIFY;
  public
    { Public declarations }
  end;

var
  Video: TVideo;

implementation

{$R *.DFM}

(*---------------------------------------------------------------*)
procedure TVideo.CapRBtnClick(Sender: TObject);
var
  MyCapStatusProc : TCapStatusProc;
begin
 		// Stop MCI - Video
	MciClose;

 		// Start CAP -  Video
	CapSetVideoArea( VideoArea );
  CapSetInfoLabel( VideoLabel );
  MyCapStatusProc := CAPStatus;
	CapSetStatusProcedure( MyCapStatusProc );
	if CapOpenDriver then
  begin
		CapSetCapSec( 15 * 3 );
		CapShow;
    if NOT CapHasDlgVSource  then VideoSourceBtn.Enabled  := FALSE;
    if NOT CapHasDlgVDisplay then VideoDisplayBtn.Enabled := FALSE;
    if NOT CapHasDlgVFormat  then VideoFormatBtn.Enabled  := FALSE;
	end;
end;

(*----------------------------------------------------------------------*)
(* -- Button: C A N C E L ----------------------------------------------*)
(*----------------------------------------------------------------------*)
procedure TVideo.CancelBtnClick(Sender: TObject);
begin
		// Close CAP - Video
	CapCloseDriver;

 		// Stop MCI - Video
	MciClose;;
end;

(*---------------------------------------------------------------*)
procedure TVideo.CAPStatus(Sender: TObject);
begin
	Panel1.Color := clBtnFace;
	Panel1.Refresh;
	StopVideoBtn.Enabled  := FALSE;
	StartVideoBtn.Enabled := TRUE;
end;

(*---------------------------------------------------------------*)
procedure TVideo.StartVideoBtnClick(Sender: TObject);
begin
	Panel1.Color := clRed;
  Panel1.Refresh;
	StopVideoBtn.Enabled  := TRUE;
	StartVideoBtn.Enabled := FALSE;
	CapSetCapSec( StrToInt(Edit1.Text)*15);

		// Start video capture to file
	CapStart;
end;

(*---------------------------------------------------------------*)
procedure TVideo.StopVideoBtnClick(Sender: TObject);
begin
	CapStop;
	Panel1.Color := clBtnFace;
	Panel1.Refresh;
	StopVideoBtn.Enabled  := FALSE;
	StartVideoBtn.Enabled := TRUE;
end;

(*---------------------------------------------------------------*)
procedure TVideo.VideoSourceBtnClick(Sender: TObject);
begin
	CapDlgVSource;
end;

(*---------------------------------------------------------------*)
procedure TVideo.VideoDisplayBtnClick(Sender: TObject);
begin
	CapDlgVDisplay;
end;

(*---------------------------------------------------------------*)
procedure TVideo.VideoFormatBtnClick(Sender: TObject);
begin
	CapDlgVFormat;
end;

(*---------------------------------------------------------------*)
procedure TVideo.SingleImageBtnClick(Sender: TObject);
var
  SingleImageFileName : string;
begin
		// Save Video as Bitmap to file in TEMP-Path
	SingleImageFileName := 'Image1.bmp';
  CapSetSingleImageFileName( SingleImageFileName );
	CapGrabSingleFrame;
	CapSetVideoLive;
end;


(*---------------------------------------------------------------*)
(*--- M C I - FUNCTIONS ---*)
(*---------------------------------------------------------------*)
procedure TVideo.MciRBtnClick(Sender: TObject);
var
  NoOfFrames      : Integer;
  MyMciStatusProc : TMciStatusProc;
begin
		// Close CAP - Video
	CapCloseDriver;

 		// Start MCI - Video
	MciSetVideoArea( VideoArea );
	MciSetVideoFileName( 'VIDEO.AVI' );
	MciSetVideoHandle( Video.Handle );

	NoOfFrames := MciGetNoOfFrames;
  if NoOfFrames > 0 then
  begin
    VideoTBar.Visible := TRUE;
		VideoTBar.Max := 99;
    VideoTBar.Min := 0;
    VideoTBar.Max := NoOfFrames-1;
    VideoTBar.Position := 0;
  end
  else
  begin
		StoreVideoFrameBBtn.Enabled := FALSE;
  	VideoTBar.Enabled := FALSE;
	end;

  MyMciStatusProc := MciStatus;
	MciSetStatusProcedure( MyMciStatusProc );
	MciOpen;
end;

(*---------------------------------------------------------------*)
procedure TVideo.StartDspBtnClick(Sender: TObject);
begin
	StopDspBtn.Enabled  := TRUE;
	StartDspBtn.Enabled := FALSE;
	VideoTBar.Enabled   := FALSE;
	StoreVideoFrameBBtn.Enabled := FALSE;
	if VideoTBar.Position >= VideoTBar.Max then
		VideoTBar.Position := 0;
	MciPlay( VideoTBar.Position );
end;

(*---------------------------------------------------------------*)
procedure TVideo.StopDspBtnClick(Sender: TObject);
begin
	LoopCBox.Checked := FALSE;
	MciStop;
	StopDspBtn.Enabled  := FALSE;
	StartDspBtn.Enabled := TRUE;
	VideoTBar.Enabled   := TRUE;
  StoreVideoFrameBBtn.Enabled := TRUE;

  	// Get actual Frame Position
	VideoTBar.Position := MciGetPos;
	VideoTBar.Refresh;
end;

(*---------------------------------------------------------------*)
procedure TVideo.StoreVideoFrameBBtnClick(Sender: TObject);
var
	TmpBmp : TBitmap;
begin
	TmpBmp := TBitmap.Create;

		// Get actual Image as BMP
  if MciFrameToBmp( TmpBmp ) then
  begin
	  	// Save Bitmap to file
		TmpBmp.SaveToFile( 'Image2.bmp' );
	end;

  TmpBmp.free;
end;

(*---------------------------------------------------------------*)
procedure TVideo.VideoTBarChange(Sender: TObject);
begin
  MciSeek( VideoTBar.Position );
end;

(*---------------------------------------------------------------*)
procedure TVideo.MciNotify( var Msg:TMessage );
begin
	MciStatus(nil);
  Msg.Result := 0;
end;

(*---------------------------------------------------------------*)
procedure TVideo.MciStatus(Sender: TObject);
var
  ActPos : Integer;
begin
	StopDspBtn.Enabled  := FALSE;
	StartDspBtn.Enabled := TRUE;

	VideoTBar.Enabled   := TRUE;
	StoreVideoFrameBBtn.Enabled := TRUE;

  	// Get actual Frame Position
	ActPos := MciGetPos;
	if ActPos >= VideoTBar.Max
  	then VideoTBar.Position := 0
    else VideoTBar.Position := ActPos;
	VideoTBar.Refresh;

  if LoopCBox.Checked then
		StartDspBtnClick(Sender);  
end;

(*---------------------------------------------------------------*)
procedure TVideo.FormShow(Sender: TObject);
begin
   MciRBtn.Checked := FALSE;
   CapRBtn.Checked := FALSE;
end;

end.