VB6 - Capture any Window, even in background, with WinRT / Windows.Graphics.Capture

[VanGoghGaming]

This project is a VB6 implementation of the "Windows.Graphics.Capture" engine from the "Windows Runtime API". It demonstrates how to initialize the API, create a "CaptureItem" object for capturing either the whole monitor or a specific window, start the capture process and fire events whenever a new frame is available in the frame pool or when the capture target has changed size or was closed.

Here's a screenshot of capturing the whole monitor while moving the app window around, creating a cool "cascading" effect. The movement is very fluid, it takes only 4-5ms on average to capture, process and render each incoming frame in a PictureBox:



This is another screenshot of capturing the "VLC Player" window playing a movie in the background. The app automatically detects when the target window has changed size and resizes itself accordingly. It also detects when the target window was closed and stops the capture.



cCapture - declared "WithEvents", this class encapsulates the capturing and processing of frames:

Event CaptureSizeChanged(ByVal lCaptureWidth As Long, ByVal lCaptureHeight As Long, ByVal lWindowHandle As Long)
Event CaptureItemClosed(ByVal lWindowHandle As Long)
Event RenderNextFrame(picFrame As IPicture, ByVal lFrameWidth As Long, ByVal lFrameHeight As Long, ByVal pBitmapBits As Long, ByVal pBitmapInfo As Long)

Private Sub ICallback_TriggerEvent(Sender As Long, Optional Args As Long, Optional lParam As Long)
Dim lpIDirect3D11CaptureFrame As Long, lpIDirect3DSurface As Long, ContentSize As SizeInt32
    With CaptureItem(lParam)
        Select Case Sender
            Case .lpIDirect3D11CaptureFramePool
                If Not .bPause And m_bProcessNextFrame Then
                    StartTiming
                    InvokePtr Sender, IDirect3D11CaptureFramePool_TryGetNextFrame, VarPtr(lpIDirect3D11CaptureFrame)
                    If InvokePtr(.lpIGraphicsCaptureItem, IGraphicsCaptureItem_GetSize, VarPtr(ContentSize)) = S_OK Then
                        If (ContentSize.Width <> .CaptureItemSize.Width) Or (ContentSize.Height <> .CaptureItemSize.Height) Then
                            .CaptureItemSize = ContentSize
                            InvokePtr Sender, IDirect3D11CaptureFramePool_Recreate, lpIDirect3DDevice, DXGI_FORMAT_B8G8R8A8_UNORM, 1&, .CaptureItemSize.Width, .CaptureItemSize.Height
                            ReleasePtr lpIDirect3D11CaptureFrame, True: Exit Sub
                        End If
                    End If
                    If InvokePtr(lpIDirect3D11CaptureFrame, IDirect3D11CaptureFrame_GetContentSize, VarPtr(ContentSize)) = S_OK Then
                        If (ContentSize.Width <> .FrameContentSize.Width) Or (ContentSize.Height <> .FrameContentSize.Height) Then
                            .FrameContentSize = ContentSize: SetBitmapSize lParam: RaiseEvent CaptureSizeChanged(.lFrameWidth, .lFrameHeight, .hWnd)
                        End If
                        If InvokePtr(lpIDirect3D11CaptureFrame, IDirect3D11CaptureFrame_GetSurface, VarPtr(lpIDirect3DSurface)) = S_OK Then
                            GetImageFromIDirect3DSurface lpIDirect3DSurface, lParam: ReleasePtr lpIDirect3DSurface, True
                            If m_lFPS > 0 Then m_bProcessNextFrame = False: m_eCaptureItem = lParam
                        End If
                    End If
                    ReleasePtr lpIDirect3D11CaptureFrame, True: RaiseEvent RenderNextFrame(Picture(lParam), .lFrameWidth, .lFrameHeight, .pBitmapBits, VarPtr(.bmiBitmapInfo))
                End If
            Case .lpIGraphicsCaptureItem
                CloseCaptureSession lParam: RaiseEvent CaptureItemClosed(lParam)
        End Select
    End With
End Sub

