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

   

[SpriggsySpriggs]

Hey, y'all. I did see your posts. I'm working on this right now. I've got it to save a bmp file and now I just have to get it to work a little better. Thank you for your patience.

Thanks for helping! If there's a way to capture a still image directly to a QB64PE image in memory, that would be useful for trying out "computer vision", but saving a still frame to an image file and loading it in off disk would probably work too, albeit a little bit slower (maybe it could be made faster if there were a way to write to an in-memory "virtual disk"...)
But any still frame capture would be great.

Directly to memory? No, but the code I just made saves to a BMP and copies it to the clipboard. I can look at that, though. Supposedly, direct to memory is an option. Just give me some time to check.

[madscijr]

Directly to memory? No, but the code I just made saves to a BMP and copies it to the clipboard. I can look at that, though. Supposedly, direct to memory is an option. Just give me some time to check.

Sure - this is great! Thanks for this.

[Petr]

@SpriggsySpriggs Thank you very much for sharing! Now @madscijr can one computer  controlled by flashes from the monitor of the other computer You are the biggest DLL expert on the forum.

[madscijr]

@SpriggsySpriggs Thank you very much for sharing! Now @madscijr can one computer  controlled by flashes from the monitor of the other computer You are the biggest DLL expert on the forum.

Ha! Putting this together with the "modem" code, I suppose that could be possible. It could be an alternative way to "network" 2 machines together wirelessly, although they would need line of sight.

The fun thing I want to do is control a Pong paddle using a laser pointer that is "seen" and tracked by QB64PE with a web cam. 

Another use case is a smart cat toy: QB64PE "watches" the floor in an empty room and tracks where the laser pointer and kitty are, and keeps moving the laser pointer away from kitty (via an Arduino or Pi connected to the PC). Don't know how hard that one is, for now tracking a laser pointer or other object on a blank background is a good simple project.

[SpriggsySpriggs]

Now you can export straight to memory, mi amigo.
It should be noted that it has to export to clipboard first and then load to memory. So your clipboard will contain the image as well. But that's the nature of the beast.

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 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, _TRUE



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_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

[madscijr]

Now you can export straight to memory, mi amigo.
It should be noted that it has to export to clipboard first and then load to memory. So your clipboard will contain the image as well. But that's the nature of the beast.

Wow! That totally works!

You're amazing. Thank you.

Thinking out loud...

I'd like to try using this to try to track a simple object, maybe a red laser pointer on a white wall.

This would mean looking at pixels. I'm thinking it would help to adjust the camera settings to whatever would make it easier and faster for the code to identify an object or a certain color.

Looking at the Windows control panel for the camera, I see settings to adjust Zoom, Brightness, Contrast, Sharpness, Saturation.

I don't see any control panel setting for lowering camera resolution, which should speed up scanning the image (but not so low that the thing we're looking for isn't visible). I wonder if there's a way to change camera resolution at the API or software level?

I wonder if the control panel settings can be read from the API to save to variables, then set to lo-res, high contrast, etc. (settings to make finding certain colors or objects easier) and then when the program is done running, restore the original values for normal webcam use? 

(If you think any of that might be possible, I'd be curious.)

But in any case, thanks a million for showing us how to acess the webcam from QB64PE!

[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

[SpriggsySpriggs]

Ignore the previous code. This will be better.
EDIT: The reason why is that this will default the resolution of the video rather than requiring you to enter it in the function call. Because who wants to do that?

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 = 1280

vidHeight = 720



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, _TRUE '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, 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

    If defaultSource = _FALSE Then

        SendMessage hwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0 'PICK YUY2!!!

        SendMessage hwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0

    End If

    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

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

   

[madscijr]

Wow, who knew BASIC could be so powerful? 
Thanks Spriggsy.
I'm out of time for today but will definitely give this a try later. 

@James2464 are you seeing this??