Delphi 控制摄像头操作

真如客 發表於 2020-12-18 23:51:00

DELPHI控制摄像头操作可以使用TVideoCap控件，或直接使用MS的AVICAP32.DLL就可轻松的实现对摄像头编程。
首先常量定义和函数定义：
implementation const WM_CAP_START = WM_USER; const WM_CAP_STOP = WM_CAP_START + 68; const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10; const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11; const WM_CAP_SAVEDIB = WM_CAP_START + 25; const WM_CAP_GRAB_FRAME = WM_CAP_START + 60; const WM_CAP_SEQUENCE = WM_CAP_START + 62; const WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20; const WM_CAP_SEQUENCE_NOFILE =WM_CAP_START+  63 ; const WM_CAP_SET_OVERLAY =WM_CAP_START+  51 ; const WM_CAP_SET_PREVIEW =WM_CAP_START+  50 ; const WM_CAP_SET_CALLBACK_VIDEOSTREAM = WM_CAP_START +6; const WM_CAP_SET_CALLBACK_ERROR=WM_CAP_START +2; const WM_CAP_SET_CALLBACK_STATUSA= WM_CAP_START +3; const WM_CAP_SET_CALLBACK_FRAME= WM_CAP_START +5; const WM_CAP_SET_SCALE=WM_CAP_START+  53 ; const WM_CAP_SET_PREVIEWRATE=WM_CAP_START+  52 ; function capCreateCaptureWindowA(lpszWindowName : PCHAR; dwStyle : longint; x : integer; y : integer; nWidth : integer; nHeight : integer; ParentWin : HWND; nId : integer): HWND; STDCALL EXTERNAL 'AVICAP32.DLL'; {$R *.dfm}
打开Delphi，添加Panel1到Form1上，定义一个全局变量，var hWndC : THandle; 添加button1 ，caption为激活摄像头：
procedure TForm1.Button1Click(Sender: TObject); begin hWndC := capCreateCaptureWindowA('My Own Capture Window', WS_CHILD or WS_VISIBLE , Panel1.Left, Panel1.Top, Panel1.Width, Panel1.Height, Form1.Handle, 0); if hWndC <> 0 then SendMessage(hWndC, WM_CAP_SET_CALLBACK_VIDEOSTREAM, 0, 0); SendMessage(hWndC, WM_CAP_SET_CALLBACK_ERROR, 0, 0); SendMessage(hWndC, WM_CAP_SET_CALLBACK_STATUSA, 0, 0); SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0); SendMessage(hWndC, WM_CAP_SET_SCALE, 1, 0); SendMessage(hWndC, WM_CAP_SET_PREVIEWRATE, 66, 0); //SendMessage(hWndC, WM_CAP_SEQUENCE_NOFILE, 1, 0); SendMessage(hWndC, WM_CAP_SET_OVERLAY, 1, 0); SendMessage(hWndC, WM_CAP_SET_PREVIEW, 1, 0); end;
添加button2 ，caption为关闭摄像头：
procedure TForm1.Button2Click(Sender: TObject); begin if hWndC <> 0 then begin SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0); hWndC := 0; end; end; 
添加button3 ，caption为保存为BMP图像：
procedure TForm1.Button3Click(Sender: TObject); begin if hWndC <> 0 then begin SendMessage(hWndC,WM_CAP_SAVEDIB,0,longint(pchar('c:\\test.bmp'))); end; end;
添加button4 ，caption为开始录像：
procedure TForm1.Button4Click(Sender: TObject); begin if hWndC <> 0 then begin SendMessage(hWndC,WM_CAP_FILE_SET_CAPTURE_FILEA,0, Longint(pchar('c:\\test.avi'))); SendMessage(hWndC, WM_CAP_SEQUENCE, 0, 0); end; end; 
添加button5 ，caption为停止录像：
procedure TForm1.Button5Click(Sender: TObject); begin if hWndC <> 0 then begin SendMessage(hWndC, WM_CAP_STOP, 0, 0); end; end;
添加button6，caption为退出：
procedure TForm1.Button6Click(Sender: TObject); begin close; end; 
可以添加MediaPlayer和opendialog控件
添加button7，caption为加载视频：
procedure TForm1.Button7Click(Sender: TObject); begin openDialog1.DefaultExt := 'avi'; openDialog1.Filter := 'avi files (*.avi)|*.avi';
if OpenDialog1.Execute  then begin  if (MediaPlayer1.DeviceID<>0) then   begin     if (MediaPlayer1.Mode=mpplaying) then MediaPlayer1.Stop;   end;
 MediaPlayer1.FileName:=openDialog1.FileName;  //MediaPlayer1.DisplayRect.Top:=panel2.Top;  //MediaPlayer1.DisplayRect.Left:=panel2.left;  //MediaPlayer1.DisplayRect.Right:=panel2.Height;  //MediaPlayer1.DeviceType   :=dtAutoSelect;  Mediaplayer1.Open;  MediaPlayer1.Play;  end; end;
