本程序用四个按钮实现对摄像头视频的监控、截图、录像，可以分别保存为图片文件和视频文件。保存的视频文件可以用媒体播放机（Windows Media Player）、 暴风影音等软件进行播放，轻松实现家庭录像制作。
　　利用电脑配备的 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 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 LongMe.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 * 2Command2.Move H1 * 5, H1 * 0.5, H1 * 4, H1 * 2Command3.Move H1 * 10, H1 * 0.5, H1 * 4, H1 * 2Command4.Move H1 * 15, H1 * 0.5, H1 * 4, H1 * 2'读出用户设置Call ReadSaveSetKjEnabled True
End SubPrivate Sub Command1_Click()'创建视频窗口和连接摄像头Dim nStyle As Long, T As LongIf ctCapWin = 0 Then '创建一个视频窗口，大小：640*480T = 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, 0, T, 640, 480, Me.hWnd, 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 SubPrivate Sub Command2_Click()SendMessage ctCapWin, WM_CAP_DisConnect, 0, 0  '断开摄像头连接ctConnect = False: KjEnabled True
End SubPrivate Sub Command3_Click()'截图,保存为图片文件Dim F As String, S As Long, nPath As String, nStr As StringnPath = Trim(ctPicPath)If nPath = "" Then nPath = App.Path & "\MyPic"If Right(nPath, 1) <> "" Then nPath = nPath & ""On Error Resume NextDoS = S + 1F = nPath & "MyPic-" & S & ".bmp"If Dir(F, 23) = "" Then Exit DoLoopOn Error GoTo 0nStr = Trim(InputBox("设置图片保存的文件名:", "保存图片", F))If nStr = "" Then Exit SubCall CutPathFile(nStr, nPath, F)  '分解出文件和目录If Not MakePath(nPath) ThenMsgBox "在指定的位置无法建立目录：" & vbCrLf & nPath, vbInformation, "保存图片文件"Exit SubEnd IfctPicPath = nPath: F = nPath & FIf Dir(F, 23) <> "" ThenIf vbCancel = MsgBox("文件已存在，覆盖此文件吗？" & vbCrLf & F, vbInformation + vbOKCancel, "截图 - 文件覆盖") Then Exit SubOn Error GoTo CuoSetAttr F, 0Kill FOn Error GoTo 0End IfClipboard.Clear: SendMessage ctCapWin, WM_CAP_Edit_Copy, 0, 0 '将当前图像复制到剪贴板SavePicture Clipboard.GetData, F '保存为 Bmp 图像，要保存为 jpg 格式，参见： 将图片保存或转变为JPG格式Exit Sub
Cuo:MsgBox "无法写文件：" & vbCrLf & F, vbInformation, "保存文件"
End SubPrivate Sub Command4_Click()'用摄像头录像，并保存为视频文件'如果不设置文件路径和名称，或路径不存在，视频窗口会使用默认文件名 C:\CAPTURE.AVIDim F As String, S As Long, nPath As String, nStr As StringnPath = Trim(ctAviPath)If nPath = "" Then nPath = App.Path & "\MyVideo"If Right(nPath, 1) <> "" Then nPath = nPath & ""On Error Resume NextDoS = S + 1F = nPath & "MyVideo-" & S & ".avi"If Dir(F, 23) = "" Then Exit DoLoopOn Error GoTo 0nStr = Trim(InputBox("设置录像保存的文件名:", "录像保存的文件名", F))If nStr = "" Then Exit SubCall CutPathFile(nStr, nPath, F)  '分解出文件和目录If Not MakePath(nPath) ThenMsgBox "在指定的位置无法建立目录：" & vbCrLf & nPath, vbInformation, "保存文件"Exit SubEnd IfctAviPath = nPath: F = nPath & FIf Dir(F, 23) <> "" ThenIf vbCancel = MsgBox("文件已存在，覆盖此文件吗？" & vbCrLf & F, vbInformation + vbOKCancel, "视频 - 文件覆盖") Then Exit SubOn Error GoTo CuoSetAttr F, 0Kill FOn Error GoTo 0End IfMe.Caption = "摄像头控制 - 正在录像（任意位置单击鼠标停止）": KjEnabled False: DoEventsSendMessage ctCapWin, WM_Cap_File_Set_File, 0, ByVal F '设置录像保存的文件SendMessage ctCapWin, WM_CAP_Sequence, 0, 0            '开始录像。录像未结束前不会返回Me.Caption = "摄像头控制": KjEnabled TrueExit Sub
Cuo:MsgBox "无法写文件：" & vbCrLf & F, vbInformation, "保存文件"
End SubPrivate Function CutPathFile(nStr As String, nPath As String, nFile As String)'分解出文件和目录Dim I As Long, S As LongFor I = 1 To Len(nStr)If Mid(nStr, I, 1) = "" Then S = I  '查找最后一个目录分隔符NextIf S > 0 ThennPath = Left(nStr, S): nFile = Mid(nStr, S + 1)ElsenPath = "": nFile = nStrEnd If
End FunctionPrivate Function MakePath(ByVal nPath As String) As Boolean'逐级建立目录,成功返回 TDim I As Long, Path1 As String, IsPath As BooleannPath = Trim(nPath)If Right(nPath, 1) <> "" Then nPath = nPath & ""On Error GoTo Exit1For I = 1 To Len(nPath)If Mid(nPath, I, 1) = "" ThenPath1 = Left(nPath, I - 1)If Dir(Path1, 23) = "" ThenMkDir Path1ElseIsPath = GetAttr(Path1) And 16If Not IsPath Then Exit Function  '有一个同名的文件End IfEnd IfNextMakePath = True: Exit Function
Exit1:
End FunctionPrivate Sub Form_Unload(Cancel As Integer)Call ReadSaveSet(True) '保存用户设置
End SubPrivate Sub KjEnabled(nEnabled As Boolean)If nEnabled ThenCommand1.Enabled = Not ctConnect: Command2.Enabled = ctConnectCommand3.Enabled = ctConnect: Command4.Enabled = ctConnectElseCommand1.Enabled = nEnabled: Command2.Enabled = nEnabledCommand3.Enabled = nEnabled: Command4.Enabled = nEnabledEnd If
End SubPrivate Sub ReadSaveSet(Optional IsSave As Boolean)'保存或读出用户设置的图片和视频默认保存目录Dim nKey As String, nSub As StringnKey = "摄像头控制程序": nSub = "UserOpt"If IsSave ThenSaveSetting nKey, nSub, "AviPath", ctAviPathSaveSetting nKey, nSub, "PicPath", ctPicPathElsectAviPath = GetSetting(nKey, nSub, "AviPath", "")ctPicPath = GetSetting(nKey, nSub, "PicPath", "")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 BooleanPrivate Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
Private Type PointAPIX As Long: Y As Long
End Type
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y 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 = &H80Private 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 SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const WM_Close = &H10Private 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 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
Const WS_Child = &H40000000
Const WS_Visible = &H10000000
Const WS_Caption = &HC00000
Const WS_ThickFrame = &H40000Const GET_Frame = 1084Const 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 = -1es_Show = 0es_Hidees_Closees_Movees_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 PCMConst 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 StructurebiSize As Long        'biWidth As LongbiHeight As Long      'LONG DWORDbiPlanes As Integer   'WORDbiBitCount As IntegerbiCompression As LongbiSizeImage As LongbiXPelsPerMeter As LongbiYPelsPerMeter As LongbiClrUsed As LongbiClrImportant As Long
End Type
Private Type BitMapInfobmiHeader 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, Len(nParms), nParms'重新设置参数
Private Type CaptureParms 'dwRequestMicroSecPerFrame As Long  'DWORDfMakeUserHitOKToCapture 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    'BOOLdwMCIStartTime As Long       'DWORD:以毫秒为单位标识MCI设备视频捕捉序列的起始位置，如果fMCIControl成员为FALSE，该成员被忽略dwMCIStopTime As Long        'DWORD:以毫秒为单位标识MCI设备视频捕捉序列的停止位置，如果fMCIControl成员为FALSE，该成员被忽略fStepCaptureAt2x As Boolean  'BOOL:为TRUE，捕捉的视频帧使用两个分辨率wStepCaptureAverageFrames As Long ':在捕捉时每帧图像使用的时间大小dwAudioBufferSize As Long     '音频缓冲大小，默认0fDisableWriteCache As Boolean 'Win32系统未使用AVStreamMaster As Long        '确定在写入AVI文件时，音频流是否控制时钟
End Type'视频窗口消息--------------------------------------
'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'可利用此 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 LongdwCurrentVideoFramesDropped As LongdwCurrentWaveSamples As LongdwCurrentTimeElapsedMS As Long   '视频流已录像时间（毫秒）hPalCurrent As Long              'HPALETTE 当前调色板句柄fCapturingNow As Boolean         '是否正在进行捕获dwReturn As Long                 '错误返回值，根据这个数值可以调用一个错误回调函数wNumVideoAllocated As Long       '视频缓冲wNumAudioAllocated As Long       '音频缓冲
End TypePrivate Sub CloseMouse()Dim nParms As CaptureParmsSendMessage ctCapWin, WM_CAP_Get_Sequence_Setup, Len(nParms), nParms  '获取参数的设置'nParms.fMakeUserHitOKToCapture = True '开始录像时，是否显示确认对话框nParms.fYield = True '用一个后台线程来进行视频捕捉nParms.fAbortLeftMouse = False  '关闭：单击鼠标左键停止录像的功能。nParms.fAbortRightMouse = False '关闭：单击鼠标右键停止录像的功能SendMessage ctCapWin, WM_CAP_Set_Sequence_Setup, Len(nParms), nParms '重新设置参数'ff = SendMessageLong(ctCapWin, WM_CAP_SET_CALLBACK_STATUS, 0, AddressOf CallBackStatus) '状态回调函数
'ff = SendMessageLong(ctCapWin, WM_CAP_SET_CALLBACK_FRAME, 0, AddressOf MyFrameCallback) '帧回调函数
'ff = SendMessageLong(ctCapWin, WM_CAP_SET_CALLBACK_YIELD, 0, AddressOf CallbackYield)
End SubPrivate Sub NoRecord()SendMessage ctCapWin, WM_CAP_Stop, 0, 0 '停止录像ctRec = False: Call SetCaption(" ")
End SubPrivate Sub StartRecord()Dim F As String, nDir As String, nF As String'如果路径不存在，用默认文件名 C:\CAPTURE.AVInDir = Trim(ctDir)If nDir = "" Or nDir = "<>" Or nDir = "<默认>" Then nDir = App.Path & "\videos"If Right(nDir, 1) <> "" Then nDir = nDir & ""If Not MakePath(nDir) ThenMsgBox "在指定的位置无法建立目录：" & vbCrLf & nPath, vbInformation, "保存视频文件"Exit SubEnd IfnF = 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 & nFIf CheckDirFile(F) = 1 ThenIf vbNo = MsgBox("文件已存在，覆盖此文件吗？" & vbCrLf & F, vbInformation + vbYesNo, "开始录像") Then Exit SubOn Error GoTo CuoSetAttr F, 0Kill FOn Error GoTo 0End IfctRec = FalseSetWin ctCapWin, es_Size, , , , 1ctRec = TrueCall SetCaption("正在录像：" & nF)Call KjEnabled(True)DoEventsCall CloseMouseSendMessage ctCapWin, WM_Cap_File_Set_File, 0, ByVal F '设置录像保存的文件PostMessage ctCapWin, WM_CAP_Sequence, 0, 0            '开始录像If ctAutoHide Then Me.Visible = FalseExit Sub
Cuo:MsgBox "无法写文件：" & vbvrlf & vbCrLf & F, vbInformation, "录像 - 错误"
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 StringIf Trim(ctDir) = "" Then ctDir = App.Path & "\videos" '如果路径不存在，用默认文件名 C:\CAPTURE.AVInStr = "设置录像保存的文件夹。" & vbCrLf & "输入“<>”表示使用默认文件夹：" & vbCrLf & App.Path & "\videos"nStr = Trim(InputBox(nStr, "录像保存的文件夹", ctDir))If nStr = "" Then Exit SubctDir = nStrIf ctDir = "<>" Or ctDir = "<默认>" Then ctDir = ""
End SubPrivate Sub SetFile()Dim nStr As String, nF As StringnF = String(255, " ")SendMessage ctCapWin, WM_Cap_File_Get_File, Len(nF), ByVal nFnF = GetStrLeft(nF, vbNullChar)If Trim(ctF) = "" Then ctF = "<默认>" '如果路径不存在，用默认文件名 C:\CAPTURE.AVInStr = "设置录像保存的文件名(不带路径)。" & vbCrLf & "输入“<>”表示使用默认文件名：日期-时间.扩展名"nStr = Trim(InputBox(nStr, "录像保存的文件名", ctF))If nStr = "" Then Exit SubctF = nStrIf ctF = "<>" Or ctF = "<默认>" Then ctF = ""SendMessage ctCapWin, WM_Cap_File_Set_File, 0, ByVal ctF
End SubPrivate Function GetStrLeft(nStr As String, Fu As String) As String'去掉 Fu 及后面的字符Dim S As LongS = InStr(nStr, Fu)If S > 0 Then GetStrLeft = Left(nStr, S - 1) Else GetStrLeft = nStr
End FunctionPrivate Function CheckDirFile(nDirFile) As Long'检查目录或文件夹，返回值：0不存在，1是文件，2是目录Dim nStr As String, nD As BooleannStr = Dir(nDirFile, 23)If nStr = "" Then Exit FunctionnD = GetAttr(nDirFile) And 16If nD Then CheckDirFile = 2 Else CheckDirFile = 1
End FunctionPrivate Sub Form_Load()Dim W As Long, H As LongCall SetCaption("")Me.ScaleMode = 3: Picture1.ScaleMode = 3Picture1.BorderStyle = 0Set Command1(0).Container = Picture1Set Check1(0).Container = Picture1Call ReadSaveSet '读取用户设置'装载数组控件AddKj Command1, "连", "Connect", "连接摄像头"AddKj Command1, "断", "DisConnect", "断开与摄像头的连接"AddKj Command1, "-"AddKj Command1, "源", "VideoSource", "选择：视频源"AddKj Command1, "格", "VideoFormat", "设置：视频格式，分辨率"AddKj Command1, "显", "VideoDisplay", "视频显示对话框。某些显卡不支持此功能。"AddKj Command1, "-"AddKj Command1, "夹", "SetDir", "设置录像文件保存的文件夹。默认为主程序所在目录下的“videos”文件夹"AddKj Command1, "文", "SetFile", "录像保存的文件名，默认为：时间-编号.扩展名"AddKj Command1, "压", "VideoCompression", "设置：视频录像文件的压缩方式"AddKj Command1, "-"AddKj Command1, "录", "Record", "开始录像"AddKj Command1, "停", "NoRecord", "停止录像"AddKj Command1, "图", "CopyImg", "将当前图像复制到剪贴板"AddKj Command1, "-"AddKj Command1, "全", "FillScreen", "切换：全屏/窗口"AddKj Command1, "关", "Exit", "关闭：退出程序"If ctAutoSize Then W = 1 Else W = 0AddKj(Check1, "自", "AutoSize", "视频窗口是否随主窗口自动改变大小").Value = WIf ctAutoHide Then W = 1 Else W = 0AddKj(Check1, "隐", "AutoHide", "录像时自动隐藏主窗口").Value = W'  ctAutoSize = True '预览图像随窗口自动缩放ListKj Command1, Command1(0).Height * 0.1 '排列数组控件W = Command1.UBound: W = Command1(W).Left + Command1(W).Width * 2ListKj Check1, W '排列数组控件Picture1.Height = Command1(0).Height * 1.2Call WinCenter '窗口居中ctRefresh = TrueCall CreateCapWin '创建视频窗口Call KjEnabled(True)Timer1.Enabled = True: Timer1.Interval = 500
End SubPrivate Sub Form_Resize()Picture1.Move 0, 0, Me.ScaleWidth, Command1(0).Height * 1.3If ctAutoSize Then SetWin ctCapWin, es_Size  '视频子窗口随主窗口自动改变大小
End SubPrivate Sub Timer1_Timer()Dim nP As PointAPI, X As Long, Y As Long, H As LongDim nStatus As CapStatus, nRec As Boolean'   '我读取窗口的当前状态 nStatus 总是失败，忘高手赐教
'   X = SendMessageLong(ctCapWin, WM_CAP_Get_Status, Len(nStatus), ByVal VarPtr(nStatus))
'   X = SendMessage(ctCapWin, WM_CAP_Get_Status, Len(nStatus), nStatus)
'   nRec = nStatus.fCapturingNow '是否正在进行捕获
'   S = nStatus.uiImageWidth     '图像宽度，像素
'   Me.Caption = XGetCursorPos nPX = nP.X - Me.Left / Screen.TwipsPerPixelXY = nP.Y - Me.Top / Screen.TwipsPerPixelYIf Not IsFillScreen Then Exit SubH = Me.Height / Screen.TwipsPerPixelY - Me.ScaleHeight '窗口标题栏高度If Y > -1 And Y < H + Picture1.Height ThenIf Picture1.Visible Then Exit SubPicture1.Visible = TrueElseIf Not Picture1.Visible Then Exit SubPicture1.Visible = FalseEnd IfSetWin ctCapWin, es_Size
End SubPrivate 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.TagEnd If
End SubPrivate Sub Check1_Click(Index As Integer)Dim nTag As String, TF As BooleanIf Not ctRefresh Then Exit SubnTag = Check1(Index).Tag: TF = Check1(Index).Value = 1Select Case LCase(nTag)Case LCase("AutoSize")ctAutoSize = TFSendMessage ctCapWin, WM_CAP_SET_Scale, ctAutoSize, 0 '预览图像随窗口自动缩放Call SetWin(ctCapWin, es_Size)Case LCase("AutoHide")ctAutoHide = TFEnd Select
End SubPrivate Sub Command1_Click(Index As Integer)Cmd Command1(Index).Tag
End SubPrivate Sub Cmd(nCmd As String)Select Case LCase(nCmd)Case LCase("Connect"):          Call CapConnect ' 连接摄像头Case LCase("DisConnect"):       ctConnect = False: SendMessage ctCapWin, WM_CAP_DisConnect, 0, 0      '断开摄像头连接Case LCase("VideoSource"):      SendMessage ctCapWin, WM_CAP_DLG_VideoSource, 0, 0  '对话框：视频源Case LCase("VideoFormat"):      SendMessage ctCapWin, WM_CAP_DLG_VideoFormat, 0, 0: Call SetWin(ctCapWin, es_Size) '显示对话框：视频格式,分辨率Case LCase("VideoDisplay"):     SendMessage ctCapWin, WM_CAP_DLG_VideoDisplay, 0, 0 '对话框：视频显示。某些显卡不支持？Case LCase("SetDir"):           Call SetDirCase LCase("SetFile"):          Call SetFileCase LCase("VideoCompression"): SendMessage ctCapWin, WM_CAP_DLG_VideoCompression, 0, 0 '对话框：视频压缩Case LCase("Record"):           Call StartRecordCase LCase("NoRecord"):         Call NoRecordCase LCase("CopyImg"): Clipboard.Clear: SendMessage ctCapWin, WM_CAP_Edit_Copy, 0, 0 '将当前图像复制到剪贴板Case LCase("FillScreen"):       Call FillScreenCase LCase("")Case LCase("")Case LCase("")Case LCase("Exit"):             Unload Me: Exit SubEnd SelectCall KjEnabled(True)
End SubPublic Sub FillScreen()'全屏切换IsFillScreen = Not IsFillScreenPicture1.Visible = Not IsFillScreenIf IsFillScreen Then Me.BorderStyle = 0 Else Me.BorderStyle = 2Call SetCaptionIf IsFillScreen Then '全屏方式Me.WindowState = 2Check1(KjIndex(Check1, "AutoSize")).Value = 1 '切换到：视频窗口随主窗口自动改变大小Else '窗口方式Me.WindowState = 0Call WinCenter '窗口居中End IfCheck1(KjIndex(Check1, "AutoSize")).Enabled = Not IsFillScreen
End SubPrivate Sub WinCenter()'窗口居中Dim W As Long, H As LongW = 650 * Screen.TwipsPerPixelX: H = 560 * Screen.TwipsPerPixelYMe.Move (Screen.Width - W) * 0.5, (Screen.Height - H) * 0.5, W, H '窗口居中
End SubPrivate Sub VideoSize(W As Long, H As Long)'获取视频的大小尺寸Dim nInf As BitMapInfoSendMessage ctCapWin, WM_CAP_Get_VideoFormat, Len(nInf), nInfW = nInf.bmiHeader.biWidth: H = nInf.bmiHeader.biHeight
End SubPrivate Function AddKj(Kj As Object, nCap As String, Optional nTag As String, Optional nNote As String) As Control'装载一个数组控件Dim I As LongI = Kj.UBoundIf Kj(I).Tag <> "" Then I = I + 1: Load Kj(I)On Error Resume NextKj(I).Caption = nCapIf nTag = "" Then Kj(I).Tag = Kj(I).Name & "-" & I Else Kj(I).Tag = nTagKj(I).ToolTipText = nNoteSet AddKj = Kj(I)
End FunctionPrivate Sub ListKj(Kj As Object, L As Long)'排列数组控件Dim I As Long, H1 As Long, T As Long, W As LongH1 = Picture1.TextHeight("A"): T = H1 * 0.25: W = H1 * 2For I = Kj.lBound To Kj.UBoundIf Kj(I).Caption = "-" ThenL = L + H1: Kj(I).Visible = FalseElseKj(I).Move L, T, W, W: Kj(I).Visible = TrueL = L + WEnd IfNext
End SubPrivate Function KjIndex(Kj As Object, nTag As String) As LongDim I As LongFor I = Kj.lBound To Kj.UBoundIf LCase(Kj(I).Tag) = LCase(nTag) Then KjIndex = I: Exit FunctionNextKjIndex = -1
End FunctionPrivate Sub KjEnabled(Optional nEnabled As Boolean)Dim Kj, TF As Boolean, nType As StringOn Error Resume NextFor Each Kj In Me.ControlsnType = LCase(TypeName(Kj))If nType = "commandbutton" Or nType = "checkbox" ThenKj.Enabled = nEnabledEnd IfNextCommand1(KjIndex(Command1, "FillScreen")).Enabled = TrueCommand1(KjIndex(Command1, "Exit")).Enabled = TrueCheck1(KjIndex(Check1, "AutoSize")).Enabled = Not IsFillScreenIf Not nEnabled Then Exit SubTF = ctConnectIf ctRec Then TF = FalseCommand1(KjIndex(Command1, "Connect")).Enabled = Not TFCommand1(KjIndex(Command1, "DisConnect")).Enabled = TF '按钮在摄像头连接状态才可用Command1(KjIndex(Command1, "VideoSource")).Enabled = TFCommand1(KjIndex(Command1, "VideoFormat")).Enabled = TFCommand1(KjIndex(Command1, "VideoDisplay")).Enabled = TFCommand1(KjIndex(Command1, "VideoCompression")).Enabled = TFCommand1(KjIndex(Command1, "Record")).Enabled = TFCommand1(KjIndex(Command1, "NoRecord")).Enabled = TFCommand1(KjIndex(Command1, "CopyImg")).Enabled = TFIf Not ctRec Then Exit SubCommand1(KjIndex(Command1, "Record")).Enabled = FalseCommand1(KjIndex(Command1, "NoRecord")).Enabled = TrueCommand1(KjIndex(Command1, "SetFile")).Enabled = FalseCommand1(KjIndex(Command1, "SetDir")).Enabled = False
End SubPrivate Sub CreateCapWin()'创建视频窗口Dim nStyle As Long, S As LongDim lpszName As String * 128Dim lpszVer As String * 128DoIf Not capGetDriverDescriptionA(S, lpszName, 128, lpszVer, 128) Then Exit Do '获得驱动程序名称和版本信息S = S + 1LoopnStyle = WS_Child + WS_Visible '+ WS_Caption + WS_ThickFrame '子窗口+可见+标题栏+边框If ctCapWin <> 0 Then Exit SubctCapWin = capCreateCaptureWindow("我创建的视频窗口", nStyle, 0, 0, 640, 480, Me.hwnd, 0)If ctCapWin = 0 Then Exit SubSetWin ctCapWin, es_Move, 0, Command1(0).Top + Command1(0).Height * 1.2, 640, 480
End SubPrivate Sub CapConnect()Dim D As Long'打开摄像头D = SendMessage(ctCapWin, WM_CAP_Connect, 0, 0)        '连接一个视频驱动，成功返回真(1)SendMessage ctCapWin, WM_CAP_SET_Scale, ctAutoSize, 0  '预览图像随窗口自动缩放SendMessage ctCapWin, WM_CAP_SET_PreViewRate, 30, 0    '设置预览显示频率SendMessage ctCapWin, WM_CAP_SET_PreView, 1, 0         '第三个参数：1-预览模式有效,0-预览模式无效ctConnect = TrueCall SetWin(ctCapWin, es_Size) '调整视频窗口为正确的大小
End SubPrivate 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 LongIf hWnds = 0 Then Exit SubSelect Case nSetCase es_Close: SendMessage hWnds, WM_Close, 0, 0: Exit SubCase es_Hide: wFlags = SWP_NoMove + SWP_NoSize + SWP_NoZorder + SWP_HideWindow '隐藏Case es_Show: hWndZOrder = HWND_Top: wFlags = SWP_NoSize + SWP_ShowWindow      '显示Case es_MovehWndZOrder = HWND_Top: wFlags = SWP_NoActivate + SWP_NoSizeCase es_SizehWndZOrder = HWND_Top: wFlags = SWP_NoActivate'录像状态下改变视频窗口大小，有时会出现莫名其妙的错误If ctRec Then wFlags = wFlags + SWP_NoSizeL = 0If Picture1.Visible Then T = Picture1.HeightIf ctAutoSize ThenW = Me.ScaleWidth - LIf H = 1 Then H = Me.ScaleHeight Else H = Me.ScaleHeight - TElseCall VideoSize(W, H) '获取视频的实际大小End IfIf W < 20 Or H < 20 Then Exit SubEnd SelectSetWindowPos hWnds, hWndZOrder, L, T, W, H, wFlags
End SubPrivate Sub ReadSaveSet(Optional IsSave As Boolean)Dim nPath As String, nSub As StringnPath = "摄像头控制": nSub = "UserSet"If IsSave ThenSaveSetting nPath, nSub, "AutoSize", ctAutoSizeSaveSetting nPath, nSub, "AutoHide", ctAutoHideSaveSetting nPath, nSub, "Path", ctDirSaveSetting nPath, nSub, "File", ctFElsectAutoSize = GetSetting(nPath, nSub, "AutoSize", "False")ctAutoHide = GetSetting(nPath, nSub, "AutoHide", "False")ctDir = GetSetting(nPath, nSub, "Path", "")ctF = GetSetting(nPath, nSub, "File", "")End If
End SubPrivate Sub Form_Unload(Cancel As Integer)'停止摄像头。一般情况，如果母窗体关闭，子窗体就会自动释放。下面两句代码是否可省？If ctRec Then Call NoRecordCmd "DisConnect" '断开摄像头连接SetWin ctCapWin, es_CloseCall ReadSaveSet(True) '保存用户设置
End SubPrivate Function CutPathFile(nStr As String, nPath As String, nFile As String)'分解出文件和目录Dim I As Long, S As LongFor I = 1 To Len(nStr)If Mid(nStr, I, 1) = "" Then S = I  '查找最后一个目录分隔符NextIf S > 0 ThennPath = Left(nStr, S): nFile = Mid(nStr, S + 1)ElsenPath = "": nFile = nStrEnd If
End FunctionPrivate Function MakePath(ByVal nPath As String) As Boolean'逐级建立目录,成功返回 TDim I As Long, Path1 As String, IsPath As BooleannPath = Trim(nPath)If Right(nPath, 1) <> "" Then nPath = nPath & ""On Error GoTo Exit1For I = 1 To Len(nPath)If Mid(nPath, I, 1) = "" ThenPath1 = Left(nPath, I - 1)If Dir(Path1, 23) = "" ThenMkDir Path1ElseIsPath = GetAttr(Path1) And 16If Not IsPath Then Exit Function  '有一个同名的文件End IfEnd IfNextMakePath = True: Exit Function
Exit1:
End Function