VB代码VB小程序:实现USB摄像头视频图像的监控、截图、录像

admin管理员组

文章数量:1530842

2024年7月13日发(作者：)

VB代码VB小程序：实现USB摄像头视

频图像的监控、截图、录像

2012-04-19 weikong66 文章来源 阅 2583 转 81

转藏到我的图书馆

微信分享：

VB代码VB小程序：实现USB摄像头视频图像的监控、截图、录像

2010-10-10 0:36

当前位置：首页>VB 小程序> 实现USB摄像头视频图像的监控、截图、录像

54. 实现USB摄像头视频图像的监控、截图、录像

本程序是“摄像头视频监控”的改进，仅用四个按钮实现对摄像头视频的监控

像，可以分别保存为图片文件和视频文件。保存的视频文件可以用媒体播放机（Win

Player）、 暴风影音等软件进行播放，轻松实现家庭录像制作。

利用电脑配备的 USB 摄像头进行视频控制，要用到两个 API 函数：

capCreateCaptureWindow 和 SendMessage。

capCreateCaptureWindow 的作用是创建一个视频窗口，摄像头捕捉到的视频

口内显示，函数返回值就是代表此窗口的句柄。此函数的 VB 声明：

Private Declare Function capCreateCaptureWindow Lib "avica

Alias "capCreateCaptureWindowA" (ByVal lpszWindowName As String, ByVal

Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeigh

ByVal hwndParent As Long, ByVal nID As Long) As Long

Dim ctCapWin As Long

各参数意义如下：

lpszWindowName 视频窗口的窗口标题

dwStyle 窗口模式，设置值可用下面数值，也可组合使用：

WS_Child：视频窗口是子窗口，位于应用程序主窗口内

立的窗口。

WS_Visible：视频窗口可见

WS_Caption：视频窗口有标题栏

WS_ThickFrame：视频窗口有边框

X 视频窗口位置x坐标

Y 视频窗口位置y坐标

nWidth 视频窗口宽度

nHeight 视频窗口高度

hwndParent 创建视频窗口的主窗口，设置为：

nID 视频ID

视频窗口创建后，剩下的事情就是用 SendMessage 向该窗口发送各种消息，

头的控制。

' '以下是完整代码，在 VB6 和 WindowsXP 下调试通过：

'在窗体放置4个控件：Command1、Command2、Command3、Command4

'程序调试时要注意：终止程序要用运行中的 Form1 窗口关闭。不要使用 VB 主窗口的菜单命

令或 VB 工具栏上的关闭按钮，这样无法关闭打开的视频窗口，导致 VB 无响应。如果 VB 无

响应，只有用系统任务管理器才能终止 VB 进程，调试过程中所做的修改将丢失。

'本人原创，转载请注明来源：

/100bd/blog/item/

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd

As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function capCreateCaptureWindow Lib "" Alias

"capCreateCaptureWindowA" (ByVal lpszWindowName As String, ByVal dwStyle As Long,

ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal

hwndParent As Long, ByVal nID As Long) As Long

Dim ctCapWin As Long, ctAviPath As String, ctPicPath As String, ctConnect As Boolean

'视频窗口控制消息常数

Const WS_Child = &H40000000: Const WS_Visible = &H10000000

Const WS_Caption = &HC00000: Const WS_ThickFrame = &H40000

Const WM_User = &H400 '用户消息开始号

Const WM_CAP_Connect = WM_User + 10 '连接一个摄像头

Const WM_CAP_DisConnect = WM_User + 11 '断开一个摄像头的连接

Const WM_CAP_Set_PreView = WM_User + 50 '使预览模式有效或者失效

Const WM_CAP_Set_Overlay = WM_User + 51 '使窗口处于叠加模式，也会自动地使

预览模式失效。

Const WM_CAP_Set_PreViewRate = WM_User + 52 '设置在预览模式下帧的显示频率

Const WM_CAP_Edit_Copy = WM_User + 30 '将当前图像复制到剪贴板

Const WM_CAP_Sequence = WM_User + 62 '开始录像，录像未结束前不会返

回。

Const WM_Cap_File_Set_File = WM_User + 20 '设置当前的视频捕捉文件

Const WM_Cap_File_Get_File = WM_User + 21 '得到当前的视频捕捉文件

Private Sub Form_Load()

'设置按钮及位置，实际可以在控件设计期间完成

Dim H1 As Long