如果电脑没有摄像头，panel就会黑黑的，可以尝试安装SoftCam虚拟摄像头。
关于摄像头编程，大家也可以看看这组VCL组件：DSPack，DSPack是一套使用微软Direct Show和DirectX技术的类和组件，设计工作于DirectX 9，支持系统Win9X, ME, 2000和Windows XP。
视屏聊天按数据压缩传输给对方，显示出来，不是那么简单。
<div>
<table border="0"><colgroup><col></colgroup>
<tbody valign="top">
<tr>
<td valign="middle">
unit Unit1;
interface
uses   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   Dialogs, StdCtrls, ExtCtrls, MPlayer;
type   TForm1 = class(TForm)     Button1: TButton;     Panel1: TPanel;     Button2: TButton;     Button3: TButton;     Button4: TButton;     Button5: TButton;     Button6: TButton;     Button7: TButton;     OpenDialog1: TOpenDialog;     MediaPlayer1: TMediaPlayer;     procedure Button1Click(Sender: TObject);     procedure Button2Click(Sender: TObject);     procedure Button3Click(Sender: TObject);     procedure Button4Click(Sender: TObject);     procedure Button5Click(Sender: TObject);     procedure Button7Click(Sender: TObject);     procedure Button6Click(Sender: TObject);   private
    { Private declarations }   public     { Public declarations }   end;
var   Form1: TForm1;    hWndC : THandle;
implementation const WM_CAP_START = WM_USER; const WM_CAP_STOP = WM_CAP_START + 68; const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10; const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11; const WM_CAP_SAVEDIB = WM_CAP_START + 25; const WM_CAP_GRAB_FRAME = WM_CAP_START + 60; const WM_CAP_SEQUENCE = WM_CAP_START + 62; const WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20; const WM_CAP_SEQUENCE_NOFILE =WM_CAP_START+  63 ; const WM_CAP_SET_OVERLAY =WM_CAP_START+  51 ; const WM_CAP_SET_PREVIEW =WM_CAP_START+  50 ; const WM_CAP_SET_CALLBACK_VIDEOSTREAM = WM_CAP_START +6; const WM_CAP_SET_CALLBACK_ERROR=WM_CAP_START +2; const WM_CAP_SET_CALLBACK_STATUSA= WM_CAP_START +3; const WM_CAP_SET_CALLBACK_FRAME= WM_CAP_START +5; const WM_CAP_SET_SCALE=WM_CAP_START+  53 ; const WM_CAP_SET_PREVIEWRATE=WM_CAP_START+  52 ; function capCreateCaptureWindowA(lpszWindowName : PCHAR; dwStyle : longint; x : integer; y : integer; nWidth : integer; nHeight : integer; ParentWin : HWND; nId : integer): HWND; STDCALL EXTERNAL 'AVICAP32.DLL'; {$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject); begin hWndC := capCreateCaptureWindowA('My Own Capture Window', WS_CHILD or WS_VISIBLE , Panel1.Left, Panel1.Top, Panel1.Width, Panel1.Height, Form1.Handle, 0); if hWndC <> 0 then SendMessage(hWndC, WM_CAP_SET_CALLBACK_VIDEOSTREAM, 0, 0); SendMessage(hWndC, WM_CAP_SET_CALLBACK_ERROR, 0, 0); SendMessage(hWndC, WM_CAP_SET_CALLBACK_STATUSA, 0, 0); SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0); SendMessage(hWndC, WM_CAP_SET_SCALE, 1, 0); SendMessage(hWndC, WM_CAP_SET_PREVIEWRATE, 66, 0); //SendMessage(hWndC, WM_CAP_SEQUENCE_NOFILE, 1, 0); SendMessage(hWndC, WM_CAP_SET_OVERLAY, 1, 0); SendMessage(hWndC, WM_CAP_SET_PREVIEW, 1, 0); end;
procedure TForm1.Button2Click(Sender: TObject); begin if hWndC <> 0 then begin SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0); hWndC := 0; end; end;
procedure TForm1.Button3Click(Sender: TObject); begin if hWndC <> 0 then begin SendMessage(hWndC,WM_CAP_SAVEDIB,0,longint(pchar('c:\\test.bmp'))); end; end;
procedure TForm1.Button4Click(Sender: TObject); begin if hWndC <> 0 then begin SendMessage(hWndC,WM_CAP_FILE_SET_CAPTURE_FILEA,0, Longint(pchar('c:\\test.avi'))); SendMessage(hWndC, WM_CAP_SEQUENCE, 0, 0); end; end;
procedure TForm1.Button5Click(Sender: TObject); begin if hWndC <> 0 then begin SendMessage(hWndC, WM_CAP_STOP, 0, 0); end; end;
procedure TForm1.Button7Click(Sender: TObject); begin openDialog1.DefaultExt := 'avi'; openDialog1.Filter := 'avi files (*.avi)|*.avi';
if OpenDialog1.Execute  then begin  if (MediaPlayer1.DeviceID<>0) then   begin     if (MediaPlayer1.Mode=mpplaying) then MediaPlayer1.Stop;   end;
 MediaPlayer1.FileName:=openDialog1.FileName;  //MediaPlayer1.DisplayRect.Top:=panel2.Top;  //MediaPlayer1.DisplayRect.Left:=panel2.left;  //MediaPlayer1.DisplayRect.Right:=panel2.Height;  //MediaPlayer1.DeviceType   :=dtAutoSelect;  Mediaplayer1.Open;  MediaPlayer1.Play;  end; end;
