本程序用四个按钮实现对摄像头视频的监控、截图、录像,可以分别保存为图片文件和视频文件。保存的视频文件可以用媒体播放机(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
下面程序是“实现USB摄像头视频图像的监控、截图、录像”的改进。可实现对摄像头视频的监控、截图、录像,可以分别保存为图片文件和视频(压缩)文件。保存的视频文件可以用媒体播放机(Windows Media Player)、 暴风影音等软件进行播放,轻松实现家庭录像制作。
利用电脑配备的 USB 摄像头进行视频控制,要用到两个 API 函数:capCreateCaptureWindow 和 SendMessage。其中,capCreateCaptureWindow 的作用是创建一个视频窗口,摄像头捕捉到的视频图像在此窗口内显示,函数返回值就是代表此窗口的句柄。视频窗口创建后,剩下的事情就是用 SendMessage 向该窗口发送各种消息,实现对摄像头的控制。
本程序特点主要有:
1.实现对摄像头视频图像的监控、截图,视频录像并保存为磁盘文件。
2.可控制多个视频摄像头。例如,如果一台电脑配置了两个摄像头,启动本程序两次,单击按钮“源”,在弹出的“视频源”对话框中选择不同的捕获源,两个窗口就能同时显示不同摄像头获得的图像。如下图所示:
3.在“视频源”对话框中,还可以设置视频的亮度、对比度等许多参数:
4.录像时,如果采用默认的 AVI 文件格式,得到的视频文件会很大。单击按钮“压”,在弹出的“视频压缩”对话框中选择压缩方式“MPEG-4”,这样得到的视频文件会比默认方式小 10 倍以上。
5.本程序的视频窗口有自动大小和全屏功能。在全屏状态时,工具栏会自动隐藏。将鼠标移动到屏幕顶部,工具栏又会自动显示出来。
遗憾的是,由于水平有限,本程序无法判断是否使用了压缩记录方式,压缩后的文件其扩展名仍然是 AVI。当然,这并不影响播放,录像完成后也可以手动将扩展名修改为 mpg。其次,录像状态下改变视频窗口大小,有时会出现莫名其妙的错误。这个错误时有时无,毫无规律,因此本程序不得不关闭了录像状态下视频窗口自动大小 的功能。
利用电脑配备的 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 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 * 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
'读出用户设置
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, 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 Sub
Private Sub Command2_Click()
SendMessage ctCapWin, WM_CAP_DisConnect, 0, 0 '断开摄像头连接
ctConnect = False: KjEnabled True
End Sub
Private Sub Command3_Click()
'截图,保存为图片文件
Dim F As String, S As Long, nPath As String, nStr As String
nPath = Trim(ctPicPath)
If nPath = "" Then nPath = 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, 0 '将当前图像复制到剪贴板
SavePicture Clipboard.GetData, F '保存为 Bmp 图像,要保存为 jpg 格式,参见: 将图片保存或转变为JPG格式
Exit Sub
Cuo:
MsgBox "无法写文件:" & vbCrLf & F, vbInformation, "保存文件"
End Sub
Private Sub Command4_Click()
'用摄像头录像,并保存为视频文件
'如果不设置文件路径和名称,或路径不存在,视频窗口会使用默认文件名 C:\CAPTURE.AVI
Dim F As String, S As Long, nPath 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("设置录像保存的文件名:", "录像保存的文件名", F))
If nStr = "" Then Exit Sub
Call CutPathFile(nStr, nPath, F) '分解出文件和目录
If Not MakePath(nPath) Then
MsgBox "在指定的位置无法建立目录:" & vbCrLf & nPath, vbInformation, "保存文件"
Exit Sub
End If
ctAviPath = nPath: F = nPath & F
If Dir(F, 23) <> "" Then
If vbCancel = MsgBox("文件已存在,覆盖此文件吗?" & vbCrLf & F, vbInformation + vbOKCancel, "视频 - 文件覆盖") Then Exit Sub
On Error GoTo Cuo
SetAttr F, 0
Kill F
On Error GoTo 0
End If
Me.Caption = "摄像头控制 - 正在录像(任意位置单击鼠标停止)": KjEnabled False: DoEvents
SendMessage ctCapWin, WM_Cap_File_Set_File, 0, ByVal F '设置录像保存的文件
SendMessage ctCapWin, WM_CAP_Sequence, 0, 0 '开始录像。录像未结束前不会返回
Me.Caption = "摄像头控制": KjEnabled True
Exit Sub
Cuo:
MsgBox "无法写文件:" & vbCrLf & F, vbInformation, "保存文件"
End Sub
Private Function CutPathFile(nStr As String, nPath As String, nFile As String)
'分解出文件和目录
Dim I As Long, S As Long
For I = 1 To Len(nStr)
If Mid(nStr, I, 1) = "" Then S = I '查找最后一个目录分隔符
Next
If S > 0 Then
nPath = Left(nStr, S): nFile = Mid(nStr, S + 1)
Else
nPath = "": nFile = nStr
End If
End Function
Private Function MakePath(ByVal nPath As String) As Boolean
'逐级建立目录,成功返回 T
Dim I As Long, Path1 As String, IsPath As Boolean
nPath = Trim(nPath)
If Right(nPath, 1) <> "" Then nPath = nPath & ""
On Error GoTo Exit1
For I = 1 To Len(nPath)
If Mid(nPath, I, 1) = "" Then
Path1 = Left(nPath, I - 1)
If Dir(Path1, 23) = "" Then
MkDir Path1
Else
IsPath = GetAttr(Path1) And 16
If Not IsPath Then Exit Function '有一个同名的文件
End If
End If
Next
MakePath = True: Exit Function
Exit1:
End Function
Private Sub Form_Unload(Cancel As Integer)
Call ReadSaveSet(True) '保存用户设置
End Sub
Private Sub KjEnabled(nEnabled As Boolean)
If nEnabled Then
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, nSub, "PicPath", ctPicPath
Else
ctAviPath = 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 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 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 = &H80
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 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 = &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 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 = &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, Len(nParms), 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 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 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, 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 Sub
Private Sub NoRecord()
SendMessage ctCapWin, WM_CAP_Stop, 0, 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, vbInformation, "保存视频文件"
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, WM_Cap_File_Set_File, 0, ByVal F '设置录像保存的文件
PostMessage ctCapWin, WM_CAP_Sequence, 0, 0 '开始录像
If ctAutoHide Then Me.Visible = False
Exit 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 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, WM_Cap_File_Set_File, 0, 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, "-"
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 = 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, 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, WM_CAP_Get_Status, Len(nStatus), 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, 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 SetDir
Case LCase("SetFile"): Call SetFile
Case LCase("VideoCompression"): SendMessage ctCapWin, WM_CAP_DLG_VideoCompression, 0, 0 '对话框:视频压缩
Case LCase("Record"): Call StartRecord
Case LCase("NoRecord"): Call NoRecord
Case LCase("CopyImg"): Clipboard.Clear: SendMessage ctCapWin, WM_CAP_Edit_Copy, 0, 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, T, W, 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, lpszName, 128, lpszVer, 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("我创建的视频窗口", nStyle, 0, 0, 640, 480, Me.hwnd, 0)
If ctCapWin = 0 Then Exit Sub
SetWin ctCapWin, es_Move, 0, Command1(0).Top + Command1(0).Height * 1.2, 640, 480
End Sub
Private 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 = 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, 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, T, W, 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, nSub, "AutoSize", ctAutoSize
SaveSetting nPath, nSub, "AutoHide", ctAutoHide
SaveSetting nPath, nSub, "Path", ctDir
SaveSetting nPath, nSub, "File", ctF
Else
ctAutoSize = GetSetting(nPath, nSub, "AutoSize", "False")
ctAutoHide = GetSetting(nPath, nSub, "AutoHide", "False")
ctDir = GetSetting(nPath, nSub, "Path", "")
ctF = GetSetting(nPath, nSub, "File", "")
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, nPath As String, nFile As String)
'分解出文件和目录
Dim I As Long, S As Long
For I = 1 To Len(nStr)
If Mid(nStr, I, 1) = "" Then S = I '查找最后一个目录分隔符
Next
If S > 0 Then
nPath = Left(nStr, S): nFile = Mid(nStr, S + 1)
Else
nPath = "": nFile = nStr
End If
End Function
Private Function MakePath(ByVal nPath As String) As Boolean
'逐级建立目录,成功返回 T
Dim I As Long, Path1 As String, IsPath As Boolean
nPath = Trim(nPath)
If Right(nPath, 1) <> "" Then nPath = nPath & ""
On Error GoTo Exit1
For I = 1 To Len(nPath)
If Mid(nPath, I, 1) = "" Then
Path1 = Left(nPath, I - 1)
If Dir(Path1, 23) = "" Then
MkDir Path1
Else
IsPath = GetAttr(Path1) And 16
If Not IsPath Then Exit Function '有一个同名的文件
End If
End If
Next
MakePath = True: Exit Function
Exit1:
End Function