USB Camera?

[SpriggsySpriggs]

Q:  I wonder if there's a way to change camera resolution at the API or software level?
A: YES! If you want to change the settings first, use this 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 WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START + 41



Const CF_DIB = &H0008



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)

    Function OpenClipboard& (ByVal hWndNewOwner As _Offset)

    Function GetClipboardData%& (ByVal uFormat As _Unsigned Long)

    Sub CloseClipboard ()

    Function GlobalLock%& (ByVal hMem As _Offset)

    Function GlobalUnlock& (ByVal hMem As _Offset)

End Declare





Dim As _Unsigned Long vidWidth, vidHeight

vidWidth = 640

vidHeight = 480



Screen _NewImage(vidWidth, vidHeight, 32)



_ScreenMove _Middle



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

Dim As _Offset childID





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, _FALSE 'change _FALSE to _TRUE to use default settings



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

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

        End

    End If

    GrabFrame childWin

    _Limit FPS

Loop



'SaveBMP childWin, "capture.bmp"

Dim As _MEM m

GrabFrameToMemory childWin, m



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

Print "Disconnecting Driver"

KillDriver childWin

Screen m.IMAGE

_MemFree m



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_VIDEOFORMAT, 0, 0 'PICK YUY2!!!

        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)

End Sub



Sub GrabFrame (hwnd As _Offset)

    SendMessage hwnd, WM_CAP_GRAB_FRAME_NOSTOP, 0, 0

End Sub



Sub GrabFrameToMemory (hwnd As _Offset, image As _MEM)

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

    If frameSize = 0 Then

        Print "Failed to get video format size"

        KillDriver hwnd

        End

    End If

    SendMessage hwnd, WM_CAP_EDIT_COPY, 0, 0

    If OpenClipboard(0) = 0 Then

        Print "Couldn't open clipboard"

        KillDriver hwnd

        End

    End If

    Dim As _Offset hDIB: hDIB = GetClipboardData(CF_DIB)

    If hDIB = 0 Then

        Print "Failed to retrieve bitmap from clipboard"

        CloseClipboard

        KillDriver hwnd

        End

    End If

    Dim As _Offset pDIB: pDIB = GlobalLock(hDIB)

    If pDIB = 0 Then

        Print "Failed to lock the clipboard"

        CloseClipboard

        KillDriver hwnd

        End

    End If

    CloseClipboard

    'Print "Frame retrieved"

    Dim As _MEM p: p = _Mem(pDIB, 4)

    Dim As _Unsigned Long biSize: biSize = _MemGet(p, p.OFFSET, _Unsigned Long)

    Dim As _MEM pBI: pBI = _Mem(pDIB, biSize)

    'Print pBI.SIZE

    Dim As BITMAPINFO bi

    _MemGet pBI, pBI.OFFSET, bi

    _MemFree pBI

    _MemFree p

    'Print bi.bmiHeader.biWidth

    'Print bi.bmiHeader.biHeight

    'Print bi.bmiHeader.biBitCount

    Dim As Long bytesPerPixel: bytesPerPixel = (bi.bmiHeader.biBitCount + 7) \ 8

    'Print bytesPerPixel

    Dim As Long stride: stride = (((bi.bmiHeader.biWidth * bi.bmiHeader.biBitCount) + 31) And Not 31) \ 8

    'Print stride

    'Print bi.bmiHeader.biSizeImage

    Dim As _MEM m: m = _Mem(pDIB + Len(bi), bi.bmiHeader.biSizeImage)

    Dim As Long y, x, t

    Dim As _Unsigned _Byte pixel24(0 To 2)

    Dim As _Unsigned _Byte pixel32(0 To 3)

    Dim As _Offset pScanLine

    Dim As _Unsigned Long q

    Dim As Long i: i = _NewImage(bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 32)

    _Dest i





    If bi.bmiHeader.biHeight > 0 Then

        For y = 0 To Abs(bi.bmiHeader.biHeight) - 1

            pScanLine = m.OFFSET + (y * stride)

            For x = 0 To bi.bmiHeader.biWidth - 1

                If bi.bmiHeader.biBitCount = 24 Then

                    _MemGet m, pScanLine + (x * bytesPerPixel), pixel24()

                    q = _RGB32(pixel24(2), pixel24(1), pixel24(0))

                ElseIf bi.bmiHeader.biBitCount = 32 Then

                    _MemGet m, pScanLine + (x * bytesPerPixel), pixel32()

                    q = _RGBA32(pixel32(2), pixel32(1), pixel32(0), pixel32(3))

                Else

                    q = _RGB32(255, 255, 255)

                End If

                PSet (x, Abs(bi.bmiHeader.biHeight) - 1 - y), q

            Next x

        Next y

    Else

        For y = 0 To Abs(bi.bmiHeader.biHeight) - 1

            pScanLine = m.OFFSET + (y * stride)

            For x = 0 To bi.bmiHeader.biWidth - 1

                If bi.bmiHeader.biBitCount = 24 Then

                    _MemGet m, pScanLine + (x * bytesPerPixel), pixel24()

                    q = _RGB32(pixel24(2), pixel24(1), pixel24(0))

                ElseIf bi.bmiHeader.biBitCount = 32 Then

                    _MemGet m, pScanLine + (x * bytesPerPixel), pixel32()

                    q = _RGBA32(pixel32(2), pixel32(1), pixel32(0), pixel32(3))

                Else

                    q = _RGB32(255, 255, 255)

                End If

                PSet (x, y), q

            Next

        Next

    End If

    _Dest 0

    image = _MemImage(i)

    Dim As Long a: a = GlobalUnlock(pDIB)

End Sub