12-08-2025, 07:12 PM
Extended _ScreenImage (declared with existing dynamic libraries in BAS source)
The built-in _ScreenImage returns the image of the primary monitor only.
This version returns the image of the primary monitor, or the secondary monitor, or both.
The built-in _ScreenImage returns the image of the primary monitor only.
This version returns the image of the primary monitor, or the secondary monitor, or both.
Code: (Select All)
Option _Explicit
' API types
Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
Type POINTAPI
x As Long
y As Long
End Type
Type MONITORINFOEX
cbSize As _Unsigned Long
rcMonitor As RECT
rcWork As RECT
dwFlags As _Unsigned Long
szDevice As String * 32
End Type
Type BITMAPINFOHEADER
biSize As _Unsigned Long
biWidth As Long
biHeight As Long
biPlanes As _Unsigned Integer
biBitCount As _Unsigned Integer
biCompression As _Unsigned Long
biSizeImage As _Unsigned Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As _Unsigned Long
biClrImportant As _Unsigned Long
End Type
Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors0 As _Unsigned Long
End Type
' API declaring
Declare Dynamic Library "user32"
Function GetDC%& (ByVal hwnd As _Offset)
Function ReleaseDC& (ByVal hwnd As _Offset, ByVal hdc As _Offset)
Function GetSystemMetrics& (ByVal nIndex As Long)
Function GetCursorPos (lpPoint As POINTAPI)
Function MonitorFromRect%& (lprc As RECT, ByVal dwFlags As _Unsigned Long)
Function GetMonitorInfoA& (ByVal hMon As _Offset, lpmi As MONITORINFOEX)
End Declare
Declare Dynamic Library "gdi32"
Function CreateCompatibleDC%& (ByVal hdc As _Offset)
Function DeleteDC& (ByVal hdc As _Offset)
Function CreateCompatibleBitmap%& (ByVal hdc As _Offset, ByVal nWidth As Long, ByVal nHeight As Long)
Function SelectObject%& (ByVal hdc As _Offset, ByVal hObject As _Offset)
Function DeleteObject& (ByVal hObject As _Offset)
Function BitBlt& (ByVal hDestDC As _Offset, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As _Offset, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As _Unsigned Long)
Function GetDIBits& (ByVal hdc As _Offset, ByVal hbmp As _Offset, ByVal uStartScan As _Unsigned Long, ByVal cScanLines As _Unsigned Long, ByVal lpvBits As _Offset, bmi As BITMAPINFO, ByVal uUsage As _Unsigned Long)
End Declare
'--------------------------------------------
' 1 = primary monitor
' 2 = secondary monitor
' 3 = both (virtual desktop)
' ESC = end
'--------------------------------------------
Screen _NewImage(1280, 720, 32)
_Title "Extended _ScreenImage! Press 1 for primary monitor, 2 for secondary monitor, 3 for both!"
Dim shot&: shot& = 0
Do
_Limit 60
Dim k$: k$ = InKey$
If k$ <> "" Then
Select Case k$
Case Chr$(27)
Exit Do
Case "1"
If shot& Then _FreeImage shot&
shot& = CapturePrimary32&
Case "2"
If shot& Then _FreeImage shot&
shot& = CaptureMonitorIndex32&(2)
Case "3"
If shot& Then _FreeImage shot&
shot& = CaptureAll32&
End Select
Cls
If shot& Then
_PutImage (0, 0)-(_Width(0) - 1, _Height(0) - 1), shot&
Else
_PrintString (10, 10), "Capture selhalo (shot&=0)."
End If
_Display
End If
Loop
If shot& Then _FreeImage shot&
End
' Both monitors at once (virtual desktop)
Function CaptureAll32& ()
Const SM_XVIRTUALSCREEN = 76
Const SM_YVIRTUALSCREEN = 77
Const SM_CXVIRTUALSCREEN = 78
Const SM_CYVIRTUALSCREEN = 79
Dim x As Long, y As Long, w As Long, h As Long
x = GetSystemMetrics(SM_XVIRTUALSCREEN)
y = GetSystemMetrics(SM_YVIRTUALSCREEN)
w = GetSystemMetrics(SM_CXVIRTUALSCREEN)
h = GetSystemMetrics(SM_CYVIRTUALSCREEN)
CaptureAll32& = CaptureRect32&(x, y, w, h)
End Function
' Primary monitor only
Function CapturePrimary32& ()
Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1
Dim w As Long, h As Long
w = GetSystemMetrics(SM_CXSCREEN)
h = GetSystemMetrics(SM_CYSCREEN)
CapturePrimary32& = CaptureRect32&(0, 0, w, h)
End Function
' Monitor according to index: (1 = first,, 2 = second, 3 = third...)
Function CaptureMonitorIndex32& (idx As Long)
Dim r As RECT
If GetMonitorRectByIndex%(idx, r) = 0 Then Exit Function
CaptureMonitorIndex32& = CaptureRect32&(r.left, r.top, r.right - r.left, r.bottom - r.top)
End Function
' Internal capture any rectangle of the virtual surface
Function CaptureRect32& (sx As Long, sy As Long, w As Long, h As Long)
Const BI_RGB = 0
Const DIB_RGB_COLORS = 0
Const SRCCOPY = &H00CC0020~&
Const CAPTUREBLT = &H40000000~&
If w <= 0 Or h <= 0 Then Exit Function
Dim img&: img& = 0
Dim hScreenDC As _Offset, hMemDC As _Offset, hBmp As _Offset, hOld As _Offset
Dim bmi As BITMAPINFO
Dim m As _MEM
Dim ok As Long
hScreenDC = GetDC(0)
If hScreenDC = 0 Then GoTo cleanup
hMemDC = CreateCompatibleDC(hScreenDC)
If hMemDC = 0 Then GoTo cleanup
hBmp = CreateCompatibleBitmap(hScreenDC, w, h)
If hBmp = 0 Then GoTo cleanup
hOld = SelectObject(hMemDC, hBmp)
ok = BitBlt(hMemDC, 0, 0, w, h, hScreenDC, sx, sy, (SRCCOPY Or CAPTUREBLT))
If ok = 0 Then GoTo cleanup
img& = _NewImage(w, h, 32)
If img& = 0 Then GoTo cleanup
m = _MemImage(img&)
bmi.bmiHeader.biSize = Len(bmi.bmiHeader)
bmi.bmiHeader.biWidth = w
bmi.bmiHeader.biHeight = -h
bmi.bmiHeader.biPlanes = 1
bmi.bmiHeader.biBitCount = 32
bmi.bmiHeader.biCompression = BI_RGB
bmi.bmiHeader.biSizeImage = w * h * 4
ok = GetDIBits(hMemDC, hBmp, 0, h, m.OFFSET, bmi, DIB_RGB_COLORS)
If ok = 0 Then
_MemFree m
_FreeImage img&
img& = 0
GoTo cleanup
End If
' B,G,R,X -> set alpha to 255
Dim o As _Offset, oLast As _Offset
o = m.OFFSET + 3
oLast = m.OFFSET + (w * h * 4)
$Checking:Off
Do While o < oLast
_MemPut m, o, 255 As _UNSIGNED _BYTE
o = o + 4
Loop
$Checking:On
_MemFree m
cleanup:
If hMemDC <> 0 And hOld <> 0 Then hOld = SelectObject(hMemDC, hOld)
If hBmp <> 0 Then hBmp = DeleteObject(hBmp)
If hMemDC <> 0 Then hMemDC = DeleteDC(hMemDC)
If hScreenDC <> 0 Then hScreenDC = ReleaseDC(0, hScreenDC)
CaptureRect32& = img&
End Function
' Internal: find monitor rectangle by index
' idx=1 primary; others left to right, top to bottom
Function GetMonitorRectByIndex% (idx As Long, rOut As RECT)
Const SM_XVIRTUALSCREEN = 76
Const SM_YVIRTUALSCREEN = 77
Const SM_CXVIRTUALSCREEN = 78
Const SM_CYVIRTUALSCREEN = 79
Const SM_CMONITORS = 80
Const MONITOR_DEFAULTTONULL = 0
Const MONITORINFOF_PRIMARY = 1
Dim need As Long: need = GetSystemMetrics(SM_CMONITORS)
If need <= 0 Then need = 1
'scan a unique HMONITOR without a callback: via MonitorFromRect on a grid of points
Dim vx As Long, vy As Long, vw As Long, vh As Long
vx = GetSystemMetrics(SM_XVIRTUALSCREEN)
vy = GetSystemMetrics(SM_YVIRTUALSCREEN)
vw = GetSystemMetrics(SM_CXVIRTUALSCREEN)
vh = GetSystemMetrics(SM_CYVIRTUALSCREEN)
If vw <= 0 Or vh <= 0 Then Exit Function
Dim hMon As _Offset
Dim monCount As Long: monCount = 0
ReDim hMon(1 To 1) As _Offset
Dim stepPx As Long: stepPx = 256
If stepPx < 32 Then stepPx = 32
Dim xx As Long, yy As Long, i As Long, found As Long
Dim rr As RECT
Dim hm As _Offset
For yy = vy To vy + vh - 1 Step stepPx
For xx = vx To vx + vw - 1 Step stepPx
rr.left = xx: rr.top = yy: rr.right = xx + 1: rr.bottom = yy + 1
hm = MonitorFromRect(rr, MONITOR_DEFAULTTONULL)
If hm <> 0 Then
found = 0
For i = 1 To monCount
If hMon(i) = hm Then found = 1: Exit For
Next
If found = 0 Then
monCount = monCount + 1
If monCount = 1 Then
hMon(1) = hm
Else
ReDim _Preserve hMon(1 To monCount) As _Offset
hMon(monCount) = hm
End If
If monCount >= need Then Exit For
End If
End If
Next
If monCount >= need Then Exit For
Next
If monCount = 0 Then Exit Function
' načíst recty + flagy
Dim leftA As Long, topA As Long, primA As Long
ReDim leftA(1 To monCount) As Long
ReDim topA(1 To monCount) As Long
ReDim primA(1 To monCount) As Long
Dim mi As MONITORINFOEX, ok As Long
For i = 1 To monCount
mi.cbSize = Len(mi)
ok = GetMonitorInfoA(hMon(i), mi)
If ok Then
leftA(i) = mi.rcMonitor.left
topA(i) = mi.rcMonitor.top
primA(i) = ((mi.dwFlags And MONITORINFOF_PRIMARY) <> 0)
Else
leftA(i) = 0: topA(i) = 0: primA(i) = 0
End If
Next
' sort: primary first, rest left/top
Dim As Long j, swp, tmpL, tmpT, tmpP
Dim tmpO As _Offset
For i = 1 To monCount - 1
For j = i + 1 To monCount
swp = 0
' primary always before non-primary
If primA(i) = 0 And primA(j) = 1 Then swp = 1
' both of the same "primary" type -> left/top
If swp = 0 And primA(i) = primA(j) Then
If leftA(j) < leftA(i) Then swp = 1
If leftA(j) = leftA(i) And topA(j) < topA(i) Then swp = 1
End If
If swp Then
tmpO = hMon(i): hMon(i) = hMon(j): hMon(j) = tmpO
tmpL = leftA(i): leftA(i) = leftA(j): leftA(j) = tmpL
tmpT = topA(i): topA(i) = topA(j): topA(j) = tmpT
tmpP = primA(i): primA(i) = primA(j): primA(j) = tmpP
End If
Next
Next
If idx < 1 Or idx > monCount Then Exit Function
mi.cbSize = Len(mi)
ok = GetMonitorInfoA(hMon(idx), mi)
If ok = 0 Then Exit Function
rOut = mi.rcMonitor
GetMonitorRectByIndex% = 1
End Function