Сделать фото с веб-камеры и сохранить на диск

'This program check whether webcam is available or not
' if available then capture and displays in picture box
 
'Created by Dixanta Bahadur Shrestha
'Created Date: 12-March-2006
 
'Programmer does not garuntees if  not functions well
 
Global Const ws_child As Long = &H40000000
Global Const ws_visible As Long = &H10000000
 
Global Const WM_USER = 1024
Global Const wm_cap_driver_connect = WM_USER + 10
Global Const wm_cap_set_preview = WM_USER + 50
Global Const WM_CAP_SET_PREVIEWRATE = WM_USER + 52
Global Const WM_CAP_DRIVER_DISCONNECT As Long = WM_USER + 11
Global Const WM_CAP_DLG_VIDEOFORMAT As Long = WM_USER + 41
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (
    ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, 
    ByVal lParam As Long) As Long
Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias 
    "capCreateCaptureWindowA" (
    ByVal a As String, ByVal b As Long, ByVal c As Integer, 
    ByVal d As Integer, ByVal e As Integer, ByVal f As Integer, 
    ByVal g As Long, ByVal h As Integer) As Long
 
 
 
 
Dim hwdc As Long
Dim startcap As Boolean
Private Sub cmdCapture_Click()
Dim temp As Long
 
  hwdc = capCreateCaptureWindow("Dixanta Vision System", 
      ws_child Or ws_visible, 0, 0, 320, 240, Picture1.hWnd, 0)
  If (hwdc <> 0) Then
    temp = SendMessage(hwdc, wm_cap_driver_connect, 0, 0)
    temp = SendMessage(hwdc, wm_cap_set_preview, 1, 0)
    temp = SendMessage(hwdc, WM_CAP_SET_PREVIEWRATE, 30, 0)
    startcap = True
    Else
    MsgBox ("No Webcam found")
  End If
End Sub
 
