Yesterday, 10:03 PM
Here's the latest version I was messing with, which includes a couple fun non-API effects, enjoy
Code: (Select All)
' Webcam fun
' https://qb64phoenix.com/forum/showthread.php?tid=3497
' -----------------------------------------------------------------------------
' Controls
' -----------------------------------------------------------------------------
' Spacebar: show/hide text
'
' Left, right: saturation level
'
' Up, down: brightness level
'
' L: cycle through scan line emulation
'
' E: cycle through echo mode (larger values=more delayed)
'
' F: cycle through echo specific color channels
'
' C: cycle through color tweak mode
'
' K: toggle "chroma key" mode (not really chroma key, it shows what changed from background)
'
' Z: reset "chroma key" (refresh background image)
'
' PgUp, Pgdn: "chroma key" threshold used to detect changed pixels
'
' Home, End: cycle through "chroma key" bg color
'
' O: toggle outline image mode
'
' R: reset all values
'
' S: save still frame
'
' Esc: quit
' -----------------------------------------------------------------------------
' What's new
' -----------------------------------------------------------------------------
' Spriggsy's fixes: https://qb64phoenix.com/forum/showthread.php?tid=3497&page=3
' Changed input from _keyhit to _button
' Madscijr's attempts at special effects (regular image processing, not camera API stuff)
' image outline code by bplus: https://qb64phoenix.com/forum/showthread.php?tid=272&pid=32066#pid32066
' -----------------------------------------------------------------------------
' TO DO
' -----------------------------------------------------------------------------
' * outline mode stops the chroma key + other fx from working, need to figure that out
' * vince's ascii video: https://qb64phoenix.com/forum/showthread.php?tid=3498&pid=32484#pid32484
' * merge in spriggsy's many new features: https://qb64phoenix.com/forum/showthread.php?tid=3498&pid=32421#pid32421
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_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 PM_REMOVE = &H0001
Const WS_EX_NOACTIVATE = &H08000000
Const FPS = 30 'Not recommended to set this higher than frame rate of webcam/video device
Const VIDWIDTH = 320
Const VIDHEIGHT = 240
'Const MOVEMENT_THRESHOLD = 55 ' 160
Const SOLID_LINE_STYLE = 65535
' _BUTTON key codes
Const KeyCode_Escape = 2
Const KeyCode_Spacebar = 58
Const KeyCode_0 = 12
Const KeyCode_1 = 3
Const KeyCode_2 = 4
Const KeyCode_3 = 5
Const KeyCode_4 = 6
Const KeyCode_5 = 7
Const KeyCode_6 = 8
Const KeyCode_7 = 9
Const KeyCode_8 = 10
Const KeyCode_9 = 11
Const KeyCode_A = 31
Const KeyCode_B = 49
Const KeyCode_C = 47
Const KeyCode_D = 33
Const KeyCode_E = 19
Const KeyCode_F = 34
Const KeyCode_G = 35
Const KeyCode_H = 36
Const KeyCode_I = 24
Const KeyCode_J = 37
Const KeyCode_K = 38
Const KeyCode_L = 39
Const KeyCode_M = 51
Const KeyCode_N = 50
Const KeyCode_O = 25
Const KeyCode_P = 26
Const KeyCode_Q = 17
Const KeyCode_R = 20
Const KeyCode_S = 32
Const KeyCode_T = 21
Const KeyCode_U = 23
Const KeyCode_V = 48
Const KeyCode_W = 18
Const KeyCode_X = 46
Const KeyCode_Y = 22
Const KeyCode_Z = 45
Const KeyCode_Up = 329
Const KeyCode_Down = 337
Const KeyCode_Left = 332
Const KeyCode_Right = 334
Const KeyCode_Minus = 13
Const KeyCode_Equal = 14
Const KeyCode_BkSp = 15
Const KeyCode_Ins = 339
Const KeyCode_Del = 340
Const KeyCode_Home = 328
Const KeyCode_End = 336
Const KeyCode_PgUp = 330
Const KeyCode_PgDn = 338
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' UDTs
' HOLDS RGB VALUES FOR A PIXEL
Type PixelType
r As Long
g As Long
b As Long
'a As Long
End Type ' PixelType
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 m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
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
ReDim Shared arrColor(-1) As _Unsigned Long
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 IsReset As Integer: IsReset = _TRUE
Dim As _MEM clippedFrame
Dim imgCamera As Long
Dim imgBackground As Long ' background image
Dim imgForeground As Long ' chroma keyed different from what camera originally saw (saved in arrComparePixels)
Dim imgTemp As Long ' for processing effects
Dim imgText As Long
Dim ShowText As Integer: ShowText = _TRUE
Dim imgLines1 As Long
Dim imgLines2 As Long
Dim imgLines3 As Long
Dim imgLines4 As Long
Dim imgBuffer As Long
Dim tx, ty, tc As Integer ' for dislaying color title
Dim sError As String: sError = ""
Dim bFirst As Integer: bFirst = _TRUE
Dim iScanLines As Integer: iScanLines = 0 ' for scan line effect (0 = none)
Dim iEchoRatio As Integer: iEchoRatio = 0 ' for video echo trails length (0 = none)
Dim iEchoChannel As Integer: iEchoChannel = 0 ' for video echo color channel (0 = full RGB)
Dim iTweakColorMode As Integer: iTweakColorMode = 0 ' tweak color select (0 = none)
Dim iTweakRed, iTweakGreen, iTweakBlue As Integer ' tweak color r/g/b modes (0 = none)
Dim iLine As Integer ' for printing instructions / displaying values
Dim TextColor As _Unsigned Long: TextColor = cBlack
Dim IsCalibrating As Integer
ReDim arrComparePixels(VIDWIDTH, VIDHEIGHT) As PixelType
Dim ChromaKeyEnabled As Integer
Dim iMovementThreshold As Integer
Dim iBgColor As Integer
Dim OutlineImageEnabled As Integer
GetColorTweakCodes iTweakColorMode, iTweakRed, iTweakGreen, iTweakBlue
AddSpectrumColors arrColor() ' INIT SPECTRUM COLOR ARRAY
iBgColor = LBound(arrColor)
InitImage imgText, VIDWIDTH, VIDHEIGHT, cEmpty
InitImage imgBuffer, VIDWIDTH, VIDHEIGHT, cEmpty
'InitImage imgBackground, VIDWIDTH, VIDHEIGHT, cCyan
InitImage imgBackground, VIDWIDTH, VIDHEIGHT, arrColor(iBgColor)
InitImage imgTemp, VIDWIDTH, VIDHEIGHT, arrColor(iBgColor)
If Len(sError) = 0 Then
sError = CreateScanLines$(imgLines1, VIDWIDTH, VIDHEIGHT, cBlack, 1)
End If
If Len(sError) = 0 Then
sError = CreateScanLines$(imgLines2, VIDWIDTH, VIDHEIGHT, cBlack, 2)
End If
If Len(sError) = 0 Then
sError = CreateScanLines$(imgLines3, VIDWIDTH, VIDHEIGHT, cBlack, 3)
End If
If Len(sError) = 0 Then
sError = CreateScanLines$(imgLines4, VIDWIDTH, VIDHEIGHT, cBlack, 4)
End If
If Len(sError) = 0 Then
' INITIALIZE
IsCalibrating = _TRUE ' Capture a single frame to window WebCam.childWin
ChromaKeyEnabled = _FALSE
iMovementThreshold = 30
OutlineImageEnabled = _FALSE
Do
' GET IMAGE FROM CAMERA
If PeekMessage(_Offset(msg), 0, 0, 0, PM_REMOVE) Then
TranslateMessage _Offset(msg)
DispatchMessage _Offset(msg)
Else
GrabFrame childWin
End If
'Screen frame.IMAGE
imgCamera = frame.IMAGE
' ================================================================================================================================================================
' BEGIN PROCESS KEYBOARD INPUT
' ================================================================================================================================================================
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _Button(KeyCode_Escape) Then
KillDriver childWin
Exit Do
ElseIf _Button(KeyCode_Spacebar) Then
If ShowText = _TRUE Then ShowText = _FALSE Else ShowText = _TRUE
ElseIf _Button(KeyCode_L) Then
' ADVANCE SCAN LINE MODE
iScanLines = iScanLines + 1
If iScanLines > 4 Then iScanLines = 0
IsReset = _FALSE
ElseIf _Button(KeyCode_E) Then
' ADVANCE ECHO MODE
iEchoRatio = iEchoRatio + 1
If iEchoRatio > 8 Then iEchoRatio = 0
IsReset = _FALSE
ElseIf _Button(KeyCode_F) Then
' ADVANCE COLOR CHANNEL FOR ECHO MODE
iEchoChannel = iEchoChannel + 1
If iEchoChannel > 3 Then iEchoChannel = 0
IsReset = _FALSE
ElseIf _Button(KeyCode_C) Then
' ADVANCE TWEAK COLOR MODE
iTweakColorMode = iTweakColorMode + 1
'If iTweakColorMode > 10 Then iTweakColorMode = 0
If iTweakColorMode > 4 Then iTweakColorMode = 0
GetColorTweakCodes iTweakColorMode, iTweakRed, iTweakGreen, iTweakBlue
IsReset = _FALSE
ElseIf _Button(KeyCode_S) Then
_SaveImage _
m_ProgramPath$ + m_ProgramName$ + "." + _
GetCurrentDateTime$("{yyyy}{mm}{dd}_{rr}{nn}{ss}") + _
".bmp", frame.IMAGE, "BMP"
ElseIf _Button(KeyCode_Equal) Or _Button(KeyCode_Right) Then
'If SATURATION_LEVEL < 2.00 Then
If SATURATION_LEVEL <= 254.9 Then
SATURATION_LEVEL = SATURATION_LEVEL + .10
IsReset = _FALSE
End If
ElseIf _Button(KeyCode_Minus) Or _Button(KeyCode_Left) Then
If SATURATION_LEVEL >= 0.10 Then
SATURATION_LEVEL = SATURATION_LEVEL - .10
IsReset = _FALSE
End If
ElseIf _Button(KeyCode_Up) Then
'If BRIGHTNESS_LEVEL < 3 Then
If BRIGHTNESS_LEVEL <= 254.9 Then
BRIGHTNESS_LEVEL = BRIGHTNESS_LEVEL + .10
IsReset = _FALSE
End If
ElseIf _Button(KeyCode_Down) Then
If BRIGHTNESS_LEVEL >= 0.10 Then
BRIGHTNESS_LEVEL = BRIGHTNESS_LEVEL - .10
IsReset = _FALSE
End If
ElseIf _Button(KeyCode_R) Then
BRIGHTNESS_LEVEL = 1.00
SATURATION_LEVEL = 1.00
iScanLines = 0
iEchoRatio = 0
iEchoChannel = 0
iTweakColorMode = 0
ChromaKeyEnabled = _FALSE
OutlineImageEnabled = _FALSE
IsReset = _TRUE
ElseIf _Button(KeyCode_K) Then
ChromaKeyEnabled = Not ChromaKeyEnabled
ElseIf _Button(KeyCode_Z) Then
IsCalibrating = _TRUE
ElseIf _Button(KeyCode_PgUp) Then
iMovementThreshold = iMovementThreshold + 5
ElseIf _Button(KeyCode_PgDn) Then
iMovementThreshold = iMovementThreshold - 5
ElseIf _Button(KeyCode_Home) Then
iBgColor = iBgColor + 1
If iBgColor > UBound(arrColor) Then iBgColor = LBound(arrColor)
_Dest imgBackground: Cls , arrColor(iBgColor)
ElseIf _Button(KeyCode_End) Then
iBgColor = iBgColor - 1
If iBgColor < LBound(arrColor) Then iBgColor = UBound(arrColor)
_Dest imgBackground: Cls , arrColor(iBgColor)
ElseIf _Button(KeyCode_O) Then
OutlineImageEnabled = Not OutlineImageEnabled
End If
' CLEAR KEYBOARD BUFFER
_KeyClear
' ================================================================================================================================================================
' END PROCESS KEYBOARD INPUT
' ================================================================================================================================================================
' ================================================================================================================================================================
' BEGIN SHOW VALUES + INSTRUCTIONS + TITLE
' ================================================================================================================================================================
_Dest imgText: Cls , cEmpty
If ShowText = _TRUE Then
If TextColor = cBlack Then TextColor = cWhite Else TextColor = cBlack
' SHOW INSTRUCTIONS
iLine = 1 ' max line is 15 in 320x240 resolution
Color TextColor, cEmpty: Locate iLine, 2: Print " LEFT and RIGHT ";
Color TextColor, cEmpty: Locate iLine, 18: Print "SATURATION_LEVEL: ";
Color TextColor, cEmpty: Locate iLine, 36: Print Left$(SngRoundedToStr$(SATURATION_LEVEL, 1) + " ", 4);
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " UP and DOWN ";
Color TextColor, cEmpty: Locate iLine, 18: Print "BRIGHTNESS_LEVEL: ";
Color TextColor, cEmpty: Locate iLine, 36: Print Left$(SngRoundedToStr$(BRIGHTNESS_LEVEL, 1) + " ", 4);
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " S ";
Color TextColor, cEmpty: Locate iLine, 18: Print "SAVE STILL FRAME ";
Color TextColor, cEmpty: Locate iLine, 36: Print " ";
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " R ";
Color TextColor, cEmpty: Locate iLine, 18: Print "RESET ALL VALUES ";
Color TextColor, cEmpty: Locate iLine, 36: Print " ";
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " SPACEBAR ";
Color TextColor, cEmpty: Locate iLine, 18: Print "TOGGLE SHOW TEXT ";
Color TextColor, cEmpty: Locate iLine, 36: Print " ";
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " ESC ";
Color TextColor, cEmpty: Locate iLine, 18: Print "QUIT ";
Color TextColor, cEmpty: Locate iLine, 36: Print " ";
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " L ";
Color TextColor, cEmpty: Locate iLine, 18: Print " SCAN LINES ";
Color TextColor, cEmpty: Locate iLine, 36: Print Left$(_Trim$(Str$(iScanLines)) + " ", 4);
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " E ";
Color TextColor, cEmpty: Locate iLine, 18: Print " ECHO MODE ";
Color TextColor, cEmpty: Locate iLine, 36: Print Left$(_Trim$(Str$(iEchoRatio)) + " ", 4);
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " F ";
Color TextColor, cEmpty: Locate iLine, 18: Print " ECHO COLORS ";
Color TextColor, cEmpty: Locate iLine, 36: Print Left$(_Trim$(Str$(iEchoChannel)) + " ", 4);
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " C ";
Color TextColor, cEmpty: Locate iLine, 18: Print " COLOR TWEAK ";
Color TextColor, cEmpty: Locate iLine, 36: Print Left$(_Trim$(Str$(iTweakColorMode)) + " ", 4);
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " K ";
Color TextColor, cEmpty: Locate iLine, 18: Print " CHROMA KEY ";
Color TextColor, cEmpty: Locate iLine, 36: Print Left$(_IIf(ChromaKeyEnabled, "ON", "OFF") + " ", 4);
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " Z ";
Color TextColor, cEmpty: Locate iLine, 18: Print "RESET CHROMA KEY ";
Color TextColor, cEmpty: Locate iLine, 36: Print " ";
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " PgUp and Pgdn ";
Color TextColor, cEmpty: Locate iLine, 18: Print "CHROMA THRESHOLD: ";
Color TextColor, cEmpty: Locate iLine, 36: Print Left$(_Trim$(Str$(iMovementThreshold)) + " ", 4);
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " Home and End ";
Color TextColor, cEmpty: Locate iLine, 18: Print "CHROMA BG COLOR: ";
Color TextColor, cEmpty: Locate iLine, 36: Print " ";
iLine = iLine + 1
Color TextColor, cEmpty: Locate iLine, 2: Print " O ";
Color TextColor, cEmpty: Locate iLine, 18: Print " OUTLINE IMAGE ";
Color TextColor, cEmpty: Locate iLine, 36: Print Left$(_IIf(OutlineImageEnabled, "ON", "OFF") + " ", 4);
' SHOW TITLE
'tc = 1
'Color cCyan, cEmpty: PrintString 0, 15, "WebCam fun", ty + tc * 1, tx + tc * 1
'Color cGreen, cEmpty: PrintString 0, 15, "WebCam fun", ty + tc * 2, tx + tc * 2
'Color cDarkGold, cEmpty: PrintString 0, 15, "WebCam fun", ty + tc * 3, tx + tc * 3
'Color cOrange, cEmpty: PrintString 0, 15, "WebCam fun", ty + tc * 4, tx + tc * 4
'Color cRed, cEmpty: PrintString 0, 15, "WebCam fun", ty + tc * 5, tx + tc * 5
'Color cMagenta, cEmpty: PrintString 0, 15, "WebCam fun", ty + tc * 6, tx + tc * 6
'Color cPurple, cEmpty: PrintString 0, 15, "WebCam fun", ty + tc * 7, tx + tc * 7
'Color cDeepPurple, cEmpty: PrintString 0, 15, "WebCam fun", ty + tc * 8, tx + tc * 8
'Color cBlue, cEmpty: PrintString 0, 15, "WebCam fun", ty + tc * 9, tx + tc * 9
'Color cDodgerBlue, cEmpty: PrintString 0, 15, "WebCam fun", ty + tc * 10, tx + tc * 10
End If
' ================================================================================================================================================================
' END SHOW VALUES + INSTRUCTIONS + TITLE
' ================================================================================================================================================================
' ================================================================================================================================================================
' BEGIN CALIBRATE: Remember background (to compare to detect movement)
' ================================================================================================================================================================
' Remember background (to compare to detect movement)
If IsCalibrating = _TRUE Then
If OutlineImageEnabled = _TRUE Then
OutlineImage imgCamera, imgTemp
_Dest imgCamera: Cls , cEmpty
_PutImage , imgTemp, 0 ' Copy the outlined image
End If
SaveFrame imgCamera, arrComparePixels()
IsCalibrating = _FALSE
End If
' ================================================================================================================================================================
' END CALIBRATE
' ================================================================================================================================================================
' ================================================================================================================================================================
' BEGIN APPLY EFFECTS
' ================================================================================================================================================================
' FIRST FRAME = NO EFFECTS
If bFirst = _TRUE Then
' Capture camera image as a frame of reference (to echo from)
'_Source imgCamera
_Dest imgBuffer: _PutImage , imgCamera, 0
' Done
bFirst = _FALSE
End If
' APPLY EFFECTS
' OUTLINE IMAGE?
If OutlineImageEnabled = _TRUE Then
OutlineImage imgCamera, imgTemp
_Dest imgCamera: Cls , cEmpty
_PutImage , imgTemp, 0 ' Copy the outlined image
End If
' ECHO IMAGE?
If iEchoRatio > 0 Then
' TWEAK COLORS FIRST (IF ENABLED)
If iTweakColorMode > 0 Then
TweakColors imgCamera, imgCamera, iTweakRed, iTweakGreen, iTweakBlue
End If
' THEN DO ECHO IMAGE
EchoImage imgCamera, imgBuffer, iEchoRatio, iEchoChannel ' merge camera layer into buffer
Else
' TWEAK COLORS IF ENABLED
If iTweakColorMode > 0 Then
TweakColors imgCamera, imgCamera, iTweakRed, iTweakGreen, iTweakBlue
End If
End If
' APPLY ECHO IMAGE?
If ChromaKeyEnabled = _FALSE Then
If iEchoRatio > 1 Then
_Dest 0: _PutImage , imgBuffer, 0 ' Add effected camera layer
Else
_Dest 0: _PutImage , imgCamera, 0 ' Add camera layer
End If
Else
' ONLY SHOW PIXELS DIFFERENT FROM ORIGINAL (WHEN WE "CALIBRATED")...
_Dest 0: _PutImage , imgBackground, 0 ' start with background
DrawDifference imgCamera, arrComparePixels(), imgForeground, iMovementThreshold
'if OutLineImageEnabled = _TRUE then
' OutlineImage imgForeground, imgTemp
' _Dest imgForeground: _PutImage , imgTemp, 0 ' Copy the outlined image
'end if
_Dest 0: _PutImage , imgForeground, 0 ' Add the layer that is different from the background
End If
' ================================================================================================================================================================
' END APPLY EFFECTS
' ================================================================================================================================================================
' ================================================================================================================================================================
' BEGIN ADD LAYERS
' ================================================================================================================================================================
' SHOW SCAN LINES?
If iScanLines = 1 Then
_Dest 0: _PutImage , imgLines1, 0 ' Add scan lines (every other line) layer
ElseIf iScanLines = 2 Then
_Dest 0: _PutImage , imgLines2, 0 ' Add scan lines (every 2 lines) layer
ElseIf iScanLines = 3 Then
_Dest 0: _PutImage , imgLines3, 0 ' Add scan lines (every 2 lines) layer
ElseIf iScanLines = 4 Then
_Dest 0: _PutImage , imgLines4, 0 ' Add scan lines (every 2 lines) layer
End If
' DRAW TEXT LAYER
_Dest 0: _PutImage , imgText, 0
' ================================================================================================================================================================
' END ADD LAYERS
' ================================================================================================================================================================
' UPDATE SCREEN
_Display
_Limit FPS
Loop
End If
If Len(sError) > 0 Then
Print "ERROR: " + sError
End If
_AutoDisplay ' RETURN TO AUTODISPLAY
' HOW TO SAVE STILL TO FILE:
'GrabFrameToClipboard childWin, clippedFrame
'_ClipboardImage = frame.IMAGE
'_SaveImage "myimage.bmp", frame.IMAGE, "BMP"
Print "Disconnecting Driver"
KillDriver childWin
_MemFree frame
'_MemFree clippedFrame
FreeImage imgCamera
FreeImage imgText
FreeImage imgLines1
FreeImage imgLines2
FreeImage imgLines3
FreeImage imgLines4
FreeImage imgBuffer
FreeImage imgBackground
FreeImage imgForeground
FreeImage imgTemp
'Sleep
End
' /////////////////////////////////////////////////////////////////////////////
' Based on input iTweakColorMode, returns different iRedMode, iGreenMode, iBlueMode codes
' iTweakColorMode iRedMode iGreenMode iBlueMode Description
' 0 0 0 0 (unchange)
' 1 0 0 1 inverse blue
' 2 0 1 0 inverse green
' 3 0 1 1 inverse green, blue
' 4 1 0 0 inverse red
' 5 1 0 1 inverse red, blue
' 6 1 1 0 inverse red, green
' 7 1 1 1 inverse red, green, blue
' 8 G R B swap red & green
' 9 B G R swap red & blue
' 10 R B G swap green & blue
' We can also run twice with different values
' e.g., inverse, then swap
' GetColorTweakCodes iTweakColorMode, iRedMode, iGreenMode, iBlueMode
' TweakColors imgSource, imgDest, iRedMode, iGreenMode, iBlueMode
Sub GetColorTweakCodes (iTweakColorMode As Integer, iRedMode As Integer, iGreenMode As Integer, iBlueMode As Integer)
Select Case iTweakColorMode
Case 0:
iRedMode = 0: iGreenMode = 0: iBlueMode = 0
Case 1:
iRedMode = 2: iGreenMode = 2: iBlueMode = 0
Case 2:
iRedMode = 3: iGreenMode = 0: iBlueMode = 2
Case 3:
iRedMode = 0: iGreenMode = 3: iBlueMode = 3
Case 4:
iRedMode = 1: iGreenMode = 1: iBlueMode = 1
Case 5:
iRedMode = 1: iGreenMode = 1: iBlueMode = 0
Case 6:
iRedMode = 1: iGreenMode = 0: iBlueMode = 1
Case 7:
iRedMode = 1: iGreenMode = 0: iBlueMode = 0
Case 8:
iRedMode = 0: iGreenMode = 1: iBlueMode = 1
Case 9:
iRedMode = 0: iGreenMode = 1: iBlueMode = 0
Case 10:
iRedMode = 0: iGreenMode = 0: iBlueMode = 1
Case Else:
iRedMode = 0: iGreenMode = 0: iBlueMode = 0
End Select
End Sub ' GetColorTweakCodes
' /////////////////////////////////////////////////////////////////////////////
' SWAPS OR INVERSES COLOR CHANNELS
' receives imgSource
' returns imgDest
' with each pixel's color channels changed
' (inverted, swapped with another color channel, unchanged)
' depending on values of iRedMode, iGreenMode, iBlueMode
' where
' i{R/G/B}Mode For What
' 0 (all) same
' 1 (all) inverse
' 2 red green
' 3 red blue
' 2 green red
' 3 green blue
' 2 blue red
' 3 blue green
' TweakColors imgSource, imgDest, iRedMode, iGreenMode, iBlueMode
Sub TweakColors (imgSource As Long, imgDest As Long, iRedMode As Integer, iGreenMode As Integer, iBlueMode As Integer)
Dim iX, iY, iToX, iToY As Integer
Dim c~&, sr&, sg&, sb&, dr&, dg&, db&
Dim fgColor~&
If _Width(imgSource) < _Width(imgDest) Then
iToX = _Width(imgSource)
Else
iToX = _Width(imgDest)
End If
If _Height(imgSource) < _Height(imgDest) Then
iToY = _Height(imgSource)
Else
iToY = _Height(imgDest)
End If
For iX = 1 To iToX
For iY = 1 To iToY
' dr/dg/db = old frame
' sr/sg/sb = new frame
_Source imgSource
c~& = Point(iX, iY)
sr& = _Red32(c~&)
sg& = _Green32(c~&)
sb& = _Blue32(c~&)
Select Case iRedMode
Case 0:
dr& = sr&
Case 1:
dr& = 255 - sr&
Case 2:
dr& = sg&
Case 3:
dr& = sb&
Case Else:
dr& = sr&
End Select
Select Case iGreenMode
Case 0:
dg& = sg&
Case 1:
dg& = 255 - sg&
Case 2:
dg& = sr&
Case 3:
dg& = sb&
Case Else:
dg& = sg&
End Select
Select Case iBlueMode
Case 0:
db& = sb&
Case 1:
db& = 255 - sb&
Case 2:
db& = sr&
Case 3:
db& = sg&
Case Else:
db& = sb&
End Select
fgColor~& = _RGB32( _
dr&, _
dg&, _
db& _
)
_Dest imgDest
Line (iX, iY)-(iX, iY), fgColor~&, BF
Next iY
Next iX
End Sub ' TweakColors
' /////////////////////////////////////////////////////////////////////////////' /////////////////////////////////////////////////////////////////////////////
Sub EchoImage (imgSource As Long, imgDest As Long, iEchoRatio As Integer, iEchoChannel As Integer)
Dim iX, iY, iToX, iToY As Integer
Dim c~&, sr&, sg&, sb&, dr&, dg&, db&
Dim fgColor~&
'_RGBA(r&, g&, b&, a&) ' a&=0=transparent, 255=opaque
If _Width(imgSource) < _Width(imgDest) Then
iToX = _Width(imgSource)
Else
iToX = _Width(imgDest)
End If
If _Height(imgSource) < _Height(imgDest) Then
iToY = _Height(imgSource)
Else
iToY = _Height(imgDest)
End If
For iX = 1 To iToX
For iY = 1 To iToY
_Source imgSource
c~& = Point(iX, iY)
sr& = _Red32(c~&)
sg& = _Green32(c~&)
sb& = _Blue32(c~&)
_Source imgDest
c~& = Point(iX, iY)
dr& = _Red32(c~&)
dg& = _Green32(c~&)
db& = _Blue32(c~&)
'' merge 1/2
'fgColor~& = _RGB32( _
' (sr& + dr&)/2, _
' (sg& + dg&)/2, _
' (sb& + db&)/2 _
' )
'' merge 1/3
'fgColor~& = _RGB32( _
' (sr& + dr& + dr&) /3, _
' (sg& + dg& + dg&) /3, _
' (sb& + db& + db&) /3 _
' )
' Merge new pixel in
' or just red/green/blue channel
' depending on value of iEchoChannel
' where
' 0 = all channels, 1=red, 2=green, 3=blue
' dr/dg/db = old frame
Select Case iEchoChannel
Case 1:
fgColor~& = _RGB32( _
AddRatio&(dr&, sr&, iEchoRatio), _
sg&, _
sb& _
)
Case 2:
fgColor~& = _RGB32( _
sr&, _
AddRatio&(dg&, sg&, iEchoRatio), _
sb& _
)
Case 3:
fgColor~& = _RGB32( _
sr&, _
sg&, _
AddRatio&(db&, sb&, iEchoRatio) _
)
Case Else:
fgColor~& = _RGB32( _
AddRatio&(dr&, sr&, iEchoRatio), _
AddRatio&(dg&, sg&, iEchoRatio), _
AddRatio&(db&, sb&, iEchoRatio) _
)
End Select
' merge 1/iEchoRatio (if iEchoRatio < 1, then just use all imgSource)
'fgColor~& = _RGB32( _
' AddRatio&(dr&, sr&, iEchoRatio), _
' AddRatio&(dg&, sg&, iEchoRatio), _
' AddRatio&(db&, sb&, iEchoRatio) _
' )
_Dest imgDest
Line (iX, iY)-(iX, iY), fgColor~&, BF
Next iY
Next iX
End Sub ' EchoImage
' /////////////////////////////////////////////////////////////////////////////
Function AddRatio& (old&, new&, denominator%)
If denominator% > 0 Then
AddRatio& = ((old& * (denominator% - 1)) + new&) / denominator%
Else
AddRatio& = new&
End If
End Function ' AddRatio&
' /////////////////////////////////////////////////////////////////////////////
' sError = CreateScanLines$(imgLines, VIDWIDTH, VIDHEIGHT, cBlack)
'iWidth = _WIDTH(imgLines)
'iHeight = _HEIGHT(imgLines)
Function CreateScanLines$ (imgLines As Long, iWidth As Integer, iHeight As Integer, fgColor As _Unsigned Long, iSkipLines As Integer)
Dim RoutineName As String: RoutineName = "CreateScanLines"
Dim sError As String: sError = ""
Dim iY, iToY As Integer
Dim iLineCount As Integer
If Len(sError) = 0 Then
If iWidth < 1 Then sError = RoutineName + ": iWidth must be > 0"
End If
If Len(sError) = 0 Then
If iHeight < 1 Then sError = RoutineName + ": iHeight must be > 0"
End If
If Len(sError) = 0 Then
' Init image
InitImage imgLines, iWidth, iHeight, cEmpty
' Draw scan lines
_Dest imgLines
iLineCount = 0
iY = 1
Do
iY = iY + 1
If iY > iHeight Then Exit Do
iLineCount = iLineCount + 1
If iLineCount > iSkipLines Then
Line (1, iY)-(iWidth, iY), fgColor, , SOLID_LINE_STYLE
iLineCount = 0
End If
Loop
_Dest 0
End If
CreateScanLines$ = sError
End Function ' CreateScanLines$
' /////////////////////////////////////////////////////////////////////////////' /////////////////////////////////////////////////////////////////////////////
'DrawDifference imgCamera, arrComparePixels(), imgForeground
Sub DrawDifference (imgSource As Long, arrComparePixels() As PixelType, imgDest As Long, iMovementThreshold As Integer)
Dim iX, iY, iToX, iToY As Integer
Dim c~&, sr&, sg&, sb&, dr&, dg&, db&
Dim fgColor~&
'_RGBA(r&, g&, b&, a&) ' a&=0=transparent, 255=opaque
If _Width(imgSource) < _Width(imgDest) Then
iToX = _Width(imgSource)
Else
iToX = _Width(imgDest)
End If
If _Height(imgSource) < _Height(imgDest) Then
iToY = _Height(imgSource)
Else
iToY = _Height(imgDest)
End If
For iX = 1 To iToX
For iY = 1 To iToY
' LOOK AT NEXT CAMERA PIXEL
_Source imgSource
c~& = Point(iX, iY)
sr& = _Red32(c~&)
sg& = _Green32(c~&)
sb& = _Blue32(c~&)
' COMPARE AGAINST ORIGINAL PIXEL
dr& = Abs(arrComparePixels(iX, iY).r - _Red32(c~&))
dg& = Abs(arrComparePixels(iX, iY).g - _Green32(c~&))
db& = Abs(arrComparePixels(iX, iY).b - _Blue32(c~&))
'_Alpha32(c~&)
' DID IT CHANGE ENOUGH?
'If (dr& + dg& + db&) > MOVEMENT_THRESHOLD Then
If (dr& + dg& + db&) > iMovementThreshold Then
' YES -> DRAW PIXEL ONTO DESTINATION
_Dest imgDest
'fgColor~& = _RGB32( _
' sr&, _
' sg&, _
' sb& _
' )
'Line (iX, iY)-(iX, iY), fgColor~&, BF
Line (iX, iY)-(iX, iY), c~&, BF
End If
Next iY
Next iX
End Sub ' DrawDifference
' /////////////////////////////////////////////////////////////////////////////
' #57 Outlining an Image
' https://qb64phoenix.com/forum/showthread.php?tid=272&pid=32066#pid32066
'
' From: bplus, Mini-Mod
' Date: 02-13-2025, 09:52 PM
' original code was from 2020-10-28 when Dav was working on coloring app around Halloween.
' Attempt at making a coloring book outlines.
' Results: well maybe this will help layout your masterpiece :)
' The last image is black outlines with shading or grey level hints
Sub OutlineImage (imgOriginal&, imgOutlined&)
Dim xmax, ymax As Long
ReDim gs(0, 0), gs2(0, 0)
Dim nRound As Integer
Dim y, x As Integer
Dim c~&
Dim r, g, b As Long
xmax = _Width(imgOriginal&)
ymax = _Height(imgOriginal&)
ReDim gs(xmax, ymax), gs2(xmax, ymax)
If imgOutlined& < -1 Or imgOutlined& > 0 Then _FreeImage imgOutlined&
imgOutlined& = _NewImage(xmax, ymax, 32)
_Dest imgOutlined&
Cls , _RGB32(0, 0, 0, 0)
_PutImage , imgOriginal&
_Source imgOutlined&
nRound = 64 ' this rounds to 4 shades of gray <<< fiddle with this number dividing 256 for a shade grade
For y = 0 To ymax - 1
For x = 0 To xmax - 1
c~& = Point(x, y)
r = _Red32(c~&)
g = _Green32(c~&)
b = _Blue32(c~&)
gs(x, y) = Int(((r + g + b) / 3) / nRound) * nRound 'round the grey
Next x
Next y
Color , &HFFFFFFFF: Cls
For y = 0 To ymax - 1
For x = 0 To xmax - 1
PSet (x, y), _RGB32(gs(x, y), gs(x, y), gs(x, y), 90)
Next x
Next y
Color , &HFFFFFFFF: Cls
For y = 0 To ymax - 1
For x = 0 To xmax - 1
If gs(x, y) <> gs(x + 1, y) Then PSet (x, y), &HFF000000: gs2(x, y) = 1
Next x
Next y
For x = 0 To xmax - 1
For y = 0 To ymax - 1
If gs(x, y) <> gs(x, y + 1) Then PSet (x, y), &HFF000000: gs2(x, y) = 1
Next y
Next x
' adding back in the shades of gray
'Color , &HFFFFFFFF: Cls
'For x = 0 To xmax - 1
' For y = 0 To ymax - 1
' If gs2(x, y) Then PSet (x, y), &HFF000000
' Next y
'Next x
'For y = 0 To ymax - 1
' For x = 0 To xmax - 1
' PSet (x, y), _RGB32(gs(x, y), gs(x, y), gs(x, y), 90)
' Next x
'Next y
_Dest 0
End Sub ' OutlineImage
' /////////////////////////////////////////////////////////////////////////////
' SAVE RGB OF EACH PIXEL CAMERA SEES BEFORE PLAYERS USE HANDS/LASERS
Sub SaveFrame (imgCamera As Long, arrComparePixels() As PixelType)
Dim x As Integer
Dim y As Integer
Dim c~&, r&, g&, b&
'Dim a&
_Source imgCamera
For y = 1 To VIDHEIGHT
For x = 1 To VIDWIDTH
c~& = Point(x, y)
arrComparePixels(x, y).r = _Red32(c~&)
arrComparePixels(x, y).g = _Green32(c~&)
arrComparePixels(x, y).b = _Blue32(c~&)
'arrComparePixels(x, y).a = _Alpha32(c~&)
Next x
Next y
End Sub ' SaveFrame
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is even
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsOdd%
Function IsEven% (n)
If n Mod 2 = 0 Then
IsEven% = _TRUE
Else
IsEven% = _FALSE
End If
End Function ' IsEven%
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if number n is odd
' https://slaystudy.com/qbasic-program-to-check-if-number-is-even-or-odd/
' see also: IsEven%
Function IsOdd% (n)
If n Mod 2 = 1 Then
IsOdd% = _TRUE
Else
IsOdd% = _FALSE
End If
End Function ' IsOdd%
' /////////////////////////////////////////////////////////////////////////////
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
' 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, 0, 255)
g1 = _Clamp(Y1 - 0.39465 * U - 0.58060 * V, 0, 255)
b1 = _Clamp(Y1 + 2.03211 * U, 0, 255)
' Convert second pixel
r2 = _Clamp(Y2 + 1.13983 * V, 0, 255)
g2 = _Clamp(Y2 - 0.39465 * U - 0.58060 * V, 0, 255)
b2 = _Clamp(Y2 + 2.03211 * U, 0, 255)
' Pack pixels into a single return value
ConvertYUY2toRGB = _RGB32(r1, g1, b1) Or _ShL(_RGB32(r2, g2, b2), 32)
End Function
' /////////////////////////////////////////////////////////////////////////////
' ROUNDING FUNCTIONS FOR TYPE SINGLE
Function RoundSingle! (num!, digits%)
RoundSingle! = Int(num! * 10 ^ digits% + .5) / 10 ^ digits%
End Function
' NOTE: not sure this one works: when digits%=3, it rounds .31 to .32
Function RoundUpSingle! (num!, digits%)
RoundUpSingle! = _Ceil(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownSingle! (num!, digits%)
RoundDownSingle! = Int(num! * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificSingle! (num!, digits%)
RoundScientificSingle! = _Round(num! * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function SngToStr$ (n!)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
Dim num$
value$ = UCase$(LTrim$(Str$(n!)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
SngToStr$ = result$
End Function ' SngToStr$
' /////////////////////////////////////////////////////////////////////////////
Function SngRoundedToStr$ (sngValue As Single, intNumPlaces As Integer)
Dim sngNew As Single
sngNew = RoundSingle!(sngValue, intNumPlaces)
SngRoundedToStr$ = SngToStr$(sngNew)
End Function ' SngRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' found at abandoned, outdated and now likely malicious qb64 dot net website
' http://www.qb64.[net]/forum/index_topic_5964-0/
'
'SUMMARY:
' Purpose: A library of custom functions that transform strings.
' Author: Dustinian Camburides (dustinian@gmail.com)
' Platform: QB64 (www.qb64.org)
' Revision: 1.6
' Updated: 5/28/2012
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
' VARIABLES:
Dim Text2 As String
Dim Find2 As String
Dim Add2 As String
Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
Dim strBefore As String ' The characters before the string to be replaced.
Dim strAfter As String ' The characters after the string to be replaced.
' INITIALIZE:
' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
Text2 = Text1
Find2 = Find1
Add2 = Add1
lngLocation = InStr(1, Text2, Find2)
' PROCESSING:
' While [Find2] appears in [Text2]...
While lngLocation
' Extract all Text2 before the [Find2] substring:
strBefore = Left$(Text2, lngLocation - 1)
' Extract all text after the [Find2] substring:
strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
' Return the substring:
Text2 = strBefore + Add2 + strAfter
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' /////////////////////////////////////////////////////////////////////////////
' Simple timestamp function
' Format: {YYYY}-{MM}-{DD} {hh}:[mm}:{ss}
' Uses:
' TIME$
' The TIME$ Function returns a STRING representation
' of the current computer time in a 24 hour format.
' https://qb64phoenix.com/qb64wiki/index.php/TIME$
' DATE$
' The DATE$ function returns the current computer date
' as a string in the format "mm-dd-yyyy".
' https://qb64phoenix.com/qb64wiki/index.php/DATE$
'
' TODO: support template where
' {yyyy} = 4 digit year
' {mm} = 2 digit month
' {dd} = 2 digit day
' {hh} = 2 digit hour (12-hour)
' {rr} = 2 digit hour (24-hour)
' {nn} = 2 digit minute
' {ss} = 2 digit second
' {ampm} = AM/PM
' We got the nn for minute from Microsoft > Office VBA Reference > DateDiff function
' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
' PRINT "Current date time (simple format) = " + Chr$(34) + GetCurrentDateTime$("{yyyy}-{mm}-{dd} {rr}:{nn}:{ss}") + Chr$(34)
' PRINT "Current date time (US format) = " + Chr$(34) + GetCurrentDateTime$("{mm}/{dd}/{yyyy} {hh}:{nn}:{ss} {ampm}") + Chr$(34)
' PRINT "Filename timestamp = " + Chr$(34) + GetCurrentDateTime$("{yyyy}{mm}{dd}_{rr}{nn}{ss}") + Chr$(34)
Function GetCurrentDateTime$ (sTemplate$)
Dim sDate$: sDate$ = Date$
Dim sTime$: sTime$ = Time$
Dim sYYYY$: sYYYY$ = Mid$(sDate$, 7, 4)
Dim sMM$: sMM$ = Mid$(sDate$, 1, 2)
Dim sDD$: sDD$ = Mid$(sDate$, 4, 2)
Dim sHH24$: sHH24$ = Mid$(sTime$, 1, 2)
Dim sHH$: sHH$ = ""
Dim sMI$: sMI$ = Mid$(sTime$, 4, 2)
Dim sSS$: sSS$ = Mid$(sTime$, 7, 2)
Dim iHour%: iHour% = Val(sHH24$)
Dim sAMPM$: sAMPM$ = ""
Dim result$: result$ = ""
' FIGURE OUT AM/PM
If InStr(sTemplate$, "{ampm}") > 0 Then
If iHour% = 0 Then
sAMPM$ = "AM"
iHour% = 12
ElseIf iHour% > 0 And iHour% < 12 Then
sAMPM$ = "AM"
ElseIf iHour% = 12 Then
sAMPM$ = "PM"
Else
sAMPM$ = "PM"
iHour% = iHour% - 12
End If
sHH$ = Right$("00" + _Trim$(Str$(iHour%)), 2)
End If
' POPULATE TEMPLATE
result$ = sTemplate$
result$ = Replace$(result$, "{yyyy}", sYYYY$)
result$ = Replace$(result$, "{mm}", sMM$)
result$ = Replace$(result$, "{dd}", sDD$)
result$ = Replace$(result$, "{hh}", sHH$)
result$ = Replace$(result$, "{rr}", sHH24$)
result$ = Replace$(result$, "{nn}", sMI$)
result$ = Replace$(result$, "{ss}", sSS$)
result$ = Replace$(result$, "{ampm}", sAMPM$)
' RETURN RESULT
GetCurrentDateTime$ = result$
End Function ' GetCurrentDateTime$
' /////////////////////////////////////////////////////////////////////////////
' Does a _PrintString at the specified row+column.
' iRow and iCol are 0-based.
' See also: PrintString1
Sub PrintString (iRow As Integer, iCol As Integer, MyString As String, RowOffset As Integer, ColOffset As Integer)
Dim iX As Integer
Dim iY As Integer
iX = (_FontWidth * iCol) + ColOffset
iY = (_FontHeight * iRow) + RowOffset
_PrintString (iX, iY), MyString
End Sub ' PrintString
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max inclusive.
' Note: random-number generator should be initialized with Randomize Timer
Function RandomNumber% (Min%, Max%)
Dim NumSpread%
NumSpread% = (Max% - Min%) + 1
RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
End Function ' RandomNumber%
' /////////////////////////////////////////////////////////////////////////////
' Use to pretty print _TRUE and _FALSE values.
Function TrueFalse$ (myValue)
If myValue = _TRUE Then
TrueFalse$ = "TRUE"
Else
TrueFalse$ = "FALSE"
End If
End Function ' TrueFalse$
' /////////////////////////////////////////////////////////////////////////////
Sub InitImage (ThisImage&, iWidth&, iHeight&, bgColor~&)
FreeImage ThisImage&
ThisImage& = _NewImage(iWidth&, iHeight&, 32)
_Dest ThisImage&: Cls , bgColor~&
End Sub ' InitImage
' /////////////////////////////////////////////////////////////////////////////
Sub FreeImage (ThisImage&)
If ThisImage& < -1 Or ThisImage& > 0 Then _FreeImage ThisImage&
End Sub ' FreeImage
' /////////////////////////////////////////////////////////////////////////////
' ################################################################################################################################################################
' BEGIN COLOR FUNCTIONS #COLOR
' ################################################################################################################################################################
Function cRed~& ()
cRed = _RGB32(255, 0, 0)
End Function
Function cOrangeRed~& ()
cOrangeRed = _RGB32(255, 69, 0)
End Function ' cOrangeRed~&
Function cDarkOrange~& ()
cDarkOrange = _RGB32(255, 140, 0)
End Function ' cDarkOrange~&
Function cOrange~& ()
cOrange = _RGB32(255, 165, 0)
End Function ' cOrange~&
Function cGold~& ()
cGold = _RGB32(255, 215, 0)
End Function ' cGold~&
Function cYellow~& ()
cYellow = _RGB32(255, 255, 0)
End Function ' cYellow~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
Function cLime~& ()
cLime = _RGB32(0, 255, 0)
End Function ' cLime~&
Function cMediumSpringGreen~& ()
cMediumSpringGreen = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen~&
' ADDED THIS FOR THE GAUGE COLOR:
Function cSpringGreen~& ()
cSpringGreen = _RGB32(0, 255, 160)
End Function ' cSpringGreen~&
Function cCyan~& ()
cCyan = _RGB32(0, 255, 255)
End Function ' cCyan~&
Function cDeepSkyBlue~& ()
cDeepSkyBlue = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue~&
Function cDodgerBlue~& ()
cDodgerBlue = _RGB32(30, 144, 255)
End Function ' cDodgerBlue~&
Function cSeaBlue~& ()
cSeaBlue = _RGB32(0, 64, 255)
End Function ' cSeaBlue~&
Function cBlue~& ()
cBlue = _RGB32(0, 0, 255)
End Function ' cBlue~&
Function cBluePurple~& ()
cBluePurple = _RGB32(64, 0, 255)
End Function ' cBluePurple~&
Function cDeepPurple~& ()
cDeepPurple = _RGB32(96, 0, 255)
End Function ' cDeepPurple~&
Function cPurple~& ()
cPurple = _RGB32(128, 0, 255)
End Function ' cPurple~&
Function cPurpleRed~& ()
cPurpleRed = _RGB32(128, 0, 192)
End Function ' cPurpleRed~&
Function cDarkRed~& ()
cDarkRed = _RGB32(160, 0, 64)
End Function ' cDarkRed~&
Function cBrickRed~& ()
cBrickRed = _RGB32(192, 0, 32)
End Function ' cBrickRed~&
Function cDarkGreen~& ()
cDarkGreen = _RGB32(0, 100, 0)
End Function ' cDarkGreen~&
Function cGreen~& ()
cGreen = _RGB32(0, 128, 0)
End Function ' cGreen~&
Function cOliveDrab~& ()
cOliveDrab = _RGB32(107, 142, 35)
End Function ' cOliveDrab~&
Function cLightPink~& ()
cLightPink = _RGB32(255, 182, 193)
End Function ' cLightPink~&
Function cHotPink~& ()
cHotPink = _RGB32(255, 105, 180)
End Function ' cHotPink~&
Function cDeepPink~& ()
cDeepPink = _RGB32(255, 20, 147)
End Function ' cDeepPink~&
Function cMagenta~& ()
cMagenta = _RGB32(255, 0, 255)
End Function ' cMagenta~&
Function cBlack~& ()
cBlack = _RGB32(0, 0, 0)
End Function ' cBlack~&
Function cDimGray~& ()
cDimGray = _RGB32(105, 105, 105)
End Function ' cDimGray~&
Function cGray~& ()
cGray = _RGB32(128, 128, 128)
End Function ' cGray~&
Function cDarkGray~& ()
cDarkGray = _RGB32(169, 169, 169)
End Function ' cDarkGray~&
Function cSilver~& ()
cSilver = _RGB32(192, 192, 192)
End Function ' cSilver~&
Function cLightGray~& ()
cLightGray = _RGB32(211, 211, 211)
End Function ' cLightGray~&
Function cGainsboro~& ()
cGainsboro = _RGB32(220, 220, 220)
End Function ' cGainsboro~&
Function cWhiteSmoke~& ()
cWhiteSmoke = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke~&
Function cWhite~& ()
cWhite = _RGB32(255, 255, 255)
End Function ' cWhite~&
Function cDarkBrown~& ()
cDarkBrown = _RGB32(128, 64, 0)
End Function ' cDarkBrown~&
Function cLightBrown~& ()
cLightBrown = _RGB32(196, 96, 0)
End Function ' cLightBrown~&
Function cKhaki~& ()
cKhaki = _RGB32(240, 230, 140)
End Function ' cKhaki~&
Function cEmpty~& ()
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ################################################################################################################################################################
' END COLOR FUNCTIONS @COLOR
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
' ################################################################################################################################################################
' BEGIN COLOR ARRAY FUNCTIONS #COLR
' ################################################################################################################################################################
' /////////////////////////////////////////////////////////////////////////////
Sub AddColor (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long)
ReDim _Preserve arrColor(0 To UBound(arrColor) + 1) As _Unsigned Long
arrColor(UBound(arrColor)) = ColorValue
End Sub ' AddColor
' /////////////////////////////////////////////////////////////////////////////
Sub AddColors (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long, HowMany As Long)
Dim iLoop As Integer
For iLoop = 1 To HowMany
AddColor ColorValue, arrColor()
Next iLoop
End Sub ' AddColors
' /////////////////////////////////////////////////////////////////////////////
Sub AddGrayscaleColors (arrColor() As _Unsigned Long)
Dim iNum As Integer
iNum = 1
AddColors cDimGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cWhite, arrColor(), iNum '* 2
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
End Sub ' AddGrayscaleColors
' /////////////////////////////////////////////////////////////////////////////
Sub AddSpectrumColors (arrColor() As _Unsigned Long)
Dim iNum As Integer
iNum = 1
AddColors cRed, arrColor(), iNum
AddColors cOrangeRed, arrColor(), iNum
AddColors cDarkOrange, arrColor(), iNum
AddColors cOrange, arrColor(), iNum
AddColors cGold, arrColor(), iNum
AddColors cYellow, arrColor(), iNum
AddColors cChartreuse, arrColor(), iNum
AddColors cOliveDrab1, arrColor(), iNum
AddColors cLime, arrColor(), iNum
AddColors cMediumSpringGreen, arrColor(), iNum
AddColors cSpringGreen, arrColor(), iNum
AddColors cCyan, arrColor(), iNum
AddColors cDeepSkyBlue, arrColor(), iNum
AddColors cDodgerBlue, arrColor(), iNum
AddColors cSeaBlue, arrColor(), iNum
AddColors cBlue, arrColor(), iNum
AddColors cBluePurple, arrColor(), iNum
AddColors cDeepPurple, arrColor(), iNum
AddColors cPurple, arrColor(), iNum
AddColors cPurpleRed, arrColor(), iNum
AddColors cDarkRed, arrColor(), iNum
AddColors cBrickRed, arrColor(), iNum
AddColors cDarkGreen, arrColor(), iNum
AddColors cGreen, arrColor(), iNum
AddColors cOliveDrab, arrColor(), iNum
AddColors cLightPink, arrColor(), iNum
AddColors cHotPink, arrColor(), iNum
AddColors cDeepPink, arrColor(), iNum
AddColors cMagenta, arrColor(), iNum
AddColors cBlack, arrColor(), iNum
AddColors cDimGray, arrColor(), iNum
AddColors cGray, arrColor(), iNum
AddColors cDarkGray, arrColor(), iNum
AddColors cSilver, arrColor(), iNum
AddColors cLightGray, arrColor(), iNum
AddColors cGainsboro, arrColor(), iNum
AddColors cWhiteSmoke, arrColor(), iNum
AddColors cWhite, arrColor(), iNum
AddColors cDarkBrown, arrColor(), iNum
AddColors cLightBrown, arrColor(), iNum
AddColors cKhaki, arrColor(), iNum
'AddColors cEmpty , arrColor(), iNum
End Sub ' AddSpectrumColors
' ################################################################################################################################################################
' END COLOR ARRAY FUNCTIONS @COLR
' ################################################################################################################################################################