利用电脑配备的 USB 摄像头进行视频控制，要用到两个 API 函数：capCreateCaptureWindow 和 SendMessage。
capCreateCaptureWindow 的作用是创建一个视频窗口，摄像头捕捉到的视频图像在此窗口内显示，函数返回值就是代表此窗口的句柄。此函数的 VB 声明：
Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" 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
各参数意义如下：
lpszWindowName 视频窗口的窗口标题
dwStyle 窗口模式，设置值可用下面数值，也可组合使用：
WS_Child：视频窗口是子窗口，位于应用程序主窗口内。否则是独立的窗口。
WS_Visible：视频窗口可见
WS_Caption：视频窗口有标题栏
WS_ThickFrame：视频窗口有边框
X 视频窗口位置x坐标
Y 视频窗口位置y坐标
nWidth 视频窗口宽度
nHeight 视频窗口高度
hwndParent 创建视频窗口的主窗口，设置为：Me.hWnd
nID 视频ID
视频窗口创建后，剩下的事情就是用 SendMessage 向该窗口发送各种消息，实现对摄像头的控制。
' '以下是完整代码，在 VB6 和 WindowsXP 下调试通过： '在窗体放置4个控件：Command1、Command2、Command3、Command4 ' 程序调试时要注意：终止程序要用运行中的 Form1 窗口关闭。不要使用 VB 主窗口的菜单命令或 VB 工具栏上的关闭按钮，这样无法关闭打开的视频窗口，导致 VB 无响应。如果 VB 无响应，只有用系统任务管理器才能终止 VB 进程，调试过程中所做的修改将丢失。 '本人原创，转载请注明来源：http://hi.baidu.com/100bd/blog/item/52c7978a9b3cdf719f2fb4a5.html 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 "avicap32.dll" Alias "capCreateCaptureWindowA" (ByVal lpszWindowName As String,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 Me.Caption = "摄像头控制" Command1.Caption = "连接": Command1.ToolTipText = "连接摄像头" Command2.Caption = "断开": Command2.ToolTipText = "断开与摄像头的连接" Command3.Caption = "截图": Command3.ToolTipText = "将当前图像保存为图片文件" Command4.Caption = "录像": Command4.ToolTipText = "开始录像，保存为视频文件" H1 = Me.TextHeight("A") Command1.Move H1 * 0.5,H1 * 0.5,H1 * 4,H1 * 2 Command2.Move H1 * 5,H1 * 2 Command3.Move H1 * 10,H1 * 2 Command4.Move H1 * 15,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 = Me.ScaleY(Command1.Top + Command1.Height * 1.1,Me.ScaleMode,3) '视频窗口垂直位置：像素 'nStyle = WS_Child + WS_Visible + WS_Caption + WS_ThickFrame '子窗口(在Form1内)+可见+标题栏+边框 nStyle = WS_Child + WS_Visible '视频窗口无标题栏和边框 'nStyle = WS_Visible '视频窗口为独立窗口，关闭主窗口视频窗口也会自动关闭 ctCapWin = capCreateCaptureWindow("我创建的视频窗口",nStyle,T,640,480,Me.hWnd,0) End If '将视频窗口连接到摄像头，如无后面两条语句视频窗口画面不会变化 SendMessage ctCapWin,WM_CAP_Connect,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 '断开摄像头连接 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 = App.Path & "\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 Clipboard.Clear: SendMessage ctCapWin,WM_CAP_Edit_Copy,0 '将当前图像复制到剪贴板 SavePicture Clipboard.GetData,F '保存为 Bmp 图像，要保存为 jpg 格式，参见： 将图片保存或转变为JPG格式 Exit Sub Cuo: MsgBox "无法写文件：" & vbCrLf & F,"保存文件" End Sub Private Sub Command4_Click() '用摄像头录像，并保存为视频文件 '如果不设置文件路径和名称，或路径不存在，视频窗口会使用默认文件名 C:\CAPTURE.AVI Dim F As String,nStr As String nPath = Trim(ctAviPath) If nPath = "" Then nPath = App.Path & "\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("设置录像保存的文件名:","录像保存的文件名","保存文件" Exit Sub End If ctAviPath = nPath: F = nPath & F If Dir(F,"视频 - 文件覆盖") Then Exit Sub On Error GoTo Cuo SetAttr F,0 Kill F On Error GoTo 0 End If Me.Caption = "摄像头控制 - 正在录像（任意位置单击鼠标停止）": KjEnabled False: DoEvents SendMessage ctCapWin,WM_Cap_File_Set_File,ByVal F '设置录像保存的文件 SendMessage ctCapWin,WM_CAP_Sequence,0 '开始录像。录像未结束前不会返回 Me.Caption = "摄像头控制": KjEnabled True Exit Sub Cuo: MsgBox "无法写文件：" & vbCrLf & F,"保存文件" End Sub Private Function CutPathFile(nStr 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,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 Command1.Enabled = Not ctConnect: Command2.Enabled = ctConnect Command3.Enabled = ctConnect: Command4.Enabled = ctConnect Else Command1.Enabled = nEnabled: Command2.Enabled = nEnabled Command3.Enabled = nEnabled: Command4.Enabled = 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,"PicPath",ctPicPath Else ctAviPath = GetSetting(nKey,"") ctPicPath = GetSetting(nKey,"") End If End Sub
下面程序是“实现USB摄像头视频图像的监控、截图、录像”的改进。可实现对摄像头视频的监控、截图、录像，可以分别保存为图片文件和视频（压缩）文件。保存的视频文件可以用媒体播放机（Windows Media Player）、 暴风影音等软件进行播放，轻松实现家庭录像制作。
利用电脑配备的 USB 摄像头进行视频控制，要用到两个 API 函数：capCreateCaptureWindow 和 SendMessage。其中，capCreateCaptureWindow 的作用是创建一个视频窗口，摄像头捕捉到的视频图像在此窗口内显示，函数返回值就是代表此窗口的句柄。视频窗口创建后，剩下的事情就是用 SendMessage 向该窗口发送各种消息，实现对摄像头的控制。
本程序特点主要有：
1.实现对摄像头视频图像的监控、截图，视频录像并保存为磁盘文件。
2.可控制多个视频摄像头。例如，如果一台电脑配置了两个摄像头，启动本程序两次，单击按钮“源”，在弹出的“视频源”对话框中选择不同的捕获源，两个窗口就能同时显示不同摄像头获得的图像。如下图所示：
3.在“视频源”对话框中，还可以设置视频的亮度、对比度等许多参数：
4.录像时，如果采用默认的 AVI 文件格式，得到的视频文件会很大。单击按钮“压”，在弹出的“视频压缩”对话框中选择压缩方式“MPEG-4”,这样得到的视频文件会比默认方式小 10 倍以上。
5.本程序的视频窗口有自动大小和全屏功能。在全屏状态时，工具栏会自动隐藏。将鼠标移动到屏幕顶部，工具栏又会自动显示出来。
遗憾的是，由于水平有限，本程序无法判断是否使用了压缩记录方式，压缩后的文件其扩展名仍然是 AVI。当然，这并不影响播放，录像完成后也可以手动将扩展名修改为 mpg。其次，录像状态下改变视频窗口大小，有时会出现莫名其妙的错误。这个错误时有时无，毫无规律，因此本程序不得不关闭了录像状态下视频窗口自动大小 的功能。
' '以下是窗体 Form1 的完整代码，在 VB6 和 WindowsXP 下调试通过： '在窗体放置4个控件： ' Command1：在属性窗口将 Index 属性设置为 0 ' Check1： 在属性窗口将 Index 属性设置为 0，将 Style 属性设置为 1 ' Picture1：不必设置任何属性 ' Timer1： 不必设置任何属性 ' 程序调试时要注意：终止程序要用运行中的 Form1 窗口关闭。不要使用 VB 主窗口的菜单命令或 VB 工具栏上的关闭按钮，这样无法关闭打开的视频窗口，导致 VB 无响应。如果 VB 无响应，只有用系统任务管理器才能终止 VB 进程，调试过程中所做的修改将丢失。 '本人原创，转载请注明来源：http://hi.baidu.com/100bd/blog/item/525292c3a37f210d0ff47724.html Public ctCapWin As Long,ctRec As Boolean,ctDir As String,ctF As String,ctAutoSize As Boolean Dim ctRefresh As Boolean,ctConnect As Boolean,ctAutoHide As Boolean,IsFillScreen As Boolean Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long Private Type PointAPI X As Long: Y As Long End Type Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long,ByVal hWndInsertAfter As Long,ByVal cX As Long,ByVal cY As Long,ByVal wFlags As Long) As Long Const HWND_Top = 0 'hWndInsertAfter 参数：Z序列的顶部 Const HWND_TopMost = -1 '最前 Const HWND_NoTopMost = -2 '不在最前 Const HWND_Bottom = 1 '位于底层 Const SWP_NoSize = &H1 'wFlags 参数 Const SWP_NoMove = &H2 Const SWP_NoZorder = &H4 Const SWP_NoActivate = &H10 Const SWP_ShowWindow = &H40 Const SWP_HideWindow = &H80 Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long,lParam As Any) As Long Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long,lParam As Long) As Long Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long,ByVal lParam As Long) As Long Const WM_Close = &H10 Private Declare Function capGetDriverDescriptionA Lib "avicap32.dll" (ByVal wDriver As Integer,ByVal lpszName As String,ByVal cbName As Long,ByVal lpszVer As String,ByVal cbVer As Long) As Boolean Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowW" (ByVal lpszWindowName As String,ByVal nID As Long) As Long Const WS_Child = &H40000000 Const WS_Visible = &H10000000 Const WS_Caption = &HC00000 Const WS_ThickFrame = &H40000 Const GET_Frame = 1084 Const WM_User = &H400 '用户消息开始号，偏移地址:1024 Const WM_CAP_GET_CAPSTREAMPTR = WM_User + 1 ' Const WM_CAP_SET_CALLBACK_ERROR = WM_User + 2 '当出错回调函数 Const WM_CAP_SET_CALLBACK_STATUS = WM_User + 3 '当状态（status）改变的时回调函数 Const WM_CAP_SET_CALLBACK_YIELD = WM_User + 4 '在流捕获期间的回调函数 Const WM_CAP_SET_CALLBACK_FRAME = WM_User + 5 '帧预览回调函数 Const WM_CAP_SET_CALLBACK_VIDEOSTREAM = WM_User + 6 '在流捕获期间，当一个新的视频缓存区可用的时候就调用它 Const WM_CAP_SET_CALLBACK_WAVESTREAM = WM_User + 7 '在流捕获期间，当一个新的音频缓存区可用的时候就调用它 Const WM_CAP_GET_USER_DATA = WM_User + 8 '获取：数据关联到一个捕捉窗口 Const WM_CAP_SET_USER_DATA = WM_User + 9 '设置：数据关联到一个捕捉窗口 Const WM_CAP_DLG_VideoFormat = WM_User + 41 '对话框：视频格式 Const WM_CAP_DLG_VideoSource = WM_User + 42 '对话框：视频源，枚举视频源，控制颜色、对比度、饱和度的改变。需视频驱动程序支技 Const WM_CAP_DLG_VideoDisplay = WM_User + 43 '对话框：视频显示？控制视频捕捉过程中视频在显示器上的显示。对捕捉数据无影响，但会影响数了信号表达式 Const WM_CAP_DLG_VideoCompression = WM_User + 46 '对话框：视频压缩 Private Enum enWinSet ' en_Copy = -1 es_Show = 0 es_Hide es_Close es_Move es_Size End Enum '捕捉文件和缓存 Const WM_Cap_File_Set_File = WM_User + 20 '设置当前的捕捉文件 Const WM_Cap_File_Get_File = WM_User + 21 '得到当前的捕捉文件 Const WM_CAP_FILE_ALLOCATE = WM_User + 22 '为捕捉文件预分配空间,从而可以减少被漏掉的帧 Const WM_CAP_FILE_SaveAs = WM_User + 23 '将捕捉文件保存为另一个用户指定的文件。这个消息不会改变捕捉文件的名字和内容,'由于捕捉文件保留它最初的文件名，因此必须指定个新的文件的文件名来保存 Const WM_CAP_FILE_SET_INFOCHUNK = WM_User + 24 '可以把信息块例如文本或者自定义数据插入avi文件。同样用这个消息也可以清除avi文件中的信息块 Const WM_CAP_FILE_SaveDIB = WM_User + 25 '把从帧缓存中复制出图像存为设备无关位图书馆（DIB),应用程序也可以使用这两个单帧捕捉消息来编辑帧序列， '或者创建一个慢速摄影序列 Const WM_CAP_Edit_Copy = WM_User + 30 '1054：把缓存中图像复制到剪贴板中 Const WM_CAP_SET_AUdioFORMAT = WM_User + 35 '设置音频格式。设置时传入一个WAVEFORMAT、WAVEFORMATEX、或PCMWAVEOFMAT结构的指针 Const WM_CAP_GET_AUdioFORMAT = WM_User + 36 '来得到音频数据的格式和该格式结构体的大小。默认的捕捉音频格式是mono、8-bit和11kHZ PCM Const WM_CAP_Get_VideoFormat = WM_User + 44 '给捕捉窗口来得到视频格式的结构和该结构的大小。 Const WM_CAP_SET_VideoFormat = WM_User + 45 '用来设置视频格式 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_SET_Scale = WM_User + 53 '来使预览模式的缩放有效或者无效 Const WM_CAP_SET_SCROLL = WM_User + 55 '如果是在预览模式或者叠加模式，还可以通过本消息发送给窗口， '在窗口里的用户区域设置视频帧的滚动条的位置 Private Type BitMapInfoHeader 'tagBitMapInfoHeader Structure biSize As Long ' biWidth As Long biHeight As Long 'LONG DWORD biPlanes As Integer 'WORD biBitCount As Integer biCompression As Long biSizeImage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End Type Private Type BitMapInfo bmiHeader As BitMapInfoHeader ' bmiColors As Byte 'RGBQUAD End Type '基本视频捕获消息-------------------------------------- Const WM_CAP_Connect = WM_User + 10 '连接一个视频驱动，成功返回真(1)。连接驱动后，不一定就能显示视频，还要保证摄像头硬件连接良好、未被其他程序使用。 Const WM_CAP_DisConnect = WM_User + 11 '断开视频窗口与驱动的连接 ' wParam：视频设备序号，从 0 到 9 Const WM_CAP_Sequence = WM_User + 62 '开始录像 Const WM_CAP_Stop = WM_User + 68 '终止视频捕获 Const WM_CAP_Abort = WM_User + 69 '暂停录像捕获？，成功返回真 Const WM_CAP_Set_Sequence_Setup = WM_User + 64 Const WM_CAP_Get_Sequence_Setup = WM_User + 65 '录像参数设置和获取 'Dim nParms As CaptureParms 'SendMessage ctCapWin,WM_CAP_Get_Sequence_Setup,Len(nParms),nParms'获取参数的设置 'nParms.fAbortLeftMouse = False '关闭：单击鼠标停止录像的功能。 'SendMessage ctCapWin,WM_CAP_Set_Sequence_Setup,nParms'重新设置参数 Private Type CaptureParms ' dwRequestMicroSecPerFrame As Long 'DWORD fMakeUserHitOKToCapture As Boolean '开始录像时，是否显示确认对话框，默认为假 wPercentDropForError As Long '每毫秒捕捉帧率，默认66667，即每秒15帧 fYield As Boolean 'BOOL:如果为TRUE，将产生一个后台线程来进行视频捕捉 dwIndexSize As Long 'DWORD:视频文件最大的索引入口数 wChunkGranularity As Long 'UINT:以字节为单位表示AVI文件的大小 fUsingDOSMemory As Boolean 'BOOL:未使用 wNumVideoRequested As Long 'UINT:分配视频缓冲区的最大数量 fCaptureAudio As Boolean '是否捕获音频流，默认值由具体的硬件设置 wNumAudioRequested As Long '分配的音频缓冲区的最大数量 vKeyAbort As Long '结束录像的按键，默认为 VK_ESCAPE（Esc键） fAbortLeftMouse As Boolean '单击鼠标左键停止录像，默认为真 fAbortRightMouse As Boolean '单击鼠标右键停止录像，默认为假 fLimitEnabled As Boolean '是否开启捕获时间限制，默认为真 wTimeLimit As Long '捕获时间限制（秒），fLimitEnabled 为真时有效 fMCIControl As Boolean 'BOOL:为TRUE，控制MCI（媒体设备接口）兼容的视频源 fStepMCIDevice As Boolean 'BOOL dwMCIStartTime As Long 'DWORD:以毫秒为单位标识MCI设备视频捕捉序列的起始位置，如果fMCIControl成员为FALSE，该成员被忽略 dwMCIStopTime As Long 'DWORD:以毫秒为单位标识MCI设备视频捕捉序列的停止位置，如果fMCIControl成员为FALSE，该成员被忽略 fStepCaptureAt2x As Boolean 'BOOL:为TRUE，捕捉的视频帧使用两个分辨率 wStepCaptureAverageFrames As Long ':在捕捉时每帧图像使用的时间大小 dwAudioBufferSize As Long '音频缓冲大小，默认0 fDisableWriteCache As Boolean 'Win32系统未使用 AVStreamMaster As Long '确定在写入AVI文件时，音频流是否控制时钟 End Type '视频窗口消息-------------------------------------- 'Private Declare Function capGetDriverDescriptionA Lib "avicap32.dll" ( _ 'ByVal wDriver As Integer,ByVal cbVer As Long) As Boolean '可利用此 API 获取所有驱动程序名称和版本信息。例子： ' Dim S As Long ' Dim lpszName As String * 128 ' Dim lpszVer As String * 128 ' ' Do ' If Not capGetDriverDescriptionA(S,lpszName,128,lpszVer,128) Then Exit Do '获得驱动程序名称和版本信息 ' S = S + 1 ' Loop Const WM_CAP_Get_Status = WM_User + 54 '获取捕捉窗口的当前状态 Private Type CapStatus '■■? uiImageWidth As Long '图像宽度，像素 uiImageHeight As Long '图像高度，像素 fLiveWindow As Boolean '视频显示是否使用预览 fOverlayWindow As Boolean '视频显示是否使用硬件 fScale As Boolean '图像是否随窗口大小自动缩放 ptScroll As PointAPI 'POINT? fUsingDefaultPalette As Boolean '是否使用默认调色板 fAudioHardware As Boolean '是否安装了音频波形硬件 fCapFileExists As Boolean '是否生成了正确的捕获文件 dwCurrentVideoFrame As Long dwCurrentVideoFramesDropped As Long dwCurrentWaveSamples As Long dwCurrentTimeElapsedMS As Long '视频流已录像时间（毫秒） hPalCurrent As Long 'HPALETTE 当前调色板句柄 fCapturingNow As Boolean '是否正在进行捕获 dwReturn As Long '错误返回值，根据这个数值可以调用一个错误回调函数 wNumVideoAllocated As Long '视频缓冲 wNumAudioAllocated As Long '音频缓冲 End Type Private Sub CloseMouse() Dim nParms As CaptureParms SendMessage ctCapWin,nParms '获取参数的设置 'nParms.fMakeUserHitOKToCapture = True '开始录像时，是否显示确认对话框 nParms.fYield = True '用一个后台线程来进行视频捕捉 nParms.fAbortLeftMouse = False '关闭：单击鼠标左键停止录像的功能。 nParms.fAbortRightMouse = False '关闭：单击鼠标右键停止录像的功能 SendMessage ctCapWin,nParms '重新设置参数 'ff = SendMessageLong(ctCapWin,WM_CAP_SET_CALLBACK_STATUS,AddressOf CallBackStatus) '状态回调函数 'ff = SendMessageLong(ctCapWin,WM_CAP_SET_CALLBACK_FRAME,AddressOf MyFrameCallback) '帧回调函数 'ff = SendMessageLong(ctCapWin,WM_CAP_SET_CALLBACK_YIELD,AddressOf CallbackYield) End Sub Private Sub NoRecord() SendMessage ctCapWin,WM_CAP_Stop,0 '停止录像 ctRec = False: Call SetCaption(" ") End Sub Private Sub StartRecord() Dim F As String,nDir As String,nF As String '如果路径不存在，用默认文件名 C:\CAPTURE.AVI nDir = Trim(ctDir) If nDir = "" Or nDir = "<>" Or nDir = "<默认>" Then nDir = App.Path & "\videos" If Right(nDir,1) <> "" Then nDir = nDir & "" If Not MakePath(nDir) Then MsgBox "在指定的位置无法建立目录：" & vbCrLf & nPath,"保存视频文件" Exit Sub End If nF = Trim(ctF) If nF = "" Or nF = "<>" Or nF = "<默认>" Then nF = Format(Now,"yyyymmdd-hhmmss") & ".avi" If InStr(nF,".") = 0 Then nF = nF & ".avi" F = nDir & nF If CheckDirFile(F) = 1 Then If vbNo = MsgBox("文件已存在，覆盖此文件吗？" & vbCrLf & F,vbInformation + vbYesNo,"开始录像") Then Exit Sub On Error GoTo Cuo SetAttr F,0 Kill F On Error GoTo 0 End If ctRec = False SetWin ctCapWin,es_Size,1 ctRec = True Call SetCaption("正在录像：" & nF) Call KjEnabled(True) DoEvents Call CloseMouse SendMessage ctCapWin,ByVal F '设置录像保存的文件 PostMessage ctCapWin,0 '开始录像 If ctAutoHide Then Me.Visible = False Exit Sub Cuo: MsgBox "无法写文件：" & vbvrlf & vbCrLf & F,"录像 - 错误" End Sub ' ' 一篇文章放不下全部代码，这是仅是第一页，转到：第二页'本人原创，转载请注明来源：http://hi.baidu.com/100bd/blog/item/525292c3a37f210d0ff47724.html 第二页 ' ' 一篇文章放不下全部代码，这仅是第二页，转到：第一页 本程序是“实现USB摄像头视频图像的监控、截图、录像”的改进。可实现对摄像头视频的监控、截图、录像，可以分别保存为图片文件和视频（压缩）文件。保存的视频文件可以用媒体播放机（Windows Media Player）、 暴风影音等软件进行播放，轻松实现家庭录像制作。 【转】VB程序VB代码：摄像头视频图像的监控、截图、录像（改进） 【转】VB程序VB代码：摄像头视频图像的监控、截图、录像（改进） 【转】VB程序VB代码：摄像头视频图像的监控、截图、录像（改进） ' ' 一篇文章放不下全部代码，这仅是第二页，转到：第一页 Private Sub SetDir() Dim nStr As String If Trim(ctDir) = "" Then ctDir = App.Path & "\videos" '如果路径不存在，用默认文件名 C:\CAPTURE.AVI nStr = "设置录像保存的文件夹。" & vbCrLf & "输入“<>”表示使用默认文件夹：" & vbCrLf & App.Path & "\videos" nStr = Trim(InputBox(nStr,"录像保存的文件夹",ctDir)) If nStr = "" Then Exit Sub ctDir = nStr If ctDir = "<>" Or ctDir = "<默认>" Then ctDir = "" End Sub Private Sub SetFile() Dim nStr As String,nF As String nF = String(255," ") SendMessage ctCapWin,WM_Cap_File_Get_File,Len(nF),ByVal nF nF = GetStrLeft(nF,vbNullChar) If Trim(ctF) = "" Then ctF = "<默认>" '如果路径不存在，用默认文件名 C:\CAPTURE.AVI nStr = "设置录像保存的文件名(不带路径)。" & vbCrLf & "输入“<>”表示使用默认文件名：日期-时间.扩展名" nStr = Trim(InputBox(nStr,ctF)) If nStr = "" Then Exit Sub ctF = nStr If ctF = "<>" Or ctF = "<默认>" Then ctF = "" SendMessage ctCapWin,ByVal ctF End Sub Private Function GetStrLeft(nStr As String,Fu As String) As String '去掉 Fu 及后面的字符 Dim S As Long S = InStr(nStr,Fu) If S > 0 Then GetStrLeft = Left(nStr,S - 1) Else GetStrLeft = nStr End Function Private Function CheckDirFile(nDirFile) As Long '检查目录或文件夹，返回值：0不存在，1是文件，2是目录 Dim nStr As String,nD As Boolean nStr = Dir(nDirFile,23) If nStr = "" Then Exit Function nD = GetAttr(nDirFile) And 16 If nD Then CheckDirFile = 2 Else CheckDirFile = 1 End Function Private Sub Form_Load() Dim W As Long,H As Long Call SetCaption("") Me.ScaleMode = 3: Picture1.ScaleMode = 3 Picture1.BorderStyle = 0 Set Command1(0).Container = Picture1 Set Check1(0).Container = Picture1 Call ReadSaveSet '读取用户设置 '装载数组控件 AddKj Command1,"连","Connect","连接摄像头" AddKj Command1,"断","DisConnect","断开与摄像头的连接" AddKj Command1,"-" AddKj Command1,"源","VideoSource","选择：视频源" AddKj Command1,"格","VideoFormat","设置：视频格式，分辨率" AddKj Command1,"显","VideoDisplay","视频显示对话框。某些显卡不支持此功能。" AddKj Command1,"夹","SetDir","设置录像文件保存的文件夹。默认为主程序所在目录下的“videos”文件夹" AddKj Command1,"文","SetFile","录像保存的文件名，默认为：时间-编号.扩展名" AddKj Command1,"压","VideoCompression","设置：视频录像文件的压缩方式" AddKj Command1,"录","Record","开始录像" AddKj Command1,"停","NoRecord","停止录像" AddKj Command1,"图","CopyImg","将当前图像复制到剪贴板" AddKj Command1,"全","FillScreen","切换：全屏/窗口" AddKj Command1,"关","Exit","关闭：退出程序" If ctAutoSize Then W = 1 Else W = 0 AddKj(Check1,"自","AutoSize","视频窗口是否随主窗口自动改变大小").Value = W If ctAutoHide Then W = 1 Else W = 0 AddKj(Check1,"隐","AutoHide","录像时自动隐藏主窗口").Value = W ' ctAutoSize = True '预览图像随窗口自动缩放 ListKj Command1,Command1(0).Height * 0.1 '排列数组控件 W = Command1.UBound: W = Command1(W).Left + Command1(W).Width * 2 ListKj Check1,W '排列数组控件 Picture1.Height = Command1(0).Height * 1.2 Call WinCenter '窗口居中 ctRefresh = True Call CreateCapWin '创建视频窗口 Call KjEnabled(True) Timer1.Enabled = True: Timer1.Interval = 500 End Sub Private Sub Form_Resize() Picture1.Move 0,Me.ScaleWidth,Command1(0).Height * 1.3 If ctAutoSize Then SetWin ctCapWin,es_Size '视频子窗口随主窗口自动改变大小 End Sub Private Sub Timer1_Timer() Dim nP As PointAPI,X As Long,Y As Long,H As Long Dim nStatus As CapStatus,nRec As Boolean ' '我读取窗口的当前状态 nStatus 总是失败，忘高手赐教 ' X = SendMessageLong(ctCapWin,WM_CAP_Get_Status,Len(nStatus),ByVal VarPtr(nStatus)) ' X = SendMessage(ctCapWin,nStatus) ' nRec = nStatus.fCapturingNow '是否正在进行捕获 ' S = nStatus.uiImageWidth '图像宽度，像素 ' Me.Caption = X GetCursorPos nP X = nP.X - Me.Left / Screen.TwipsPerPixelX Y = nP.Y - Me.Top / Screen.TwipsPerPixelY If Not IsFillScreen Then Exit Sub H = Me.Height / Screen.TwipsPerPixelY - Me.ScaleHeight '窗口标题栏高度 If Y > -1 And Y < H + Picture1.Height Then If Picture1.Visible Then Exit Sub Picture1.Visible = True Else If Not Picture1.Visible Then Exit Sub Picture1.Visible = False End If SetWin ctCapWin,es_Size End Sub Private Sub SetCaption(Optional nCap As String) If nCap <> "" Then Me.Tag = Trim(nCap) If IsFillScreen Then '全屏方式 Me.Caption = "" Else '窗口方式 If Me.Tag = "" Then Me.Caption = "摄像头控制" Else Me.Caption = "摄像头控制 - " & Me.Tag End If End Sub Private Sub Check1_Click(Index As Integer) Dim nTag As String,TF As Boolean If Not ctRefresh Then Exit Sub nTag = Check1(Index).Tag: TF = Check1(Index).Value = 1 Select Case LCase(nTag) Case LCase("AutoSize") ctAutoSize = TF SendMessage ctCapWin,WM_CAP_SET_Scale,ctAutoSize,0 '预览图像随窗口自动缩放 Call SetWin(ctCapWin,es_Size) Case LCase("AutoHide") ctAutoHide = TF End Select End Sub Private Sub Command1_Click(Index As Integer) Cmd Command1(Index).Tag End Sub Private Sub Cmd(nCmd As String) Select Case LCase(nCmd) Case LCase("Connect"): Call CapConnect ' 连接摄像头 Case LCase("DisConnect"): ctConnect = False: SendMessage ctCapWin,0 '断开摄像头连接 Case LCase("VideoSource"): SendMessage ctCapWin,WM_CAP_DLG_VideoSource,0 '对话框：视频源 Case LCase("VideoFormat"): SendMessage ctCapWin,WM_CAP_DLG_VideoFormat,0: Call SetWin(ctCapWin,es_Size) '显示对话框：视频格式,分辨率 Case LCase("VideoDisplay"): SendMessage ctCapWin,WM_CAP_DLG_VideoDisplay,0 '对话框：视频显示。某些显卡不支持？ Case LCase("SetDir"): Call SetDir Case LCase("SetFile"): Call SetFile Case LCase("VideoCompression"): SendMessage ctCapWin,WM_CAP_DLG_VideoCompression,0 '对话框：视频压缩 Case LCase("Record"): Call StartRecord Case LCase("NoRecord"): Call NoRecord Case LCase("CopyImg"): Clipboard.Clear: SendMessage ctCapWin,0 '将当前图像复制到剪贴板 Case LCase("FillScreen"): Call FillScreen Case LCase("") Case LCase("") Case LCase("") Case LCase("Exit"): Unload Me: Exit Sub End Select Call KjEnabled(True) End Sub Public Sub FillScreen() '全屏切换 IsFillScreen = Not IsFillScreen Picture1.Visible = Not IsFillScreen If IsFillScreen Then Me.BorderStyle = 0 Else Me.BorderStyle = 2 Call SetCaption If IsFillScreen Then '全屏方式 Me.WindowState = 2 Check1(KjIndex(Check1,"AutoSize")).Value = 1 '切换到：视频窗口随主窗口自动改变大小 Else '窗口方式 Me.WindowState = 0 Call WinCenter '窗口居中 End If Check1(KjIndex(Check1,"AutoSize")).Enabled = Not IsFillScreen End Sub Private Sub WinCenter() '窗口居中 Dim W As Long,H As Long W = 650 * Screen.TwipsPerPixelX: H = 560 * Screen.TwipsPerPixelY Me.Move (Screen.Width - W) * 0.5,(Screen.Height - H) * 0.5,W,H '窗口居中 End Sub Private Sub VideoSize(W As Long,H As Long) '获取视频的大小尺寸 Dim nInf As BitMapInfo SendMessage ctCapWin,WM_CAP_Get_VideoFormat,Len(nInf),nInf W = nInf.bmiHeader.biWidth: H = nInf.bmiHeader.biHeight End Sub Private Function AddKj(Kj As Object,nCap As String,Optional nTag As String,Optional nNote As String) As Control '装载一个数组控件 Dim I As Long I = Kj.UBound If Kj(I).Tag <> "" Then I = I + 1: Load Kj(I) On Error Resume Next Kj(I).Caption = nCap If nTag = "" Then Kj(I).Tag = Kj(I).Name & "-" & I Else Kj(I).Tag = nTag Kj(I).ToolTipText = nNote Set AddKj = Kj(I) End Function Private Sub ListKj(Kj As Object,L As Long) '排列数组控件 Dim I As Long,H1 As Long,T As Long,W As Long H1 = Picture1.TextHeight("A"): T = H1 * 0.25: W = H1 * 2 For I = Kj.lBound To Kj.UBound If Kj(I).Caption = "-" Then L = L + H1: Kj(I).Visible = False Else Kj(I).Move L,W: Kj(I).Visible = True L = L + W End If Next End Sub Private Function KjIndex(Kj As Object,nTag As String) As Long Dim I As Long For I = Kj.lBound To Kj.UBound If LCase(Kj(I).Tag) = LCase(nTag) Then KjIndex = I: Exit Function Next KjIndex = -1 End Function Private Sub KjEnabled(Optional nEnabled As Boolean) Dim Kj,TF As Boolean,nType As String On Error Resume Next For Each Kj In Me.Controls nType = LCase(TypeName(Kj)) If nType = "commandbutton" Or nType = "checkBox" Then Kj.Enabled = nEnabled End If Next Command1(KjIndex(Command1,"FillScreen")).Enabled = True Command1(KjIndex(Command1,"Exit")).Enabled = True Check1(KjIndex(Check1,"AutoSize")).Enabled = Not IsFillScreen If Not nEnabled Then Exit Sub TF = ctConnect If ctRec Then TF = False Command1(KjIndex(Command1,"Connect")).Enabled = Not TF Command1(KjIndex(Command1,"DisConnect")).Enabled = TF '按钮在摄像头连接状态才可用 Command1(KjIndex(Command1,"VideoSource")).Enabled = TF Command1(KjIndex(Command1,"VideoFormat")).Enabled = TF Command1(KjIndex(Command1,"VideoDisplay")).Enabled = TF Command1(KjIndex(Command1,"VideoCompression")).Enabled = TF Command1(KjIndex(Command1,"Record")).Enabled = TF Command1(KjIndex(Command1,"NoRecord")).Enabled = TF Command1(KjIndex(Command1,"CopyImg")).Enabled = TF If Not ctRec Then Exit Sub Command1(KjIndex(Command1,"Record")).Enabled = False Command1(KjIndex(Command1,"NoRecord")).Enabled = True Command1(KjIndex(Command1,"SetFile")).Enabled = False Command1(KjIndex(Command1,"SetDir")).Enabled = False End Sub Private Sub CreateCapWin() '创建视频窗口 Dim nStyle As Long,S As Long Dim lpszName As String * 128 Dim lpszVer As String * 128 Do If Not capGetDriverDescriptionA(S,128) Then Exit Do '获得驱动程序名称和版本信息 S = S + 1 Loop nStyle = WS_Child + WS_Visible '+ WS_Caption + WS_ThickFrame '子窗口+可见+标题栏+边框 If ctCapWin <> 0 Then Exit Sub ctCapWin = capCreateCaptureWindow("我创建的视频窗口",Me.hwnd,0) If ctCapWin = 0 Then Exit Sub SetWin ctCapWin,es_Move,Command1(0).Top + Command1(0).Height * 1.2,480 End Sub Private Sub CapConnect() Dim D As Long '打开摄像头 D = SendMessage(ctCapWin,0) '连接一个视频驱动，成功返回真(1) SendMessage ctCapWin,0 '预览图像随窗口自动缩放 SendMessage ctCapWin,WM_CAP_SET_PreViewRate,0 '设置预览显示频率 SendMessage ctCapWin,WM_CAP_SET_PreView,0 '第三个参数：1-预览模式有效,0-预览模式无效 ctConnect = True Call SetWin(ctCapWin,es_Size) '调整视频窗口为正确的大小 End Sub Private Sub SetWin(hWnds As Long,nSet As enWinSet,Optional ByVal L As Long,Optional ByVal T As Long,Optional ByVal W As Long,Optional ByVal H As Long) Dim hWndZOrder As Long,wFlags As Long If hWnds = 0 Then Exit Sub Select Case nSet Case es_Close: SendMessage hWnds,WM_Close,0: Exit Sub Case es_Hide: wFlags = SWP_NoMove + SWP_NoSize + SWP_NoZorder + SWP_HideWindow '隐藏 Case es_Show: hWndZOrder = HWND_Top: wFlags = SWP_NoSize + SWP_ShowWindow '显示 Case es_Move hWndZOrder = HWND_Top: wFlags = SWP_NoActivate + SWP_NoSize Case es_Size hWndZOrder = HWND_Top: wFlags = SWP_NoActivate '录像状态下改变视频窗口大小，有时会出现莫名其妙的错误 If ctRec Then wFlags = wFlags + SWP_NoSize L = 0 If Picture1.Visible Then T = Picture1.Height If ctAutoSize Then W = Me.ScaleWidth - L If H = 1 Then H = Me.ScaleHeight Else H = Me.ScaleHeight - T Else Call VideoSize(W,H) '获取视频的实际大小 End If If W < 20 Or H < 20 Then Exit Sub End Select SetWindowPos hWnds,hWndZOrder,L,H,wFlags End Sub Private Sub ReadSaveSet(Optional IsSave As Boolean) Dim nPath As String,nSub As String nPath = "摄像头控制": nSub = "UserSet" If IsSave Then SaveSetting nPath,ctAutoSize SaveSetting nPath,ctAutoHide SaveSetting nPath,"Path",ctDir SaveSetting nPath,"File",ctF Else ctAutoSize = GetSetting(nPath,"False") ctAutoHide = GetSetting(nPath,"False") ctDir = GetSetting(nPath,"") ctF = GetSetting(nPath,"") End If End Sub Private Sub Form_Unload(Cancel As Integer) '停止摄像头。一般情况，如果母窗体关闭，子窗体就会自动释放。下面两句代码是否可省？ If ctRec Then Call NoRecord Cmd "DisConnect" '断开摄像头连接 SetWin ctCapWin,es_Close Call ReadSaveSet(True) '保存用户设置 End Sub Private Function CutPathFile(nStr As String,nFile As String) '分解出文件和目录 Dim I As Long,S As Long For I = 1 To Len(nStr) If Mid(nStr,1) = "" Then S = I '查找最后一个目录分隔符 Next If S > 0 Then nPath = Left(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,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,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原文链接：https://www.f2er.com/vb/256958.html