Private Sub Class_Initialize()
Dim i As Long, lpIGraphicsCaptureSessionStatics As Long
    InitIIDs
    For i = LBound(CaptureItem) To UBound(CaptureItem)
        With CaptureItem(i)
            With .bmiBitmapInfo.bmiHeader: .biSize = LenB(CaptureItem(i).bmiBitmapInfo.bmiHeader): .biPlanes = 1: .biBitCount = 32: End With
            With .PictDesc: .cbSizeofstruct = LenB(CaptureItem(i).PictDesc): .picType = vbPicTypeBitmap: End With
            .CaptureRegion.Back = 1
            With .IDirect3D11CaptureFramePool_FrameArrived: .pVTable = GetVTablePointer: .lUserData = i: .pIID_EventHandler = pIID(eITypedEventHandlerDirect3D11CaptureFramePool): Set .Callback = Me: End With
            With .IGraphicsCaptureItem_Closed: .pVTable = GetVTablePointer: .lUserData = i: .pIID_EventHandler = pIID(eITypedEventHandlerGraphicsCaptureItem): Set .Callback = Me: End With
        End With
    Next i
    If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureSession, pIID(eIGraphicsCaptureSessionStatics), lpIGraphicsCaptureSessionStatics) Then
        If InvokePtr(lpIGraphicsCaptureSessionStatics, IGraphicsCaptureSessionStatics_IsSupported, VarPtr(m_bIsSupported)) = S_OK Then
            If m_bIsSupported Then
                If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureItem, pIID(eIGraphicsCaptureItemInterop), lpIGraphicsCaptureItemInterop) Then
                    If GetActivationFactory(WindowsGraphicsCaptureDirect3D11CaptureFramePool, pIID(eIDirect3D11CaptureFramePoolStatics), lpIDirect3D11CaptureFramePoolStatics) Then
                        If D3D11CreateDevice(0, D3D_DRIVER_TYPE_HARDWARE, 0, D3D11_CREATE_DEVICE_BGRA_SUPPORT, 0, 0, D3D11_SDK_VERSION, VarPtr(lpID3D11Device), 0, VarPtr(lpID3D11ImmediateDeviceContext)) = S_OK Then
                            CreateDirect3D11DeviceFromDXGIDevice lpID3D11Device, VarPtr(lpIDirect3DDevice)
                        End If
                    End If
                End If
            End If
        End If
        ReleasePtr lpIGraphicsCaptureSessionStatics
    End If
End Sub

Private Sub Class_Terminate()
Dim i As Long
    For i = LBound(CaptureItem) To UBound(CaptureItem)
        With CaptureItem(i).PictDesc
            If .hBitmap Then DeleteObject .hBitmap
        End With
        CloseCaptureSession i
    Next i
    ReleasePtr lpIDirect3DDevice, True: ReleasePtr lpID3D11ImmediateDeviceContext: ReleasePtr lpID3D11Device: ReleasePtr lpIDirect3D11CaptureFramePoolStatics: ReleasePtr lpIGraphicsCaptureItemInterop
End Sub

Friend Property Get EnableCaptureCursor() As Boolean
    EnableCaptureCursor = m_bEnableCaptureCursor
End Property

Friend Property Let EnableCaptureCursor(bEnableCaptureCursor As Boolean)
    m_bEnableCaptureCursor = bEnableCaptureCursor
End Property

Friend Property Get EnableCaptureBorder() As Boolean
    EnableCaptureBorder = m_bEnableCaptureBorder
End Property

Friend Property Let EnableCaptureBorder(bEnableCaptureBorder As Boolean)
    m_bEnableCaptureBorder = bEnableCaptureBorder
End Property

Friend Property Get ExcludeWindowTitleBar() As Boolean
    ExcludeWindowTitleBar = m_bExcludeWindowTitleBar
End Property

Friend Property Let ExcludeWindowTitleBar(bExcludeWindowTitleBar As Boolean)
Dim rcWindowRect As RECT, rcClientRect As RECT, lBorderWidth As Long
    With CaptureItem(eWindow)
        If .hWnd Then
            m_bExcludeWindowTitleBar = bExcludeWindowTitleBar
            If m_bExcludeWindowTitleBar Then
                GetWindowRect .hWnd, VarPtr(rcWindowRect): GetClientRect .hWnd, VarPtr(rcClientRect)
                lBorderWidth = (rcWindowRect.Right - rcWindowRect.Left - rcClientRect.Right + rcClientRect.Left) \ 2
                .lTitleBarHeight = rcWindowRect.Bottom - rcWindowRect.Top - rcClientRect.Bottom + rcClientRect.Top - lBorderWidth
            Else
                .lTitleBarHeight = 0
            End If
        End If
    End With
End Property

Friend Property Get FrameRate() As Long
    FrameRate = m_lFPS
End Property

Friend Property Let FrameRate(lFPS As Long)
    If lFPS >= 0 Then m_lFPS = lFPS
End Property

Friend Property Get IsCaptureStarted(Optional eCaptureItem As CaptureItemEnum = eWindow) As Boolean
    IsCaptureStarted = CaptureItem(eCaptureItem).bStartCapture
