Как получить доступ к веб-камере и сделать снимок

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

'Created by Puguhwah

Private Sub cmd4_Click()
Dim sFileName As String
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&)
    With CDialog
        .CancelError = True
        .InitDir = App.Path
        .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 cmd4_Click()
Dim sFileName As String
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&)
    sFileName = App.Path & "\photo.jpg"
    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 cmd4_Click()
Dim sFileName As String
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&)
    sFileName = App.Path & "\photo.jpg"
    Call SendMessage(hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(sFileName))
DoFinally:
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
End Sub

Option Explicit
Dim cnt As Integer
Dim hCap As Long
 
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 cmd4_Click()
cnt = 5: Label1.Caption = (5)
Timer2.Interval = (1000)
Label1.Visible = True
Wait (5)
Dim sFileName As String
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&)
    sFileName = App.Path & "\photo.jpg"
    Call SendMessage(hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(sFileName))
DoFinally:
    Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
Wait (1)
Picture1.Picture = LoadPicture("C:\11\research_camera\photo.jpg")
Picture1.Visible = True
End Sub
 
Private Sub Cmd3_Click()
Dim temp As Long
temp = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
End Sub
 
Private Sub Cmd2_Click()
Dim temp As Long
temp = SendMessage(hCap, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
End Sub
Public Sub Wait(seconds)
Timer1.Enabled = True '????????? ???????
Timer1.Interval = 1000 * seconds '????????? ????????? ??? ???????
While Timer1.Interval > 0
DoEvents
Wend
Timer1.Enabled = False ' ?????????? ???????
End Sub
 
 
Private Sub Form_Load()
cmd1.Caption = "Камера"
cmd2.Caption = "Параметры"
cmd3.Caption = "Выключить камеру"
cmd4.Caption = "СДЕЛАТЬ ФОТО"
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 Timer1_Timer()
Timer1.Interval = 0
End Sub
 
Private Sub Timer2_Timer()
cnt = cnt - (1)
 
If (cnt = (0)) Then
cnt = (5): Label1.Visible = False
End If
 
Label1.Caption = (cnt)
End Sub

Option Explicit
 
Private Const WS_CHILD As Long = &H40000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const CW_USEDEFAULT = &H80000000
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_SET_PREVIEW As Long = WM_CAP_START + 50
Private Const WM_CAP_SET_PREVIEWRATE As Long = WM_CAP_START + 52
Private Const WM_CAP_SET_SCALE = WM_CAP_START + 53
Private Const WM_CAP_SET_VIDEOFORMAT = WM_CAP_START + 45
Private Const WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44
 
Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowW" (ByVal wn As Long, 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 SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As Any) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
 
Dim hwndCap As Long
 
Private Sub Form_Load()
    hwndCap = capCreateCaptureWindow(StrPtr("Take a Camera Shot"), WS_CHILD Or WS_VISIBLE, 0, 0, CW_USEDEFAULT, CW_USEDEFAULT, Me.hwnd, 0)
    If hwndCap = 0 Then End
    If SendMessage(hwndCap, WM_CAP_DRIVER_CONNECT, 0, ByVal 0&) = False Then End
    SendMessage hwndCap, WM_CAP_SET_PREVIEWRATE, 66, ByVal 0&
    SendMessage hwndCap, WM_CAP_SET_PREVIEW, 1, ByVal 0&
    SendMessage hwndCap, WM_CAP_SET_SCALE, 1, ByVal 0&
    If Not SetSize(1600, 1200) Then
        MsgBox "Не поддерживается"
    End If
End Sub
 
Private Function SetSize(ByVal w As Long, ByVal h As Long) As Boolean
    ' Задаем формат
    Dim buf()   As Long
    Dim c       As Long
    c = SendMessage(hwndCap, WM_CAP_GET_VIDEOFORMAT, 0, ByVal 0&)
    ReDim buf(c \ 4)
    buf(0) = 40         ' BITMAPINFO.biSize
    buf(1) = w          ' BITMAPINFO.biWidth
    buf(2) = h          ' BITMAPINFO.biHeight
    buf(3) = &H180001   ' BITMAPINFO.biPlanes = 1: BITMAPINFO.biBitCount = 24
    buf(4) = 0          ' BITMAPINFO.biCompression = 0 ' Без компрессии
    SetSize = SendMessage(hwndCap, WM_CAP_SET_VIDEOFORMAT, c, buf(0))
End Function
Private Sub Form_Resize()
    Dim RC(3) As Long
    GetClientRect Me.hwnd, RC(0)
    MoveWindow hwndCap, 0, 0, RC(2), RC(3), False
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    SendMessage hwndCap, WM_CAP_DRIVER_DISCONNECT, 0, ByVal 0&
End Sub

Private Function SetSize(ByVal w As Long, ByVal h As Long) As Boolean
    ' Çàäàåì ôîðìàò
    Dim buf()   As Long
    Dim c       As Long
    c = SendMessage(hwndCap, WM_CAP_GET_VIDEOFORMAT, 0, ByVal 0&)
    ReDim buf(c \ 4)
    SendMessage hwndCap, WM_CAP_GET_VIDEOFORMAT, c, buf(0)
    buf(0) = 40         ' BITMAPINFO.biSize
    buf(1) = w          ' BITMAPINFO.biWidth
    buf(2) = h          ' BITMAPINFO.biHeight
    buf(4) = 0          ' BITMAPINFO.biCompression = 0 ' Áåç êîìïðåññèè
    buf(5) = 0
    SetSize = SendMessage(hwndCap, WM_CAP_SET_VIDEOFORMAT, c, buf(0))
End Function