USB Camera?

[SpriggsySpriggs]

Hey, guys. It's working now and here is the code:

Code: (Select All)

Option _Explicit

Const WS_VISIBLE = &H10000000

'------------------------------------------------------------------------------------------------------------------------------

'Capture Driver Constants

Const WM_CAP_START = &H0400

Const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10

Const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11

Const WM_CAP_EDIT_COPY = WM_CAP_START + 30

Const WM_CAP_SET_SCALE = WM_CAP_START + 53

Const WM_CAP_SET_PREVIEWRATE = WM_CAP_START + 52

Const WM_CAP_SET_PREVIEW = WM_CAP_START + 50

Const WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START + 42

Const WM_CAP_GRAB_FRAME_NOSTOP = WM_CAP_START + 61

Const WM_CAP_FILE_SAVEDIB = WM_CAP_START + 25

Const WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44

Const WM_CAP_SET_VIDEOFORMAT = WM_CAP_START + 45



Const FPS = 30 'Not recommended to set this higher than frame rate of webcam/video device



Type BITMAPINFOHEADER

    As _Unsigned Long biSize

    As Long biWidth, biHeight

    As _Unsigned Integer biPlanes, biBitCount

    As _Unsigned Long biCompression, biSizeImage

    As Long biXPelsPerMeter, biYPelsPerMeter

    As _Unsigned Long biClrUsed, biClrImportant

End Type



Type BITMAPINFO

    As BITMAPINFOHEADER bmiHeader

End Type



Declare Dynamic Library "Avicap32"

    Function CreateCaptureWindow& Alias "capCreateCaptureWindowA" (ByVal lpszWindowName As _Offset, ByVal dwStyle As _Unsigned Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As _Offset, ByVal nId As Long)

End Declare



Declare CustomType Library

    Sub SendMessage Alias "SendMessageA" (ByVal hWnd As _Offset, ByVal Msg As _Unsigned Long, ByVal wParam As _Offset, ByVal lParam As _Offset)

    Function SendMessage& Alias "SendMessageA" (ByVal hWnd As _Offset, ByVal Msg As _Unsigned Long, ByVal wParam As _Offset, ByVal lParam As _Offset)

    Sub DestroyWindow (ByVal hWnd As _Offset)

    Function GetAsyncKeyState% (ByVal vKey As Long)

    Function mmioStringToFOURCC& (sz As String, ByVal uFlags As _Unsigned Long)

End Declare



_ScreenMove _Middle



Dim As String captureWinText: captureWinText = "Webcam API Test - Child" + Chr$(0)

Dim As _Offset childID

Dim As _Unsigned Long vidWidth, vidHeight

vidWidth = 640

vidHeight = 480



Dim As _Offset childWin: childWin = CreateCaptureWindow(_Offset(captureWinText), WS_VISIBLE, 0, 0, vidWidth, vidHeight, _WindowHandle, childID)

_Title "Webcam API Test - Parent"

If _FileExists("capture.bmp") Then Kill "capture.bmp"

'Initialize the driver

SetupDriver childWin, vidWidth, vidHeight, _TRUE



Print "Previewing... Press Space bar to capture frame to capture.bmp"

Print "Press escape to kill the window"

Print "DO NOT GO CLICKING ALL WILLY-NILLY ON THE PROGRAM WINDOW, ESPECIALLY IF YOUR CURSOR HAS THE LOADING CIRCLE/HOURGLASS. For some reason, this will cause it to freeze and crash. Why? 'cause Microsoft, that's why."



Do

    'GetAsyncKeyState is necessary because the capture window steals keyboard focus

    If GetAsyncKeyState(&H20) <> 0 Then Exit Do

    If GetAsyncKeyState(&H1B) <> 0 Then KillDriver childWin

    GrabFrame childWin

    _Limit FPS

Loop



SaveBMP childWin, "capture.bmp"

If _FileExists("capture.bmp") Then Print "Capture succeeded"

Print "Disconnecting Driver"

KillDriver childWin

Shell _Hide "start capture.bmp" 'open BMP in default photo viewer



Sub SetupDriver (hwnd As _Offset, videoWidth As _Unsigned Long, videoHeight As _Unsigned Long, defaultSource As _Byte)

    SendMessage hwnd, WM_CAP_DRIVER_CONNECT, 0, 0

    SendMessage hwnd, WM_CAP_SET_SCALE, -1, 0

    SendMessage hwnd, WM_CAP_SET_PREVIEWRATE, 1000 / FPS, 0

    SendMessage hwnd, WM_CAP_SET_PREVIEW, -1, 0

    Dim As _Unsigned Long formatSize: formatSize = SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, 0, 0)

    Dim As BITMAPINFO bmi

    If Len(bmi) <> formatSize Then

        KillDriver hwnd

        Print "Wrong size"

        Print formatSize, Len(bmi)

        End

    End If



    If SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, formatSize, _Offset(bmi)) = 0 Then

        KillDriver hwnd

        Print "Couldn't get format"

        End

    End If

    bmi.bmiHeader.biWidth = videoWidth

    bmi.bmiHeader.biHeight = videoHeight

    bmi.bmiHeader.biBitCount = 16 'yuy2 format

    bmi.bmiHeader.biCompression = mmioStringToFOURCC("YUY2" + Chr$(0), &H00000010) 'MUST BE YUY2 FORMAT

    bmi.bmiHeader.biSizeImage = videoWidth * videoHeight * 2

    If SendMessage(hwnd, WM_CAP_SET_VIDEOFORMAT, formatSize, _Offset(bmi)) = 0 Then

        KillDriver hwnd

        Print "Failed to set video format"

        End

    End If

    If defaultSource = _FALSE Then

        SendMessage hwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0

    End If

End Sub



Sub KillDriver (hwnd As _Offset)

    SendMessage hwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0

    DestroyWindow hwnd

End Sub



Sub SaveBMP (hwnd As _Offset, filename As String)

    filename = filename + Chr$(0)

    SendMessage hwnd, WM_CAP_FILE_SAVEDIB, 0, _Offset(filename)

    SendMessage hwnd, WM_CAP_EDIT_COPY, 0, 0 'It is now in the clipboard, too 

End Sub



Sub GrabFrame (hwnd As _Offset)

    SendMessage hwnd, WM_CAP_GRAB_FRAME_NOSTOP, 0, 0

End Sub