AVI would work. Another possibility is animated GIF format Did I see someone post something about reading/writing animated GIF files with QB64PE or am I dreaming?? Being able to work with those from code could be fun...
6 hours ago(This post was last modified: 6 hours ago by SpriggsySpriggs.)
_ScreenMove _Middle appears to have a performance issue and doesn't actually move the window to the middle of the screen. So I've changed that to a calculated value based on _DesktopWidth, _DesktopHeight, VIDWIDTH, and VIDHEIGHT.
Also, _ScreenMove _Middle did not allow me to move the window by grabbing the titlebar. Now, it does work. @SMcNeill, there appears to be a bug with that function. Not sure how longstanding it is.
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
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)
6 hours ago(This post was last modified: 6 hours ago by SpriggsySpriggs.)
Hey! I think that also fixed the issue of needing GetAsyncKeystate! Now, we don't need it! We can use _KeyHit instead. Sweeeeeet. Also, there are no more freeze ups. Feel free to click, drag, double-click, triple-click, etc. to your heart's desire.
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 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
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
Dim As Long k
Do
k = _KeyHit
If k = 32 Then Exit Do
If k = 27 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)
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 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)
_Delay 0.2 'Just in case
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)
If childWin = 0 Then
Print "Couldn't create capture window."
End
End If
_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
Dim As Long k
Do
k = _KeyHit
If k = 32 Then Exit Do
If k = 27 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")
If myCallback = 0 Then
Print "Can't find callback pointer"
End
End If
Dim As BITMAPINFO format
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)
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
Type POINT
As Long x, y
End Type
Type MSG
As _Offset hwnd
As _Unsigned Long message
$If 64BIT Then
As String * 4 padding1
$End If
As _Unsigned _Offset wParam
As _Offset lParam
As _Unsigned Long time
$If 64BIT Then
As String * 4 padding2
$End If
As POINT pt
As _Unsigned Long lPrivat
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)
Function PeekMessage& Alias "PeekMessageA" (ByVal lpMsg As _Offset, ByVal hWnd As _Offset, ByVal wMsgFilterMin As _Unsigned Long, ByVal wMsgFilterMax As _Unsigned Long, ByVal wRemoveMsg As _Unsigned Long)
Sub TranslateMessage (ByVal lpMsg As _Offset)
Sub DispatchMessage (ByVal lpMsg As _Offset)
Sub DestroyWindow (ByVal hWnd As _Offset)
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)
_Delay 0.2 'Just in case
Dim As String captureWinText: captureWinText = "Webcam API Test - Child" + Chr$(0)
Dim As _Offset childID
Dim As _Offset childWin: childWin = CreateCaptureWindow(_Offset(captureWinText), WS_EX_NOACTIVATE, 0, 0, VIDWIDTH, VIDHEIGHT, _WindowHandle, childID)
If childWin = 0 Then
Print "Couldn't create capture window."
End
End If
_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
Dim As Long k
Dim As MSG msg
Do
k = _KeyHit
If k = 32 Then Exit Do
If k = 27 Then
KillDriver childWin
End
End If
If PeekMessage(_Offset(msg), 0, 0, 0, PM_REMOVE) Then
TranslateMessage _Offset(msg)
DispatchMessage _Offset(msg)
Else
GrabFrame childWin
End If
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")
If myCallback = 0 Then
Print "Can't find callback pointer"
End
End If
Dim As BITMAPINFO format
SendMessage hwnd, WM_CAP_DRIVER_CONNECT, 0, 0
SendMessage hwnd, WM_CAP_SET_SCALE, _FALSE, 0
'SendMessage hwnd, WM_CAP_SET_PREVIEWRATE, 1000 / FPS, 0
SendMessage hwnd, WM_CAP_SET_PREVIEW, _FALSE, 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)
4 hours ago(This post was last modified: 4 hours ago by SpriggsySpriggs.)
I couldn't help myself. I have made a change that allows you to increase and decrease the saturation using the plus and minus keys on the numpad. I've set the limit at double the saturation.
Const FPS = 30 'Not recommended to set this higher than frame rate of webcam/video device
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
Type POINT
As Long x, y
End Type
Type MSG
As _Offset hwnd
As _Unsigned Long message
$If 64BIT Then
As String * 4 padding1
$End If
As _Unsigned _Offset wParam
As _Offset lParam
As _Unsigned Long time
$If 64BIT Then
As String * 4 padding2
$End If
As POINT pt
As _Unsigned Long lPrivat
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)
Function PeekMessage& Alias "PeekMessageA" (ByVal lpMsg As _Offset, ByVal hWnd As _Offset, ByVal wMsgFilterMin As _Unsigned Long, ByVal wMsgFilterMax As _Unsigned Long, ByVal wRemoveMsg As _Unsigned Long)
Sub TranslateMessage (ByVal lpMsg As _Offset)
Sub DispatchMessage (ByVal lpMsg As _Offset)
Sub DestroyWindow (ByVal hWnd As _Offset)
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 Single SATURATION_LEVEL: SATURATION_LEVEL = 0.00 '0.00 for greyscale, 1.00 for normal, and >1.00 for oversaturation
Screen _NewImage(VIDWIDTH, VIDHEIGHT, 32)
_Delay 0.2 'Just in case
Dim As String captureWinText: captureWinText = "Webcam API Test - Child" + Chr$(0)
Dim As _Offset childID
Dim As _Offset childWin: childWin = CreateCaptureWindow(_Offset(captureWinText), WS_EX_NOACTIVATE, 0, 0, VIDWIDTH, VIDHEIGHT, _WindowHandle, childID)
If childWin = 0 Then
Print "Couldn't create capture window."
End
End If
_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
Dim As _Integer64 k
Dim As MSG msg
Do
k = _KeyHit
Select Case k
Case 32
Exit Do
Case 27
KillDriver childWin
End
Case 43
If SATURATION_LEVEL < 2 Then
SATURATION_LEVEL = SATURATION_LEVEL + .1
End If
Case 45
If SATURATION_LEVEL > 0 Then
SATURATION_LEVEL = SATURATION_LEVEL - .1
End If
End Select
If PeekMessage(_Offset(msg), 0, 0, 0, PM_REMOVE) Then
TranslateMessage _Offset(msg)
DispatchMessage _Offset(msg)
Else
GrabFrame childWin
End If
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")
If myCallback = 0 Then
Print "Can't find callback pointer"
End
End If
Dim As BITMAPINFO format
SendMessage hwnd, WM_CAP_DRIVER_CONNECT, 0, 0
SendMessage hwnd, WM_CAP_SET_SCALE, _FALSE, 0
'SendMessage hwnd, WM_CAP_SET_PREVIEWRATE, 1000 / FPS, 0
SendMessage hwnd, WM_CAP_SET_PREVIEW, _FALSE, 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)
2 hours ago(This post was last modified: 2 hours ago by SpriggsySpriggs.)
Fixed a bug with the saturation calculation. Also, I've added the ability to adjust brightness! Use➕ or ➖ to adjust saturation and ⬆️ and ⬇️ arrows to adjust brightness. Press "R" to reset saturation and brightness.
Const FPS = 30 'Not recommended to set this higher than frame rate of webcam/video device
Const VIDWIDTH = 640
Const VIDHEIGHT = 480
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
Type POINT
As Long x, y
End Type
Type MSG
As _Offset hwnd
As _Unsigned Long message
$If 64BIT Then
As String * 4 padding1
$End If
As _Unsigned _Offset wParam
As _Offset lParam
As _Unsigned Long time
$If 64BIT Then
As String * 4 padding2
$End If
As POINT pt
As _Unsigned Long lPrivat
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)
Function PeekMessage& Alias "PeekMessageA" (ByVal lpMsg As _Offset, ByVal hWnd As _Offset, ByVal wMsgFilterMin As _Unsigned Long, ByVal wMsgFilterMax As _Unsigned Long, ByVal wRemoveMsg As _Unsigned Long)
Sub TranslateMessage (ByVal lpMsg As _Offset)
Sub DispatchMessage (ByVal lpMsg As _Offset)
Sub DestroyWindow (ByVal hWnd As _Offset)
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 Single SATURATION_LEVEL: SATURATION_LEVEL = 1.00 '0.00 for greyscale, 1.00 for normal, and >1.00 for oversaturation
Dim Shared As Single BRIGHTNESS_LEVEL: BRIGHTNESS_LEVEL = 1.00
Screen _NewImage(VIDWIDTH, VIDHEIGHT, 32)
_Delay 0.2 'Just in case
Dim As String captureWinText: captureWinText = "Webcam API Test - Child" + Chr$(0)
Dim As _Offset childID
Dim As _Offset childWin: childWin = CreateCaptureWindow(_Offset(captureWinText), WS_EX_NOACTIVATE, 0, 0, VIDWIDTH, VIDHEIGHT, _WindowHandle, childID)
If childWin = 0 Then
Print "Couldn't create capture window."
End
End If
_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
Dim As _Integer64 k
Dim As MSG msg
Do
k = _KeyHit
Select Case k
Case 32
Exit Do
Case 27
KillDriver childWin
End
Case 43
If SATURATION_LEVEL < 2.00 Then
SATURATION_LEVEL = SATURATION_LEVEL + .10
'_Echo _ToStr$(SATURATION_LEVEL)
End If
Case 45
If SATURATION_LEVEL > 0.00 Then
SATURATION_LEVEL = SATURATION_LEVEL - .10
'_Echo _ToStr$(SATURATION_LEVEL)
End If
Case 18432
If BRIGHTNESS_LEVEL < 2 Then
BRIGHTNESS_LEVEL = BRIGHTNESS_LEVEL + .10
'_Echo _ToStr$(BRIGHTNESS_LEVEL)
End If
Case 20480
If BRIGHTNESS_LEVEL > 0.00 Then
BRIGHTNESS_LEVEL = BRIGHTNESS_LEVEL - .10
'_Echo _ToStr$(BRIGHTNESS_LEVEL)
End If
Case Asc("R"), Asc("r") 'Reset
BRIGHTNESS_LEVEL = 1.00
SATURATION_LEVEL = 1.00
End Select
If PeekMessage(_Offset(msg), 0, 0, 0, PM_REMOVE) Then
TranslateMessage _Offset(msg)
DispatchMessage _Offset(msg)
Else
GrabFrame childWin
End If
Screen frame.IMAGE
_Display
_Limit FPS
Loop
Dim As _MEM clippedFrame
'GrabFrameToClipboard childWin, clippedFrame
_ClipboardImage = frame.IMAGE
_SaveImage "myimage.bmp", frame.IMAGE, "BMP"
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")
If myCallback = 0 Then
Print "Can't find callback pointer"
End
End If
Dim As BITMAPINFO format
SendMessage hwnd, WM_CAP_DRIVER_CONNECT, 0, 0
SendMessage hwnd, WM_CAP_SET_SCALE, _FALSE, 0
'SendMessage hwnd, WM_CAP_SET_PREVIEWRATE, 1000 / FPS, 0
SendMessage hwnd, WM_CAP_SET_PREVIEW, _FALSE, 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)
Dim As _Unsigned _Byte r1, g1, b1, r2, g2, b2
Dim As Double Y1, Y2, U, V