n = "摄像头控制"

n = "连接": pText = "连接摄像头"

n = "断开": pText = "断开与摄像头的连接"

n = "截图": pText = "将当前图像保存为图片文件

"

n = "录像": pText = "开始录像，保存为视频文件

"

H1 = ight("A")

H1 * 0.5, H1 * 0.5, H1 * 4, H1 * 2

H1 * 5, H1 * 0.5, H1 * 4, H1 * 2

H1 * 10, H1 * 0.5, H1 * 4, H1 * 2

H1 * 15, H1 * 0.5, H1 * 4, H1 * 2

'读出用户设置

Call ReadSaveSet

KjEnabled True

End Sub

Private Sub Command1_Click()

'创建视频窗口和连接摄像头

Dim nStyle As Long, T As Long

If ctCapWin = 0 Then '创建一个视频窗口，大小：640*480

T = ( + * 1.1, ode,

3) '视频窗口垂直位置：像素

'nStyle = WS_Child + WS_Visible + WS_Caption + WS_ThickFrame '子窗

口(在Form1内)+可见+标题栏+边框

nStyle = WS_Child + WS_Visible '视频窗口无标题栏和边框

'nStyle = WS_Visible '视频窗口为独立窗口，关闭主窗口视频窗口也会自

动关闭

ctCapWin = capCreateCaptureWindow("我创建的视频窗口", nStyle, 0,

T, 640, 480, , 0)

End If

'将视频窗口连接到摄像头，如无后面两条语句视频窗口画面不会变化

SendMessage ctCapWin, WM_CAP_Connect, 0, 0 '连接摄像头

SendMessage ctCapWin, WM_CAP_Set_PreView, 1, 0 '第三个参数：1-

预览模式有效,0-预览模式无效

SendMessage ctCapWin, WM_CAP_Set_PreViewRate, 30, 0 '第三个参数：设置预

览显示频率为每秒 30 帧

ctConnect = True: KjEnabled True

'"请检检查摄像头连接，并确定没有其他用户和程序使用。"

End Sub

Private Sub Command2_Click()

SendMessage ctCapWin, WM_CAP_DisConnect, 0, 0 '断开摄像头连接

ctConnect = False: KjEnabled True

End Sub

Private Sub Command3_Click()

'截图,保存为图片文件

Dim F As String, S As Long, nPath As String, nStr As String

nPath = Trim(ctPicPath)

If nPath = "" Then nPath = & "MyPic"

If Right(nPath, 1) <> "" Then nPath = nPath & ""

On Error Resume Next

Do

S = S + 1

F = nPath & "MyPic-" & S & ".bmp"

If Dir(F, 23) = "" Then Exit Do

Loop

On Error GoTo 0

nStr = Trim(InputBox("设置图片保存的文件名:", "保存图片", F))

If nStr = "" Then Exit Sub

Call CutPathFile(nStr, nPath, F) '分解出文件和目录

If Not MakePath(nPath) Then

MsgBox "在指定的位置无法建立目录：" & vbCrLf & nPath, vbInformation,

"保存图片文件"

Exit Sub

End If

ctPicPath = nPath: F = nPath & F

If Dir(F, 23) <> "" Then

If vbCancel = MsgBox("文件已存在，覆盖此文件吗？" & vbCrLf & F,

vbInformation + vbOKCancel, "截图 - 文件覆盖") Then Exit Sub

On Error GoTo Cuo

SetAttr F, 0

Kill F

On Error GoTo 0

End If

: SendMessage ctCapWin, WM_CAP_Edit_Copy, 0, 0 '将当前图

像复制到剪贴板

SavePicture a, F '保存为 Bmp 图像，要保存为 jpg 格式，参

见： 将图片保存或转变为JPG格式

Exit Sub

Cuo:

MsgBox "无法写文件：" & vbCrLf & F, vbInformation, "保存文件"

End Sub

Private Sub Command4_Click()

'用摄像头录像，并保存为视频文件

'如果不设置文件路径和名称，或路径不存在，视频窗口会使用默认文件名

C:

Dim F As String, S As Long, nPath As String, nStr As String

nPath = Trim(ctAviPath)

If nPath = "" Then nPath = & "MyVideo"

If Right(nPath, 1) <> "" Then nPath = nPath & ""

On Error Resume Next

Do

S = S + 1

F = nPath & "MyVideo-" & S & ".avi"

