54. 實現(xiàn)USB攝像頭視頻圖像的監(jiān)控,、截圖,、錄像
本程序是“攝像頭視頻監(jiān)控”的改進，僅用四個按鈕實現(xiàn)對攝像頭視頻的監(jiān)控,、截圖,、錄像，可以分別保存為圖片文件和視頻文件,。保存的視頻文件可以用媒體播放機（Windows Media Player）,、 暴風影音等軟件進行播放，輕松實現(xiàn)家庭錄像制作,。
利用電腦配備的 USB 攝像頭進行視頻控制,，要用到兩個 API 函數(shù)：capCreateCaptureWindow 和 SendMessage。
capCreateCaptureWindow 的作用是創(chuàng)建一個視頻窗口,，攝像頭捕捉到的視頻圖像在此窗口內顯示,，函數(shù)返回值就是代表此窗口的句柄。此函數(shù)的 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
各參數(shù)意義如下：
lpszWindowName 視頻窗口的窗口標題
dwStyle 窗口模式,，設置值可用下面數(shù)值,，也可組合使用：
WS_Child：視頻窗口是子窗口，位于應用程序主窗口內,。否則是獨立的窗口,。
WS_Visible：視頻窗口可見
WS_Caption：視頻窗口有標題欄
WS_ThickFrame：視頻窗口有邊框
X 視頻窗口位置x坐標
Y 視頻窗口位置y坐標
nWidth 視頻窗口寬度
nHeight 視頻窗口高度
hwndParent 創(chuàng)建視頻窗口的主窗口，設置為：Me.hWnd
nID 視頻ID
視頻窗口創(chuàng)建后，剩下的事情就是用 SendMessage 向該窗口發(fā)送各種消息,，實現(xiàn)對攝像頭的控制,。
' '以下是完整代碼,，在 VB6 和 WindowsXP 下調試通過：
'在窗體放置4個控件：Command1,、Command2、Command3,、Command4
'程序調試時要注意：終止程序要用運行中的 Form1 窗口關閉,。不要使用 VB 主窗口的菜單命令或 VB 工具欄上的關閉按鈕，這樣無法關閉打開的視頻窗口,，導致 VB 無響應,。如果 VB 無響應，只有用系統(tǒng)任務管理器才能終止 VB 進程,，調試過程中所做的修改將丟失,。
'本人原創(chuàng)，轉載請注明來源：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
'視頻窗口控制消息常數(shù)
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()
'創(chuàng)建視頻窗口和連接攝像頭
Dim nStyle As Long, T As Long
If ctCapWin = 0 Then '創(chuàng)建一個視頻窗口,，大?。?40*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("我創(chuàng)建的視頻窗口", 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 '第三個參數(shù)：1-預覽模式有效,0-預覽模式無效
SendMessage ctCapWin, WM_CAP_Set_PreViewRate, 30, 0 '第三個參數(shù)：設置預覽顯示頻率為每秒 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 格式,，參見： 將圖片保存或轉變?yōu)镴PG格式
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
后記：本程序改進見 攝像頭視頻圖像的監(jiān)控,、截圖、錄像（改進），改進后的增加了以下功能：
1.可控制多個視頻攝像頭,。例如,，如果一臺電腦配置了兩個攝像頭，啟動程序兩次,，在彈出的“視頻源”對話框中選擇不同的捕獲源,，兩個窗口就能同時顯示不同攝像頭獲得的圖像。
2.調節(jié)視頻的亮度,、對比度等許多參數(shù),。
3.將視頻壓縮后保存到硬盤，這樣得到的視頻文件會比默認方式小 10 倍以上,。
4.視頻窗口有自動大小和全屏功能,。在全屏狀態(tài)時，工具欄按鈕會自動隱藏,。將鼠標移動到屏幕頂部,，工具欄又會自動顯示出來。