End Property

Friend Property Get IsInitialized(Optional eCaptureItem As CaptureItemEnum = eWindow) As Boolean
    IsInitialized = CaptureItem(eCaptureItem).bIsInitialized
End Property

Friend Property Get IsSupported() As Boolean
    IsSupported = m_bIsSupported
End Property

Friend Property Get MonitorHandle() As Long
    MonitorHandle = CaptureItem(eMonitor).hMonitor
End Property

Friend Property Let MonitorHandle(hMonitor As Long)
    With CaptureItem(eMonitor)
        If lpIDirect3DDevice Then
            If .hMonitor = hMonitor Then Exit Property
            .hMonitor = hMonitor
            If .bStartCapture Then CloseCaptureSession eMonitor
            If InvokePtr(lpIGraphicsCaptureItemInterop, IGraphicsCaptureItemInterop_CreateForMonitor, .hMonitor, pIID(eIGraphicsCaptureItem), VarPtr(.lpIGraphicsCaptureItem)) = S_OK Then
                .bIsInitialized = InvokePtr(.lpIGraphicsCaptureItem, IGraphicsCaptureItem_GetSize, VarPtr(.CaptureItemSize)) = S_OK
                If .bIsInitialized Then AddRemoveEventHandler eMonitor, .lpIGraphicsCaptureItem
            End If
        End If
    End With
End Property

Friend Property Get PauseCapture(Optional eCaptureItem As CaptureItemEnum = eWindow) As Boolean
    PauseCapture = CaptureItem(eCaptureItem).bPause
End Property

Friend Property Let PauseCapture(Optional eCaptureItem As CaptureItemEnum = eWindow, bPause As Boolean)
Dim lpIDirect3D11CaptureFrame As Long
    With CaptureItem(eCaptureItem)
        If (.bPause <> bPause) And .bStartCapture Then
            .bPause = bPause
            If Not .bPause Then
                InvokePtr .lpIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_TryGetNextFrame, VarPtr(lpIDirect3D11CaptureFrame): ReleasePtr lpIDirect3D11CaptureFrame, True
                m_bProcessNextFrame = True: If m_lFPS > 0 Then Set TimerFPS = cTimer.CreatePeriodicTimer(1000 \ m_lFPS)
            Else
                m_bProcessNextFrame = False: Set TimerFPS = Nothing
            End If
        End If
    End With
End Property

Friend Property Get Picture(Optional eCaptureItem As CaptureItemEnum = eWindow) As IPicture
    OleCreatePictureIndirect VarPtr(CaptureItem(eCaptureItem).PictDesc), pIID(eIUnknown), APIFALSE, Picture
End Property

Friend Property Get WindowHandle() As Long
    WindowHandle = CaptureItem(eWindow).hWnd
End Property

Friend Property Let WindowHandle(hWnd As Long)
    With CaptureItem(eWindow)
        If lpIDirect3DDevice Then
            If IsWindow(hWnd) Then
                If .hWnd = hWnd Then Exit Property
                If Not IsMinimized(hWnd) Then
                    .hWnd = hWnd
                    If .bStartCapture Then CloseCaptureSession eWindow
                    If InvokePtr(lpIGraphicsCaptureItemInterop, IGraphicsCaptureItemInterop_CreateForWindow, .hWnd, pIID(eIGraphicsCaptureItem), VarPtr(.lpIGraphicsCaptureItem)) = S_OK Then
                        .bIsInitialized = InvokePtr(.lpIGraphicsCaptureItem, IGraphicsCaptureItem_GetSize, VarPtr(.CaptureItemSize)) = S_OK
                        If .bIsInitialized Then AddRemoveEventHandler eWindow, .lpIGraphicsCaptureItem
                    End If
                End If
            End If
        End If
    End With
End Property

Friend Sub CaptureMonitor()
    With CaptureItem(eMonitor)
        If .hMonitor Then If .bIsInitialized Then StartCapture eMonitor
    End With
End Sub

Friend Sub CaptureWindow()
    With CaptureItem(eWindow)
        If .hWnd Then If Not IsMinimized(.hWnd) Then If .bIsInitialized Then StartCapture eWindow
    End With
End Sub

Friend Function GetCaptureSize(lWidth As Long, lHeight As Long, Optional eCaptureItem As CaptureItemEnum = eWindow)
    With CaptureItem(eCaptureItem): lWidth = .FrameContentSize.Width: lHeight = .FrameContentSize.Height: End With
End Function

