我知道這是幾乎沒人用的功能
，用手機還比較方便一些
，有興趣的，就看看吧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
