www.pudn.com > VideoCam.rar > VideoUnit.pas

unit VideoUnit; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  Videocap,videodisp,vfw, StdCtrls, ExtCtrls, Buttons,syncobjs,IniFiles, 
  ExtDlgs;  //Spin 
 
type 
  TVideoForm = class(TForm) 
    Panel1: TPanel; 
    Btformat: TButton; 
    BtDriver: TButton; 
    Panel3: TPanel; 
    BTCompress: TBitBtn; 
    BitBtn1: TBitBtn; 
    BtSPict: TButton; 
    Button2: TButton; 
    ScrollBox1: TScrollBox; 
    VideoCap1: TVideoCap; 
    BitBtn3: TBitBtn; 
    BitBtn4: TBitBtn; 
    SavePictureDialog1: TSavePictureDialog; 
    SpeedButton1: TSpeedButton; 
    SpeedButton2: TSpeedButton; 
    Label3: TLabel; 
    Label4: TLabel; 
    Label5: TLabel; 
    Label6: TLabel; 
    Panel2: TPanel; 
    imgDestinate: TImage; 
    PaintBox1: TPaintBox; 
    BitBtn2: TBitBtn; 
    procedure FormClose(Sender: TObject; var Action: TCloseAction); 
    procedure BtFormatClick(Sender: TObject); 
    procedure BtDriverClick(Sender: TObject); 
    procedure BTCompressClick(Sender: TObject); 
    procedure BtCapClick(Sender: TObject); 
    procedure BitBtn1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure BtSPictClick(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure CheckBox1Click(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormShow(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
    procedure SpeedButton1Click(Sender: TObject); 
    procedure SpeedButton2Click(Sender: TObject); 
    procedure VideoCap1MouseDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure VideoCap1MouseMove(Sender: TObject; Shift: TShiftState; X, 
      Y: Integer); 
    procedure VideoCap1MouseUp(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure DrawBox(X, Y: Integer); 
    procedure BitBtn2Click(Sender: TObject); 
  private 
    MyHight: Integer; 
    MyWidth: Integer; 
    MyFlag: Boolean; 
    MyGet: Boolean; 
    { Private-Deklarationen} 
  public 
    { Public-Deklarationen} 
  end; 
 
var 
  VideoForm: TVideoForm; 
 
implementation 
 
uses DlgTreiber; 
 
{$R *.DFM} 
 
type 
  TMyCustomControl = class(TCustomControl); 
 
   
procedure TVideoForm.FormClose(Sender: TObject; var Action: TCloseAction); 
var 
  Myini: TInifile; 
begin 
  VideoCap1.StopCapture; 
  Myini := TIniFile.Create(ExtractFilePath(ParamStr(0))+'XYMis.ini'); 
  Myini.WriteInteger('Driver','Index',VideoCap1.DriverIndex); 
  Myini.Free; 
end; 
 
//设置视频格式 
procedure TVideoForm.BtFormatClick(Sender: TObject); 
begin 
  VideoCap1.DlgVFormat; 
end; 
 
//选择设备 
procedure TVideoForm.BtDriverClick(Sender: TObject); 
var 
  DrvList: TStrings; 
begin 
  DlgEinstell := TDlgEinstell.Create(Self); 
  drvList := GetDriverList; 
  dlgEinstell.Combobox1.Items := drvList; 
  VideoCap1.DriverOpen := False; 
  dlgEinstell.ComboBox1.Itemindex := VideoCap1.DriverIndex; 
  if DlgEinstell.ShowModal = mrOK then 
  begin 
    videoCap1.DriverIndex := dlgEinstell.combobox1.ItemIndex; 
  end; 
  VideoCap1.DriverOpen := True; 
  VideoCap1.Videopreview := True; 
  DlgEinstell.Free; 
  drvList.Clear; 
  drvList.Free; 
end; 
 
//压缩格式 
procedure TVideoForm.BTCompressClick(Sender: TObject); 
begin 
  VideoCap1.DlgVCompression; 
end; 
 
procedure TVideoForm.BtCapClick(Sender: TObject); 
begin 
  VideoCap1.CapSingleFrame; 
end; 
 
//设置属性 
procedure TVideoForm.BitBtn1Click(Sender: TObject); 
begin 
  VideoCap1.DlgVSource; 
end; 
 
 
//存到剪贴板 
procedure TVideoForm.Button2Click(Sender: TObject); 
begin 
  VideoCap1.GrabFrameNoStop; 
  VideoCap1.SaveToClipboard; 
end; 
 
//存为BMP 
procedure TVideoForm.BtSPictClick(Sender: TObject); 
begin 
  if SavePictureDialog1.Execute then 
  begin 
    VideoCap1.SingleImageFile := SavePictureDialog1.FileName; 
    VideoCap1.GrabFrameNoStop; 
    if not VideoCap1.SaveAsDib then 
      MessageBox(Handle,'不能保存图片，请与管理员联系！   ','',48) 
    else 
      MessageBox(Handle,'图片保存成功！             ','',64); 
  end; 
end; 
 
//存为AVI 
procedure TVideoForm.Button1Click(Sender: TObject); 
begin 
  if VideoCap1.CapInProgess then 
  begin 
    VideoCap1.StopCapture; 
  end 
  else 
  begin 
    //VideoCap1.VideoFileName := ''; 
    VideoCap1.StartCapture; 
  end; 
end; 
 
//是否满屏显示 
procedure TVideoForm.CheckBox1Click(Sender: TObject); 
begin 
  //videoCap1.PreviewScaleToWindow := CheckBox1.Checked; 
end; 
 
procedure TVideoForm.FormCreate(Sender: TObject); 
var 
  Myini: TIniFile; 
begin 
  Screen.Cursor := crHourGlass; 
  Myini := TIniFile.Create(ExtractFilePath(ParamStr(0))+'XYMis.ini'); 
  VideoCap1.Driverindex := Myini.ReadInteger('Driver','Index',-1); 
  Myini.Free; 
  VideoCap1.VideoPreview := True; 
  Height := Height - Panel1.Height; 
  MyWidth := 150; 
  MyHight := 180; 
  MyFlag := False; 
  MyGet := False; 
  Screen.Cursor := crDefault; 
end; 
 
procedure TVideoForm.FormShow(Sender: TObject); 
begin 
  VideoCap1.DriverOpen := True; 
end; 
 
//开始播放 
procedure TVideoForm.Button3Click(Sender: TObject); 
begin 
  VideoCap1.VideoPreview := True; 
end; 
 
procedure TVideoForm.SpeedButton1Click(Sender: TObject); 
begin 
  if SpeedButton1.Visible then 
  begin 
    Height := Height + Panel1.Height; 
    Panel1.Visible := True; 
    SpeedButton1.Visible := False; 
    SpeedButton2.Visible := True; 
  end; 
end; 
 
procedure TVideoForm.SpeedButton2Click(Sender: TObject); 
begin 
  if SpeedButton2.Visible then 
  begin 
    Height := Height - Panel1.Height; 
    Panel1.Visible := False; 
    SpeedButton2.Visible := False; 
    SpeedButton1.Visible := True; 
  end; 
end; 
 
var 
  oX, oY: Integer; 
 
procedure TVideoForm.VideoCap1MouseDown(Sender: TObject; 
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 
begin 
  VideoCap1.VideoPreview := False; 
  Application.ProcessMessages; 
  MyFlag := True; 
  PaintBox1.Visible := True; 
  oX := -1; 
  oY := -1; 
end; 
 
procedure TVideoForm.VideoCap1MouseMove(Sender: TObject; Shift: TShiftState; 
  X, Y: Integer); 
begin 
  if not MyFlag then Exit; 
  if (oX <> -1) and (oY <> -1) then DrawBox(oX, oY); 
 
  Label5.Caption := IntToStr(X); 
  Label6.Caption := IntToStr(Y); 
  //VideoCap1.Refresh; 
  if (X < MyWidth) or (Y < MyHight) or (X > VideoCap1.Width) or ( Y > VideoCap1.Height) then 
  begin 
    oX := -1; 
    oY := -1; 
    MyGet := False; 
    Screen.Cursor := crDefault; 
    Exit; 
  end 
  else 
  begin 
    Screen.Cursor := -21; 
  end; 
  MyGet := True; 
 
  PaintBox1.Canvas.CopyRect(imgDestinate.ClientRect, TMyCustomControl(VideoCap1).Canvas, Rect(X-MyWidth,Y-MyHight,X,Y)); 
  DrawBox(X, Y); 
  oX := X; 
  oY := Y; 
end; 
 
procedure TVideoForm.VideoCap1MouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
var 
  P: TPoint; 
begin 
  if (oX <> -1) and (oY <> -1) then DrawBox(oX, oY); 
  P := Point(X, Y); 
  PaintBox1.Visible := False; 
  if MyGet then 
    imgDestinate.Canvas.CopyRect(imgDestinate.ClientRect, TMyCustomControl(VideoCap1).Canvas, Rect(X-MyWidth,Y-MyHight,X,Y)); 
  VideoCap1.VideoPreview := True; 
  Screen.Cursor := crDefault; 
  MyFlag := False; 
  MyGet := False; 
end; 
 
procedure TVideoForm.DrawBox(X, Y: Integer); 
begin 
  with TMyCustomControl(VideoCap1).Canvas do 
  begin 
    Pen.Color := clWhite; 
    Pen.Width := 1; 
    Pen.Mode := pmXor; 
    Brush.Style := bsClear; 
    Rectangle(X-MyWidth,Y-MyHight,X,Y); 
  end; 
end; 
 
procedure TVideoForm.BitBtn2Click(Sender: TObject); 
begin 
  Close; 
end; 
 
end.