Friend Sub SetCaptureRegion(Optional lLeft As Long, Optional lTop As Long, Optional lWidth As Long, Optional lHeight As Long)
Dim i As Long
    For i = LBound(CaptureItem) To UBound(CaptureItem)
        With CaptureItem(i)
            If lWidth * lHeight Then
                .CaptureRegion.Left = lLeft: .CaptureRegion.Top = lTop + .lTitleBarHeight: .CaptureRegion.Right = lLeft + lWidth: .CaptureRegion.Bottom = .CaptureRegion.Top + lHeight: .bCaptureRegion = True
            Else
                .bCaptureRegion = False
            End If
        End With
    Next i
End Sub

Friend Sub StopCapture(Optional eCaptureItem As CaptureItemEnum = eWindow)
    With CaptureItem(eCaptureItem)
        If .bStartCapture Then CloseCaptureSession eCaptureItem
    End With
End Sub

Private Sub AddRemoveEventHandler(eCaptureItem As CaptureItemEnum, Sender As Long, Optional bRemove As Boolean)
    If Sender Then
        With CaptureItem(eCaptureItem)
            Select Case Sender
                Case .lpIDirect3D11CaptureFramePool
                    With .IDirect3D11CaptureFramePool_FrameArrived
                        If bRemove Then
                            If .EventRegistrationToken Then InvokePtr Sender, IDirect3D11CaptureFramePool_RemoveFrameArrived, .EventRegistrationToken
                        Else
                            If .EventRegistrationToken = 0 Then
                                InvokePtr Sender, IDirect3D11CaptureFramePool_AddFrameArrived, VarPtr(.pVTable), VarPtr(.EventRegistrationToken)
                                Set .Callback = Me
                            End If
                        End If
                    End With
                Case .lpIGraphicsCaptureItem
                    With .IGraphicsCaptureItem_Closed
                        If bRemove Then
                            If .EventRegistrationToken Then InvokePtr Sender, IGraphicsCaptureItem_RemoveClosed, .EventRegistrationToken
                        Else
                            If .EventRegistrationToken = 0 Then
                                InvokePtr Sender, IGraphicsCaptureItem_AddClosed, VarPtr(.pVTable), VarPtr(.EventRegistrationToken)
                                Set .Callback = Me
                            End If
                        End If
                    End With
            End Select
        End With
    End If
End Sub

Private Sub StartCapture(Optional eCaptureItem As CaptureItemEnum = eWindow)
    With CaptureItem(eCaptureItem)
        If .lpIDirect3D11CaptureFramePool = 0 Then
            If InvokePtr(lpIDirect3D11CaptureFramePoolStatics, IDirect3D11CaptureFramePoolStatics_Create, lpIDirect3DDevice, DXGI_FORMAT_B8G8R8A8_UNORM, 1&, .CaptureItemSize.Width, .CaptureItemSize.Height, VarPtr(.lpIDirect3D11CaptureFramePool)) = S_OK Then
                AddRemoveEventHandler eCaptureItem, .lpIDirect3D11CaptureFramePool
                If .lpIGraphicsCaptureSession = 0 Then
                    If InvokePtr(.lpIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_CreateCaptureSession, .lpIGraphicsCaptureItem, VarPtr(.lpIGraphicsCaptureSession)) = S_OK Then
                        InvokeObj QueryInterfacePtr(.lpIGraphicsCaptureSession, pIID(eIGraphicsCaptureSession2)), IGraphicsCaptureSession2_PutIsCursorCaptureEnabled, m_bEnableCaptureCursor
                        InvokeObj QueryInterfacePtr(.lpIGraphicsCaptureSession, pIID(eIGraphicsCaptureSession3), GetWindowsVersion > 10), IGraphicsCaptureSession3_PutIsBorderRequired, m_bEnableCaptureBorder
                        .bStartCapture = InvokePtr(.lpIGraphicsCaptureSession, IGraphicsCaptureSession_StartCapture) = S_OK
                        If .bStartCapture Then m_bProcessNextFrame = True: If m_lFPS > 0 Then Set TimerFPS = cTimer.CreatePeriodicTimer(1000 \ m_lFPS)
                    End If
                End If
            End If
        End If
    End With
End Sub

