www.pudn.com > CAPMCI.rar > WVideo.pas

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.