02-26-2025, 07:46 PM
(This post was last modified: 02-26-2025, 08:52 PM by SpriggsySpriggs.)
Now you can export straight to memory, mi amigo.
It should be noted that it has to export to clipboard first and then load to memory. So your clipboard will contain the image as well. But that's the nature of the beast.
It should be noted that it has to export to clipboard first and then load to memory. So your clipboard will contain the image as well. But that's the nature of the beast.
Code: (Select All)
Option _Explicit
Const WS_VISIBLE = &H10000000
'------------------------------------------------------------------------------------------------------------------------------
'Capture Driver Constants
Const WM_CAP_START = &H0400
Const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10
Const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11
Const WM_CAP_EDIT_COPY = WM_CAP_START + 30
Const WM_CAP_SET_SCALE = WM_CAP_START + 53
Const WM_CAP_SET_PREVIEWRATE = WM_CAP_START + 52
Const WM_CAP_SET_PREVIEW = WM_CAP_START + 50
Const WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START + 42
Const WM_CAP_GRAB_FRAME_NOSTOP = WM_CAP_START + 61
Const WM_CAP_FILE_SAVEDIB = WM_CAP_START + 25
Const WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44
Const WM_CAP_SET_VIDEOFORMAT = WM_CAP_START + 45
Const CF_DIB = &H0008
Const FPS = 30 'Not recommended to set this higher than frame rate of webcam/video device
Type BITMAPINFOHEADER
As _Unsigned Long biSize
As Long biWidth, biHeight
As _Unsigned Integer biPlanes, biBitCount
As _Unsigned Long biCompression, biSizeImage
As Long biXPelsPerMeter, biYPelsPerMeter
As _Unsigned Long biClrUsed, biClrImportant
End Type
Type BITMAPINFO
As BITMAPINFOHEADER bmiHeader
End Type
Declare Dynamic Library "Avicap32"
Function CreateCaptureWindow& Alias "capCreateCaptureWindowA" (ByVal lpszWindowName As _Offset, ByVal dwStyle As _Unsigned Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As _Offset, ByVal nId As Long)
End Declare
Declare CustomType Library
Sub SendMessage Alias "SendMessageA" (ByVal hWnd As _Offset, ByVal Msg As _Unsigned Long, ByVal wParam As _Offset, ByVal lParam As _Offset)
Function SendMessage& Alias "SendMessageA" (ByVal hWnd As _Offset, ByVal Msg As _Unsigned Long, ByVal wParam As _Offset, ByVal lParam As _Offset)
Sub DestroyWindow (ByVal hWnd As _Offset)
Function GetAsyncKeyState% (ByVal vKey As Long)
Function mmioStringToFOURCC& (sz As String, ByVal uFlags As _Unsigned Long)
Function OpenClipboard& (ByVal hWndNewOwner As _Offset)
Function GetClipboardData%& (ByVal uFormat As _Unsigned Long)
Sub CloseClipboard ()
Function GlobalLock%& (ByVal hMem As _Offset)
Function GlobalUnlock& (ByVal hMem As _Offset)
End Declare
Dim As _Unsigned Long vidWidth, vidHeight
vidWidth = 640
vidHeight = 480
Screen _NewImage(vidWidth, vidHeight, 32)
_ScreenMove _Middle
Dim As String captureWinText: captureWinText = "Webcam API Test - Child" + Chr$(0)
Dim As _Offset childID
Dim As _Offset childWin: childWin = CreateCaptureWindow(_Offset(captureWinText), WS_VISIBLE, 0, 0, vidWidth, vidHeight, _WindowHandle, childID)
_Title "Webcam API Test - Parent"
'If _FileExists("capture.bmp") Then Kill "capture.bmp"
'Initialize the driver
SetupDriver childWin, vidWidth, vidHeight, _TRUE
Print "Previewing... Press Space bar to capture frame"
Print "Press escape to kill the window"
Print "DO NOT GO CLICKING ALL WILLY-NILLY ON THE PROGRAM WINDOW, ESPECIALLY IF YOUR CURSOR HAS THE LOADING CIRCLE/HOURGLASS. For some reason, this will cause it to freeze and crash. Why? 'cause Microsoft, that's why."
Do
'GetAsyncKeyState is necessary because the capture window steals keyboard focus
If GetAsyncKeyState(&H20) <> 0 Then Exit Do
If GetAsyncKeyState(&H1B) <> 0 Then
KillDriver childWin
End
End If
GrabFrame childWin
_Limit FPS
Loop
'SaveBMP childWin, "capture.bmp"
Dim As _MEM m
GrabFrameToMemory childWin, m
'If _FileExists("capture.bmp") Then Print "Capture succeeded"
Print "Disconnecting Driver"
KillDriver childWin
Screen m.IMAGE
_MemFree m
Sub SetupDriver (hwnd As _Offset, videoWidth As _Unsigned Long, videoHeight As _Unsigned Long, defaultSource As _Byte)
SendMessage hwnd, WM_CAP_DRIVER_CONNECT, 0, 0
SendMessage hwnd, WM_CAP_SET_SCALE, -1, 0
SendMessage hwnd, WM_CAP_SET_PREVIEWRATE, 1000 / FPS, 0
SendMessage hwnd, WM_CAP_SET_PREVIEW, -1, 0
Dim As _Unsigned Long formatSize: formatSize = SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, 0, 0)
Dim As BITMAPINFO bmi
If Len(bmi) <> formatSize Then
KillDriver hwnd
Print "Wrong size"
Print formatSize, Len(bmi)
End
End If
If SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, formatSize, _Offset(bmi)) = 0 Then
KillDriver hwnd
Print "Couldn't get format"
End
End If
bmi.bmiHeader.biWidth = videoWidth
bmi.bmiHeader.biHeight = videoHeight
bmi.bmiHeader.biBitCount = 16 'yuy2 format
bmi.bmiHeader.biCompression = mmioStringToFOURCC("YUY2" + Chr$(0), &H00000010) 'MUST BE YUY2 FORMAT
bmi.bmiHeader.biSizeImage = videoWidth * videoHeight * 2
If SendMessage(hwnd, WM_CAP_SET_VIDEOFORMAT, formatSize, _Offset(bmi)) = 0 Then
KillDriver hwnd
Print "Failed to set video format"
End
End If
If defaultSource = _FALSE Then
SendMessage hwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0
End If
End Sub
Sub KillDriver (hwnd As _Offset)
SendMessage hwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0
DestroyWindow hwnd
End Sub
Sub SaveBMP (hwnd As _Offset, filename As String)
filename = filename + Chr$(0)
SendMessage hwnd, WM_CAP_FILE_SAVEDIB, 0, _Offset(filename)
End Sub
Sub GrabFrame (hwnd As _Offset)
SendMessage hwnd, WM_CAP_GRAB_FRAME_NOSTOP, 0, 0
End Sub
Sub GrabFrameToMemory (hwnd As _Offset, image As _MEM)
Dim As _Unsigned Long frameSize: frameSize = SendMessage(hwnd, WM_CAP_GET_VIDEOFORMAT, 0, 0)
If frameSize = 0 Then
Print "Failed to get video format size"
KillDriver hwnd
End
End If
SendMessage hwnd, WM_CAP_EDIT_COPY, 0, 0
If OpenClipboard(0) = 0 Then
Print "Couldn't open clipboard"
KillDriver hwnd
End
End If
Dim As _Offset hDIB: hDIB = GetClipboardData(CF_DIB)
If hDIB = 0 Then
Print "Failed to retrieve bitmap from clipboard"
CloseClipboard
KillDriver hwnd
End
End If
Dim As _Offset pDIB: pDIB = GlobalLock(hDIB)
If pDIB = 0 Then
Print "Failed to lock the clipboard"
CloseClipboard
KillDriver hwnd
End
End If
CloseClipboard
'Print "Frame retrieved"
Dim As _MEM p: p = _Mem(pDIB, 4)
Dim As _Unsigned Long biSize: biSize = _MemGet(p, p.OFFSET, _Unsigned Long)
Dim As _MEM pBI: pBI = _Mem(pDIB, biSize)
'Print pBI.SIZE
Dim As BITMAPINFO bi
_MemGet pBI, pBI.OFFSET, bi
_MemFree pBI
_MemFree p
'Print bi.bmiHeader.biWidth
'Print bi.bmiHeader.biHeight
'Print bi.bmiHeader.biBitCount
Dim As Long bytesPerPixel: bytesPerPixel = (bi.bmiHeader.biBitCount + 7) \ 8
'Print bytesPerPixel
Dim As Long stride: stride = (((bi.bmiHeader.biWidth * bi.bmiHeader.biBitCount) + 31) And Not 31) \ 8
'Print stride
'Print bi.bmiHeader.biSizeImage
Dim As _MEM m: m = _Mem(pDIB + Len(bi), bi.bmiHeader.biSizeImage)
Dim As Long y, x, t
Dim As _Unsigned _Byte pixel24(0 To 2)
Dim As _Unsigned _Byte pixel32(0 To 3)
Dim As _Offset pScanLine
Dim As _Unsigned Long q
Dim As Long i: i = _NewImage(bi.bmiHeader.biWidth, bi.bmiHeader.biHeight, 32)
_Dest i
If bi.bmiHeader.biHeight > 0 Then
For y = 0 To Abs(bi.bmiHeader.biHeight) - 1
pScanLine = m.OFFSET + (y * stride)
For x = 0 To bi.bmiHeader.biWidth - 1
If bi.bmiHeader.biBitCount = 24 Then
_MemGet m, pScanLine + (x * bytesPerPixel), pixel24()
q = _RGB32(pixel24(2), pixel24(1), pixel24(0))
ElseIf bi.bmiHeader.biBitCount = 32 Then
_MemGet m, pScanLine + (x * bytesPerPixel), pixel32()
q = _RGBA32(pixel32(2), pixel32(1), pixel32(0), pixel32(3))
Else
q = _RGB32(255, 255, 255)
End If
PSet (x, Abs(bi.bmiHeader.biHeight) - 1 - y), q
Next x
Next y
Else
For y = 0 To Abs(bi.bmiHeader.biHeight) - 1
pScanLine = m.OFFSET + (y * stride)
For x = 0 To bi.bmiHeader.biWidth - 1
If bi.bmiHeader.biBitCount = 24 Then
_MemGet m, pScanLine + (x * bytesPerPixel), pixel24()
q = _RGB32(pixel24(2), pixel24(1), pixel24(0))
ElseIf bi.bmiHeader.biBitCount = 32 Then
_MemGet m, pScanLine + (x * bytesPerPixel), pixel32()
q = _RGBA32(pixel32(2), pixel32(1), pixel32(0), pixel32(3))
Else
q = _RGB32(255, 255, 255)
End If
PSet (x, y), q
Next
Next
End If
_Dest 0
image = _MemImage(i)
Dim As Long a: a = GlobalUnlock(pDIB)
End Sub
The noticing will continue