Private Sub GetImageFromIDirect3DSurface(lpIDirect3DSurface As Long, Optional eCaptureItem As CaptureItemEnum = eWindow)
Dim lpID3D11Texture2D As Long, i As Long, lRowWidth As Long
    If InvokeObj(QueryInterfacePtr(lpIDirect3DSurface, pIID(eIDirect3DDxgiInterfaceAccess)), IDirect3DDxgiInterfaceAccess_GetInterface, pIID(eID3D11Texture2D), VarPtr(lpID3D11Texture2D)) = S_OK Then
        With CaptureItem(eCaptureItem)
            If .lpID3D11Texture2DCopy = 0 Then
                InvokePtr lpID3D11Texture2D, ID3D11Texture2D_GetDesc, VarPtr(D3D11Texture2DDesc)
                If .bCaptureRegion Then
                    CaptureRegion = .CaptureRegion
                Else
                    CaptureRegion.Left = 0: CaptureRegion.Right = .lFrameWidth: CaptureRegion.Bottom = .lFrameHeight + .lTitleBarHeight: CaptureRegion.Top = .lTitleBarHeight: CaptureRegion.Back = 1
                End If
                If (.lTitleBarHeight <> 0) Or .bCaptureRegion Then D3D11Texture2DDesc.Width = .lFrameWidth: D3D11Texture2DDesc.Height = .lFrameHeight
                With D3D11Texture2DDesc: .Usage = D3D11_USAGE_STAGING: .CPUAccessFlags = D3D11_CPU_ACCESS_READ: .BindFlags = 0: .MiscFlags = 0: End With
                InvokePtr lpID3D11Device, ID3D11Device_CreateTexture2D, VarPtr(D3D11Texture2DDesc), 0&, VarPtr(.lpID3D11Texture2DCopy)
            End If
            If .lpID3D11Texture2DCopy Then
                If (.lTitleBarHeight <> 0) Or .bCaptureRegion Then
                    InvokePtr lpID3D11ImmediateDeviceContext, ID3D11DeviceContext_CopySubresourceRegion, .lpID3D11Texture2DCopy, 0&, 0&, 0&, 0&, lpID3D11Texture2D, 0&, VarPtr(CaptureRegion)
                Else
                    InvokePtr lpID3D11ImmediateDeviceContext, ID3D11DeviceContext_CopyResource, .lpID3D11Texture2DCopy, lpID3D11Texture2D
                End If
                If InvokePtr(lpID3D11ImmediateDeviceContext, ID3D11DeviceContext_Map, .lpID3D11Texture2DCopy, 0&, D3D11_MAP_READ, 0&, VarPtr(D3D11MappedSubresource)) = S_OK Then
                    lRowWidth = .lFrameWidth * 4
                    If lRowWidth <> D3D11MappedSubresource.RowPitch Then
                        For i = 0 To .lFrameHeight - 1
                            CopyBytes lRowWidth, ByVal .pBitmapBits + i * lRowWidth, ByVal D3D11MappedSubresource.pData + i * D3D11MappedSubresource.RowPitch
                        Next i
                    Else
                        CopyBytes lRowWidth * .lFrameHeight, ByVal .pBitmapBits, ByVal D3D11MappedSubresource.pData
                    End If
                    InvokePtr lpID3D11ImmediateDeviceContext, ID3D11DeviceContext_Unmap, .lpID3D11Texture2DCopy, 0&
                End If
            End If
        End With
        ReleasePtr lpID3D11Texture2D
    End If
End Sub

Private Sub CloseCaptureSession(Optional eCaptureItem As CaptureItemEnum = eWindow)
    With CaptureItem(eCaptureItem)
        AddRemoveEventHandler eCaptureItem, .lpIDirect3D11CaptureFramePool, True: AddRemoveEventHandler eCaptureItem, .lpIGraphicsCaptureItem, True
        ReleasePtr .lpIGraphicsCaptureSession, True: ReleasePtr .lpIDirect3D11CaptureFramePool, True
        ReleasePtr .lpIGraphicsCaptureItem: ReleasePtr .lpID3D11Texture2DCopy
        With .CaptureItemSize: .Width = 0: .Height = 0: End With
        With .FrameContentSize: .Width = 0: .Height = 0: End With
        .hWnd = 0: .hMonitor = 0: .bIsInitialized = False: .bPause = False: .bStartCapture = False: Set TimerFPS = Nothing
    End With
End Sub

Private Sub SetBitmapSize(Optional eCaptureItem As CaptureItemEnum = eWindow)
    With CaptureItem(eCaptureItem)
        If .bCaptureRegion Then
            .lFrameWidth = .CaptureRegion.Right - .CaptureRegion.Left: .lFrameHeight = .CaptureRegion.Bottom - .CaptureRegion.Top
        Else
            .lFrameWidth = .FrameContentSize.Width: .lFrameHeight = .FrameContentSize.Height - .lTitleBarHeight
        End If
        If .PictDesc.hBitmap Then DeleteObject .PictDesc.hBitmap
        .bmiBitmapInfo.bmiHeader.biWidth = .lFrameWidth: .bmiBitmapInfo.bmiHeader.biHeight = -.lFrameHeight
        .PictDesc.hBitmap = CreateDIBSection(0, VarPtr(.bmiBitmapInfo), DIB_RGB_COLORS, .pBitmapBits, 0, 0): ReleasePtr .lpID3D11Texture2DCopy
    End With
