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)
Function LoadLibrary%& (lpLibFileName As String)
Function GetProcAddress%& (ByVal hModule As _Offset, lpProcName As String)
End Declare
Declare Library ".\internal\c\c_compiler\include\vfw"
End Declare
Declare Library "framecallback"
End Declare
Dim Shared 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), 0, 0, 0, vidWidth, vidHeight, _WindowHandle, childID)
_Title "Webcam API Test - Parent"
SetupDriver childWin, _TRUE 'change _FALSE to _TRUE to use default settings
Print "Previewing... Press Space bar to stop"
Print "Press escape to kill the window"
Dim Shared As _MEM frame
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
Screen frame.IMAGE
_Display
_Limit FPS
Loop
Print "Disconnecting Driver"
KillDriver childWin
_MemFree frame
Sleep
Sub SetupDriver (hwnd As _Offset, defaultSource As _Byte)
Dim As _Offset libload: libload = LoadLibrary(Command$(0))
Dim As _Offset myCallback: myCallback = GetProcAddress(libload, "CapVideoCallback")
Dim As BITMAPINFO format
'End
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)
If Len(format) <> formatSize Then
KillDriver hwnd
Print "Wrong size"
Print formatSize, Len(format)
End
End If
If SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, formatSize, _Offset(format)) = 0 Then
KillDriver hwnd
Print "Couldn't get format"
End
End If
'bmi.bmiHeader.biWidth = vidWidth
'bmi.bmiHeader.biHeight = vidHeight
format.bmiHeader.biBitCount = 16 'yuy2 format
format.bmiHeader.biCompression = mmioStringToFOURCC("YUY2" + Chr$(0), &H00000010) 'MUST BE YUY2 FORMAT
If SendMessage(hwnd, WM_CAP_SET_VIDEOFORMAT, formatSize, _Offset(format)) = 0 Then
KillDriver hwnd
Print "Failed to set video format"
End
End If
SendMessage hwnd, WM_CAP_GET_VIDEOFORMAT, 0, _Offset(format)
SendMessage hwnd, WM_CAP_SET_CALLBACK_FRAME, 0, myCallback
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 GrabFrameToClipboard (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
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)
Dim As BITMAPINFO bi
_MemGet pBI, pBI.OFFSET, bi
_MemFree pBI
_MemFree p
Dim As Long bytesPerPixel: bytesPerPixel = (bi.bmiHeader.biBitCount + 7) \ 8
Dim As Long stride: stride = (((bi.bmiHeader.biWidth * bi.bmiHeader.biBitCount) + 31) And Not 31) \ 8
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
Function CapVideoCallback%& (hWnd As _Offset, lpVHdr As _Offset)
Type VIDEOHDR
As _Offset lpData
As _Unsigned Long dwBufferLength, dwBytesUsed, dwTimeCaptured
As String * 4 padding1
As _Unsigned _Offset dwUser
As _Unsigned Long dwFlags
As String * 4 padding2
As _Offset dwReserved1, dwReserved2, dwReserved3, dwReserved4
End Type
Dim As VIDEOHDR vhdr
Dim As _MEM pVhdr: pVhdr = _Mem(lpVHdr, Len(vhdr))
_MemGet pVhdr, pVhdr.OFFSET, vhdr
_MemFree pVhdr
Dim As _MEM lpData: lpData = _Mem(vhdr.lpData, vhdr.dwBufferLength)
If _MemExists(frame) Then _MemFree frame
Dim As Long bitsPerPixel: bitsPerPixel = 16
Dim As Long bytesPerPixel: bytesPerPixel = 2
Dim As Long stride: stride = vidWidth * 2
Dim As Long y, x
Dim As _Unsigned _Byte yuy2(0 To 3)
Dim As _Offset pScanLine
Dim As _Unsigned _Integer64 converted
Dim As _Unsigned _Byte r, g, b
Dim As _Offset pixelOffset
Dim As Long i: i = _NewImage(vidWidth, vidHeight, 32)
_Dest i
For y = 0 To vidHeight - 1
pScanLine = lpData.OFFSET + (y * stride)
For x = 0 To vidWidth - 2 Step 2
pixelOffset = pScanLine + (x * 2)
_MemGet lpData, pixelOffset, yuy2()
converted = ConvertYUY2toRGB(yuy2())
PSet (x, y), converted And &HFFFFFFFF
PSet (x + 1, y), _ShR(converted, 32) And &HFFFFFFFF
Next
Next
_Dest 0
frame = _MemImage(i)
End Function
Function ConvertYUY2toRGB~&& (yuy2() As _Unsigned _Byte) '(y1 As _Byte, u As _Byte, y2 As _Byte, v As _Byte)
Dim As _Unsigned _Byte r1, g1, b1, r2, g2, b2
' Convert first pixel (Y1)
r1 = yuy2(0) + 1.13983 * (yuy2(3) - 128)
g1 = yuy2(0) - 0.39465 * (yuy2(1) - 128) - 0.714 * (yuy2(3) - 128)
b1 = yuy2(0) + 0.58060 * (yuy2(1) - 128)
10 hours ago(This post was last modified: 9 hours ago by madscijr.)
(Today, 06:17 AM)SpriggsySpriggs Wrote:
(Today, 04:11 AM)madscijr Wrote: One thing I was gonna ask was, how might those two dialogs that open at the beginning be auto-filled or otherwise hidden? Windows API functions are so mysterious!
You gotta toggle that _TRUE/_FALSE flag in the SetupDriver call, my dude.
Oooh I gotta try that!
BTW when you say "my dude" like that, in my mind I'm picturing the character Downward Dog from the Dog Man book Fetch 22, good stuff! :p LoL
There is a bit of a bug with some calculation. I was only able to get 640 x 480 resolution to work, which probably means I'm not calculating something right. Nonetheless, you should be able to at least see it. I'll keep working on getting it to be compatible with all resolutions.
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)
Function LoadLibrary%& (lpLibFileName As String)
Function GetProcAddress%& (ByVal hModule As _Offset, lpProcName As String)
End Declare
Declare Library ".\internal\c\c_compiler\include\vfw"
End Declare
Declare Library "framecallback"
End Declare
Dim Shared 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), 0, 0, 0, vidWidth, vidHeight, _WindowHandle, childID)
_Title "Webcam API Test - Parent"
SetupDriver childWin, _TRUE 'change _FALSE to _TRUE to use default settings
Print "Previewing... Press Space bar to stop"
Print "Press escape to kill the window"
Dim Shared As _MEM frame
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
Screen frame.IMAGE
_Display
_Limit FPS
Loop
Dim As _MEM clippedFrame
GrabFrameToClipboard childWin, clippedFrame
Print "Disconnecting Driver"
KillDriver childWin
_MemFree frame
_MemFree clippedFrame
Sleep
Sub SetupDriver (hwnd As _Offset, defaultSource As _Byte)
Dim As _Offset libload: libload = LoadLibrary(Command$(0))
Dim As _Offset myCallback: myCallback = GetProcAddress(libload, "CapVideoCallback")
Dim As BITMAPINFO format
'End
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)
If Len(format) <> formatSize Then
KillDriver hwnd
Print "Wrong size"
Print formatSize, Len(format)
End
End If
If SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, Len(format), _Offset(format)) = 0 Then
KillDriver hwnd
Print "Couldn't get format"
End
End If
format.bmiHeader.biSize = Len(format)
format.bmiHeader.biWidth = vidWidth
format.bmiHeader.biHeight = vidHeight
format.bmiHeader.biPlanes = 1
format.bmiHeader.biBitCount = 16 'yuy2 format
format.bmiHeader.biSizeImage = vidWidth * vidHeight * 2
format.bmiHeader.biCompression = mmioStringToFOURCC("YUY2" + Chr$(0), &H00000010) 'MUST BE YUY2 FORMAT
If SendMessage(hwnd, WM_CAP_SET_VIDEOFORMAT, Len(format), _Offset(format)) = 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
SendMessage hwnd, WM_CAP_GET_VIDEOFORMAT, 0, _Offset(format)
SendMessage hwnd, WM_CAP_SET_CALLBACK_FRAME, 0, myCallback
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 GrabFrameToClipboard (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
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)
Dim As BITMAPINFO bi
_MemGet pBI, pBI.OFFSET, bi
_MemFree pBI
_MemFree p
Dim As Long bytesPerPixel: bytesPerPixel = (bi.bmiHeader.biBitCount + 7) \ 8
Dim As Long stride: stride = (((bi.bmiHeader.biWidth * bi.bmiHeader.biBitCount) + 31) And Not 31) \ 8
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
Function CapVideoCallback%& (hWnd As _Offset, lpVHdr As _Offset)
Type VIDEOHDR
As _Offset lpData
As _Unsigned Long dwBufferLength, dwBytesUsed, dwTimeCaptured
As String * 4 padding1
As _Unsigned _Offset dwUser
As _Unsigned Long dwFlags
As String * 4 padding2
As _Offset dwReserved1, dwReserved2, dwReserved3, dwReserved4
End Type
Dim As VIDEOHDR vhdr
Dim As _MEM pVhdr: pVhdr = _Mem(lpVHdr, Len(vhdr))
_MemGet pVhdr, pVhdr.OFFSET, vhdr
_MemFree pVhdr
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
Dim As BITMAPINFO bi
SendMessage hWnd, WM_CAP_GET_VIDEOFORMAT, frameSize, _Offset(bi)
'Print bi.bmiHeader.biHeight
Dim As _MEM lpData: lpData = _Mem(vhdr.lpData, vhdr.dwBufferLength)
If _MemExists(frame) Then _MemFree frame
Dim As Long bitsPerPixel: bitsPerPixel = bi.bmiHeader.biBitCount
Dim As Long bytesPerPixel: bytesPerPixel = (bitsPerPixel + 7) \ 8
Dim As _Unsigned Long stride: stride = (((bi.bmiHeader.biWidth * bi.bmiHeader.biBitCount) + 31) And Not 31) \ 8
Dim As Long y, x
Dim As _Unsigned _Byte yuy2(0 To 3)
Dim As _Offset pScanLine
Dim As _Unsigned _Integer64 converted
Dim As _Unsigned _Byte r, g, b
Dim As _Offset pixelOffset
Dim As Long i: i = _NewImage(bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 32)
_Dest i
For y = 0 To bi.bmiHeader.biHeight - 1
pScanLine = lpData.OFFSET + (y * stride)
For x = 0 To bi.bmiHeader.biWidth - bytesPerPixel Step bytesPerPixel
pixelOffset = pScanLine + (x * bytesPerPixel)
_MemGet lpData, pixelOffset, yuy2()
converted = ConvertYUY2toRGB(yuy2())
PSet (x, y), converted And &HFFFFFFFF
PSet (x + 1, y), _ShR(converted, 32) And &HFFFFFFFF
Next
Next
_Dest 0
frame = _MemImage(i)
End Function
Function ConvertYUY2toRGB~&& (yuy2() As _Unsigned _Byte) '(y1 As _Byte, u As _Byte, y2 As _Byte, v As _Byte)
Dim As _Unsigned _Byte r1, g1, b1, r2, g2, b2
' Convert first pixel (Y1)
r1 = _Clamp(yuy2(0) + 1.13983 * (yuy2(3) - 128), 0, 255)
g1 = _Clamp(yuy2(0) - 0.39465 * (yuy2(1) - 128) - 0.714 * (yuy2(3) - 128), 0, 255)
b1 = _Clamp(yuy2(0) + 0.58060 * (yuy2(1) - 128), 0, 255)
(10 hours ago)SpriggsySpriggs Wrote: You need to download framecallback.h (Size: 355 bytes / Downloads: 0)
(10 hours ago)SpriggsySpriggs Wrote: There is a bit of a bug with some calculation. I was only able to get 640 x 480 resolution to work, which probably means I'm not calculating something right. Nonetheless, you should be able to at least see it. I'll keep working on getting it to be compatible with all resolutions.
(9 hours ago)SpriggsySpriggs Wrote: Fixed the bug. Phew.
Big improvement - thank you! I merged your changes into my code (no small feat, LoL) and it works!
And so, here is Webcam Pong v0.04 which no longer opens those pesky dialogs, thanks to @SpriggsySpriggs:
Code: (Select All)
' Webcam Pong by Madscijr (v0.04)
' Thanks to SpriggsySpriggs for figuring out how to program the webcam.
' HOW TO RUN:
' Download "framecallback.h" from
' https://qb64phoenix.com/forum/attachment.php?aid=4150
' and place it in the same folder as the source code.
' TODO:
' * Auto-fill & hide the Video Format & Video Source forms that open in the beginning
' * Enable clipboard while the program is running?
' * Enable program to lose and regain focus gracefully?
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' USB Camera? Reply #26 > Help Me! > Code and Stuff > QB64 Rising > QB64 Phoenix Edition
' https://qb64phoenix.com/forum/showthread.php?tid=1163&pid=32337#pid32337
' From: SpriggsySpriggs, Professional Noticer
' Date: 2/26/2025 2:48 PM
' 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.
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' USB Camera? Reply #28 > Help Me! > Code and Stuff > QB64 Rising > QB64 Phoenix Edition
' https://qb64phoenix.com/forum/showthread.php?tid=1163&pid=32339#pid32339
' From: SpriggsySpriggs, Professional Noticer
' Date: 2/26/2025 4:01 PM
' 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:
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Webcam Pong v0.01 > Reply #11 - Webcam Pong v0.01 > Works in Progress > Code and Stuff > QB64 Rising > QB64 Phoenix Edition
' https://qb64phoenix.com/forum/showthread.php?tid=3497&pid=32368#pid32368
' From: SpriggsySpriggs, Professional Noticer
' Date: 2/28/2025 9:12 AM
' Don't let your dreams be dreams.
' -Shia TheBeef
' You need to download framecallback.h (Size: 355 bytes / Downloads: 0)
' https://qb64phoenix.com/forum/attachment.php?aid=4150
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Webcam Pong v0.01 > Reply #16 - Webcam Pong v0.01 > Works in Progress > Code and Stuff > QB64 Rising > QB64 Phoenix Edition
' https://qb64phoenix.com/forum/showthread.php?tid=3497&pid=32373#pid32373
' From: SpriggsySpriggs, Professional Noticer
' Date: 2/28/2025 8:55 AM
' Fixed the bug. Phew.
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
Option _Explicit
_Title "Webcam API Test - Parent"
' ================================================================================================================================================================
' CONSTANTS
' ================================================================================================================================================================
Const FPS = 30 ' Not recommended to set this higher than frame rate of webcam/video device
Const MOVEMENT_THRESHOLD = 160
Const CAMERA_WIDTH = 320
Const CAMERA_HEIGHT = 240
Const DETECT_WIDTH = 40 ' # pixels from right/left edges of screen to scan for movement
Const WS_VISIBLE = &H10000000 ' The window is initially visible.
Const WS_MAXIMIZE = &H1000000 ' The window is initially maximized.
Const WS_MINIMIZE = &H20000000 ' The window is initially minimized.
' ================================================================================================================================================================
' UDTs
' ================================================================================================================================================================
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
' HOLDS DISPLAY LAYERS (ALL NEED _FREEIMAGE WHEN PROGRAM ENDS)
Type GraphicsType
imgBackground As Long ' background image
imgCamera As Long
imgWalls As Long
imgStaticText As Long '
imgDynamicText As Long
imgSprites As Long
End Type ' GraphicsType
' HOLDS VALUES FOR OPERATING WEBCAM
Type WebcamType
captureWinText As String
childID As _Offset
videoWidth As _Unsigned Long
videoHeight As _Unsigned Long
childWin As _Offset
'm As _MEM
frame As _MEM
CaptureWindowStyle As _Unsigned Long
End Type ' WebcamType
' HOLDS PLAYER COORDINATES AND INFO
Type PlayerType
color As _Unsigned Long
x As Long
y As Long
width As Integer
height As Integer
score As Integer
Visible As Integer
End Type ' PlayerType
' HOLDS BALL COORDINATES AND INFO
Type BallType
color As _Unsigned Long
size As Integer
x As Long
y As Long
dx As Integer
dy As Integer
Visible As Integer
End Type ' BallType
' HOLDS RGB VALUES FOR A PIXEL
Type PixelType
r As Long
g As Long
b As Long
End Type ' PixelType
' ================================================================================================================================================================
' API DEFINITIONS
' ================================================================================================================================================================
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)
Function LoadLibrary%& (lpLibFileName As String)
Function GetProcAddress%& (ByVal hModule As _Offset, lpProcName As String)
End Declare
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 Library ".\internal\c\c_compiler\include\vfw"
End Declare
Declare Library "framecallback"
End Declare
' ================================================================================================================================================================
' GLOBAL VARIABLES
' ================================================================================================================================================================
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' GLOBAL VARIABLES TO TRACK ERROR STATE
Dim Shared m_ErrorMessage As String: m_ErrorMessage = ""
'Dim Shared m_RoutineName As String: m_RoutineName = ""
'Dim Shared m_LastStatement As String: m_LastStatement = ""
' GLOBAL VARIABLES FOR SCREEN
Dim Shared m_iScreenWidth As Long: m_iScreenWidth = 1024 ' _DesktopWidth
Dim Shared m_iScreenHeight As Long: m_iScreenHeight = 768 ' _DesktopHeight
Dim Shared m_iTextRows As Long: m_iTextRows = (m_iScreenHeight / _FontHeight)
Dim Shared m_iTextCols As Long: m_iTextCols = (m_iScreenWidth / _FontWidth)
Dim Shared PLAYER_HEIGHT As Long: PLAYER_HEIGHT = 32
Dim Shared MIN_Y As Long: MIN_Y = 44 + 1
Dim Shared MAX_Y As Long: MAX_Y = (m_iScreenHeight - 54) - (PLAYER_HEIGHT + 1)
' GLOBAL VARIABLES FOR WEBCAM
Dim Shared WebCam As WebcamType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' EXECUTION STARTS HERE!
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' START THE MAIN ROUTINE
main
' FINISH
Print m_ProgramName$ + " finished."
'End
System ' return control to the operating system
' /////////////////////////////////////////////////////////////////////////////
' MAIN PROGRAM
Sub main
Dim Graph1 As GraphicsType
ReDim arrPlayer(1 To 2) As PlayerType ' 1 = left, 2 = right
ReDim arrComparePixels(CAMERA_WIDTH, CAMERA_HEIGHT) As PixelType
Dim Ball1 As BallType
Dim x, y As Integer
Dim iValue As Integer
Dim IsCalibrating As Integer
Dim ShowCamera As Integer
' Show initial detailed instructions
Cls
Print "Webcam Pong, a 'computer vision' experiment, v0.01"
Print "by madscijr, webcam code by spriggsyspriggs"
Print
Print "At 'Video Format' popup, values should say:"
Print " Resolution : 320x240"
Print " Pixel Depth (bits) and Compression: YUY2"
Print " Size (bytes) : 153600"
Print "Do not change these values, just click [OK]"
Print
Print "At 'Video Source' popup, values should say:"
Print " Select a Video Device: {your camera name}"
Print "Click [OK]"
Print
Print "1 window should open:"
Print " Webcam API Test - Parent"
Print
Print "And this window hidden (maybe visible in Task Manager):"
Print " Webcam API Test - Child"
Print
Print "Point webcam at an empty room or down at a blank sheet of paper,"
Print "away from you and your friends, and anything that's moving."
Print "Press Enter to 'calibrate', where program memorizes the room."
Print "Enter also toggles the camera picture on and off,"
Print "with the camera on, you can see yourself moving around."
Print "Try moving something up and down along the left half of the screen,"
Print "that controls the left paddle. Right half of screen = right paddle."
Print
Print "Per SpriggsySpriggs:"
Print "DO NOT GO CLICKING ALL WILLY-NILLY ON THE PROGRAM WINDOW,"
Print "ESPECIALLY IF YOUR CURSOR HAS THE LOADING CIRCLE/HOURGLASS."
Print "For some reason, this will cause it to freeze and crash."
Print "Why? 'cause Microsoft, that's why."
Print
Print "Also note that this version has the following QUIRKS while running:"
Print "* clipboard is not available in other programs"
Print "* when changing focus to another program, to switch back, you must minimize the other program for this to be visible again"
Print
Print "Press any key to start..."
Sleep
_KeyClear: '_DELAY 1 ' clear keyboard buffer
' CLEAR THE SCREEN
_Dest 0: Cls , cEmpty
_Display ' update screen with changes & wait for next update
' Initialize the driver
'SetupDriver WebCam.childWin, WebCam.videoWidth, WebCam.videoHeight, _FALSE ' change _FALSE to _TRUE to use default settings
SetupDriver WebCam.childWin, WebCam.videoWidth, WebCam.videoHeight, _TRUE ' change _FALSE to _TRUE to use default settings
' RANDOM BALL DIRECTION
Randomize Timer
If RandomNumber%(1, 2) = 1 Then
Ball1.dx = -1
Else
Ball1.dx = 1
End If
iValue = RandomNumber%(1, 3)
If iValue = 1 Then
Ball1.dy = -1
Else
If iValue = 2 Then
Ball1.dy = 0
Else
Ball1.dy = 1
End If
End If
' Capture a single frame to window WebCam.childWin
IsCalibrating = _TRUE
ShowCamera = _TRUE
Do
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' READ KEYBOARD
' GetAsyncKeyState is necessary because the capture window steals keyboard focus
' ENTER = RECALIBRATE + SHOW CAMERA FRAME
' PRESSING ENTER AGAIN HIDES CAMERA FRAME
If GetAsyncKeyState(&H0D) <> 0 Then ' user pressed Enter
If ShowCamera = _FALSE Then
ShowCamera = _TRUE
IsCalibrating = _TRUE
Else
ShowCamera = _FALSE
End If
End If
' ESC = QUIT
If GetAsyncKeyState(&H1B) <> 0 Then ' user pressed Escape
KillDriver WebCam.childWin
Exit Do
End If
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CAPTURE FRAME WITH WEBCAM
' Get still picture from camera to frame
GrabFrame WebCam.childWin
'' Copy frame from WebCam.childWin from clipboard to image in memory
'GrabFrameToClipboard WebCam.childWin, WebCam.frame
' Remember background (to compare to detect movement)
If IsCalibrating = _TRUE Then
SaveFrame WebCam.frame.IMAGE, arrComparePixels()
IsCalibrating = _FALSE
End If
' Detect movement with the camera (computer vision)
DetectMovement WebCam.frame.IMAGE, arrComparePixels(), arrPlayer()
' Display the image
DrawCameraLayer Graph1, WebCam.frame.IMAGE, ShowCamera
'Screen WebCam.frame.IMAGE
' /////////////////////////////////////////////////////////////////////////////
' COMPARE PIXELS IN CAMERA FRAME AGAINST WHAT IT SAW AT BEGINNING
Sub DetectMovement (imgCamera As Long, arrComparePixels() As PixelType, arrPlayer() As PlayerType)
Dim iPlayer As Integer
Dim x As Integer
Dim y As Integer
Dim c&
Dim dr&, dg&, db&
' LOOK FOR PLAYER 1 IN LEFT HALF OF CAMERA FRAME
iPlayer = 1
arrPlayer(iPlayer).Visible = _FALSE
_Source imgCamera
'For x = (CAMERA_WIDTH - 1) To (CAMERA_WIDTH / 2) Step -1
For x = (CAMERA_WIDTH - 1) To (CAMERA_WIDTH - 1) - DETECT_WIDTH Step -1
For y = 1 To (CAMERA_HEIGHT - 1)
' COMPARE AGAINST ORIGINAL PIXEL
c& = Point(x, y)
dr& = Abs(arrComparePixels(x, y).r - _Red32(c&))
dg& = Abs(arrComparePixels(x, y).g - _Green32(c&))
db& = Abs(arrComparePixels(x, y).b - _Blue32(c&))
'_Alpha32(c&)
' DID IT CHANGE ENOUGH?
If (dr& + dg& + db&) > MOVEMENT_THRESHOLD Then
'arrPlayer(iPlayer).x = x
arrPlayer(iPlayer).y = y * (m_iScreenHeight / CAMERA_HEIGHT)
'NO:
'' Y has to be reversed (up is down & down is up)
'arrPlayer(iPlayer).y = m_iScreenHeight - (y * (m_iScreenHeight / CAMERA_HEIGHT))
' Keep within boundaries
If arrPlayer(iPlayer).y < MIN_Y Then
arrPlayer(iPlayer).y = MIN_Y
ElseIf arrPlayer(iPlayer).y > MAX_Y Then
arrPlayer(iPlayer).y = MAX_Y
End If
' Done looking
arrPlayer(iPlayer).Visible = _TRUE
Exit For
End If
Next y
If arrPlayer(iPlayer).Visible = _TRUE Then
Exit For
End If
Next x
' LOOK FOR PLAYER 2 IN RIGHT HALF OF CAMERA FRAME
iPlayer = 2
arrPlayer(iPlayer).Visible = _FALSE
_Source imgCamera
'For x = 1 To (CAMERA_WIDTH / 2)
For x = 1 To DETECT_WIDTH
For y = 1 To (CAMERA_HEIGHT - 1)
' COMPARE AGAINST ORIGINAL PIXEL
c& = Point(x, y)
dr& = Abs(arrComparePixels(x, y).r - _Red32(c&))
dg& = Abs(arrComparePixels(x, y).g - _Green32(c&))
db& = Abs(arrComparePixels(x, y).b - _Blue32(c&))
'_Alpha32(c&)
' DID IT CHANGE ENOUGH?
If (dr& + dg& + db&) > MOVEMENT_THRESHOLD Then
'arrPlayer(iPlayer).x = x
arrPlayer(iPlayer).y = y * (m_iScreenHeight / CAMERA_HEIGHT)
'NO:
'' Y has to be reversed (up is down & down is up)
'arrPlayer(iPlayer).y = m_iScreenHeight - (y * (m_iScreenHeight / CAMERA_HEIGHT))
' Keep within boundaries
If arrPlayer(iPlayer).y < MIN_Y Then
arrPlayer(iPlayer).y = MIN_Y
ElseIf arrPlayer(iPlayer).y > MAX_Y Then
arrPlayer(iPlayer).y = MAX_Y
End If
' Done looking
arrPlayer(iPlayer).Visible = _TRUE
Exit For
End If
Next y
If arrPlayer(iPlayer).Visible = _TRUE Then
Exit For
End If
Next x
End Sub ' DetectMovement
' /////////////////////////////////////////////////////////////////////////////
' SAVE RGB OF EACH PIXEL CAMERA SEES BEFORE PLAYERS USE HANDS/LASERS
Sub SaveFrame (imgCamera As Long, arrComparePixels() As PixelType)
Dim x As Integer
Dim y As Integer
Dim c&, r&, g&, b&
'Dim a&
_Source imgCamera
For y = 1 To CAMERA_HEIGHT
For x = 1 To CAMERA_WIDTH
c& = Point(x, y)
arrComparePixels(x, y).r = _Red32(c&)
arrComparePixels(x, y).g = _Green32(c&)
arrComparePixels(x, y).b = _Blue32(c&)
'arrComparePixels(x, y).a = _Alpha32(c&)
Next x
Next y
End Sub ' SaveFrame
Sub InitImage (ThisImage&, iWidth&, iHeight&, bgColor~&)
If ThisImage& = -1 Or ThisImage& = 0 Then
ThisImage& = _NewImage(iWidth&, iHeight&, 32)
_Dest ThisImage&: Cls , bgColor~&
End If
End Sub ' InitImage
' ROW 47: INSTRUCTIONS
iCol = 1
sMessage = "POINT WEBCAM AT EMPTY ROOM OR WHITE SHEET OF PAPER"
'iCol = (((m_iTextCols / 3) / 2) - (Len(sMessage) / 2)) ' LEFT THIRD
Color cBlack, cWhite
Locate 47, iCol: Print sMessage;
' ROW 48: INSTRUCTIONS
iCol = 1
sMessage = "PRESS ENTER TO CALIBRATE + SHOW/HIDE CAMERA"
'iCol = (((m_iTextCols / 3) / 2) - (Len(sMessage) / 2)) ' LEFT THIRD
Color cBlack, cLime
Locate 48, iCol: Print sMessage;
iCol = iCol + Len(sMessage) + 2
sMessage = "MOVE HAND UP & DOWN ALONG LEFT AND RIGHT EDGES"
'iCol = ((m_iTextCols / 2) - (Len(sMessage) / 2)) ' MIDDLE THIRD
Color cWhite, cRed
Locate 48, iCol: Print sMessage;
iCol = iCol + Len(sMessage) + 2
sMessage = "PRESS [ESC] TO EXIT"
'iCol = (m_iTextCols - ((m_iTextCols / 3) / 2)) - (Len(sMessage) / 2) ' RIGHT THIRD
Color cWhite, cBlue
Locate 48, iCol: Print sMessage;
' DRAW THE NET
For iLoop = 44 To (m_iScreenHeight - 48) Step 20
Line ((m_iScreenWidth / 2) - 2, iLoop)-((m_iScreenWidth / 2) + 2, iLoop + 10), cWhite, BF
Next iLoop
End Sub ' DrawWallsLayer
' /////////////////////////////////////////////////////////////////////////////
' DRAW THE SCORE LAYER
' TEXT SCREEN AT 1024 x 768 = 128 x 48 (m_iTextCols x m_iTextRows)
Sub DrawDynamicTextLayer (Graph1 As GraphicsType, arrPlayer() As PlayerType, ShowCamera As Integer)
Dim y
_Dest Graph1.imgDynamicText: Cls , cEmpty
' SHOW SCORES
Color cCyan, cEmpty: Locate 2, 32
Print _Trim$(Str$(arrPlayer(1).score))
Color cLightPink, cEmpty: Locate 2, 96
Print _Trim$(Str$(arrPlayer(2).score))
' SHOW POSITIONS
If arrPlayer(1).Visible = _TRUE Then
Color cCyan, cEmpty: Locate 37, 32
Print "Player 1: x=" + _Trim$(Str$(arrPlayer(1).x)) + " y=" + _Trim$(Str$(arrPlayer(1).y))
End If
If arrPlayer(2).Visible = _TRUE Then
Color cLightPink, cEmpty: Locate 37, 96
Print "Player 2: x=" + _Trim$(Str$(arrPlayer(2).x)) + " y=" + _Trim$(Str$(arrPlayer(2).y))
End If
' SHOW OTHER
If ShowCamera = _TRUE Then
'y = ( ( (m_iScreenHeight - CAMERA_HEIGHT) / 2 ) / _FontHeight) - _FontHeight
'color cBlack, cYellow : Locate y, 60
Color cBlack, cYellow: Locate 16, 60
Print "ShowCamera = _TRUE"
End If
End Sub ' DrawDynamicTextLayer
Sub DrawSpritesLayer (Graph1 As GraphicsType, arrPlayer() As PlayerType, Ball1 As BallType)
_Dest Graph1.imgSprites: Cls , cEmpty
' If players are visible draw a box at the locations
If arrPlayer(1).Visible = _TRUE Then
DrawRectSolid arrPlayer(1).x, arrPlayer(1).y, arrPlayer(1).width, arrPlayer(1).height, arrPlayer(1).color
End If
If arrPlayer(2).Visible = _TRUE Then
DrawRectSolid arrPlayer(2).x, arrPlayer(2).y, arrPlayer(2).width, arrPlayer(2).height, arrPlayer(2).color
End If
' If ball is visible, draw it
If Ball1.Visible = _TRUE Then
DrawRectSolid Ball1.x, Ball1.y, Ball1.size, Ball1.size, Ball1.color
End If
End Sub ' DrawSpritesLayer
' /////////////////////////////////////////////////////////////////////////////
' COPY LAYERS TO SCREEN AND UPDATE DISPLAY
Sub RenderScreen (Graph1 As GraphicsType)
' CLEAR THE SCREEN
_Dest 0: Cls , cEmpty
' Add the background
_PutImage , Graph1.imgBackground, 0
' Add the camera image
_PutImage , Graph1.imgCamera, 0
' Add the walls
_PutImage , Graph1.imgWalls, 0
' Add the instructions
_PutImage , Graph1.imgStaticText, 0
' Add the score
_PutImage , Graph1.imgDynamicText, 0
' Add the sprites
_PutImage , Graph1.imgSprites, 0
' update screen with changes
_Display
End Sub ' RenderScreen
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (SOLID)
Sub DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + iSizeW, iY + iSizeH), fgColor, BF ' Draw a solid rectangle
End Sub ' DrawRectSolid
Sub GrabFrameToClipboard (hwnd As _Offset, image As _MEM)
Dim As _Unsigned Long frameSize
Dim As _Offset hDIB
Dim As _Offset pDIB
Dim As _MEM p
Dim As _Unsigned Long biSize
Dim As _MEM pBI
Dim As BITMAPINFO bi
Dim As Long bytesPerPixel
Dim As Long stride
Dim As _MEM m
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
Dim As Long a
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
hDIB = GetClipboardData(CF_DIB)
If hDIB = 0 Then
Print "Failed to retrieve bitmap from clipboard"
CloseClipboard
KillDriver hwnd
End
End If
pDIB = GlobalLock(hDIB)
If pDIB = 0 Then
Print "Failed to lock the clipboard"
CloseClipboard
KillDriver hwnd
End
End If
stride = (((bi.bmiHeader.biWidth * bi.bmiHeader.biBitCount) + 31) And Not 31) \ 8
'Print stride
'Print bi.bmiHeader.biSizeImage
m = _Mem(pDIB + Len(bi), bi.bmiHeader.biSizeImage)
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)
a = GlobalUnlock(pDIB)
End Sub ' GrabFrameToClipboard
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns TRUE (-1) if string is an integer, FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = _FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = TRUE
Else
TestString$ = OriginalString$
'bNegative% = FALSE
End If
If Len(TestString$) > 0 Then
bResult% = _TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = _FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = _FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
Sub KillDriver (hwnd As _Offset)
SendMessage hwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0
DestroyWindow hwnd
End Sub ' KillDriver
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 0-based.
' See also: PrintString1
Sub PrintString (iRow As Integer, iCol As Integer, MyString As String)
Dim iX As Integer
Dim iY As Integer
iX = _FontWidth * iCol
iY = _FontHeight * iRow ' (iRow + 1)
_PrintString (iX, iY), MyString
End Sub ' PrintString
' /////////////////////////////////////////////////////////////////////////////
' Print sMessage in fancy alternating colors
' at row RowNum, column StartCol
Sub PrintTitle (RowNum As Integer, StartCol As Integer, sMessage As String)
Dim ColNum As Integer
Dim iLoop As Integer
Dim fgColor~&
ColNum = StartCol
For iLoop = 1 To Len(sMessage)
If fgColor~& = cBlue Then fgColor~& = cRed Else fgColor~& = cBlue
Color cWhite, fgColor~&
Locate RowNum, ColNum: Print Mid$(sMessage, iLoop, 1);
'PrintString RowNum, ColNum, mid$(sMessage, iLoop, 1)
ColNum = ColNum + 1
Next iLoop
End Sub ' PrintTitle
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
' Note: random-number generator should be initialized with
' InitializeRandom or Randomize Timer
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
'' SET RANDOM SEED
''Randomize ' Initialize random-number generator.
'Randomize Timer
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
Sub SaveBMP (hwnd As _Offset, filename As String)
filename = filename + Chr$(0)
SendMessage hwnd, WM_CAP_FILE_SAVEDIB, 0, _Offset(filename)
End Sub ' SaveBMP
Sub SetupDriver (hwnd As _Offset, videoWidth As _Unsigned Long, videoHeight As _Unsigned Long, defaultSource As _Byte)
Dim As _Offset libload
Dim As _Offset myCallback
Dim As BITMAPINFO format
Dim As _Unsigned Long formatSize
If defaultSource = _FALSE Then
SendMessage hwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0 ' PICK YUY2!!!
SendMessage hwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0
End If
formatSize = SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, 0, 0)
If Len(format) <> formatSize Then
KillDriver hwnd
Print "Wrong size"
Print formatSize, Len(format)
End
End If
If SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, Len(format), _Offset(format)) = 0 Then
KillDriver hwnd
Print "Couldn't get format"
End
End If
format.bmiHeader.biSize = Len(format)
format.bmiHeader.biWidth = videoWidth
format.bmiHeader.biHeight = videoHeight
format.bmiHeader.biPlanes = 1
format.bmiHeader.biBitCount = 16 ' yuy2 format
format.bmiHeader.biSizeImage = videoWidth * videoHeight * 2
format.bmiHeader.biCompression = mmioStringToFOURCC("YUY2" + Chr$(0), &H00000010) ' MUST BE YUY2 FORMAT
If SendMessage(hwnd, WM_CAP_SET_VIDEOFORMAT, Len(format), _Offset(format)) = 0 Then
KillDriver hwnd
Print "Failed to set video format"
End
End If
SendMessage hwnd, WM_CAP_GET_VIDEOFORMAT, 0, _Offset(format)
SendMessage hwnd, WM_CAP_SET_CALLBACK_FRAME, 0, myCallback
End Sub ' SetupDriver
Function CapVideoCallback%& (hWnd As _Offset, lpVHdr As _Offset)
Type VIDEOHDR
As _Offset lpData
As _Unsigned Long dwBufferLength, dwBytesUsed, dwTimeCaptured
As String * 4 padding1
As _Unsigned _Offset dwUser
As _Unsigned Long dwFlags
As String * 4 padding2
As _Offset dwReserved1, dwReserved2, dwReserved3, dwReserved4
End Type
Dim As VIDEOHDR vhdr
Dim As _MEM pVhdr
Dim As _Unsigned Long frameSize
Dim As BITMAPINFO bi
Dim As _MEM lpData
Dim As Long bitsPerPixel
Dim As Long bytesPerPixel
Dim As _Unsigned Long stride
Dim As Long y, x
Dim As _Unsigned _Byte yuy2(0 To 3)
Dim As _Offset pScanLine
Dim As _Unsigned _Integer64 converted
Dim As _Unsigned _Byte r, g, b
Dim As _Offset pixelOffset
Dim As Long i
i = _NewImage(bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 32)
_Dest i
For y = 0 To bi.bmiHeader.biHeight - 1
pScanLine = lpData.OFFSET + (y * stride)
For x = 0 To bi.bmiHeader.biWidth - bytesPerPixel Step bytesPerPixel
pixelOffset = pScanLine + (x * bytesPerPixel)
_MemGet lpData, pixelOffset, yuy2()
converted = ConvertYUY2toRGB(yuy2())
PSet (x, y), converted And &HFFFFFFFF
PSet (x + 1, y), _ShR(converted, 32) And &HFFFFFFFF
Next x
Next y
_Dest 0
WebCam.frame = _MemImage(i)
End Function ' CapVideoCallback%&
Function ConvertYUY2toRGB~&& (yuy2() As _Unsigned _Byte) '(y1 As _Byte, u As _Byte, y2 As _Byte, v As _Byte)
Dim As _Unsigned _Byte r1, g1, b1, r2, g2, b2
' ################################################################################################################################################################
' BEGIN COLOR FUNCTIONS #COLOR
' ################################################################################################################################################################
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
' ADDED THIS FOR THE GAUGE COLOR:
Function cSpringGreen~& ()
cSpringGreen = _RGB32(0, 255, 160)
End Function ' cSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ################################################################################################################################################################
' END COLOR FUNCTIONS @COLOR
' ################################################################################################################################################################
7 hours ago(This post was last modified: 7 hours ago by SpriggsySpriggs.)
Ha! And some more changes! I added the ability to adjust the saturation level. Why? Because I can! Now you can have greyscale images as well as full color OR oversaturated images.
Also, I left the code for copying the frame to clipboard but commented out the call because we can just copy it using _ClipboardImage anyways.
Const FPS = 30 'Not recommended to set this higher than frame rate of webcam/video device
Const SATURATION_LEVEL = 0.00 '0.00 for greyscale, 1.00 for normal, and >1.00 for oversaturation
Const VIDWIDTH = 320
Const VIDHEIGHT = 240
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)
Function LoadLibrary%& (lpLibFileName As String)
Function GetProcAddress%& (ByVal hModule As _Offset, lpProcName As String)
End Declare
Declare Library ".\internal\c\c_compiler\include\vfw"
End Declare
Declare Library "framecallback"
End Declare
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), 0, 0, 0, VIDWIDTH, VIDHEIGHT, _WindowHandle, childID)
_Title "Webcam API Test - Parent"
SetupDriver childWin, _TRUE 'change _FALSE to _TRUE to use default settings
Print "Previewing... Press Space bar to stop"
Print "Press escape to kill the window"
Dim Shared As _MEM frame
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
Screen frame.IMAGE
_Display
_Limit FPS
Loop
Dim As _MEM clippedFrame
'GrabFrameToClipboard childWin, clippedFrame
_ClipboardImage = frame.IMAGE
Print "Disconnecting Driver"
KillDriver childWin
_MemFree frame
'_MemFree clippedFrame
Sleep
Sub SetupDriver (hwnd As _Offset, defaultSource As _Byte)
Dim As _Offset libload: libload = LoadLibrary(Command$(0))
Dim As _Offset myCallback: myCallback = GetProcAddress(libload, "CapVideoCallback")
Dim As BITMAPINFO format
'End
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)
If Len(format) <> formatSize Then
KillDriver hwnd
Print "Wrong size"
Print formatSize, Len(format)
End
End If
If SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, Len(format), _Offset(format)) = 0 Then
KillDriver hwnd
Print "Couldn't get format"
End
End If
format.bmiHeader.biSize = Len(format)
format.bmiHeader.biWidth = VIDWIDTH
format.bmiHeader.biHeight = VIDHEIGHT
format.bmiHeader.biPlanes = 1
format.bmiHeader.biBitCount = 16 'yuy2 format
format.bmiHeader.biSizeImage = VIDWIDTH * VIDHEIGHT * 2
format.bmiHeader.biCompression = mmioStringToFOURCC("YUY2" + Chr$(0), &H00000010) 'MUST BE YUY2 FORMAT
If SendMessage(hwnd, WM_CAP_SET_VIDEOFORMAT, Len(format), _Offset(format)) = 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
SendMessage hwnd, WM_CAP_GET_VIDEOFORMAT, 0, _Offset(format)
SendMessage hwnd, WM_CAP_SET_CALLBACK_FRAME, 0, myCallback
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 GrabFrameToClipboard (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
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)
Dim As BITMAPINFO bi
_MemGet pBI, pBI.OFFSET, bi
_MemFree pBI
_MemFree p
Dim As Long bytesPerPixel: bytesPerPixel = (bi.bmiHeader.biBitCount + 7) \ 8
Dim As Long stride: stride = (((bi.bmiHeader.biWidth * bi.bmiHeader.biBitCount) + 31) And Not 31) \ 8
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
Function CapVideoCallback%& (hWnd As _Offset, lpVHdr As _Offset)
Type VIDEOHDR
As _Offset lpData
As _Unsigned Long dwBufferLength, dwBytesUsed, dwTimeCaptured
As String * 4 padding1
As _Unsigned _Offset dwUser
As _Unsigned Long dwFlags
As String * 4 padding2
As _Offset dwReserved1, dwReserved2, dwReserved3, dwReserved4
End Type
Dim As VIDEOHDR vhdr
Dim As _MEM pVhdr: pVhdr = _Mem(lpVHdr, Len(vhdr))
_MemGet pVhdr, pVhdr.OFFSET, vhdr
_MemFree pVhdr
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
Dim As BITMAPINFO bi
SendMessage hWnd, WM_CAP_GET_VIDEOFORMAT, frameSize, _Offset(bi)
'Print bi.bmiHeader.biHeight
Dim As _MEM lpData: lpData = _Mem(vhdr.lpData, vhdr.dwBufferLength)
If _MemExists(frame) Then _MemFree frame
Dim As Long bitsPerPixel: bitsPerPixel = bi.bmiHeader.biBitCount
Dim As Long bytesPerPixel: bytesPerPixel = (bitsPerPixel + 7) \ 8
Dim As _Unsigned Long stride: stride = (((bi.bmiHeader.biWidth * bi.bmiHeader.biBitCount) + 31) And Not 31) \ 8
Dim As Long y, x
Dim As _Unsigned _Byte yuy2(0 To 3)
Dim As _Offset pScanLine
Dim As _Unsigned _Integer64 converted
Dim As _Unsigned _Byte r, g, b
Dim As _Offset pixelOffset
Dim As Long i: i = _NewImage(bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 32)
_Dest i
For y = 0 To bi.bmiHeader.biHeight - 1
pScanLine = lpData.OFFSET + (y * stride)
For x = 0 To bi.bmiHeader.biWidth - bytesPerPixel Step bytesPerPixel
pixelOffset = pScanLine + (x * bytesPerPixel)
_MemGet lpData, pixelOffset, yuy2()
converted = ConvertYUY2toRGB(yuy2())
PSet (x, y), converted And &HFFFFFFFF
PSet (x + 1, y), _ShR(converted, 32) And &HFFFFFFFF
Next
Next
_Dest 0
frame = _MemImage(i)
End Function
Function ConvertYUY2toRGB~&& (yuy2() As _Unsigned _Byte) '(y1 As _Byte, u As _Byte, y2 As _Byte, v As _Byte)
Dim As _Unsigned _Byte r1, g1, b1, r2, g2, b2
' Convert first pixel (Y1)
7 hours ago(This post was last modified: 7 hours ago by madscijr.)
(7 hours ago)SpriggsySpriggs Wrote: Ha! And some more changes! I added the ability to adjust the saturation level. Why? Because I can! Now you can have greyscale images as well as full color OR oversaturated images.
Also, I left the code for copying the frame to clipboard but commented out the call because we can just copy it using _ClipboardImage anyways.
Nice! Those might come in handy to make it easier to detect movement with the camera.
Can we drop the quality down to 8-bit color?
Doing some of this from the API might speed up the processing by eliminating calculations where we're analyzing a frame pixel-by-pixel.
However, just being able to process a frame as an image, pixel-by-pixel, opens up some fun possibilities!
Want to see yourself in color ASCII characters? No problem! Or inverse video or other funky effects that used to be built into camcorders back in the day. You could even emulate green screen from software!
Though I'm not sure how we'd grab input from 2 simultaneous webcam video sources, or maybe the background could come from a video file that plays and the code superimposes your greenscreen video over it, frame by frame? I know we can write images to an image file, I wonder how might we write these altered image frames back to a video file? Hmmm...
7 hours ago(This post was last modified: 7 hours ago by SpriggsySpriggs.)
Quote:I wonder how might we write these altered image frames back to a video file? Hmm...
We'd probably need to learn video codecs. I can probably convert my stored frames into an AVI format, which would be easiest as it is uncompressed and lossless.
Quote:Though I'm not sure how we'd grab input from 2 simultaneous webcam video sources
Ehhhhh... I don't know, man.
Quote:You could even emulate green screen from software!
Yeah, you could.
Quote:Can we drop the quality down to 8-bit color?
16 bits per pixel is what we need. YUY2 records as 4 bytes for 2 pixels, shared, which is native colorspace of the camera. I reckon you could always display only 8 bits if you wanted to, although I don't know much about doing that. But we need to record at this particular colorspace and bit.
framecallback.h (Size: 355 bytes / Downloads: 8)
![[Image: dogman-fetch22-downwarddog-you-were-trippin.png]](https://i.ibb.co/d03pqXQN/dogman-fetch22-downwarddog-you-were-trippin.png)