MSカメラから画像をキャプチャして保存するVBAコード

Question

私のフォーム（MS Accessデータベース）にボタンを追加して、カメラ（ラップトップ）から画像をキャプチャして特定の場所に保存することができます：\画像）。 オフィス2010またはオフィス365でWindows 10を使用しています。

アイデアや助けがあります。

ありがとうございます。 WIAと

Psの更新コード：私は（添付USB）私のiPhoneのカメラを開くために管理する。これにより

Private Sub Command1_Click() 

    Dim oWIA_DeviceManager As WIA.DeviceManager 
    Dim oWIA_Device As WIA.Device 
    Dim oWIA_ComDlg As WIA.CommonDialog 
    Dim oImageFile As WIA.ImageFile 
    Dim i As Long 

    Set oWIA_DeviceManager = New WIA.DeviceManager 

    If oWIA_DeviceManager.DeviceInfos.Count > 0 Then 
     Set oWIA_ComDlg = New WIA.CommonDialog 

     ' Index the Devices property starting here at 1, not 0 . 
     For i = 1 To oWIA_DeviceManager.DeviceInfos.Count 
      Set oWIA_Device = oWIA_DeviceManager.DeviceInfos.Item(i).Connect 

      ' Use this to show Acquisition CommonDialog 
      Set oImageFile = oWIA_ComDlg.ShowAcquireImage 

      ' Use this to show Acquisition Wizard 
      'Set oImageFile = oWIA_ComDlg.ShowAcquisitionWizard(oWIA_Device) 

     Next i 
    Else 
     MsgBox "No WIA compatible device attached!" 
    End If 

End Sub 

。私は私のラップトップの私の組み込みのカメラを使用する必要があります。

ありがとうございました

Answer 1

このページはおそらく必要なものです。 http://www.developerfusion.com/thread/46191/how-to-capture-picture-using-webcam-in-vb60/

'******************* module code ************** 

Public Const WS_CHILD As Long = &H40000000 
Public Const WS_VISIBLE As Long = &H10000000 


Public Const WM_USER As Long = &H400 
Public Const WM_CAP_START As Long = WM_USER 


Public Const WM_CAP_DRIVER_CONNECT As Long = WM_CAP_START + 10 
Public Const WM_CAP_DRIVER_DISCONNECT As Long = WM_CAP_START + 11 
Public Const WM_CAP_SET_PREVIEW As Long = WM_CAP_START + 50 
Public Const WM_CAP_SET_PREVIEWRATE As Long = WM_CAP_START + 52 
Public Const WM_CAP_DLG_VIDEOFORMAT As Long = WM_CAP_START + 41 
Public Const WM_CAP_FILE_SAVEDIB As Long = WM_CAP_START + 25 






Public 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 






Public Declare Function SendMessage Lib "user32" _ 
    Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long _ 
     , ByVal wParam As Long, ByRef lParam As Any) As Long 


'************* end of module code ****************** 

Add the following controls in a form 

1. A picture box with name "PicWebCam" 

2. A commondialog control with name "CDialog" 

3. Add 4 command buttons with name "cmd1","cmd2,"cmd3","cmd4" 

then paste the following code 

'************************** Code ************** 

Dim hCap As Long 
Private Sub cmd4_Click() 
Dim sFileName As String 
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&) 
    With CDialog 
     .CancelError = True 
     .Flags = cdlOFNPathMustExist Or cdlOFNOverwritePrompt 
     .Filter = "Bitmap Picture(*.bmp)|*.bmp|JPEG Picture(*.jpg)|*.jpg|All Files|*.*" 
     .ShowSave 
     sFileName = .FileName 









    End With 
    Call SendMessage(hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(sFileName)) 
DoFinally: 
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&) 
End Sub 




Private Sub Cmd3_Click() 
Dim temp As Long 
temp = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&) 
End Sub 


Private Sub Cmd1_Click() 
hCap = capCreateCaptureWindow("Take a Camera Shot", WS_CHILD Or WS_VISIBLE, 0, 0, PicWebCam.Width, PicWebCam.Height, PicWebCam.hWnd, 0) 
    If hCap <> 0 Then 
     Call SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0) 
     Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 66, 0&) 
     Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&) 
    End If 
End Sub 






Private Sub Cmd2_Click() 
Dim temp As Long 
temp = SendMessage(hCap, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&) 
End Sub 


Private Sub Form_Load() 
cmd1.Caption = "Start &Cam" 
cmd2.Caption = "&Format Cam" 
cmd3.Caption = "&Close Cam" 
cmd4.Caption = "&Save Image" 
End Sub 
'**************** Code end ************************ 

基本的にこれが何をしているか写真を撮るためにそれを求めて、ウェブカムドライバにメッセージを送信するには、Windowsのメッセージポンプを使用しています。 また、将来のセルフヘルプのヒント。 VBAとほぼ同じことであるVB6を検索すると、より良い結果を得ることができます。 VBAにはわずかな機能しかありません。

共通のダイアログコントロールがない場合。このコードを変更することができます

Private Sub cmd4_Click() 
Dim sFileName As String 
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&) 
    sFileName="C:\PathToNewImageFile.bmp" 
    Call SendMessage(hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(sFileName)) 
DoFinally: 
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&) 
End Sub 

Answer 2

以前はスキャナ用にWIA（Microsoft Windows Image Acquisition）を使用していましたが、ウェブカメラでも使用できます。私は間違いなくそれを試してみるだろう。