End Sub

Private Function IsMinimized(hWnd As Long) As Boolean
    IsMinimized = GetWindowLongW(hWnd, GWL_STYLE) And WS_MINIMIZE
End Function

Private Sub TimerFPS_Elapsed(bCancel As Boolean)
Dim lpIDirect3D11CaptureFrame As Long
    With CaptureItem(m_eCaptureItem)
        If Not .bPause And .bStartCapture Then
            If Not m_bProcessNextFrame Then
                m_bProcessNextFrame = True
                InvokePtr .lpIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_TryGetNextFrame, VarPtr(lpIDirect3D11CaptureFrame): ReleasePtr lpIDirect3D11CaptureFrame, True
            End If
        End If
    End With
End Sub

There's also a property that can enable capturing the "Mouse Pointer" (set to "False" by default) if you want a visual aid about something that happens during the capture process.

At the moment, the project is set up to capture the monitor or window that is currently beneath the mouse pointer. Obviously if you click the "Start Capture" button, it will capture the app window since that contains the button you've just clicked. In case you're wondering, even though the button itself is a "window" (since it has a hWnd!), the "Windows.Graphics.Capture" engine can capture only "Top-Level Windows" so the app looks at the "hWnd" you've just clicked and then goes up the chain until it finds the root owner window and starts the capturing process on that one instead!

So if you want to capture another window (for testing purposes), you need to keep the app window in the foreground, hover the mouse over your desired target window and press "Alt-S" or just "Enter" (the keyboard shortcut for the default "Start Capture" button) and that will initiate the capture process. If you prefer subclassing then it's very easy to install a generic "HotKey" and have the main form watch for "WM_HOTKEY" messages so that it can initiate captures without being in the foreground!

Update: In this version I've added an "ExcludeWindowTitleBar" property (to remove the title bar when capturing a window) and a "SetCaptureRegion" function where you can specify a rectangular region to capture from either a window or the whole monitor. The following screenshot shows the capture of a 400x300 region with the top left corner at the (100:200) coordinates relative to the window being captured:



Update: This version includes a major code overhaul to streamline the usage of WinRT event handlers in VB6. Now you can Pause and Resume the capture process as well as select a custom FPS value (play with the FPS scrollbar in the demo project below). The FPS scrollbar goes from 0 to 100 (with zero meaning disabled, running at maximum possible FPS).

There is also an option to scale down the capture output to display it in a smaller size (using the "Render" method of the Picture object). The second scrollbar goes from 10 to 100 (percent of the original capture size). You can also make the smaller capture look smoother by using "StretchDIBits" in "Halftone" mode at the expense of slightly more processing power.



Here's the demo project: WindowsGraphicsCapture.zip

Special thanks to -Franky- for exploring the WinRT API for the VB6 community!

[yokesee]

It doesn't work, the screen goes blank.
Use Windows 10 Build: 17134 ReleaseId: 1803

[VanGoghGaming]

I'm also on Windows 10 but the current build is 19045 and it works great on it. Your build seems to be several years old, why don't you update? You're missing out on a lot of new features...

Also I'd be more interested to see if you could go through it step by step in the debugger and figure out where it's failing with an error instead of "S_OK". That's why I shared the source code instead of an ActiveX DLL!

[VanGoghGaming]

the screen goes blank.

It just dawned on me that the reason you see a blank PictureBox is that you've tried to capture the VB6 IDE window. For some mystic reason the "IGraphicsCaptureItemInterop_CreateForWindow" method returns "E_INVALIDARG" when you supply it with the "hWnd" for the main VB6 IDE window. Try to capture any other window or the whole monitor instead and see how that goes.

[yokesee]

the problem is bIsSupported is false.

[VanGoghGaming]

Awww man, I'm sorry to hear that. Judging from the documentation for the IsSupported method, it seems that your Windows version build number should be the minimum that is actually supported:

Applies to
Product Versions
WinRT Build 17134, Build 17763, Build 18362, Build 19041, Build 20348, Build 22000, Build 22621, Build 29541 (Preview)

So I don't know what to say other than bite the bullet and update your Windows (if it's a genuine version that supports updates)...

