4 hours ago
(This post was last modified: 4 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.
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.
Code: (Select All)
Option _Explicit
'$Console
'------------------------------------------------------------------------------------------------------------------------------
'Capture Driver Constants
Const WM_CAP_START = &H0400
Const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10
Const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11
Const WM_CAP_EDIT_COPY = WM_CAP_START + 30
Const WM_CAP_SET_SCALE = WM_CAP_START + 53
Const WM_CAP_SET_PREVIEWRATE = WM_CAP_START + 52
Const WM_CAP_SET_PREVIEW = WM_CAP_START + 50
Const WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START + 42
Const WM_CAP_GRAB_FRAME_NOSTOP = WM_CAP_START + 61
Const WM_CAP_FILE_SAVEDIB = WM_CAP_START + 25
Const WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44
Const WM_CAP_SET_VIDEOFORMAT = WM_CAP_START + 45
Const WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START + 41
Const WM_CAP_SET_CALLBACK_FRAME = WM_CAP_START + 5
Const CF_DIB = &H0008
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 (_DesktopWidth / 2) - VIDWIDTH / 2, (_DesktopHeight / 2) - VIDHEIGHT / 2
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)
r1 = _Clamp(yuy2(0) + 1.13983 * (yuy2(3) - 128) * SATURATION_LEVEL, 0, 255)
g1 = _Clamp(yuy2(0) - 0.39465 * (yuy2(1) - 128) - 0.714 * (yuy2(3) - 128) * SATURATION_LEVEL, 0, 255)
b1 = _Clamp(yuy2(0) + 0.58060 * (yuy2(1) - 128) * SATURATION_LEVEL, 0, 255)
' Convert second pixel (Y2)
r2 = _Clamp(yuy2(2) + 1.13983 * (yuy2(3) - 128) * SATURATION_LEVEL, 0, 255)
g2 = _Clamp(yuy2(2) - 0.39465 * (yuy2(1) - 128) - 0.714 * (yuy2(3) - 128) * SATURATION_LEVEL, 0, 255)
b2 = _Clamp(yuy2(2) + 0.58060 * (yuy2(1) - 128) * SATURATION_LEVEL, 0, 255)
ConvertYUY2toRGB = _RGB32(r1, g1, b1) Or _ShL(_RGB32(r2, g2, b2), 32)
End Function
The noticing will continue