procedure TForm1.Button6Click(Sender: TObject); begin close; end;
end.
//= == =====================
object Form1: TForm1   Left = 192   Top = 114   Width = 658   Height = 422   Caption = '摄像头操作'   Color = clBtnFace   Font.Charset = DEFAULT_CHARSET   Font.Color = clWindowText   Font.Height = -11   Font.Name = 'MS Sans Serif'   Font.Style = []   OldCreateOrder = False   PixelsPerInch = 96   TextHeight = 13   object Button1: TButton     Left = 536     Top = 8     Width = 97     Height = 41     Caption = '激活摄像头'     TabOrder = 0     OnClick = Button1Click   end   object Panel1: TPanel     Left = 0     Top = 0     Width = 521     Height = 385     Caption = '摄像头尚未激活中'     TabOrder = 1     object MediaPlayer1: TMediaPlayer       Left = 200       Top = 16       Width = 253       Height = 33       TabOrder = 0     end   end   object Button2: TButton     Left = 536     Top = 56     Width = 97     Height = 41     Caption = '关闭摄像头'     TabOrder = 2     OnClick = Button2Click   end   object Button3: TButton     Left = 536     Top = 112     Width = 97     Height = 41     Caption = '保存为BMP图片'     TabOrder = 3     OnClick = Button3Click   end   object Button4: TButton     Left = 536     Top = 160     Width = 97     Height = 41     Caption = '开始录像'     TabOrder = 4     OnClick = Button4Click   end   object Button5: TButton     Left = 536     Top = 208     Width = 97     Height = 41     Caption = '停止录像'     TabOrder = 5     OnClick = Button5Click   end   object Button6: TButton     Left = 536     Top = 320     Width = 97     Height = 41     Caption = '退出'     TabOrder = 6     OnClick = Button6Click   end   object Button7: TButton     Left = 536     Top = 256     Width = 97     Height = 49     Caption = '加载视频'     TabOrder = 7     OnClick = Button7Click   end   object OpenDialog1: TOpenDialog     Left = 464     Top = 24   end end

</td>

</tr>

</tbody>

</table>

</div>
摘录自：Delphi摄像头操作 http://yxmhero1989.blog.163.com/blog/static/112157956201102703433980/
试写的Delphi摄像头照相（抓图）小软件  http://www.codefans.net/soft/8385.shtml Delphi 激活摄像头  http://hi.baidu.com/warrially/blog 利用Delphi编程控制摄像头 http://www.haoxiai.net/bianchengyuyan/Delphi/84272.html http://blog.csdn.net/walkershrek/archive/2007/12/04/1915440.aspx 关与Usb摄像头问题  http://group.gimoo.net/review/142849 MTPlay V1.0 摄像头视频捕捉程序  www.hackcode.com 用Delphi开发视频捕获(摄像头拍照)程序 http://www.delphibbs.com/keylife/iblog_show.asp?xid=15554 Delphi实现摄像头拍照能 http://www.xuedelphi.cn/wenzhang/mrjq/gjyy/2008/11/200811232621.htm 用Delphi控制摄像头编程（转载）http://blog.ednchina.com/999wjc/4230/message.aspx http://blog.csdn.net/walkershrek/archive/2007/12/04/1915429.aspx VB编写控制摄像头程序  http://down.bbs156.cn/exef1226.html 一个用VC写的视屏聊天工具(源代码) http://www.trydone.com/posts/list/301.page GraghDialog.rar   http://www.hackchina.com/cont/182020

</div>
<div id="MySignature" role="contentinfo">
好的代码像粥一样，都是用时间熬出来的 
来源：https://www.cnblogs.com/jijm123/p/14157698.html

頁: [1]

琼殿技术论坛's Archiver

Delphi 控制摄像头操作