VB调用摄像头录像，拍照，保存

私人声明函数库SendMessage函数“USER32”别名“SendMessageA”（BYVAL的hWnd长，BYVAL WMSG长，BYVAL的wParam长，lParam中任意）只要

私人声明函数库capCreateCaptureWindow“avicap32.dll”别名“capCreateCaptureWindowA”（BYVAL lpszWindowName作为字符串，BYVAL dwStyle长，BYVAL×如龙，BYVALÿ长，BYVAL nWidth长，BYVAL nHeight参数长，BYVAL hwndParent长， BYVAL的NID长）只要

昏暗ctCapWin长，ctAviPath作为字符串，ctPicPath作为字符串，ctConnect由于布尔

“视频窗口控制消息常数

常量WS_CHILD =＆H40000000：常量WS_VISIBLE =＆H10000000

常量WS_CAPTION = HC00000：常量WS_THICKFRAME =＆H40000

常量WM_USER =＆H400                      '用户消息开始号

常量WM_CAP_Connect = WM_USER + 10         '连接一个摄像头

常量WM_CAP_DisConnect = WM_USER + 11      '断开一个摄像头的连接

常量WM_CAP_Set_PreView = WM_USER + 50    '使预览模式有效或者失效

常量WM_CAP_Set_Overlay = WM_USER + 51    “使窗口处于叠加模式，也会自动地使预览模式失效。

常量WM_CAP_Set_PreViewRate = WM_USER + 52'设置在预览模式下帧的显示频率

常量WM_CAP_Edit_Copy = WM_USER + 30      “将当前图像复制到剪贴板

常量WM_CAP_Sequence = WM_USER + 62        “开始录像，录像未结束前不会返回。

常量WM_Cap_File_Set_File = WM_USER + 20   “设置当前的视频捕捉文件

常量WM_Cap_File_Get_File = WM_USER + 21   '得到当前的视频捕捉文件

私人小组的Form_Load（）

Me.Left = Screen.Width - 7000

“Me.Top = Screen.Height + 5000

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

    昏暗H1只要

    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 * 0.5，H1 * 4，H1 * 2

    'Command3.Move H1 * 10，H1 * 0.5，H1 * 4，H1 * 2

    “Command4.Move H1 * 15，H1 * 0.5，H1 * 4，H1 * 2

   “读出用户设置

    呼叫ReadSaveSet

    KjEnabled真

结束小组

私人小组Command1_Click（）

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

     昏暗n型式长，T只要

    

     如果ctCapWin = 0，则“创建一个视频窗口，大小：640 * 480

         T = Me.ScaleY（Command1.Top + Command1.Height * 1.1，Me.ScaleMode，3）“视频窗口垂直位置：像素

         

        

        

        'n型式= WS_CHILD + WS_VISIBLE + WS_CAPTION + WS_THICKFRAME“子窗口（在Form1中内）+可见+标题栏+边框

         'n型式= WS_CHILD + WS_VISIBLE“视频窗口无标题栏和边框

        n型式= WS_VISIBLE'视频窗口为独立窗口，关闭主窗口视频窗口也会自动关闭

         ctCapWin = capCreateCaptureWindow（“视频监视中”n型式，0，T，500，400，Me.hWnd，0）

     万一

    

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

     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真

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

结束小组

私人小组Command2_Click（）

     SendMessage函数ctCapWin，WM_CAP_DisConnect，0，0   '断开摄像头连接

     ctConnect =假：KjEnabled真

结束小组

私人小组Command3_Click（）

   “截图，保存为图片文件

     昏暗f，按字符串，S长，n路径作为字符串，NSTR作为字符串

    

     n路径=修剪（ctPicPath）

     如果n路径=“”那么n路径= App.Path＆“\ MyPic”

     如果右（n路径，1）<>“\”然后n路径= n路径＆“\”

    

     在错误恢复下一页

     做

        S = S + 1

        F = n路径与“MyPic-”＆S＆“.BMP”

        如果目录（女，23）=“”然后退出待办事项

     循环

     对错误转到0

    

     NSTR =修剪（输入框（“设置图片保存的文件名：”，“保存图片”F））

     如果NSTR =“”然后退出小组

     呼叫CutPathFile（NSTR，n路径，F）   '分解出文件和目录

     如果不MakePath（n路径）然后

        MSGBOX“在指定的位置无法建立目录：”＆vbCrLf＆n路径，vbInformation，“保存图片文件”

        退出小组

     万一

     ctPicPath = n路径：F = n路径＆F

     如果目录（女，23）<>“”那

        如果vbCancel = MSGBOX（“文件已存在，覆盖此文件吗？”＆vbCrLf＆F，vbInformation + vbOKCancel，“截图 - 文件覆盖”），然后退出小组

        对错误转到挫

        SETATTR楼0

        杀˚F

        对错误转到0

     万一

   

     Clipboard.Clear：SendMessage消息ctCapWin，WM_CAP_Edit_Copy，0,0'将当前图像复制到剪贴板

     SavePicture Clipboard.GetData，F'保存为骨形态发生蛋白图像，要保存为JPG格式，参见：将图片保存或转变为JPG格式

     退出小组