Private Sub cmdClose_Click()
Dim temp As Long
If startcap = True Then
temp = SendMessage(hwdc, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
startcap = False
End If
End Sub
 
Private Sub cmdVideoFormat_Click()
 Dim temp As Long
 If startcap = True Then
  temp = SendMessage(hwdc, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
End If
End Sub

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
 
    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
 
    Public TCap As Boolean
    Private mCapHwnd As Long
 
    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_DLG_VIDEOFORMAT = WM_CAP_START + 41
    Private Const WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START + 42
 
    'WM_CAP_DRIVER_CONNECT     '- подключает драйвер видеоустройства.
    'WM_CAP_DRIVER_DISCONNECT  '- отключает драйвер видеоустройства.
    'WM_CAP_GRAB_FRAME         '- захватывает один кадр из видеопотока.
    'WM_CAP_FILE_SAVEDIB       '- сохраняет захваченный кадр в файл формата BMP.
    'WM_CAP_DLG_VIDEOFORMAT    '- открывает диалоговое окно формата видеозахвата.
    'WM_CAP_DLG_VIDEOSOURCE    '- открывает диалоговое окно настроек видеоустройства.
 
    '=================================================================================
 
    Private Sub UserForm_Initialize()
        TCap = False
        mCapHwnd = capCreateCaptureWindow("VideoCapture", 0, 0, 0, 320, 240, Application.hWnd, 0)
    End Sub
    'Стандартная процедура инициализации формы.
    'То есть форма загружается в память, но еще не выводится на экран.
    'Убеждаемся, что драйверы видеоустройств отключены, создаем в главном окне Excel
    'невидимое окно видеозахвата с названиями VideoCapture
    'размером 320х240 пикселей.
    'Функция Application.hWnd возвращает идентификатор главного (родительского) окна Excel.
    'Присваиваем переменной mCapHwnd значения идентификаторов окна видеозахвата.
 
    'Кн. ФОРМАТ
    'Если драйверы видеоустройств подключены, показывают диалоговое окно настройки
    'формата видеозахвата, если отключены, ничего не происходит.
    Private Sub Format_Bttn_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Format_Bttn.Click
        SendMessageAsLong(mCapWnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0)
    End Sub
 
    'Кн. КАМЕРА
    'Если драйверы видеоустройств подключены, показывают диалоговое окно
    'настройки параметров видеоустройства, если отключены, ничего не происходит.
    Private Sub Kamera_Bttn_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Kamera_Bttn.Click
        SendMessageAsLong(mCapWnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0)
    End Sub
 
    'Кн. СТАРТ
    Private Sub Start_Bttn_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Start_Bttn.Click
        TCap = True
        SendMessageAsLong(mCapHwnd, WM_CAP_DRIVER_CONNECT, 0, 0)
        Do While TCap = True
            DoEvents()
            SendMessageAsLong(mCapHwnd, WM_CAP_GRAB_FRAME, 0, 0)
            SendMessageAsString(mCapHwnd, WM_CAP_FILE_SAVEDIB, 0, "D:\VIDEO.BMP")
            Monitor_PB.ImageLocation = "D:\VIDEO.BMP"
        Loop
    End Sub
 
    'Кн. СТОП
    'Процедура обработки событий нажатия кнопок Стоп.
    'Устанавливаем значения переменной TCap в False (драйвер отключен),
    'после чего посылаем окну видеозахвата системное сообщение с командой отключить драйвер.
    Private Sub Stop_Bttn_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Stop_Bttn.Click
        TCap = False
        SendMessageAsLong(mCapHwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0)
    End Sub

Private Sub Format_Bttn_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Format_Bttn.Click
        SendMessageAsLong(mCapWnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0)

Private Sub Kamera_Bttn_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Kamera_Bttn.Click
        SendMessageAsLong(mCapWnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0)

Private Sub Start_Bttn_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Start_Bttn.Click

SendMessageAsLong(mCapHwnd, WM_CAP_DRIVER_CONNECT, 0, 0)

DoEvents()
            SendMessageAsLong(mCapHwnd, WM_CAP_GRAB_FRAME, 0, 0)
            SendMessageAsString(mCapHwnd, WM_CAP_FILE_SAVEDIB, 0, "D:\VIDEO.BMP")

 Private Sub Stop_Bttn_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Stop_Bttn.Click
        TCap = False
        SendMessageAsLong(mCapHwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0)

Private Const ws_child As Long = &H40000000
Private Const ws_visible As Long = &H10000000
 
Private Const WM_USER = 1024
Private Const wm_cap_driver_connect = WM_USER + 10
Private Const wm_cap_set_preview = WM_USER + 50
Private Const WM_CAP_SET_PREVIEWRATE = WM_USER + 52
Private Const WM_CAP_DRIVER_DISCONNECT As Long = WM_USER + 11
Private Const WM_CAP_DLG_VIDEOFORMAT As Long = WM_USER + 41
 
Private Declare Function SendMessage 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 capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowA" (ByVal a As String, ByVal b As Long, ByVal c As Integer, ByVal d As Integer, ByVal e As Integer, ByVal f As Integer, ByVal g As Long, ByVal h As Integer) As Long
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
 
Dim hwdc As Long
Dim startcap As Boolean
Private Sub cmdCapture_Click()
Dim temp As Long
  
  hWnd = FindWindow("ThunderDFrame", Me.Caption)
  
  hwdc = capCreateCaptureWindow("Dixanta Vision System", ws_child Or ws_visible, 0, 0, 320, 240, Picture1.hWnd, 0)
  If (hwdc <> 0) Then
    temp = SendMessage(hwdc, wm_cap_driver_connect, 0, 0)
    temp = SendMessage(hwdc, wm_cap_set_preview, 1, 0)
    temp = SendMessage(hwdc, WM_CAP_SET_PREVIEWRATE, 30, 0)
    startcap = True
    Else
    MsgBox ("No Webcam found")
  End If
End Sub