unit1.pas

制作摄相头的。网上下的

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, XPMan, Capture, Menus, ExtCtrls, ComCtrls;

type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    Cap1: TMenuItem;
    Start: TMenuItem;
    Panel1: TPanel;
    StatusBar1: TStatusBar;
    Stop: TMenuItem;
    Config: TMenuItem;
    VideoSource: TMenuItem;
    VideoFormat: TMenuItem;
    VideoCompression: TMenuItem;
    CanSacle: TMenuItem;
    N2: TMenuItem;
    Exit1: TMenuItem;
    Record1: TMenuItem;
    StartRecord: TMenuItem;
    StopRecord: TMenuItem;
    N3: TMenuItem;
    SaveBMP: TMenuItem;
    Help: TMenuItem;
    About: TMenuItem;
    N1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure StartClick(Sender: TObject);
    procedure StatusBar1DrawPanel(StatusBar: TStatusBar;
      Panel: TStatusPanel; const Rect: TRect);
    procedure StopClick(Sender: TObject);
    procedure VideoSourceClick(Sender: TObject);
    procedure VideoFormatClick(Sender: TObject);
    procedure VideoDisplayClick(Sender: TObject);
    procedure VideoCompressionClick(Sender: TObject);
    procedure CanSacleClick(Sender: TObject);
    procedure Panel1Resize(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure StartRecordClick(Sender: TObject);
    procedure StopRecordClick(Sender: TObject);
    procedure SaveBMPClick(Sender: TObject);
    procedure AboutClick(Sender: TObject);

  private
  public
    { Public declarations }
    FCap: TCapture;
    cmbCap: TComboBox;
    procedure MyMouseDown(Sender: TObject; Button: TMouseButton; X, Y: Integer);
    procedure MyDblClick(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}



procedure TForm1.FormCreate(Sender: TObject);
begin
   cmbCap:=TComboBox.Create(StatusBar1);
   cmbCap.Style:=csOwnerDrawFixed;
   cmbCap.Left:=75;
   cmbCap.Width:=self.Width-83;
   cmbCap.Parent:=StatusBar1;

   FCap:= TCapture.Create(Panel1);
   if FCap.GetCapDevice(cmbCap.Items)=0 then
      ShowMessage('貌似你没装摄像头耶-_-!')
   else
      cmbCap.ItemIndex:=0;

   FCap.OnMouseDown:=MyMouseDown;
   FCap.OnDblClick:=MyDblClick;
end;


procedure TForm1.FormDestroy(Sender: TObject);
begin
   FCap.Free;
   cmbCap.Free;
end;

procedure TForm1.StartClick(Sender: TObject);
begin
   FCap.CapOpen();
   self.Width:=FCap.Width+8;
   self.Height:=FCap.Height+StatusBar1.Height+54;


   Start.Enabled:=false;//menus
   Stop.Enabled:=true;
   VideoSource.Enabled:=true;
   VideoFormat.Enabled:=true;
   VideoCompression.Enabled:=true;
   CanSacle.Enabled:=true;
   StartRecord.Enabled:=true;
   StopRecord.Enabled:=false;
   SaveBMP.Enabled:=true;
end;

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
  Panel: TStatusPanel; const Rect: TRect);
begin
   cmbCap.Width:=self.Width-83;
end;

procedure TForm1.StopClick(Sender: TObject);
begin
   FCap.CapClose;
   FCap.CapStopRecord;

   Start.Enabled:=true;//menus
   Stop.Enabled:=false;
   VideoSource.Enabled:=false;
   VideoFormat.Enabled:=false;
   VideoCompression.Enabled:=false;
   CanSacle.Enabled:=false;
   StartRecord.Enabled:=false;
   StopRecord.Enabled:=false;
   SaveBMP.Enabled:=false;
end;

procedure TForm1.VideoSourceClick(Sender: TObject);
begin
   FCap.CapDlgVideoSource;
end;

procedure TForm1.VideoFormatClick(Sender: TObject);
begin
   FCap.CapDlgVideoFormat;
   self.Width:=FCap.Width+8;
   self.Height:=FCap.Height+StatusBar1.Height+54;
end;

procedure TForm1.VideoDisplayClick(Sender: TObject);
begin
   FCap.CapDlgVideoDisplay;
end;

procedure TForm1.VideoCompressionClick(Sender: TObject);
begin
   FCap.CapDlgVideoCompression;
end;

procedure TForm1.CanSacleClick(Sender: TObject);
begin
   CanSacle.Checked:=not FCap.Scale;
   FCap.Scale:=not FCap.Scale;
end;

procedure TForm1.Panel1Resize(Sender: TObject);
begin
   if FCap=nil then Exit;
   if FCap.Scale then
   begin
      FCap.Width:=Panel1.Width;
      FCap.Height:=panel1.Height;
   end;
end;

procedure TForm1.Exit1Click(Sender: TObject);
begin
   Close;
end;

procedure TForm1.StartRecordClick(Sender: TObject);
begin
   FCap.CapStartRecord('c:\1.avi');
   StartRecord.Enabled:=false;
   StopRecord.Enabled:=true;
end;

procedure TForm1.StopRecordClick(Sender: TObject);
begin
   FCap.CapStopRecord;
   StartRecord.Enabled:=true;
   StopRecord.Enabled:=false;
end;

procedure TForm1.SaveBMPClick(Sender: TObject);
begin
   FCap.CapFileSaveDIB('c:\1.bmp');
end;

procedure TForm1.AboutClick(Sender: TObject);
begin
   MessageBox(self.Handle,PChar('谢谢大家的支持！希望这个对大家有用【⌒_⌒】'),PChar('http://www.2ccc.com'),MB_ICONINFORMATION);
end;



procedure TForm1.MyDblClick(Sender: TObject);
begin
   ShowMessage('我的双击事件');
end;

procedure TForm1.MyMouseDown(Sender: TObject; Button: TMouseButton; X,
  Y: Integer);
begin
   if Button=mbLeft then
      Caption:='VFW摄像头测试程序'+' L('+IntToStr(X)+','+IntToStr(Y)+')'
   else
      Caption:='VFW摄像头测试程序'+' R('+IntToStr(X)+','+IntToStr(Y)+')';
end;


end.