03-02-2025, 01:52 AM
(This post was last modified: 03-02-2025, 01:55 AM by SpriggsySpriggs.)
Yeah, zoom with using the dialog ain't too bad
This version allows for changing video source or adjusting camera settings using "Z". The changes you make don't happen live. Once you click "OK" on the dialog, the window will reflect the changes.
This version allows for changing video source or adjusting camera settings using "Z". The changes you make don't happen live. Once you click "OK" on the dialog, the window will reflect the changes.
Code: (Select All)
Option _Explicit
'$Console
$VersionInfo:Comments=Avicap32 webcam to memory test
'Using $VersionInfo so we get modern controls
'------------------------------------------------------------------------------------------------------------------------------
'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_SET_SCALE = WM_CAP_START + 53
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_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 PM_REMOVE = &H0001
Const WS_EX_NOACTIVATE = &H08000000
Const FPS = 60 '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
Dim Shared As _Byte NEGATIVE: NEGATIVE = _FALSE
Dim Shared As _Byte FLIPPED_H: FLIPPED_H = _FALSE
Dim Shared As _Byte FLIPPED_V: FLIPPED_V = _FALSE
Dim Shared As Single COLOR_TEMP_WARM: COLOR_TEMP_WARM = 1.00
Dim Shared As Single COLOR_TEMP_COOL: COLOR_TEMP_COOL = 1.00
Dim Shared As Single COLOR_GREEN: COLOR_GREEN = 1.00
Dim Shared As _Unsigned _Byte PALETTE_SWAP: PALETTE_SWAP = 0
Screen _NewImage(VIDWIDTH, VIDHEIGHT, 32)
_Delay 0.2 'Just in case
_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), 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
Dim As Long i
$Checking:Off
Do
k = _KeyHit
Select Case k
Case 32 'Space bar
Exit Do
Case 27 'Escape - Reset
BRIGHTNESS_LEVEL = 1.00
SATURATION_LEVEL = 1.00
NEGATIVE = _FALSE
FLIPPED_H = _FALSE
FLIPPED_V = _FALSE
COLOR_TEMP_WARM = 1.00
COLOR_TEMP_COOL = 1.00
COLOR_GREEN = 1.00
PALETTE_SWAP = 0
Case 43 'numpad plus key
If SATURATION_LEVEL < 2.00 Then
SATURATION_LEVEL = SATURATION_LEVEL + .10
End If
Case 45 'numpad minus key
If SATURATION_LEVEL > 0.00 Then
SATURATION_LEVEL = SATURATION_LEVEL - .10
End If
Case 18432 'arrow key up
If BRIGHTNESS_LEVEL < 2 Then
BRIGHTNESS_LEVEL = BRIGHTNESS_LEVEL + .10
End If
Case 20480 'arrow key down
If BRIGHTNESS_LEVEL > 0.00 Then
BRIGHTNESS_LEVEL = BRIGHTNESS_LEVEL - .10
End If
Case Asc("N"), Asc("n") 'negative filter toggle
NEGATIVE = Not NEGATIVE
Case Asc("P"), Asc("p")
If _FileExists("capture(" + _ToStr$(i) + ").png") Then
While _FileExists("capture(" + _ToStr$(i) + ").png")
i = i + 1
Wend
End If
_SaveImage "capture(" + _ToStr$(i) + ").png", frame.IMAGE, "PNG"
i = i + 1
Case Asc("C"), Asc("c")
_ClipboardImage = frame.IMAGE
Case Asc("H"), Asc("h")
FLIPPED_H = Not FLIPPED_H
Case Asc("V"), Asc("v")
FLIPPED_V = Not FLIPPED_V
Case Asc("R")
If COLOR_TEMP_WARM < 2.00 Then
COLOR_TEMP_WARM = COLOR_TEMP_WARM + .10
End If
Case Asc("r")
If COLOR_TEMP_WARM > 0 Then
COLOR_TEMP_WARM = COLOR_TEMP_WARM - .10
End If
Case Asc("G")
If COLOR_GREEN < 2.00 Then
COLOR_GREEN = COLOR_GREEN + .10
End If
Case Asc("g")
If COLOR_GREEN > 0 Then
COLOR_GREEN = COLOR_GREEN - .10
End If
Case Asc("B")
If COLOR_TEMP_COOL < 2.00 Then
COLOR_TEMP_COOL = COLOR_TEMP_COOL + .10
End If
Case Asc("b")
If COLOR_TEMP_COOL > 0 Then
COLOR_TEMP_COOL = COLOR_TEMP_COOL - .10
End If
Case Asc("1")
PALETTE_SWAP = 1
Case Asc("2")
PALETTE_SWAP = 2
Case Asc("3")
PALETTE_SWAP = 3
Case Asc("4")
PALETTE_SWAP = 4
Case Asc("5")
PALETTE_SWAP = 5
Case Asc("6")
PALETTE_SWAP = 6
Case Asc("Z"), Asc("z")
SendMessage childWin, WM_CAP_DLG_VIDEOSOURCE, 0, 0
End Select
If PeekMessage(_Offset(msg), 0, 0, 0, PM_REMOVE) Then
TranslateMessage _Offset(msg)
DispatchMessage _Offset(msg)
Else
GrabFrame childWin
End If
_PutImage , frame.IMAGE, _Dest
_Display
_Limit FPS
Loop
$Checking:On
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")
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_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 GrabFrame (hwnd As _Offset)
SendMessage hwnd, WM_CAP_GRAB_FRAME_NOSTOP, 0, 0
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
If FLIPPED_H Then
Dim As Long hi: hi = _CopyImage(i)
_PutImage , hi, i, (bi.bmiHeader.biWidth - 1, 0)-(0, bi.bmiHeader.biHeight - 1)
_FreeImage hi
End If
If FLIPPED_V Then
Dim As Long vi: vi = _CopyImage(i)
_PutImage , vi, i, (bi.bmiHeader.biWidth - 1, bi.bmiHeader.biHeight - 1)-(0, 0)
_FreeImage vi
End If
_Dest 0
frame = _MemImage(i)
End Function
Function ConvertYUY2toRGB~&& (yuy2() As _Unsigned _Byte)
Dim As _Unsigned _Byte r1, g1, b1, r2, g2, b2, r3, g3, b3
Dim As Double Y1, Y2, U, V
' Extract values
Y1 = yuy2(0) * BRIGHTNESS_LEVEL
Y2 = yuy2(2) * BRIGHTNESS_LEVEL
U = (yuy2(1) - 128) * SATURATION_LEVEL
V = (yuy2(3) - 128) * SATURATION_LEVEL
' Convert first pixel
r1 = _Clamp((Y1 + 1.13983 * V) * COLOR_TEMP_WARM, 0, 255)
g1 = _Clamp((Y1 - 0.39465 * U - 0.58060 * V) * COLOR_GREEN, 0, 255)
b1 = _Clamp((Y1 + 2.03211 * U) * COLOR_TEMP_COOL, 0, 255)
' Convert second pixel
r2 = _Clamp((Y2 + 1.13983 * V) * COLOR_TEMP_WARM, 0, 255)
g2 = _Clamp((Y2 - 0.39465 * U - 0.58060 * V) * COLOR_GREEN, 0, 255)
b2 = _Clamp((Y2 + 2.03211 * U) * COLOR_TEMP_COOL, 0, 255)
If NEGATIVE Then
r1 = 255 - r1: g1 = 255 - g1: b1 = 255 - b1
r2 = 255 - r2: g2 = 255 - g2: b2 = 255 - b2
End If
If PALETTE_SWAP > 0 Then
Select Case PALETTE_SWAP
Case 1
''Dobra
r3 = _Clamp(r1 * 0.989 + g1 * 1.000 + b1 * 0.510, 0, 255)
g3 = _Clamp(r1 * 0.157 + g1 * 0.500 + b1 * 0.400, 0, 255)
b3 = _Clamp(r1 * 0.278 + g1 * 0.000 + b1 * 0.267, 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp(r2 * 0.989 + g2 * 1.000 + b2 * 0.510, 0, 255)
g3 = _Clamp(r2 * 0.157 + g2 * 0.500 + b2 * 0.400, 0, 255)
b3 = _Clamp(r2 * 0.278 + g2 * 0.000 + b2 * 0.267, 0, 255)
r2 = r3
g2 = g3
b2 = b3
Case 2
''Roden
r3 = _Clamp(r1 * 0.545 + g1 * 0.0902 + b1 * 0.804, 0, 255)
g3 = _Clamp(r1 * 0.412 + g1 * 0.502 + b1 * 0.522, 0, 255)
b3 = _Clamp(r1 * 0.412 + g1 * 0.427 + b1 * 0.247, 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp(r2 * 0.545 + g2 * 0.0902 + b2 * 0.804, 0, 255)
g3 = _Clamp(r2 * 0.412 + g2 * 0.502 + b2 * 0.522, 0, 255)
b3 = _Clamp(r2 * 0.412 + g2 * 0.427 + b2 * 0.247, 0, 255)
r2 = r3
g2 = g3
b2 = b3
Case 3
''Flowers
r3 = _Clamp(r1 * 0.753 + g1 * 1.000 + b1 * 0.000, 0, 255)
g3 = _Clamp(r1 * 0.000 + g1 * 1.000 + b1 * 0.000, 0, 255)
b3 = _Clamp(r1 * 0.000 + g1 * 1.000 + b1 * 1.000, 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp(r2 * 0.753 + g2 * 1.000 + b2 * 0.000, 0, 255)
g3 = _Clamp(r2 * 0.000 + g2 * 1.000 + b2 * 0.000, 0, 255)
b3 = _Clamp(r2 * 0.000 + g2 * 1.000 + b2 * 1.000, 0, 255)
r2 = r3
g2 = g3
b2 = b3
Case 4
''GBR
r3 = _Clamp(r1 * 0 + g1 * 0 + b1 * 1, 0, 255)
g3 = _Clamp(r1 * 1 + g1 * 0 + b1 * 0, 0, 255)
b3 = _Clamp(r1 * 0 + g1 * 1 + b1 * 0, 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp(r2 * 0 + g2 * 0 + b2 * 1, 0, 255)
g3 = _Clamp(r2 * 1 + g2 * 0 + b2 * 0, 0, 255)
b3 = _Clamp(r2 * 0 + g2 * 1 + b2 * 0, 0, 255)
r2 = r3
g2 = g3
b2 = b3
Case 5
''Sepia
r3 = _Clamp((r1 * 0.393) + (g1 * 0.769) + (b1 * 0.189), 0, 255)
g3 = _Clamp((r1 * 0.349) + (g1 * 0.686) + (b1 * 0.168), 0, 255)
b3 = _Clamp((r1 * 0.272) + (g1 * 0.534) + (b1 * 0.131), 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp((r2 * 0.393) + (g2 * 0.769) + (b2 * 0.189), 0, 255)
g3 = _Clamp((r2 * 0.349) + (g2 * 0.686) + (b2 * 0.168), 0, 255)
b3 = _Clamp((r2 * 0.272) + (g2 * 0.534) + (b2 * 0.131), 0, 255)
r2 = r3
g2 = g3
b2 = b3
Case 6
''High contrast
r3 = _Clamp((r1 - 128) * 1.5 + 128, 0, 255)
g3 = _Clamp((g1 - 128) * 1.5 + 128, 0, 255)
b3 = _Clamp((b1 - 128) * 1.5 + 128, 0, 255)
r1 = r3
g1 = g3
b1 = b3
r3 = _Clamp((r2 - 128) * 1.5 + 128, 0, 255)
g3 = _Clamp((g2 - 128) * 1.5 + 128, 0, 255)
b3 = _Clamp((b2 - 128) * 1.5 + 128, 0, 255)
r2 = r3
g2 = g3
b2 = b3
End Select
End If
' Pack pixels into a single return value
ConvertYUY2toRGB = _RGB32(r1, g1, b1) Or _ShL(_RGB32(r2, g2, b2), 32)
End Function
The noticing will continue