[yokesee]

It is original.
But I don't like Windows making decisions for me and when I'm happy with something I don't update it, I know it entails things

[VanGoghGaming]

Update: In this version I've added an "ExcludeWindowTitleBar" property (to remove the title bar when capturing a window) and a "SetCaptureRegion" function where you can specify a rectangular region to capture from either a window or the whole monitor. The following screenshot shows the capture of a 400x300 region with the top left corner at the (100:200) coordinates relative to the window being captured:



As usual you can download this latest update from the first post above.

[xxdoc123]

Update: In this version I've added an "ExcludeWindowTitleBar" property (to remove the title bar when capturing a window) and a "SetCaptureRegion" function where you can specify a rectangular region to capture from either a window or the whole monitor. The following screenshot shows the capture of a 400x300 region with the top left corner at the (100:200) coordinates relative to the window being captured:



As usual you can download this latest update from the first post above.

Very good, it looks like the images are captured continuously, can I set it to capture only 1 image one time

Private Sub cCapture_RenderNextFrame(picFrame As IPicture)
    Set picCapture.Picture = picFrame: lblTiming = Elapsed
    Call cmdStartCapture_Click
End Sub

[VanGoghGaming]

It all depends on what you are trying to do. Stopping the continuous capture process means destroying and recreating the "FramePool" and "CaptureSession" objects which incurs additional overhead (about 15-25 ms, which can be a lot, again depending on what you are trying to do in the meantime).

Another way to go about it is to let the capture process run continuously (it hardly consumes any resources) and whenever you need to process a frame, it's already there waiting for you. Just because the capture process is running continuously, it doesn't mean you have to display every single frame in a PictureBox, this is just an example I've put together in this project for demonstration purposes.

[xxdoc123]

It all depends on what you are trying to do. Stopping the continuous capture process means destroying and recreating the "FramePool" and "CaptureSession" objects which incurs additional overhead (about 15-25 ms, which can be a lot, again depending on what you are trying to do in the meantime).

Another way to go about it is to let the capture process run continuously (it hardly consumes any resources) and whenever you need to process a frame, it's already there waiting for you. Just because the capture process is running continuously, it doesn't mean you have to display every single frame in a PictureBox, this is just an example I've put together in this project for demonstration purposes.

I have an OCR recognition project to operate an old phone via scrcpy. I need to take a screenshot, call OCR to identify the information, and then remind me. I only need 1 minute or 10 minutes to take a screenshot. At the moment, the speed of this continuous screenshot is much faster than I need, and I am worried about the consumption of additional memory。Can I set 1 or more screenshots per minute in Continuous Screenshots?

[VanGoghGaming]

Then, for your needs, you can safely stop the capture after processing the first frame and start it again later.

However there is virtually no additional memory consumption if you let it run continuously. Old frames are destroyed as soon as new ones arrive in the buffer. They are not saved anywhere.

The capture engine uses some sort of cache internally but as far as I've seen that is limited to around 2MB or so, which is nothing. I've tested with the program running continuously for about half an hour and the memory consumption in "Task Manager" slowly increases for the first few minutes and then remains stable when the internal cache reaches its maximum.

[xxdoc123]

Then, for your needs, you can safely stop the capture after processing the first frame and start it again later.

However there is virtually no additional memory consumption if you let it run continuously. Old frames are destroyed as soon as new ones arrive in the buffer. They are not saved anywhere.

The capture engine uses some sort of cache internally but as far as I've seen that is limited to around 2MB or so, which is nothing. I've tested with the program running continuously for about half an hour and the memory consumption in "Task Manager" slowly increases for the first few minutes and then remains stable when the internal cache reaches its maximum.

Very nice so I don't have to worry about memory anomalies. I just need to go and look at the screenshots at intervals

Private Sub cCapture_RenderNextFrame(picFrame As IPicture)
    if setT=true then
     Set picCapture.Picture = picFrame: lblTiming = Elapsed
     setT=False
     call  DoSoming
     
   end if
   
End Sub

  private  function DoSoming（）
       Timer1.Interval=60000

      call Timer1_Timer()

   ....do someing
    
        
  end function

Private Sub Timer1_Timer()
    if setT=False then
      setT=true
    end if
End Sub

How about my code logic

[VanGoghGaming]

Sure that works but there are simpler ways even without a Timer control. For example process a new frame whenever:

    If CLng(Timer) Mod 60 = 0 Then ' once every minute
        If Not bFrameProcessed Then
            ' .........
            ' Do Something
            ' .........
            bFrameProcessed = True
        End if
    Else
        bFrameProcessed = False
    End If

