《2022年vb源代码vb小程序：摄像头视频图像的监控、截图、录像 .pdf》由会员分享，可在线阅读，更多相关《2022年vb源代码vb小程序：摄像头视频图像的监控、截图、录像 .pdf（14页珍藏版）》请在taowenge.com淘文阁网|工程机械CAD图纸|机械工程制图|CAD装配图下载|SolidWorks_CaTia_CAD_UG_PROE_设计图分享下载上搜索。
1、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 &a
2、mp; "videos" nStr = Trim(InputBox(nStr, "录像保存的文件夹", ctDir) If nStr = "" Then Exit Sub ctDir = nStr If ctDir = "<>" Or ctDir = "<默认 >" Then ctDir = ""End SubPrivate Sub SetFile() Dim nStr As String, nF As String nF = String(255,
3、" ") 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 & "输入“<>”表示使用默认文件名：日期-时间 .扩展名 &qu
4、ot; nStr = Trim(InputBox(nStr, "录像保存的文件名", ctF) If nStr = "" Then Exit Sub ctF = nStr If ctF = "<>" Or ctF = "<默认 >" Then ctF = ""名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 1 页，共 14 页 - - - - - - - - -
5、 SendMessage ctCapWin, WM_Cap_File_Set_File, 0, ByVal ctFEnd SubPrivate 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 = nStrEnd FunctionPrivate Function CheckDirFile(nDirFile)
6、 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 = 1End FunctionPrivate Sub Form_Load() Dim W As Long, H As Long Call SetCaption(&
7、quot;") Me.ScaleMode = 3: Picture1.ScaleMode = 3 Picture1.BorderStyle = 0 Set Command1(0).Container = Picture1 Set Check1(0).Container = Picture1 Call ReadSaveSet 读取用户设置 装载数组控件 AddKj Command1, "连", "Connect", "连接摄像头 "名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - -
8、 - - - - 名师精心整理 - - - - - - - 第 2 页，共 14 页 - - - - - - - - - AddKj Command1, "断", "DisConnect", "断开与摄像头的连接" AddKj Command1, "-" AddKj Command1, "源", "VideoSource", "选择：视频源" AddKj Command1, "格", "VideoFormat", &
9、quot;设置：视频格式，分辨率 " AddKj Command1, "显", "VideoDisplay", "视频显示对话框。某些显卡不支持此功能。" AddKj Command1, "-" AddKj Command1, "夹", "SetDir", "设置录像文件保存的文件夹。默认为主程序所在目录下的“videos”文件夹" AddKj Command1, "文", "SetFile", "
10、;录像保存的文件名，默认为：时间 -编号 .扩展名 " AddKj Command1, "压", "VideoCompression", "设置：视频录像文件的压缩方式" AddKj Command1, "-" AddKj Command1, "录", "Record", "开始录像 " AddKj Command1, "停", "NoRecord", "停止录像 " AddKj Com
11、mand1, "图", "CopyImg", "将当前图像复制到剪贴板 " AddKj Command1, "-" AddKj Command1, "全", "FillScreen", "切换：全屏 / 窗口" AddKj Command1, "关", "Exit", "关闭：退出程序" If ctAutoSize Then W = 1 Else W = 0 AddKj(Check1, "
12、;自", "AutoSize", "视频窗口是否随主窗口自动改变大小 ").Value = W If ctAutoHide Then W = 1 Else W = 0 AddKj(Check1, "隐", "AutoHide", "录像时自动隐藏主窗口").Value = W ctAutoSize = True 预览图像随窗口自动缩放名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - -
13、 第 3 页，共 14 页 - - - - - - - - - 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) Tim
14、er1.Enabled = True: Timer1.Interval = 500End SubPrivate Sub Form_Resize() Picture1.Move 0, 0, Me.ScaleWidth, Command1(0).Height * 1.3 If ctAutoSize Then SetWin ctCapWin, es_Size 视频子窗口随主窗口自动改变大小End SubPrivate Sub Timer1_Timer() Dim nP As PointAPI, X As Long, Y As Long, H As Long Dim nStatus As CapSta
15、tus, 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 GetCursorP
16、os nP X = nP.X - Me.Left / Screen.TwipsPerPixelX Y = nP.Y - Me.Top / Screen.TwipsPerPixelY名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 4 页，共 14 页 - - - - - - - - - If Not IsFillScreen Then Exit Sub H = Me.Height / Screen.TwipsPerPixelY - Me.ScaleHeight 窗口标题栏高度 If Y
17、 > -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_SizeEnd SubPrivate Sub SetCaption(Optional nCap As String) If nCap <> "" Then Me.Tag =
18、 Trim(nCap) If IsFillScreen Then 全屏方式 Me.Caption = "" Else 窗口方式 If Me.Tag = "" Then Me.Caption = "摄像头控制 " Else Me.Caption = "摄像头控制 - " & Me.Tag End IfEnd SubPrivate Sub Check1_Click(Index As Integer) Dim nTag As String, TF As Boolean If Not ctRefresh Then
19、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")名师资料总结 - - -精品资料欢迎下载 - - - - - - -
20、 - - - - - - - - - - - 名师精心整理 - - - - - - - 第 5 页，共 14 页 - - - - - - - - - ctAutoHide = TF End SelectEnd SubPrivate Sub Command1_Click(Index As Integer) Cmd Command1(Index).TagEnd SubPrivate Sub Cmd(nCmd As String) Select Case LCase(nCmd) Case LCase("Connect"): Call CapConnect 连接摄像头 Case L
21、Case("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(
22、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_C
23、AP_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
24、LCase("") Case LCase("") Case LCase("")名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 6 页，共 14 页 - - - - - - - - - Case LCase("Exit"): Unload Me: Exit Sub End Select Call KjEnabled(True)End SubPublic Sub FillScreen() 全屏切换 IsFil
25、lScreen = 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 WinC
26、enter 窗口居中 End If Check1(KjIndex(Check1, "AutoSize").Enabled = Not IsFillScreenEnd SubPrivate 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 SubPrivate
27、Sub VideoSize(W As Long, H As Long) 获取视频的大小尺寸 Dim nInf As BitMapInfo名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 7 页，共 14 页 - - - - - - - - - SendMessage ctCapWin, WM_CAP_Get_VideoFormat, Len(nInf), nInf W = nInf.bmiHeader.biWidth: H = nInf.bmiHeader.biHeightEnd Su
28、bPrivate 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(
29、I).Name & "-" & I Else Kj(I).Tag = nTag Kj(I).ToolTipText = nNote Set 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 Long H1 = Picture1.TextHeight("A"): T = H1 * 0.25: W = H1 * 2 For I = Kj.lBound To
30、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 NextEnd Sub名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 8 页，共 14 页 - - - - - - - - - Private Function KjIndex(Kj As O
31、bject, 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 = -1End FunctionPrivate Sub KjEnabled(Optional nEnabled As Boolean) Dim Kj, TF As Boolean, nType As String On Error Resume Next For Each Kj In Me
32、.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, "
33、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
34、").Enabled = TF Command1(KjIndex(Command1, "VideoFormat").Enabled = TF名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 9 页，共 14 页 - - - - - - - - - Command1(KjIndex(Command1, "VideoDisplay").Enabled = TF Command1(KjIndex(Command1, "VideoCo
35、mpression").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 = Fal
36、se Command1(KjIndex(Command1, "NoRecord").Enabled = True Command1(KjIndex(Command1, "SetFile").Enabled = False Command1(KjIndex(Command1, "SetDir").Enabled = FalseEnd SubPrivate Sub CreateCapWin() 创建视频窗口 Dim nStyle As Long, S As Long Dim lpszName As String * 128 Dim lps
37、zVer 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("我创建的视频窗口"
38、, 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名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 10 页，共 14 页 - - - - - - - - - End SubPrivate Sub CapConnect() Dim D As
39、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 S
40、etWin(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 Long If hWnds = 0 Then Exit Sub Select Case nSet Case es_Close: Se
41、ndMessage 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 =
42、HWND_Top: wFlags = SWP_NoActivate 录像状态下改变视频窗口大小，有时会出现莫名其妙的错误 If ctRec Then wFlags = wFlags + SWP_NoSize L = 0名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 11 页，共 14 页 - - - - - - - - - If Picture1.Visible Then T = Picture1.Height If ctAutoSize Then W = Me.ScaleWidth
43、 - 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, wFlagsEnd SubPrivate Sub ReadSaveSet(Optional IsSave As Boolean) Dim nPath As String, nSub As St
44、ring 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 ctAutoSi
45、ze = GetSetting(nPath, nSub, "AutoSize", "False") ctAutoHide = GetSetting(nPath, nSub, "AutoHide", "False") ctDir = GetSetting(nPath, nSub, "Path", "") ctF = GetSetting(nPath, nSub, "File", "") End IfEnd SubPrivate Sub F
46、orm_Unload(Cancel As Integer) 停止摄像头。一般情况，如果母窗体关闭，子窗体就会自动释放。下面两句代码是否可省？ If ctRec Then Call NoRecord名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 12 页，共 14 页 - - - - - - - - - Cmd "DisConnect" 断开摄像头连接 SetWin ctCapWin, es_Close Call ReadSaveSet(True) 保存用户设置En
47、d SubPrivate 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
48、 = nStr End IfEnd FunctionPrivate 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(
49、nPath, I, 1) = "" Then Path1 = Left(nPath, I - 1) If Dir(Path1, 23) = "" Then MkDir Path1 Else IsPath = GetAttr(Path1) And 16名师资料总结 - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 13 页，共 14 页 - - - - - - - - - If Not IsPath Then Exit Function 有一个同名的文件 End If End If Next MakePath = True: Exit FunctionExit1:End Function查看文档来源：http:/ - - -精品资料欢迎下载 - - - - - - - - - - - - - - - - - - 名师精心整理 - - - - - - - 第 14 页，共 14 页 - - - - - - - - -