不使用第3方工具,開啟webcam預覽畫面+連續抓圖(vba範例)

(***此文只在mobile01發表,如轉貼到其它論譠、bolg,請附上來源網址,謝謝***)
我知道這是幾乎沒人用的功能,用手機還比較方便一些,有興趣的,就看看吧
xp 時代可以用Dim WebCam As WIA.Device解決,程式碼也很簡單

win7 之後就不能用wia方式了,要用比較複雜的方式處理
因為google不到vba版範例,所以寫這個程式碼讓大家參考






'========================================================
#If VBA7 Then
Private Declare PtrSafe 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
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Boolean
Private Declare PtrSafe Function SendMessageAsLong Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare PtrSafe Function SendMessageAsString Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
#Else
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
Private Declare Function DestroyWindow Lib "user32" (ByVal Hwnd As Long) As Boolean
Private Declare Function SendMessageAsLong Lib "user32" Alias "SendMessageA" _
(ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessageAsString Lib "user32" Alias "SendMessageA" _
(ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
#End If


Private Const WM_CAP_START As Long = &H400
Private Const WM_CAP_DRIVER_CONNECT As Long = WM_CAP_START + 10
Private Const WM_CAP_DRIVER_DISCONNECT As Long = WM_CAP_START + 11
Private Const WM_CAP_FILE_SAVEDIB As Long = WM_CAP_START + 25
Private Const WM_CAP_GRAB_FRAME As Long = WM_CAP_START + 60
Private Const WM_CAP_EDIT_COPY As Long = WM_CAP_START + 30
Private Const WM_CAP_SET_PREVIEW As Long = WM_CAP_START + 50
Private Const WM_CAP_SET_PREVIEWRATE As Long = WM_CAP_START + 52
Private Const WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START + 41
Private Const WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START + 42
Private Const WM_CAP_DLG_VIDEOCOMPRESSION = WM_CAP_START + 46
Private mCapHwnd As Long



Sub opencam()

mCapHwnd = capCreateCaptureWindow("視訊", &H10000000, 400, 500, 352, 288, Application.hWnd, 0)
'&H50000000 '&H40000000 '&H10000000
'預覽視窗種類,視窗位置x,視窗位置y,視窗大小(寬),視窗大小(長)
If SendMessageAsLong(mCapHwnd, WM_CAP_DRIVER_CONNECT, 0, 0) = 0 Then
MsgBox ("webcam error")
report = SendMessageAsLong(mCapHwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0)
DestroyWindow (mCapHwnd)
End If
SendMessageAsLong mCapHwnd, WM_CAP_SET_PREVIEWRATE, 60, 0
SendMessageAsLong mCapHwnd, WM_CAP_SET_PREVIEW, True, 0

End Sub


Sub Capture()

Dim Save_Name As String
Save_Name = Format(Now, "yyyymmdd_hhmmss") & ".bmp"
'SendMessageAsLong mCapHwnd, WM_CAP_DRIVER_CONNECT, 0, 0
SendMessageAsLong mCapHwnd, WM_CAP_GRAB_FRAME, 0, 0
'SendMessageAsLong mCapHwnd, WM_CAP_EDIT_COPY, 0, 0
SendMessageAsString mCapHwnd, WM_CAP_FILE_SAVEDIB, 0, ThisWorkbook.Path & "\" & Save_Name
'連續抓圖時,會使用日期+時間做檔名
SendMessageAsLong mCapHwnd, WM_CAP_SET_PREVIEWRATE, 60, 0
SendMessageAsLong mCapHwnd, WM_CAP_SET_PREVIEW, True, 0
解碼 (Save_Name)
'不想配合zxing解條碼的,刪掉解碼這一行
End Sub

Sub ChangeVideoFormat()
'調整webcam解析度
report = SendMessageAsLong(mCapHwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0)
If report = 0 Then
MsgBox ("無法調整視訊格式")
End If


End Sub

Sub ChangeVideoSource()

report = SendMessageAsLong(mCapHwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0)
If report = 0 Then
MsgBox ("無法調整色彩")
End If


End Sub

Sub ChangeVideoCompression()

report = SendMessageAsLong(mCapHwnd, WM_CAP_DLG_VIDEOCOMPRESSION, 0, 0)
If report = 0 Then
MsgBox ("無法調整壓縮格式")
End If


End Sub

Sub 解碼(Save_Name As String)

Dim read As IBarcodeReader, decode As Result
Set read = New BarcodeReader
read.Options.PossibleFormats.Add BarcodeFormat_QR_CODE
read.Options.PossibleFormats.Add BarcodeFormat_DATA_MATRIX

Set decode = read.DecodeImageFile(ThisWorkbook.Path & "\" & Save_Name)

If decode.Text = "" Then
Cells(7, 1) = "try again"
Else
Cells(7, 1) = decode
End If

End Sub

Public Sub Auto_Close()

SendMessageAsLong mCapHwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0
DestroyWindow mCapHwnd


End Sub
'==========================================================
也可以和這篇文章一起看
利用Gnu license library 來製作 Qrcode離線版+webcam掃描(vba範例)
https://www.mobile01.com/topicdetail.php?f=511&t=5037106&p=2#65941125

電腦沒webcam想玩看看的,可以在手機裝droidcam,電腦也裝上droidcam for windows
可以用手機鏡頭代替webcam,不過免費版的好像沒自動對焦功能,玩玩還可以
程式打開後如果沒畫面,可用調整色彩按鍵選擇視訊來源

附加壓縮檔: 201710/mobile01-ac04a0beae454211486958165bd5469b.zip
2017-10-06 22:14 #1
限制級
您即將進入之討論頁 需滿18歲 方可瀏覽。
提醒:內容可能因過於寫實、驚悚而令人感到不舒服,是否繼續觀看?

根據「電腦網路內容分級處理辦法」修正條文第六條第三款規定,已於該限制級網頁,依台灣網站分級推廣基金會規定作標示。
評分
複製連結