[VanGoghGaming]

Update: This version includes a major code overhaul to streamline the usage of WinRT event handlers in VB6. Now you can Pause and Resume the capture process as well as select a custom FPS value (play with the FPS scrollbar in the demo project below). The FPS scrollbar goes from 0 to 100 (with zero meaning disabled, running at maximum possible FPS).

There is also an option to scale down the capture output to display it in a smaller size (using the "Render" method of the Picture object). The second scrollbar goes from 10 to 100 (percent of the original capture size). You can also make the smaller capture look smoother by using "StretchDIBits" in "Halftone" mode at the expense of slightly more processing power.



As usual you can download this update from the first post above.

[Maatooh]

I just tried it, and it's great in terms of performance.


This code is great.

[yereverluvinuncleber]

It is potentially a very good tool, very efficient.

Needs Save AS functionality to be actually useful as a tool in itself, otherwise it is a just a demo. of VB6's capabilities and a good starting point for a more functional and useful desktop tool.

[VanGoghGaming]

This code is great.

Yeah, it's the next best thing since sliced bread! Looking at it in retrospective I must have been out of my mind to even attempt it. Calling interface methods via "DispCallFunc" makes for very clumsy code which is hard to understand by others and a pain to maintain or expand upon.

The correct approach would have been to make a TypeLib with the required interface definitions and then the code would have been much cleaner and half the size. TwinBasic makes it ridiculously easy to write such interface definitions which are then usable in VB6, especially for people who are not familiar with IDL language and the intricacies of the MIDL compiler.

[Maatooh]

Certainly For the implementation of vb6 it is really a marvel.
I remember starting this thread: https://www.vbforums.com/showthread....nd-PrintWindow

But I ended up using PrintWindow. Now I'd like to use Windows.Graphics.Capture, which is great for reducing CPU load.

Do you think you could help me organize a .dll file to properly encapsulate this application? In fact, I created one with PrintWindow that creates a hidden picturebox at runtime. When I call a function, I capture the window image using Hwnd at that instant and can easily export it to another picturebox for easy scaling and cropping if needed.

Although in this case, I'd like to implement continuous capture, As you have done in your project. Doing this repeatedly with standard timers causes the yellow frame to flicker, which is a bit annoying on Windows 10.

Public CVHwnd As Long
Public CVCapture As PictureBox
Private CVForm As Form

'---------------------------------------------------------------
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function PrintWindow Lib "User32.dll" (ByVal hwnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
'----------------------------------------------------------------

Public Function SetupCapture(GHwnd As Long, ByRef GForm As Object)
On Error GoTo QH
    CVHwnd = GHwnd
    Set CVForm = GForm
    Set CVCapture = CVForm.Controls.Add("VB.PictureBox", "MainCaptureCV")
QH:
End Function

Public Function GetCapture(SMode As Long, Optional SWidth As Long, Optional SHeight As Long)
    Dim Calc_hWnd As Long
    Dim Calc_Rect As RECT
    
    CVForm.ScaleMode = vbPixels
    CVCapture.ScaleMode = vbPixels
    CVCapture.AutoRedraw = True
    ' Get Handle to windows calculator
    Calc_hWnd = CVHwnd
    
    ' get size of windows calculator
    If Calc_hWnd Then
        GetWindowRect Calc_hWnd, Calc_Rect
        ' size temp destination to calc
        If SWidth = 0 Then
        CVCapture.Width = (Calc_Rect.Right - Calc_Rect.Left)
        Else
        CVCapture.Width = SWidth
        End If
        
        If SHeight = 0 Then
        CVCapture.Height = (Calc_Rect.Bottom - Calc_Rect.Top)
        Else
        CVCapture.Height = SHeight
        End If
        
        ' capture it
        PrintWindow Calc_hWnd, CVCapture.hdc, SMode 'PW_CLIENTONLY Or PW_RENDERFULLCONTENT
        CVCapture.Refresh
        BitBlt CVCapture.hdc, 0, 0, _
                            CVCapture.ScaleWidth, _
                            CVCapture.ScaleHeight, _
                            CVCapture.hdc, 0, 0, vbSrcCopy
        CVCapture.Picture = CVCapture.Image
    Else
    'Msgbox "Err Cap"
    End If
    
End Function

[VanGoghGaming]

Yeah, PrintWindow is great for taking snapshots. This demo is intended for continuous capture.

The yellow frame flickers if you start and stop the capture process repeatedly (in Windows 11 you can disable the yellow frame completely). You shouldn't do that, use the Pause/Resume feature instead.