挫：

     MSGBOX“无法写文件：”＆vbCrLf＆F，vbInformation，“保存文件”

结束小组

私人小组Command4_Click（）

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

   “如果不设置文件路径和名称，或路径不存在，视频窗口会使用默认文件名C：\ CAPTURE.AVI

     昏暗f，按字符串，S长，n路径作为字符串，NSTR作为字符串

    

     n路径=修剪（ctAviPath）

     如果n路径=“”那么n路径= App.Path＆“\ MyVideo网站”

     如果右（n路径，1）<>“\”然后n路径= n路径＆“\”

    

     在错误恢复下一页

     做

        S = S + 1

        F = n路径与“MyVideo-”＆S＆“.AVI”

        如果目录（女，23）=“”然后退出待办事项

     循环

     对错误转到0

    

     NSTR =修剪（输入框（“设置录像保存的文件名：”，“录像保存的文件名”，F））

     如果NSTR =“”然后退出小组

     呼叫CutPathFile（NSTR，n路径，F）   '分解出文件和目录

     如果不MakePath（n路径）然后

        MSGBOX“在指定的位置无法建立目录：”＆vbCrLf＆n路径，vbInformation，“保存文件”

        退出小组

     万一

     ctAviPath = n路径：F = n路径＆F

     如果目录（女，23）<>“”那

        如果vbCancel = MSGBOX（“文件已存在，覆盖此文件吗？”＆vbCrLf＆F，vbInformation + vbOKCancel，“视频 - 文件覆盖”），然后退出小组

        对错误转到挫

        SETATTR楼0

        杀˚F

        对错误转到0

     万一

    

     Me.Caption =“摄像头控制 - 正在录像（任意位置单击鼠标停止）”：KjEnabled错误：的DoEvents

     SendMessage函数ctCapWin，WM_Cap_File_Set_File，0，BYVAL F'设置录像保存的文件

     SendMessage函数ctCapWin，WM_CAP_Sequence，0，0            '开始录像。录像未结束前不会返回

     Me.Caption =“摄像头控制”：KjEnabled真

   

     退出小组

挫：

     MSGBOX“无法写文件：”＆vbCrLf＆F，vbInformation，“保存文件”

结束小组

专用功能CutPathFile（NSTR作为字符串，n路径作为字符串，n文件作为字符串）

   “分解出文件和目录

    昏暗我一样长，一样久

   

    对于i = 1到莱恩（NSTR）

       如果MID（NSTR，I，1）=“\”然后S =我   '查找最后一个目录分隔符

    下一个

    若S> 0。然后

       n路径=左（NSTR，S）：n文件= MID（NSTR，S + 1）

    其他

       n路径=“”：n文件= NSTR

    万一

结束功能

专用功能MakePath（BYVAL n路径作为字符串）作为布尔

   “逐级建立目录，成功返回Ť

    昏暗我一样长，路径1作为字符串，IsPath由于布尔

    n路径=修剪（n路径）

    如果右（n路径，1）<>“\”然后n路径= n路径＆“\”

    对错误转到退出1

    对于i = 1到莱恩（n路径）

      如果MID（n路径，I，1）=“\”然后

         路径1 =左（n路径，我 - 1）

         如果目录（路径1，23）=“”那

            MKDIR路径1

         其他

           IsPath = GETATTR（路径1）和16

           如果没有IsPath然后退出功能   “有一个同名的文件

         万一

      万一

    下一个

    MakePath = TRUE：退出功能

退出1：

结束功能

私人小组Form_Unload（取消作为整数）

    呼叫ReadSaveSet（真）“保存用户设置

结束小组

私人小组KjEnabled（nEnabled由于布尔）

    如果nEnabled然后

       Command1.Enabled =未ctConnect：Command2.Enabled = ctConnect

       Command3.Enabled = ctConnect：Command4.Enabled = ctConnect

    其他

       Command1.Enabled = nEnabled：Command2.Enabled = nEnabled

       Command3.Enabled = nEnabled：Command4.Enabled = nEnabled

    万一

结束小组

私人小组ReadSaveSet（可选IsSave由于布尔）

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

    昏暗nKey作为字符串，NSUB作为字符串

    nKey =“摄像头控制程序”：NSUB =“UserOpt”

    如果IsSave然后

       SaveSetting nKey，NSUB，“AviPath”，ctAviPath

       SaveSetting nKey，NSUB，“PicPath”，ctPicPath

    其他

       ctAviPath = GetSetting（nKey，NSUB“AviPath”，“”）

       ctPicPath = GetSetting（nKey，NSUB“PicPath”，“”）

    万一

结束小组