本程序用四个按钮实现对摄像头视频的监控、截图、录像，可以分别保存为图片文件和视频文件。保存的视频文件可以用媒体播放机（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 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