If Dir(F, 23) = "" Then Exit Do

Loop

On Error GoTo 0

nStr = Trim(InputBox("设置录像保存的文件名:", "录像保存的文件名", F))

If nStr = "" Then Exit Sub

Call CutPathFile(nStr, nPath, F) '分解出文件和目录

If Not MakePath(nPath) Then

MsgBox "在指定的位置无法建立目录：" & vbCrLf & nPath, vbInformation,

"保存文件"

Exit Sub

End If

ctAviPath = nPath: F = nPath & F

If Dir(F, 23) <> "" Then

If vbCancel = MsgBox("文件已存在，覆盖此文件吗？" & vbCrLf & F,

vbInformation + vbOKCancel, "视频 - 文件覆盖") Then Exit Sub

On Error GoTo Cuo

SetAttr F, 0

Kill F

On Error GoTo 0

End If

n = "摄像头控制 - 正在录像（任意位置单击鼠标停止）": KjEnabled

False: DoEvents

SendMessage ctCapWin, WM_Cap_File_Set_File, 0, ByVal F '设置录像保存的文

件

SendMessage ctCapWin, WM_CAP_Sequence, 0, 0 '开始

录像。录像未结束前不会返回

n = "摄像头控制": KjEnabled True

Exit Sub

Cuo:

MsgBox "无法写文件：" & vbCrLf & F, vbInformation, "保存文件"

End Sub

Private Function CutPathFile(nStr As String, nPath As String, nFile As String)

'分解出文件和目录

Dim I As Long, S As Long

For I = 1 To Len(nStr)

If Mid(nStr, I, 1) = "" Then S = I '查找最后一个目录分隔符

Next

If S > 0 Then

nPath = Left(nStr, S): nFile = Mid(nStr, S + 1)

Else

nPath = "": nFile = nStr

End If

End Function

Private Function MakePath(ByVal nPath As String) As Boolean

'逐级建立目录,成功返回 T

Dim I As Long, Path1 As String, IsPath As Boolean

nPath = Trim(nPath)

If Right(nPath, 1) <> "" Then nPath = nPath & ""

On Error GoTo Exit1

For I = 1 To Len(nPath)

If Mid(nPath, I, 1) = "" Then

Path1 = Left(nPath, I - 1)

If Dir(Path1, 23) = "" Then

MkDir Path1

Else

IsPath = GetAttr(Path1) And 16

If Not IsPath Then Exit Function '有一个同名的文件

End If

End If

Next

MakePath = True: Exit Function

Exit1:

End Function

Private Sub Form_Unload(Cancel As Integer)

Call ReadSaveSet(True) '保存用户设置

End Sub

Private Sub KjEnabled(nEnabled As Boolean)

If nEnabled Then

d = Not ctConnect: d = ctConnect

d = ctConnect: d = ctConnect

Else

d = nEnabled: d = nEnabled

d = nEnabled: d = nEnabled

End If

End Sub

Private Sub ReadSaveSet(Optional IsSave As Boolean)

'保存或读出用户设置的图片和视频默认保存目录

Dim nKey As String, nSub As String

nKey = "摄像头控制程序": nSub = "UserOpt"

If IsSave Then

SaveSetting nKey, nSub, "AviPath", ctAviPath

SaveSetting nKey, nSub, "PicPath", ctPicPath

Else

ctAviPath = GetSetting(nKey, nSub, "AviPath", "")

ctPicPath = GetSetting(nKey, nSub, "PicPath", "")

End If

End Sub

后记：本程序改进见 摄像头视频图像的监控、截图、录像（改进），改进后的增加了以下功

能：

1.可控制多个视频摄像头。例如，如果一台电脑配置了两个摄像头，启动程序两次，在弹出的

“视频源”对话框中选择不同的捕获源，两个窗口就能同时显示不同摄像头获得的图像。

2.调节视频的亮度、对比度等许多参数。

3.将视频压缩后保存到硬盘，这样得到的视频文件会比默认方式小 10 倍以上。

4.视频窗口有自动大小和全屏功能。在全屏状态时，工具栏按钮会自动隐藏。将鼠标移动到屏

幕顶部，工具栏又会自动显示出来。

'本人原创，转载请注明来源：

/100bd/blog/item/

当前位置：首页>VB 小程序> USB摄像头视频图像的监控、截图、录像

本文标签： 视频摄像头保存