Problems getting a window capture with Bitblt and PrintWindow.

[VanGoghGaming]

@Franky - I've managed to optimize your CapturePicker class to achieve decent capturing speeds now. Stripped it down to the bare minimum required to capture either a whole monitor or a specific window and replaced some "Invokes" with direct calls from a D3D11 TypeLib. It turns out much of the code needs to be executed only once, not every time a capture is taken. That was killing the capture speed before!

frmMain.frm

Option Explicit

Private Sub cmdCaptureMonitor_Click()
    StartTiming
    If clsCapturePicker.CaptureMonitor() Then
        Set picCapture.Picture = clsCapturePicker.Picture
    Else
        Set picCapture.Picture = LoadPicture()
    End If
    lblTiming = Elapsed
End Sub

Private Sub cmdCaptureWindow_Click()
    clsCapturePicker.hWnd = Me.hWnd
    StartTiming
    If clsCapturePicker.CaptureWindow() Then
        Set picCapture.Picture = clsCapturePicker.Picture
    Else
        Set picCapture.Picture = LoadPicture()
    End If
    lblTiming = Elapsed
End Sub

Private Sub Form_Load()
    QueryPerformanceFrequency cFrequency
    Me.Show
    clsCapturePicker.SelectMonitorFromPoint 1920, 0
End Sub

mdlTiming.bas

Option Explicit

Public seqStart As Currency, seqStop As Currency, cFrequency As Currency

Public Sub StartTiming()
    QueryPerformanceCounter seqStart
End Sub

Public Function Elapsed() As Double
    QueryPerformanceCounter seqStop
    Elapsed = (seqStop - seqStart) * 1000 / cFrequency
End Function

clsCapturePicker.cls

Option Explicit

Private Const IID_IPicture As String = "{7bf80980-bf32-101a-8bbb-00aa00300cab}"
Private Const IID_IClosable As String = "{30d5a829-7fa4-4026-83bb-d75bae4ea99e}"
Private Const IID_IDXGIDevice As String = "{54ec77fa-1377-44e6-8c32-88fd5f44c84c}"
Private Const IID_IDirect3DDevice As String = "{a37624ab-8d5f-4650-9d3e-9eae3d9bc670}"
Private Const WindowsGraphicsCaptureGraphicsCaptureSession As String = "Windows.Graphics.Capture.GraphicsCaptureSession"
Private Const IID_IGraphicsCaptureSession As String = "{814e42a9-f70f-4ad7-939b-fddcc6eb880d}"
Private Const IID_IGraphicsCaptureSession_2 As String = "{2c39ae40-7d2e-5044-804e-8b6799d4cf9e}"
Private Const IID_IGraphicsCaptureSession_3 As String = "{f2cdd966-22ae-5ea1-9596-3a289344c3be}"
Private Const IID_IGraphicsCaptureSessionStatics As String = "{2224a540-5974-49aa-b232-0882536f4cb5}"
Private Const WindowsGraphicsCaptureGraphicsCaptureItem As String = "Windows.Graphics.Capture.GraphicsCaptureItem"
Private Const IID_IGraphicsCaptureItemInterop As String = "{3628e81b-3cac-4c60-b7f4-23ce0e0c3356}"
Private Const IID_IGraphicsCaptureItem As String = "{79c3f95b-31f7-4ec2-a464-632ef5d30760}"
Private Const WindowsGraphicsCaptureDirect3D11CaptureFramePool As String = "Windows.Graphics.Capture.Direct3D11CaptureFramePool"
Private Const IID_IDirect3D11CaptureFramePoolStatics As String = "{7784056a-67aa-4d53-ae54-1088d5a8ca21}"
Private Const IID_ID3D11Texture2D As String = "{6f15aaf2-d208-4e89-9ab4-489535d34f9c}"
Private Const IID_IDirect3DDxgiInterfaceAccess As String = "{a9b3d012-3df2-4ee3-b8d1-8695f457d3c1}"

Private Enum vtb_Interfaces
    ' IUnknown
    IUnknown_QueryInterface = 0
    IUnknown_Release = 2
    ' IClosable
    IClosable_Close = 6
    ' IGraphicsCaptureSessionStatics
    IGraphicsCaptureSessionStatics_IsSupported = 6
    ' IGraphicsCaptureItem
    IGraphicsCaptureItem_GetDisplayName = 6
    IGraphicsCaptureItem_GetSize = 7
    ' IDirect3D11CaptureFramePoolStatics
    IDirect3D11CaptureFramePoolStatics_Create = 6
    ' IDirect3D11CaptureFramePool
    IDirect3D11CaptureFramePool_TryGetNextFrame = 7
    IDirect3D11CaptureFramePool_CreateCaptureSession = 10
    ' IGraphicsCaptureSession
    IGraphicsCaptureSession_StartCapture = 6
    ' IGraphicsCaptureSession2
    IGraphicsCaptureSession2_GetIsCursorCaptureEnabled = 6
    IGraphicsCaptureSession2_PutIsCursorCaptureEnabled = 7
    ' IGraphicsCaptureSession3
    IGraphicsCaptureSession3_GetIsBorderRequired = 6
    IGraphicsCaptureSession3_PutIsBorderRequired = 7
    ' IDirect3D11CaptureFrame
    IDirect3D11CaptureFrame_GetSurface = 6
    ' IDirect3DDxgiInterfaceAccess
    IDirect3DDxgiInterfaceAccess_GetInterface = 3
    ' ID3D11Texture2D
    ID3D11Texture2D_GetDesc = 10
    ' ID3D11Device
    ID3D11Device_CreateTexture2D = 5
    ' ID3D11DeviceContext
    ID3D11DeviceContext_Map = 14
    ID3D11DeviceContext_Unmap = 15
    ID3D11DeviceContext_CopyResource = 47
     ' IGraphicsCaptureItemInterop
    IGraphicsCaptureItemInterop_CreateForWindow = 3
    IGraphicsCaptureItemInterop_CreateForMonitor = 4
End Enum

Private Type MONITORINFO
    cbSize As Long
    rcMonitor As RECT
    rcWork As RECT
    dwFlags As Long
End Type

Private Declare Function vbaCastObj Lib "msvbvm60" Alias "__vbaCastObj" (ByVal pObj As Long, ByVal pIID As Long) As IUnknown
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal cc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgvt As Any, prgpvarg As Any, pvargResult As Variant) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (ByVal lpPictDesc As Long, ByVal riid As Long, ByVal fOwn As Long, lplpvObj As IPicture) As Long
Private Declare Function IIDFromString Lib "combase" (ByVal lpsz As Long, lpiid As Any) As Long
Private Declare Function WindowsCreateString Lib "combase" (ByVal sourceString As Long, ByVal length As Long, hString As Long) As Long
Private Declare Function WindowsDeleteString Lib "combase" (ByVal sourceString As Long) As Long
Private Declare Function RoGetActivationFactory Lib "combase" (ByVal activatableClassId As Long, ByVal riid As Long, pFactory As Long) As Long
Private Declare Function GetMonitorInfo Lib "user32" Alias "GetMonitorInfoW" (ByVal hMonitor As Long, ByVal lpmi As Long) As Long
Private Declare Function MonitorFromPoint Lib "user32" (ByVal X As Long, ByVal Y As Long, ByVal dwFlags As Long) As Long
Private Declare Function CreateDirect3D11DeviceFromDXGIDevice Lib "d3d11" (ByVal dxgiDevice As Long, graphicsDevice As Long) As Long

Private IIDs(0 To 51) As Long, pIID_IClosable As Long, pIID_IDXGIDevice As Long, pIID_IDirect3DDevice As Long, pIID_IGraphicsCaptureSession As Long, pIID_IGraphicsCaptureSession_2 As Long, _
        pIID_IGraphicsCaptureSessionStatics As Long, pIID_IGraphicsCaptureItemInterop As Long, pIID_IGraphicsCaptureItem As Long, pIID_IDirect3D11CaptureFramePoolStatics As Long, _
        pIID_ID3D11Texture2D As Long, pIID_IPicture As Long, pIID_IDirect3DDxgiInterfaceAccess As Long, pIID_IGraphicsCaptureSession_3 As Long, pIID_IGraphicsCaptureAccessStatics As Long

Private m_Picture As IPicture, m_bIsInitialized As Boolean, m_hWnd As Long, m_hMonitor As Long, m_lWidth As Long, m_lHeight As Long, m_hDC As Long, m_hBitmap As Long, _
        m_BitmapInfo As BITMAPINFO, m_PicDesc As PICTDESCBMP

Private m_pIGraphicsCaptureItemInterop As Long, objID3D11Device As VBD3D11.ID3D11Device, objID3D11DeviceContext As VBD3D11.ID3D11DeviceContext, objIDXGIDevice As VBD3D11.IDXGIDevice, _
         pIDirect3D11CaptureFramePoolStatics As Long, pIInspectable As Long, objIDirect3DDevice As IUnknown, pIGraphicsCaptureWnd As Long, pIGraphicsCaptureMonitor As Long

Private Sub Class_Initialize()
    IIDFromString StrPtr(IID_IClosable), IIDs(0): pIID_IClosable = VarPtr(IIDs(0))
    IIDFromString StrPtr(IID_IDXGIDevice), IIDs(4): pIID_IDXGIDevice = VarPtr(IIDs(4))
    IIDFromString StrPtr(IID_IDirect3DDevice), IIDs(8): pIID_IDirect3DDevice = VarPtr(IIDs(8))
    IIDFromString StrPtr(IID_IGraphicsCaptureSession), IIDs(12): pIID_IGraphicsCaptureSession = VarPtr(IIDs(12))
    IIDFromString StrPtr(IID_IGraphicsCaptureSession_2), IIDs(16): pIID_IGraphicsCaptureSession_2 = VarPtr(IIDs(16))
    IIDFromString StrPtr(IID_IGraphicsCaptureSession_3), IIDs(20): pIID_IGraphicsCaptureSession_3 = VarPtr(IIDs(20))
    IIDFromString StrPtr(IID_IGraphicsCaptureSessionStatics), IIDs(24): pIID_IGraphicsCaptureSessionStatics = VarPtr(IIDs(24))
    IIDFromString StrPtr(IID_IGraphicsCaptureItemInterop), IIDs(28): pIID_IGraphicsCaptureItemInterop = VarPtr(IIDs(28))
    IIDFromString StrPtr(IID_IGraphicsCaptureItem), IIDs(32): pIID_IGraphicsCaptureItem = VarPtr(IIDs(32))
    IIDFromString StrPtr(IID_IDirect3D11CaptureFramePoolStatics), IIDs(36): pIID_IDirect3D11CaptureFramePoolStatics = VarPtr(IIDs(36))
    IIDFromString StrPtr(IID_ID3D11Texture2D), IIDs(40): pIID_ID3D11Texture2D = VarPtr(IIDs(40))
    IIDFromString StrPtr(IID_IDirect3DDxgiInterfaceAccess), IIDs(44): pIID_IDirect3DDxgiInterfaceAccess = VarPtr(IIDs(44))
    IIDFromString StrPtr(IID_IPicture), IIDs(48): pIID_IPicture = VarPtr(IIDs(48))
    m_BitmapInfo.bmiHeader.biSize = LenB(m_BitmapInfo.bmiHeader): m_BitmapInfo.bmiHeader.biPlanes = 1: m_BitmapInfo.bmiHeader.biBitCount = 32
    m_PicDesc.cbSizeofstruct = LenB(m_PicDesc): m_PicDesc.picType = vbPicTypeBitmap: m_hDC = GetDC(0)
    Dim pIGraphicsCaptureSessionStatics As Long
    If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureSession, pIID_IGraphicsCaptureSessionStatics, pIGraphicsCaptureSessionStatics) Then
        Dim bIsSupported As Boolean
        If Invoke(pIGraphicsCaptureSessionStatics, IGraphicsCaptureSessionStatics_IsSupported, VarPtr(bIsSupported)) = S_OK Then
            If bIsSupported Then
                If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureItem, pIID_IGraphicsCaptureItemInterop, m_pIGraphicsCaptureItemInterop) Then
                    If GetActivationFactory(WindowsGraphicsCaptureDirect3D11CaptureFramePool, pIID_IDirect3D11CaptureFramePoolStatics, pIDirect3D11CaptureFramePoolStatics) Then
                        If VBD3D11.D3D11CreateDevice(Nothing, D3D_DRIVER_TYPE_HARDWARE, 0, D3D11_CREATE_DEVICE_BGRA_SUPPORT, ByVal 0&, 0, D3D11_SDK_VERSION, objID3D11Device, 0, objID3D11DeviceContext) = S_OK Then
                            Set objIDXGIDevice = vbaCastObj(ObjPtr(objID3D11Device), pIID_IDXGIDevice)
                            If Not (objIDXGIDevice Is Nothing) Then
                                If CreateDirect3D11DeviceFromDXGIDevice(ObjPtr(objIDXGIDevice), pIInspectable) = S_OK Then
                                    Set objIDirect3DDevice = vbaCastObj(pIInspectable, pIID_IDirect3DDevice)
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
        Call Release(pIGraphicsCaptureSessionStatics)
    End If
End Sub

Private Sub Class_Terminate()
    If m_hDC Then m_hDC = ReleaseDC(0, m_hDC)
    If m_hBitmap Then m_hBitmap = DeleteObject(m_hBitmap)
    Call CloseAndRelease(pIInspectable)
    Set objIDirect3DDevice = Nothing: Set objIDXGIDevice = Nothing
    Call Release(pIDirect3D11CaptureFramePoolStatics)
    Call Release(pIGraphicsCaptureWnd): Call Release(pIGraphicsCaptureMonitor)
    Call Release(m_pIGraphicsCaptureItemInterop)
End Sub

Friend Property Get IsInitialized() As Boolean
    IsInitialized = m_bIsInitialized
End Property

Friend Property Get Picture() As IPicture
    Call OleCreatePictureIndirect(VarPtr(m_PicDesc), pIID_IPicture, APITRUE, m_Picture)
    Set Picture = m_Picture
End Property

Friend Property Get hBitmap() As Long
    hBitmap = m_hBitmap
End Property

Friend Property Get hWnd(Optional bOverwriteWnd As Boolean) As Long
    hWnd = m_hWnd
End Property

Friend Property Let hWnd(Optional bOverwriteWnd As Boolean, lWnd As Long)
Dim rcWndRect As RECT
    If IsWindow(lWnd) Then
        If Not bOverwriteWnd Then If m_hWnd = lWnd Then Exit Property
        If Not IsMinimized(lWnd) Then
            m_hWnd = lWnd
            GetWindowRect m_hWnd, rcWndRect
            With rcWndRect: m_lWidth = .Right - .Left: m_lHeight = .bottom - .Top: End With
            If m_hBitmap Then DeleteObject m_hBitmap
            m_hBitmap = CreateCompatibleBitmap(m_hDC, m_lWidth, m_lHeight): m_PicDesc.hBitmap = m_hBitmap
            With m_BitmapInfo.bmiHeader: .biWidth = m_lWidth: .biHeight = -m_lHeight: End With
            If pIGraphicsCaptureWnd Then Call Release(pIGraphicsCaptureWnd)
            If Invoke(m_pIGraphicsCaptureItemInterop, IGraphicsCaptureItemInterop_CreateForWindow, m_hWnd, pIID_IGraphicsCaptureItem, VarPtr(pIGraphicsCaptureWnd)) = S_OK Then m_bIsInitialized = True
        End If
    End If
End Property

Friend Function CaptureWindow() As Boolean
    If m_hWnd Then If m_bIsInitialized Then If Not IsMinimized(m_hWnd) Then CaptureWindow = StartCapture(pIGraphicsCaptureWnd)
End Function

Friend Function CaptureMonitor() As Boolean
    If m_hMonitor Then If m_bIsInitialized Then CaptureMonitor = StartCapture(pIGraphicsCaptureMonitor)
End Function

Friend Sub SelectMonitorFromPoint(Optional X As Long, Optional Y As Long)
Dim mi As MONITORINFO
    m_hMonitor = MonitorFromPoint(X, Y, 2): mi.cbSize = LenB(mi): GetMonitorInfo m_hMonitor, VarPtr(mi)
    With mi.rcMonitor: m_lWidth = .Right - .Left: m_lHeight = .bottom - .Top: End With
    If m_hBitmap Then DeleteObject m_hBitmap
    m_hBitmap = CreateCompatibleBitmap(m_hDC, m_lWidth, m_lHeight): m_PicDesc.hBitmap = m_hBitmap
    With m_BitmapInfo.bmiHeader: .biWidth = m_lWidth: .biHeight = -m_lHeight: End With
    If pIGraphicsCaptureMonitor Then Call Release(pIGraphicsCaptureMonitor)
    If Invoke(m_pIGraphicsCaptureItemInterop, IGraphicsCaptureItemInterop_CreateForMonitor, m_hMonitor, pIID_IGraphicsCaptureItem, VarPtr(pIGraphicsCaptureMonitor)) = S_OK Then m_bIsInitialized = True
End Sub

Private Function StartCapture(ByVal pIGraphicsCaptureItem As Long) As Boolean
    Dim pIDirect3D11CaptureFramePool As Long
    If Invoke(pIDirect3D11CaptureFramePoolStatics, IDirect3D11CaptureFramePoolStatics_Create, ObjPtr(objIDirect3DDevice), DXGI_FORMAT_B8G8R8A8_UNORM, 1, m_lWidth, m_lHeight, VarPtr(pIDirect3D11CaptureFramePool)) = S_OK Then
        Dim pIGraphicsCaptureSession As Long
        If Invoke(pIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_CreateCaptureSession, pIGraphicsCaptureItem, VarPtr(pIGraphicsCaptureSession)) = S_OK Then
            Dim pIGraphicsCaptureSession2 As Long
            If Invoke(pIGraphicsCaptureSession, IUnknown_QueryInterface, pIID_IGraphicsCaptureSession_2, VarPtr(pIGraphicsCaptureSession2)) = S_OK Then
                Call Invoke(pIGraphicsCaptureSession2, IGraphicsCaptureSession2_PutIsCursorCaptureEnabled, 0&)
                Call Release(pIGraphicsCaptureSession2)
            End If
            Dim pIGraphicsCaptureSession3 As Long
            If Invoke(pIGraphicsCaptureSession, IUnknown_QueryInterface, pIID_IGraphicsCaptureSession_3, VarPtr(pIGraphicsCaptureSession3)) = S_OK Then
                Call Invoke(pIGraphicsCaptureSession3, IGraphicsCaptureSession3_PutIsBorderRequired, 0&)
                Call Release(pIGraphicsCaptureSession3)
            End If
            If Invoke(pIGraphicsCaptureSession, IGraphicsCaptureSession_StartCapture) = S_OK Then
                Dim pIDirect3D11CaptureFrame As Long
                While pIDirect3D11CaptureFrame = 0: Call Invoke(pIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_TryGetNextFrame, VarPtr(pIDirect3D11CaptureFrame)): Wend
                Dim pIDirect3DSurface As Long
                If Invoke(pIDirect3D11CaptureFrame, IDirect3D11CaptureFrame_GetSurface, VarPtr(pIDirect3DSurface)) = S_OK Then
                    StartCapture = GetImageFromIDirect3DSurface(pIDirect3DSurface)
                    Call CloseAndRelease(pIDirect3DSurface)
                End If
                Call CloseAndRelease(pIDirect3D11CaptureFrame)
            End If
            Call CloseAndRelease(pIGraphicsCaptureSession)
        End If
        Call CloseAndRelease(pIDirect3D11CaptureFramePool)
    End If
End Function

Private Function GetImageFromIDirect3DSurface(pIDirect3DSurface As Long) As Boolean
    Dim pIDirect3DDxgiInterfaceAccess As Long
    If Invoke(pIDirect3DSurface, IUnknown_QueryInterface, pIID_IDirect3DDxgiInterfaceAccess, VarPtr(pIDirect3DDxgiInterfaceAccess)) = S_OK Then
        Dim objID3D11Texture2D As VBD3D11.ID3D11Texture2D
        If Invoke(pIDirect3DDxgiInterfaceAccess, IDirect3DDxgiInterfaceAccess_GetInterface, pIID_ID3D11Texture2D, VarPtr(objID3D11Texture2D)) = S_OK Then
            Dim tD3D11_TEXTURE2D_DESC As VBD3D11.D3D11_TEXTURE2D_DESC
            objID3D11Texture2D.GetDesc tD3D11_TEXTURE2D_DESC
            With tD3D11_TEXTURE2D_DESC
                .Usage = D3D11_USAGE_STAGING: .CPUAccessFlags = D3D11_CPU_ACCESS_READ: .BindFlags = 0: .MiscFlags = 0
            End With
            Dim objID3D11Texture2D_2 As VBD3D11.ID3D11Texture2D
            Set objID3D11Texture2D_2 = objID3D11Device.CreateTexture2D(tD3D11_TEXTURE2D_DESC, ByVal 0&)
            If Not (objID3D11Texture2D_2 Is Nothing) Then
                Call objID3D11DeviceContext.CopyResource(objID3D11Texture2D_2, objID3D11Texture2D)
                Dim tD3D11_MAPPED_SUBRESOURCE As VBD3D11.D3D11_MAPPED_SUBRESOURCE, i As Long
                If objID3D11DeviceContext.Map(objID3D11Texture2D_2, 0, D3D11_MAP_READ, 0, tD3D11_MAPPED_SUBRESOURCE) = S_OK Then
                    With tD3D11_MAPPED_SUBRESOURCE
                        If m_lWidth * 4 = .RowPitch Then
                            SetDIBits 0, m_hBitmap, 0, m_lHeight, ByVal .pData, m_BitmapInfo, DIB_RGB_COLORS
                        Else
                            Dim PixelData() As Long
                            ReDim PixelData(0 To m_lWidth * m_lHeight - 1)
                            For i = 0 To m_lHeight - 1
                                CopyMemory PixelData(i * m_lWidth), ByVal .pData + i * .RowPitch, m_lWidth * 4
                            Next i
                            SetDIBits 0, m_hBitmap, 0, m_lHeight, PixelData(0), m_BitmapInfo, DIB_RGB_COLORS
                        End If
                    End With
                    objID3D11DeviceContext.Unmap objID3D11Texture2D_2, 0: GetImageFromIDirect3DSurface = True
                End If
            End If
        End If
        Call Release(pIDirect3DDxgiInterfaceAccess)
    End If
End Function

Private Function IsMinimized(lWnd As Long) As Boolean
    IsMinimized = GetWindowLong(lWnd, GWL_STYLE) And WS_MINIMIZE
End Function

Private Function GetActivationFactory(ByVal ClassName As String, ByVal iid As Long, pFactory As Long) As Boolean
Dim hString As Long
    If WindowsCreateString(StrPtr(ClassName), Len(ClassName), hString) = S_OK Then
        If hString Then
            If RoGetActivationFactory(hString, iid, pFactory) = S_OK Then GetActivationFactory = True
            Call WindowsDeleteString(hString)
        End If
    End If
End Function

Private Sub Release(pInterface As Long)
    If pInterface Then
        Call Invoke(pInterface, IUnknown_Release)
        pInterface = 0
    End If
End Sub

Private Sub CloseAndRelease(pInterface As Long)
    If pInterface Then
        Dim pIClosable As Long
        If Invoke(pInterface, IUnknown_QueryInterface, pIID_IClosable, VarPtr(pIClosable)) = S_OK Then
            Call Invoke(pIClosable, IClosable_Close)
            Call Release(pIClosable)
        End If
        Call Release(pInterface)
    End If
End Sub

Private Function Invoke(ByVal pInterface As Long, ByVal vtb As vtb_Interfaces, ParamArray aParam()) As Variant
Dim i As Long, ParamValues(0 To 9) As Long, ParamTypes(0 To 9) As Integer, varParam As Variant, varRet As Variant
    If pInterface Then
        varParam = aParam
        For i = 0 To UBound(varParam)
            ParamTypes(i) = VarType(varParam(i))
            ParamValues(i) = VarPtr(varParam(i))
        Next i
        Call DispCallFunc(pInterface, vtb * 4, CC_STDCALL, vbLong, i, ParamTypes(0), ParamValues(0), varRet)
        Invoke = varRet
    End If
End Function

Here's a screenshot captured from my second monitor (12.5ms for a FullHD screenshot 1920x1080 including the conversion to GDI Bitmap):



And the demo project: VBC_UwpCapturePicker.zip, requires the VBD3D11 TypeLib for the D3D11 calls and Bruce McKinney's Windows Unicode API Type Library for the rest of API functions, types and constants.

[-Franky-]

Very good work. If fafalone releases a TLB for WinRT, then you will certainly be able to get even more speed and possibilities out of it.

[VanGoghGaming]

Yep, even an incomplete WinRT TypeLib would be a lot better than nothing at all.

Also I wanted to ask you why are there two invoke functions "Invoke" and "OleInvoke" that call each other and take exactly the same parameters? Is this some trick involving ParamArrays and Variants? I'm having a hard time understanding what's going on in there...

Private Function Invoke(ByVal pInterface As Long, ByVal vtb As vtb_Interfaces, ParamArray aParam()) As Variant
    If pInterface Then Invoke = OleInvoke(pInterface, vtb, aParam)
End Function

Private Function OleInvoke(ByVal pInterface As Long, ByVal lngCmd As Long, ParamArray aParam()) As Variant
Dim lngCount As Long, lngItem As Long, oleParameter(0 To 9) As Long, oleType(0 To 9) As Integer, varParam As Variant, varRet As Variant
    If UBound(aParam) >= 0 Then
        varParam = aParam
        If IsArray(varParam) Then varParam = varParam(0)
        lngCount = UBound(varParam)
        For lngItem = 0 To lngCount
            oleType(lngItem) = VarType(varParam(lngItem))
            oleParameter(lngItem) = VarPtr(varParam(lngItem))
        Next lngItem
    End If
    Call DispCallFunc(pInterface, lngCmd * 4, CC_STDCALL, vbLong, lngItem, VarPtr(oleType(0)), VarPtr(oleParameter(0)), varRet)
    OleInvoke = varRet
End Function

At first glance it looks that the first function is superfluous but removing it will cause "DispCallFunc" to fail...

[VanGoghGaming]

Removed the "ByVal" from those two "DispCallFunc" parameters colored in red because "ByVal as Any" doesn't make much sense in my opinion:

Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal cc As Long, ByVal vtReturn As VbVarType,
ByVal cActuals As Long, ByVal prgvt As Any, ByVal prgpvarg As Any, ByRef pvargResult As Variant) As Long

Also rewrote those two "Invoke" functions as one to shave a few more milliseconds of execution speed. As far as I can see the behavior is exactly the same as it was before:

Private Function Invoke(ByVal pInterface As Long, ByVal vtb As vtb_Interfaces, ParamArray aParam()) As Variant
Dim i As Long, ParamValues(0 To 9) As Long, ParamTypes(0 To 9) As Integer, varParam As Variant, varRet As Variant
    If pInterface Then
        varParam = aParam
        For i = 0 To UBound(aParam)
            ParamTypes(i) = VarType(aParam(i))
            ParamValues(i) = VarPtr(varParam(i)) ' VarPtr(aParam(i)) <-- This doesn't work... Why?
        Next i
        Call DispCallFunc(pInterface, vtb * 4, CC_STDCALL, vbLong, i, ParamTypes(0), ParamValues(0), varRet)
        Invoke = varRet
    End If
End Function

I'm still not clear why does the ParamArray need to be saved in a local variant before being processed. Maybe someone more savvy with these intricacies could shed some light into the matter?

EDIT: I think this article does a pretty good job at explaining this scenario.

[Niya]

I'm still not clear why does the ParamArray need to be saved in a local variant before being processed.

Olaf explained this to me once. It has something to do with the VT_BYREF flag.

Here's an excerpt from one of my own submissions:-

Public Function CallFunctionPointer(ByVal funcPtr As Long, ByVal returnType As VbVarType, ParamArray args() As Variant) As Variant
    'Use this function to call any function pointer with any amount
    'and types of parameters and any return value
    '****************************************************************
    
    Dim DispCallFuncResult As Long
    Dim i As Long
    Dim params() As Long
    Dim paramTypes() As Integer
    Dim args2() As Variant
    
    'VERY IMPORTANT
    '*******************************************************
    'params(i) = VarPtr(args(i))
    'The above assignment in the loop doesn't work correctly because it's working
    'directly on the ParamArray array. There are two ways to fix it.
    'You could do this:-
    'params(i) = VarPtr(CVar(args(i)))
    'or you could copy the ParamArray arguments to a local array of Variants
    'and loop on that instead. I chose this second approach.
    'Without this correction, wrong values can get passed as arguments to the function
    'we are going to call with DispCallFunc if those arguments were passed in using variables
    'when CallFunctionPointer was caled.
    'I have no idea why this happens. All I know this fixes it.
    '*******************************************************
    'UPDATE:-
    '*******************************************************
    'Credit to Olaf Schmidt for providing and answer to this.
    'It turns out that the bug was caused by the VT_BYREF flag
    'being set on Variants when a variable is passed as an argument in the
    'ParamArray parameter
    '*******************************************************
     args2 = args
    
    ReDim params(0 To UBound(args2))
    ReDim paramTypes(0 To UBound(args2))
        
    For i = 0 To UBound(args2)
        params(i) = VarPtr(args2(i))
        paramTypes(i) = VarType(args2(i))
    Next
    
    DispCallFuncResult = DispCallFunc(0, funcPtr, CLng(4), CInt(returnType), UBound(args2) + 1, VarPtr(paramTypes(0)), VarPtr(params(0)), VarPtr(CallFunctionPointer))
    
    If DispCallFuncResult <> 0 Then Err.Raise 12000, , "Function pointer call failed"
End Function

That is from this submission and the comments explain why you have to copy the arguments.

[VanGoghGaming]

Thanks Niya, the article I linked above (by Raymond Chen) explains pretty much the same thing. I found it by googling for "variant vs variantarg" when reading the description of DispCallFunc.

Btw, I like your ASM example as well as the other articles you linked showing how to use this function in some clever ways! Fun fact, the first time I've seen this function I thought the "Disp" comes from "Display" and it didn't make sense at all!

[VanGoghGaming]

It's too bad that WinRT doesn't implement IDispatch. I've found this old code (now archived in the Wayback Machine) showing how to call the Invoke method of IDispatch. It was using "olelib" but it works just fine with "oleexp" instead:

Enum InvokeCall
   PropGet = INVOKE_PROPERTYGET
   PropLet = INVOKE_PROPERTYPUT
   PropSet = INVOKE_PROPERTYPUTREF
   Method = INVOKE_FUNC
End Enum
'------------------------------------------------------------------
' Procedure : CallByNameEx
' Purpose   : Calls an object function/property by name or DISPID
'             taking the parameters as ParamArray.
'------------------------------------------------------------------
'
Public Function CallByNameEx(Object As Object, ByVal Name As Variant, ByVal CallType As InvokeCall, ParamArray Args() As Variant) As Variant
Dim lDISPID As Long
Dim tDISPPARAMS As oleexp.DISPPARAMS
Dim avParams() As Variant
Dim lNamedParam As Long
Dim lIdx As Long
Dim lParamCount As Long
   ' Get the DISPID
   lDISPID = GetDISPID(Object, Name)
   If Not IsMissing(Args) Then
      ' Get parameters count
      lParamCount = UBound(Args) - LBound(Args)
      ReDim avParams(0 To lParamCount)
      ' Copy the array in reverse order
      For lIdx = 0 To lParamCount
         VariantCopy avParams(lParamCount - lIdx), Args(lIdx)
      Next
      With tDISPPARAMS
         .cArgs = lParamCount + 1
         .rgPointerToVariantArray = VarPtr(avParams(0))
      End With
      If CallType = INVOKE_PROPERTYPUT Or _
         CallType = INVOKE_PROPERTYPUTREF Then
         lNamedParam = DISPID_PROPERTYPUT
         With tDISPPARAMS
            .cNamedArgs = 1
            .rgPointerToLONGNamedArgs = VarPtr(lNamedParam)
         End With
      End If
   End If
   CallInvoke Object, lDISPID, CallType, tDISPPARAMS, CallByNameEx
End Function
'------------------------------------------------------------------
' Procedure : GetDISPID
' Purpose   : Returns the DISPID of a member
'------------------------------------------------------------------
'
Private Function GetDISPID(ByVal Object As oleexp.IDispatch, Name As Variant) As Long
' NULL interface ID
Dim IID_NULL As oleexp.UUID
   If IsNumeric(Name) Then
      ' Return the value
      GetDISPID = CLng(Name)
   Else
      ' Get the DISPID using the name
      Object.GetIDsOfNames IID_NULL, CStr(Name), 1, 0, GetDISPID
   End If
End Function

'------------------------------------------------------------------
' Procedure : CallInvoke
' Purpose   : Calls the Invoke method of IDispatch
'------------------------------------------------------------------
'
Private Sub CallInvoke(ByVal Object As oleexp.IDispatch, ByVal DISPID As Long, ByVal CallType As Long, Params As oleexp.DISPPARAMS, Result As Variant)
' NULL interface ID
Dim IID_NULL As oleexp.UUID
' Exception Error info
Dim tEXCEPINFO As oleexp.EXCEPINFO
' Argument that produced the error
Dim lArgErr As Long
' Call result
Dim lResult As Long
   ' Invoke method/property
   lResult = Object.Invoke(DISPID, IID_NULL, 0, CallType, Params, VarPtr(Result), tEXCEPINFO, lArgErr)
   If lResult <> 0 Then
      ' There was an error
      ' If the error is DISP_E_EXCEPTION
      ' we can get the error description
      ' from the EXCEPINFO structure.
      If lResult = DISP_E_EXCEPTION Then
         With tEXCEPINFO
            ' Raise the error using
            ' the EXCEPINFO data
            Err.Raise .wCode, .Source, .Description, .HelpFile, .dwHelpContext
         End With
      Else
         ' Raise the error using the HRESULT
         Err.Raise lResult
      End If
   End If
End Sub

[xxdoc123]

@Franky


And the demo project: Attachment 187467, requires the VBD3D11 TypeLib for the D3D11 calls.

It's great to be able to take screenshots of video images~

I want to cooperate with image recognition to do screen monitoring

[VanGoghGaming]

Feel free to contribute with your code about image recognition.

If we are talking strictly about taking screenshots of videos then you could always do that with a simple "BitBlt" from the desktop window. This "WinRT Capture" approach has two main advantages over that:

1. It works while the video is playing in the background as long as its window is not minimized.
2. You can capture multiple frames at a time (I think the number of frames is capped at the refresh rate of your monitor, for example 60 frames per second).

You can modify the number of frames in the following line of code. Where it currently says "1", you can put any number of frames:

Invoke(pIDirect3D11CaptureFramePoolStatics, IDirect3D11CaptureFramePoolStatics_Create, ObjPtr(objIDirect3DDevice), _
DXGI_FORMAT_B8G8R8A8_UNORM, 1, m_lWidth, m_lHeight, VarPtr(pIDirect3D11CaptureFramePool))

Using this method you can actually stream the video in real time straight into a PictureBox. The following code streams 1 second of video (60 frames) into the PictureBox from the main form. It's as fluid as the actual video player:

Private Function StartCapture(ByVal pIGraphicsCaptureItem As Long) As Boolean
    Dim pIDirect3D11CaptureFramePool As Long, lFrames As Long
    lFrames = 60
    If Invoke(pIDirect3D11CaptureFramePoolStatics, IDirect3D11CaptureFramePoolStatics_Create, ObjPtr(objIDirect3DDevice), DXGI_FORMAT_B8G8R8A8_UNORM, lFrames, m_lWidth, m_lHeight, VarPtr(pIDirect3D11CaptureFramePool)) = S_OK Then
        Dim pIGraphicsCaptureSession As Long
        If Invoke(pIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_CreateCaptureSession, pIGraphicsCaptureItem, VarPtr(pIGraphicsCaptureSession)) = S_OK Then
            Dim pIGraphicsCaptureSession2 As Long
            If Invoke(pIGraphicsCaptureSession, IUnknown_QueryInterface, pIID_IGraphicsCaptureSession_2, VarPtr(pIGraphicsCaptureSession2)) = S_OK Then
                Call Invoke(pIGraphicsCaptureSession2, IGraphicsCaptureSession2_PutIsCursorCaptureEnabled, 0&)
                Call Release(pIGraphicsCaptureSession2)
            End If
            Dim pIGraphicsCaptureSession3 As Long
            If Invoke(pIGraphicsCaptureSession, IUnknown_QueryInterface, pIID_IGraphicsCaptureSession_3, VarPtr(pIGraphicsCaptureSession3)) = S_OK Then
                Call Invoke(pIGraphicsCaptureSession3, IGraphicsCaptureSession3_PutIsBorderRequired, 0&)
                Call Release(pIGraphicsCaptureSession3)
            End If
            If Invoke(pIGraphicsCaptureSession, IGraphicsCaptureSession_StartCapture) = S_OK Then
                Dim pIDirect3D11CaptureFrame As Long, i As Long
                For i = 0 To lFrames - 1
                    While pIDirect3D11CaptureFrame = 0: Call Invoke(pIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_TryGetNextFrame, VarPtr(pIDirect3D11CaptureFrame)): Wend
                    Dim pIDirect3DSurface As Long
                    If Invoke(pIDirect3D11CaptureFrame, IDirect3D11CaptureFrame_GetSurface, VarPtr(pIDirect3DSurface)) = S_OK Then
                        StartCapture = GetImageFromIDirect3DSurface(pIDirect3DSurface)
                        Call CloseAndRelease(pIDirect3DSurface)
                    End If
                    Call CloseAndRelease(pIDirect3D11CaptureFrame)
                    Set frmMain.picCapture.Picture = Picture
                Next i
            End If
            Call CloseAndRelease(pIGraphicsCaptureSession)
        End If
        Call CloseAndRelease(pIDirect3D11CaptureFramePool)
    End If
End Function

[OptionBase1]

No offense, but when I come back, I'm sitting over there.

[xxdoc123]

Feel free to contribute with your code about image recognition.

If we are talking strictly about taking screenshots of videos then you could always do that with a simple "BitBlt" from the desktop window. This "WinRT Capture" approach has two main advantages over that:

1. It works while the video is playing in the background as long as its window is not minimized.
2. You can capture multiple frames at a time (I think the number of frames is capped at the refresh rate of your monitor, for example 60 frames per second).

You can modify the number of frames in the following line of code. Where it currently says "1", you can put any number of frames:

Invoke(pIDirect3D11CaptureFramePoolStatics, IDirect3D11CaptureFramePoolStatics_Create, ObjPtr(objIDirect3DDevice), _
DXGI_FORMAT_B8G8R8A8_UNORM, 1, m_lWidth, m_lHeight, VarPtr(pIDirect3D11CaptureFramePool))

Using this method you can actually stream the video in real time straight into a PictureBox. The following code streams 1 second of video (60 frames) into the PictureBox from the main form. It's as fluid as the actual video player:

Private Function StartCapture(ByVal pIGraphicsCaptureItem As Long) As Boolean
    Dim pIDirect3D11CaptureFramePool As Long, lFrames As Long
    lFrames = 60
    If Invoke(pIDirect3D11CaptureFramePoolStatics, IDirect3D11CaptureFramePoolStatics_Create, ObjPtr(objIDirect3DDevice), DXGI_FORMAT_B8G8R8A8_UNORM, lFrames, m_lWidth, m_lHeight, VarPtr(pIDirect3D11CaptureFramePool)) = S_OK Then
        Dim pIGraphicsCaptureSession As Long
        If Invoke(pIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_CreateCaptureSession, pIGraphicsCaptureItem, VarPtr(pIGraphicsCaptureSession)) = S_OK Then
            Dim pIGraphicsCaptureSession2 As Long
            If Invoke(pIGraphicsCaptureSession, IUnknown_QueryInterface, pIID_IGraphicsCaptureSession_2, VarPtr(pIGraphicsCaptureSession2)) = S_OK Then
                Call Invoke(pIGraphicsCaptureSession2, IGraphicsCaptureSession2_PutIsCursorCaptureEnabled, 0&)
                Call Release(pIGraphicsCaptureSession2)
            End If
            Dim pIGraphicsCaptureSession3 As Long
            If Invoke(pIGraphicsCaptureSession, IUnknown_QueryInterface, pIID_IGraphicsCaptureSession_3, VarPtr(pIGraphicsCaptureSession3)) = S_OK Then
                Call Invoke(pIGraphicsCaptureSession3, IGraphicsCaptureSession3_PutIsBorderRequired, 0&)
                Call Release(pIGraphicsCaptureSession3)
            End If
            If Invoke(pIGraphicsCaptureSession, IGraphicsCaptureSession_StartCapture) = S_OK Then
                Dim pIDirect3D11CaptureFrame As Long, i As Long
                For i = 0 To lFrames - 1
                    While pIDirect3D11CaptureFrame = 0: Call Invoke(pIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_TryGetNextFrame, VarPtr(pIDirect3D11CaptureFrame)): Wend
                    Dim pIDirect3DSurface As Long
                    If Invoke(pIDirect3D11CaptureFrame, IDirect3D11CaptureFrame_GetSurface, VarPtr(pIDirect3DSurface)) = S_OK Then
                        StartCapture = GetImageFromIDirect3DSurface(pIDirect3DSurface)
                        Call CloseAndRelease(pIDirect3DSurface)
                    End If
                    Call CloseAndRelease(pIDirect3D11CaptureFrame)
                    Set frmMain.picCapture.Picture = Picture
                Next i
            End If
            Call CloseAndRelease(pIGraphicsCaptureSession)
        End If
        Call CloseAndRelease(pIDirect3D11CaptureFramePool)
    End If
End Function

good idea.

I'm actually controlling my old phone with scrcpy. By taking a screenshot, you can get the picture in the mobile phone, and by analyzing the image, give me an alarm when I am not looking at the mobile phone.
When I was using it, I found that if scrcpy is partially hidden outside the desktop view, only part of the screenshot will be displayed. Images hidden from view on the desktop are static.Click the screenshot button several times and find that there is a difference between the screenshot and the actual phone screen

you can see scrcpy form this url，thanks

https://github.com/Genymobile/scrcpy

[VanGoghGaming]

Very good work. If fafalone releases a TLB for WinRT, then you will certainly be able to get even more speed and possibilities out of it.

Is there a TypeLib available for WinRT?

No, there is no TypeLib available for WinRT. TypeLibs, or Type Libraries, are a type of binary file that contain information about the interfaces and types defined in a COM component. WinRT, on the other hand, is a modern, component-based programming model that is designed to replace COM.

WinRT provides its own metadata format, called Windows Metadata (WinMD), which is similar to TypeLibs but is specifically designed for the WinRT platform. WinMD files contain information about the types, methods, events, and other members defined in WinRT components, and can be used by compilers and tools to generate code and validate usage.

Unlike COM TypeLibs, WinMD files are an integral part of the WinRT runtime, and are automatically generated for all WinRT components. Developers do not need to create or manage WinMD files directly, but can instead rely on the tools and services provided by the WinRT platform to handle metadata and component registration.

In summary, while there is no TypeLib available for WinRT, there is an equivalent metadata format called WinMD that serves a similar purpose and is used extensively in WinRT development.

How can you use WinMD files in Visual Basic 6?

Unfortunately, Visual Basic 6 does not have built-in support for WinMD files or the WinRT platform. VB6 is an older technology that was released before WinRT was introduced, and as such, it does not include the necessary components and language features to consume WinMD files.

However, it may be possible to use WinMD files in VB6 by creating a wrapper component in a language that supports WinRT, such as C++ or C#, and then calling this component from VB6. The wrapper component would provide a simple, VB6-compatible interface that exposes the WinRT functionality, allowing VB6 code to call the WinRT APIs indirectly through the wrapper.

Alternatively, it may be possible to use the Windows API Code Pack for .NET, which provides a set of .NET wrappers for many WinRT APIs, and then use COM interop to access these wrappers from VB6. However, this approach may be more complex and may require more effort to set up and maintain.

In general, while it may be possible to use WinMD files in VB6 with some workarounds and additional components, it is generally recommended to use a more modern development platform that fully supports WinRT, such as .NET or UWP. These platforms provide better tooling and integration with WinRT, making it easier to create high-quality, cross-platform applications.

TL;DR: ChatGPT doesn't have much faith in fafalone!

[dima0909]

@Franky - I've managed to optimize your CapturePicker class to achieve decent capturing speeds now. Stripped it down to the bare minimum required to capture either a whole monitor or a specific window and replaced some "Invokes" with direct calls from a D3D11 TypeLib. It turns out much of the code needs to be executed only once, not every time a capture is taken. That was killing the capture speed before!

frmMain.frm

Option Explicit

Private Sub cmdCaptureMonitor_Click()
    StartTiming
    If clsCapturePicker.CaptureMonitor() Then
        Set picCapture.Picture = clsCapturePicker.Picture
    Else
        Set picCapture.Picture = LoadPicture()
    End If
    lblTiming = Elapsed
End Sub

Private Sub cmdCaptureWindow_Click()
    clsCapturePicker.hWnd = Me.hWnd
    StartTiming
    If clsCapturePicker.CaptureWindow() Then
        Set picCapture.Picture = clsCapturePicker.Picture
    Else
        Set picCapture.Picture = LoadPicture()
    End If
    lblTiming = Elapsed
End Sub

Private Sub Form_Load()
    QueryPerformanceFrequency cFrequency
    Me.Show
    clsCapturePicker.SelectMonitorFromPoint 1920, 0
End Sub

mdlTiming.bas

Option Explicit

Public seqStart As Currency, seqStop As Currency, cFrequency As Currency

Public Sub StartTiming()
    QueryPerformanceCounter seqStart
End Sub

Public Function Elapsed() As Double
    QueryPerformanceCounter seqStop
    Elapsed = (seqStop - seqStart) * 1000 / cFrequency
End Function

clsCapturePicker.cls

Option Explicit

Private Const IID_IPicture As String = "{7bf80980-bf32-101a-8bbb-00aa00300cab}"
Private Const IID_IClosable As String = "{30d5a829-7fa4-4026-83bb-d75bae4ea99e}"
Private Const IID_IDXGIDevice As String = "{54ec77fa-1377-44e6-8c32-88fd5f44c84c}"
Private Const IID_IDirect3DDevice As String = "{a37624ab-8d5f-4650-9d3e-9eae3d9bc670}"
Private Const WindowsGraphicsCaptureGraphicsCaptureSession As String = "Windows.Graphics.Capture.GraphicsCaptureSession"
Private Const IID_IGraphicsCaptureSession As String = "{814e42a9-f70f-4ad7-939b-fddcc6eb880d}"
Private Const IID_IGraphicsCaptureSession_2 As String = "{2c39ae40-7d2e-5044-804e-8b6799d4cf9e}"
Private Const IID_IGraphicsCaptureSession_3 As String = "{f2cdd966-22ae-5ea1-9596-3a289344c3be}"
Private Const IID_IGraphicsCaptureSessionStatics As String = "{2224a540-5974-49aa-b232-0882536f4cb5}"
Private Const WindowsGraphicsCaptureGraphicsCaptureItem As String = "Windows.Graphics.Capture.GraphicsCaptureItem"
Private Const IID_IGraphicsCaptureItemInterop As String = "{3628e81b-3cac-4c60-b7f4-23ce0e0c3356}"
Private Const IID_IGraphicsCaptureItem As String = "{79c3f95b-31f7-4ec2-a464-632ef5d30760}"
Private Const WindowsGraphicsCaptureDirect3D11CaptureFramePool As String = "Windows.Graphics.Capture.Direct3D11CaptureFramePool"
Private Const IID_IDirect3D11CaptureFramePoolStatics As String = "{7784056a-67aa-4d53-ae54-1088d5a8ca21}"
Private Const IID_ID3D11Texture2D As String = "{6f15aaf2-d208-4e89-9ab4-489535d34f9c}"
Private Const IID_IDirect3DDxgiInterfaceAccess As String = "{a9b3d012-3df2-4ee3-b8d1-8695f457d3c1}"

Private Enum vtb_Interfaces
    ' IUnknown
    IUnknown_QueryInterface = 0
    IUnknown_Release = 2
    ' IClosable
    IClosable_Close = 6
    ' IGraphicsCaptureSessionStatics
    IGraphicsCaptureSessionStatics_IsSupported = 6
    ' IGraphicsCaptureItem
    IGraphicsCaptureItem_GetDisplayName = 6
    IGraphicsCaptureItem_GetSize = 7
    ' IDirect3D11CaptureFramePoolStatics
    IDirect3D11CaptureFramePoolStatics_Create = 6
    ' IDirect3D11CaptureFramePool
    IDirect3D11CaptureFramePool_TryGetNextFrame = 7
    IDirect3D11CaptureFramePool_CreateCaptureSession = 10
    ' IGraphicsCaptureSession
    IGraphicsCaptureSession_StartCapture = 6
    ' IGraphicsCaptureSession2
    IGraphicsCaptureSession2_GetIsCursorCaptureEnabled = 6
    IGraphicsCaptureSession2_PutIsCursorCaptureEnabled = 7
    ' IGraphicsCaptureSession3
    IGraphicsCaptureSession3_GetIsBorderRequired = 6
    IGraphicsCaptureSession3_PutIsBorderRequired = 7
    ' IDirect3D11CaptureFrame
    IDirect3D11CaptureFrame_GetSurface = 6
    ' IDirect3DDxgiInterfaceAccess
    IDirect3DDxgiInterfaceAccess_GetInterface = 3
    ' ID3D11Texture2D
    ID3D11Texture2D_GetDesc = 10
    ' ID3D11Device
    ID3D11Device_CreateTexture2D = 5
    ' ID3D11DeviceContext
    ID3D11DeviceContext_Map = 14
    ID3D11DeviceContext_Unmap = 15
    ID3D11DeviceContext_CopyResource = 47
     ' IGraphicsCaptureItemInterop
    IGraphicsCaptureItemInterop_CreateForWindow = 3
    IGraphicsCaptureItemInterop_CreateForMonitor = 4
End Enum

Private Type MONITORINFO
    cbSize As Long
    rcMonitor As RECT
    rcWork As RECT
    dwFlags As Long
End Type

Private Declare Function vbaCastObj Lib "msvbvm60" Alias "__vbaCastObj" (ByVal pObj As Long, ByVal pIID As Long) As IUnknown
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal cc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgvt As Any, prgpvarg As Any, pvargResult As Variant) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (ByVal lpPictDesc As Long, ByVal riid As Long, ByVal fOwn As Long, lplpvObj As IPicture) As Long
Private Declare Function IIDFromString Lib "combase" (ByVal lpsz As Long, lpiid As Any) As Long
Private Declare Function WindowsCreateString Lib "combase" (ByVal sourceString As Long, ByVal length As Long, hString As Long) As Long
Private Declare Function WindowsDeleteString Lib "combase" (ByVal sourceString As Long) As Long
Private Declare Function RoGetActivationFactory Lib "combase" (ByVal activatableClassId As Long, ByVal riid As Long, pFactory As Long) As Long
Private Declare Function GetMonitorInfo Lib "user32" Alias "GetMonitorInfoW" (ByVal hMonitor As Long, ByVal lpmi As Long) As Long
Private Declare Function MonitorFromPoint Lib "user32" (ByVal X As Long, ByVal Y As Long, ByVal dwFlags As Long) As Long
Private Declare Function CreateDirect3D11DeviceFromDXGIDevice Lib "d3d11" (ByVal dxgiDevice As Long, graphicsDevice As Long) As Long

Private IIDs(0 To 51) As Long, pIID_IClosable As Long, pIID_IDXGIDevice As Long, pIID_IDirect3DDevice As Long, pIID_IGraphicsCaptureSession As Long, pIID_IGraphicsCaptureSession_2 As Long, _
        pIID_IGraphicsCaptureSessionStatics As Long, pIID_IGraphicsCaptureItemInterop As Long, pIID_IGraphicsCaptureItem As Long, pIID_IDirect3D11CaptureFramePoolStatics As Long, _
        pIID_ID3D11Texture2D As Long, pIID_IPicture As Long, pIID_IDirect3DDxgiInterfaceAccess As Long, pIID_IGraphicsCaptureSession_3 As Long, pIID_IGraphicsCaptureAccessStatics As Long

Private m_Picture As IPicture, m_bIsInitialized As Boolean, m_hWnd As Long, m_hMonitor As Long, m_lWidth As Long, m_lHeight As Long, m_hDC As Long, m_hBitmap As Long, _
        m_BitmapInfo As BITMAPINFO, m_PicDesc As PICTDESCBMP

Private m_pIGraphicsCaptureItemInterop As Long, objID3D11Device As VBD3D11.ID3D11Device, objID3D11DeviceContext As VBD3D11.ID3D11DeviceContext, objIDXGIDevice As VBD3D11.IDXGIDevice, _
         pIDirect3D11CaptureFramePoolStatics As Long, pIInspectable As Long, objIDirect3DDevice As IUnknown, pIGraphicsCaptureWnd As Long, pIGraphicsCaptureMonitor As Long

Private Sub Class_Initialize()
    IIDFromString StrPtr(IID_IClosable), IIDs(0): pIID_IClosable = VarPtr(IIDs(0))
    IIDFromString StrPtr(IID_IDXGIDevice), IIDs(4): pIID_IDXGIDevice = VarPtr(IIDs(4))
    IIDFromString StrPtr(IID_IDirect3DDevice), IIDs(8): pIID_IDirect3DDevice = VarPtr(IIDs(8))
    IIDFromString StrPtr(IID_IGraphicsCaptureSession), IIDs(12): pIID_IGraphicsCaptureSession = VarPtr(IIDs(12))
    IIDFromString StrPtr(IID_IGraphicsCaptureSession_2), IIDs(16): pIID_IGraphicsCaptureSession_2 = VarPtr(IIDs(16))
    IIDFromString StrPtr(IID_IGraphicsCaptureSession_3), IIDs(20): pIID_IGraphicsCaptureSession_3 = VarPtr(IIDs(20))
    IIDFromString StrPtr(IID_IGraphicsCaptureSessionStatics), IIDs(24): pIID_IGraphicsCaptureSessionStatics = VarPtr(IIDs(24))
    IIDFromString StrPtr(IID_IGraphicsCaptureItemInterop), IIDs(28): pIID_IGraphicsCaptureItemInterop = VarPtr(IIDs(28))
    IIDFromString StrPtr(IID_IGraphicsCaptureItem), IIDs(32): pIID_IGraphicsCaptureItem = VarPtr(IIDs(32))
    IIDFromString StrPtr(IID_IDirect3D11CaptureFramePoolStatics), IIDs(36): pIID_IDirect3D11CaptureFramePoolStatics = VarPtr(IIDs(36))
    IIDFromString StrPtr(IID_ID3D11Texture2D), IIDs(40): pIID_ID3D11Texture2D = VarPtr(IIDs(40))
    IIDFromString StrPtr(IID_IDirect3DDxgiInterfaceAccess), IIDs(44): pIID_IDirect3DDxgiInterfaceAccess = VarPtr(IIDs(44))
    IIDFromString StrPtr(IID_IPicture), IIDs(48): pIID_IPicture = VarPtr(IIDs(48))
    m_BitmapInfo.bmiHeader.biSize = LenB(m_BitmapInfo.bmiHeader): m_BitmapInfo.bmiHeader.biPlanes = 1: m_BitmapInfo.bmiHeader.biBitCount = 32
    m_PicDesc.cbSizeofstruct = LenB(m_PicDesc): m_PicDesc.picType = vbPicTypeBitmap: m_hDC = GetDC(0)
    Dim pIGraphicsCaptureSessionStatics As Long
    If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureSession, pIID_IGraphicsCaptureSessionStatics, pIGraphicsCaptureSessionStatics) Then
        Dim bIsSupported As Boolean
        If Invoke(pIGraphicsCaptureSessionStatics, IGraphicsCaptureSessionStatics_IsSupported, VarPtr(bIsSupported)) = S_OK Then
            If bIsSupported Then
                If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureItem, pIID_IGraphicsCaptureItemInterop, m_pIGraphicsCaptureItemInterop) Then
                    If GetActivationFactory(WindowsGraphicsCaptureDirect3D11CaptureFramePool, pIID_IDirect3D11CaptureFramePoolStatics, pIDirect3D11CaptureFramePoolStatics) Then
                        If VBD3D11.D3D11CreateDevice(Nothing, D3D_DRIVER_TYPE_HARDWARE, 0, D3D11_CREATE_DEVICE_BGRA_SUPPORT, ByVal 0&, 0, D3D11_SDK_VERSION, objID3D11Device, 0, objID3D11DeviceContext) = S_OK Then
                            Set objIDXGIDevice = vbaCastObj(ObjPtr(objID3D11Device), pIID_IDXGIDevice)
                            If Not (objIDXGIDevice Is Nothing) Then
                                If CreateDirect3D11DeviceFromDXGIDevice(ObjPtr(objIDXGIDevice), pIInspectable) = S_OK Then
                                    Set objIDirect3DDevice = vbaCastObj(pIInspectable, pIID_IDirect3DDevice)
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
        Call Release(pIGraphicsCaptureSessionStatics)
    End If
End Sub

Private Sub Class_Terminate()
    If m_hDC Then m_hDC = ReleaseDC(0, m_hDC)
    If m_hBitmap Then m_hBitmap = DeleteObject(m_hBitmap)
    Call CloseAndRelease(pIInspectable)
    Set objIDirect3DDevice = Nothing: Set objIDXGIDevice = Nothing
    Call Release(pIDirect3D11CaptureFramePoolStatics)
    Call Release(pIGraphicsCaptureWnd): Call Release(pIGraphicsCaptureMonitor)
    Call Release(m_pIGraphicsCaptureItemInterop)
End Sub

Friend Property Get IsInitialized() As Boolean
    IsInitialized = m_bIsInitialized
End Property

Friend Property Get Picture() As IPicture
    Call OleCreatePictureIndirect(VarPtr(m_PicDesc), pIID_IPicture, APITRUE, m_Picture)
    Set Picture = m_Picture
End Property

Friend Property Get hBitmap() As Long
    hBitmap = m_hBitmap
End Property

Friend Property Get hWnd(Optional bOverwriteWnd As Boolean) As Long
    hWnd = m_hWnd
End Property

Friend Property Let hWnd(Optional bOverwriteWnd As Boolean, lWnd As Long)
Dim rcWndRect As RECT
    If IsWindow(lWnd) Then
        If Not bOverwriteWnd Then If m_hWnd = lWnd Then Exit Property
        If Not IsMinimized(lWnd) Then
            m_hWnd = lWnd
            GetWindowRect m_hWnd, rcWndRect
            With rcWndRect: m_lWidth = .Right - .Left: m_lHeight = .bottom - .Top: End With
            If m_hBitmap Then DeleteObject m_hBitmap
            m_hBitmap = CreateCompatibleBitmap(m_hDC, m_lWidth, m_lHeight): m_PicDesc.hBitmap = m_hBitmap
            With m_BitmapInfo.bmiHeader: .biWidth = m_lWidth: .biHeight = -m_lHeight: End With
            If pIGraphicsCaptureWnd Then Call Release(pIGraphicsCaptureWnd)
            If Invoke(m_pIGraphicsCaptureItemInterop, IGraphicsCaptureItemInterop_CreateForWindow, m_hWnd, pIID_IGraphicsCaptureItem, VarPtr(pIGraphicsCaptureWnd)) = S_OK Then m_bIsInitialized = True
        End If
    End If
End Property

Friend Function CaptureWindow() As Boolean
    If m_hWnd Then If m_bIsInitialized Then If Not IsMinimized(m_hWnd) Then CaptureWindow = StartCapture(pIGraphicsCaptureWnd)
End Function

Friend Function CaptureMonitor() As Boolean
    If m_hMonitor Then If m_bIsInitialized Then CaptureMonitor = StartCapture(pIGraphicsCaptureMonitor)
End Function

Friend Sub SelectMonitorFromPoint(Optional X As Long, Optional Y As Long)
Dim mi As MONITORINFO
    m_hMonitor = MonitorFromPoint(X, Y, 2): mi.cbSize = LenB(mi): GetMonitorInfo m_hMonitor, VarPtr(mi)
    With mi.rcMonitor: m_lWidth = .Right - .Left: m_lHeight = .bottom - .Top: End With
    If m_hBitmap Then DeleteObject m_hBitmap
    m_hBitmap = CreateCompatibleBitmap(m_hDC, m_lWidth, m_lHeight): m_PicDesc.hBitmap = m_hBitmap
    With m_BitmapInfo.bmiHeader: .biWidth = m_lWidth: .biHeight = -m_lHeight: End With
    If pIGraphicsCaptureMonitor Then Call Release(pIGraphicsCaptureMonitor)
    If Invoke(m_pIGraphicsCaptureItemInterop, IGraphicsCaptureItemInterop_CreateForMonitor, m_hMonitor, pIID_IGraphicsCaptureItem, VarPtr(pIGraphicsCaptureMonitor)) = S_OK Then m_bIsInitialized = True
End Sub

Private Function StartCapture(ByVal pIGraphicsCaptureItem As Long) As Boolean
    Dim pIDirect3D11CaptureFramePool As Long
    If Invoke(pIDirect3D11CaptureFramePoolStatics, IDirect3D11CaptureFramePoolStatics_Create, ObjPtr(objIDirect3DDevice), DXGI_FORMAT_B8G8R8A8_UNORM, 1, m_lWidth, m_lHeight, VarPtr(pIDirect3D11CaptureFramePool)) = S_OK Then
        Dim pIGraphicsCaptureSession As Long
        If Invoke(pIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_CreateCaptureSession, pIGraphicsCaptureItem, VarPtr(pIGraphicsCaptureSession)) = S_OK Then
            Dim pIGraphicsCaptureSession2 As Long
            If Invoke(pIGraphicsCaptureSession, IUnknown_QueryInterface, pIID_IGraphicsCaptureSession_2, VarPtr(pIGraphicsCaptureSession2)) = S_OK Then
                Call Invoke(pIGraphicsCaptureSession2, IGraphicsCaptureSession2_PutIsCursorCaptureEnabled, 0&)
                Call Release(pIGraphicsCaptureSession2)
            End If
            Dim pIGraphicsCaptureSession3 As Long
            If Invoke(pIGraphicsCaptureSession, IUnknown_QueryInterface, pIID_IGraphicsCaptureSession_3, VarPtr(pIGraphicsCaptureSession3)) = S_OK Then
                Call Invoke(pIGraphicsCaptureSession3, IGraphicsCaptureSession3_PutIsBorderRequired, 0&)
                Call Release(pIGraphicsCaptureSession3)
            End If
            If Invoke(pIGraphicsCaptureSession, IGraphicsCaptureSession_StartCapture) = S_OK Then
                Dim pIDirect3D11CaptureFrame As Long
                While pIDirect3D11CaptureFrame = 0: Call Invoke(pIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_TryGetNextFrame, VarPtr(pIDirect3D11CaptureFrame)): Wend
                Dim pIDirect3DSurface As Long
                If Invoke(pIDirect3D11CaptureFrame, IDirect3D11CaptureFrame_GetSurface, VarPtr(pIDirect3DSurface)) = S_OK Then
                    StartCapture = GetImageFromIDirect3DSurface(pIDirect3DSurface)
                    Call CloseAndRelease(pIDirect3DSurface)
                End If
                Call CloseAndRelease(pIDirect3D11CaptureFrame)
            End If
            Call CloseAndRelease(pIGraphicsCaptureSession)
        End If
        Call CloseAndRelease(pIDirect3D11CaptureFramePool)
    End If
End Function

Private Function GetImageFromIDirect3DSurface(pIDirect3DSurface As Long) As Boolean
    Dim pIDirect3DDxgiInterfaceAccess As Long
    If Invoke(pIDirect3DSurface, IUnknown_QueryInterface, pIID_IDirect3DDxgiInterfaceAccess, VarPtr(pIDirect3DDxgiInterfaceAccess)) = S_OK Then
        Dim objID3D11Texture2D As VBD3D11.ID3D11Texture2D
        If Invoke(pIDirect3DDxgiInterfaceAccess, IDirect3DDxgiInterfaceAccess_GetInterface, pIID_ID3D11Texture2D, VarPtr(objID3D11Texture2D)) = S_OK Then
            Dim tD3D11_TEXTURE2D_DESC As VBD3D11.D3D11_TEXTURE2D_DESC
            objID3D11Texture2D.GetDesc tD3D11_TEXTURE2D_DESC
            With tD3D11_TEXTURE2D_DESC
                .Usage = D3D11_USAGE_STAGING: .CPUAccessFlags = D3D11_CPU_ACCESS_READ: .BindFlags = 0: .MiscFlags = 0
            End With
            Dim objID3D11Texture2D_2 As VBD3D11.ID3D11Texture2D
            Set objID3D11Texture2D_2 = objID3D11Device.CreateTexture2D(tD3D11_TEXTURE2D_DESC, ByVal 0&)
            If Not (objID3D11Texture2D_2 Is Nothing) Then
                Call objID3D11DeviceContext.CopyResource(objID3D11Texture2D_2, objID3D11Texture2D)
                Dim tD3D11_MAPPED_SUBRESOURCE As VBD3D11.D3D11_MAPPED_SUBRESOURCE, i As Long
                If objID3D11DeviceContext.Map(objID3D11Texture2D_2, 0, D3D11_MAP_READ, 0, tD3D11_MAPPED_SUBRESOURCE) = S_OK Then
                    With tD3D11_MAPPED_SUBRESOURCE
                        If m_lWidth * 4 = .RowPitch Then
                            SetDIBits 0, m_hBitmap, 0, m_lHeight, ByVal .pData, m_BitmapInfo, DIB_RGB_COLORS
                        Else
                            Dim PixelData() As Long
                            ReDim PixelData(0 To m_lWidth * m_lHeight - 1)
                            For i = 0 To m_lHeight - 1
                                CopyMemory PixelData(i * m_lWidth), ByVal .pData + i * .RowPitch, m_lWidth * 4
                            Next i
                            SetDIBits 0, m_hBitmap, 0, m_lHeight, PixelData(0), m_BitmapInfo, DIB_RGB_COLORS
                        End If
                    End With
                    objID3D11DeviceContext.Unmap objID3D11Texture2D_2, 0: GetImageFromIDirect3DSurface = True
                End If
            End If
        End If
        Call Release(pIDirect3DDxgiInterfaceAccess)
    End If
End Function

Private Function IsMinimized(lWnd As Long) As Boolean
    IsMinimized = GetWindowLong(lWnd, GWL_STYLE) And WS_MINIMIZE
End Function

Private Function GetActivationFactory(ByVal ClassName As String, ByVal iid As Long, pFactory As Long) As Boolean
Dim hString As Long
    If WindowsCreateString(StrPtr(ClassName), Len(ClassName), hString) = S_OK Then
        If hString Then
            If RoGetActivationFactory(hString, iid, pFactory) = S_OK Then GetActivationFactory = True
            Call WindowsDeleteString(hString)
        End If
    End If
End Function

Private Sub Release(pInterface As Long)
    If pInterface Then
        Call Invoke(pInterface, IUnknown_Release)
        pInterface = 0
    End If
End Sub

Private Sub CloseAndRelease(pInterface As Long)
    If pInterface Then
        Dim pIClosable As Long
        If Invoke(pInterface, IUnknown_QueryInterface, pIID_IClosable, VarPtr(pIClosable)) = S_OK Then
            Call Invoke(pIClosable, IClosable_Close)
            Call Release(pIClosable)
        End If
        Call Release(pInterface)
    End If
End Sub

Private Function Invoke(ByVal pInterface As Long, ByVal vtb As vtb_Interfaces, ParamArray aParam()) As Variant
Dim i As Long, ParamValues(0 To 9) As Long, ParamTypes(0 To 9) As Integer, varParam As Variant, varRet As Variant
    If pInterface Then
        varParam = aParam
        For i = 0 To UBound(varParam)
            ParamTypes(i) = VarType(varParam(i))
            ParamValues(i) = VarPtr(varParam(i))
        Next i
        Call DispCallFunc(pInterface, vtb * 4, CC_STDCALL, vbLong, i, ParamTypes(0), ParamValues(0), varRet)
        Invoke = varRet
    End If
End Function

Here's a screenshot captured from my second monitor (12.5ms for a FullHD screenshot 1920x1080 including the conversion to GDI Bitmap):



And the demo project: VBC_UwpCapturePicker.zip, requires the VBD3D11 TypeLib for the D3D11 calls and Bruce McKinney's Windows Unicode API Type Library for the rest of API functions, types and constants.

Why I cant open it in Visual Studio 2017?

[-Franky-]

Why I cant open it in Visual Studio 2017?

The code and downloads only work in VB6. But you can easily reprogram it in .NET. You have 3 options:
1. You make a reference to the Windows.winmd in your .NET project. I have it here: C:\Program Files (x86)\Windows Kits\10\UnionMetadata\10.0.22621.0\Windows.winmd. Then you need the NuGet package "System.Runtime.WindowsRuntime". This means that all important namespaces and classes of WinRT are available to you.
2. Very classic, just like using COM interfaces in .NET via <ComImport>.
3. You only work with the pointers of the COM interface, the vtable and delegates.

You can find examples for VB.NET on vbparadise.de in the source code exchange (VBN_CapturePicker_With_Direct3D.zip) or on activevb.de in the upload/download area (VBN_CapturePicker.zip). Both downloads contained the same code.

Of course, it is easier to use Windows.winmd. But is no longer supported from NET5. So I like to program something like this using pointers and delegates.

[fafalone]

It's too bad that WinRT doesn't implement IDispatch. I've found this old code (now archived in the Wayback Machine) showing how to call the Invoke method of IDispatch. It was using "olelib" but it works just fine with "oleexp" instead:

FYI, oleexp is a fork of olelib; if something uses olelib, oleexp can be substituted; only in a few cases have I made small changes to the original interfaces/APIs, and it will be obvious how to adjust it when it comes up. tbShellLib (for twinBASIC, the only option for 64bit as you can't compile oleexp for it) has more differences compared to both, mostly in APIs, but some interfaces do things like change 'As Any' to a UDT that's optional, since tB supports passing a null pointer without requiring it be 'As Any' with the vbNullPtr keyword.

Very good work. If fafalone releases a TLB for WinRT, then you will certainly be able to get even more speed and possibilities out of it.

TL;DR: ChatGPT doesn't have much faith in fafalone!

Not sure there's anything you can do with a TLB that you can't do with using APIs for vtable calls, of course it's **much** friendlier. But I had no idea just how much -Franky- had done with it so far, I think I'll leave the WinRT-in-VB6 area to you... I was originally only looking at a proof of concept anyway since I was curious, not making an expansive TLB like oleexp.

[fafalone]

The code and downloads only work in VB6. But you can easily reprogram it in .NET. You have 3 options:
1. You make a reference to the Windows.winmd in your .NET project. I have it here: C:\Program Files (x86)\Windows Kits\10\UnionMetadata\10.0.22621.0\Windows.winmd. Then you need the NuGet package "System.Runtime.WindowsRuntime". This means that all important namespaces and classes of WinRT are available to you.
2. Very classic, just like using COM interfaces in .NET via <ComImport>.
3. You only work with the pointers of the COM interface, the vtable and delegates.

You can find examples for VB.NET on vbparadise.de in the source code exchange (VBN_CapturePicker_With_Direct3D.zip) or on activevb.de in the upload/download area (VBN_CapturePicker.zip). Both downloads contained the same code.

Of course, it is easier to use Windows.winmd. But is no longer supported from NET5. So I like to program something like this using pointers and delegates.

Is there stuff that's not included in the Windows SDK? Everyone developing for Windows even close to low level should have the SDK; it had all the WinRT stuff I looked at, but I wasn't doing an exhaustive search.

[-Franky-]

Not sure there's anything you can do with a TLB that you can't do with using APIs for vtable calls, of course it's **much** friendlier. But I had no idea just how much -Franky- had done with it so far, I think I'll leave the WinRT-in-VB6 area to you... I was originally only looking at a proof of concept anyway since I was curious, not making an expansive TLB like oleexp.

I tried maybe 5% of the WinRT. So there is still a lot to discover in WinRT. I don't want to do this alone. I'm just a little hobby programmer. It doesn't matter whether it's with a TLB or in the classic way via DispCallFunc.

Is there stuff that's not included in the Windows SDK? Everyone developing for Windows even close to low level should have the SDK; it had all the WinRT stuff I looked at, but I wasn't doing an exhaustive search.

99% are certainly included in the SDK. However, not always without errors.

[dima0909]

could someone convert this code to VB.NET?

[VanGoghGaming]

VB.NET sucks! But I'm sure you can find a kind soul here who has been swayed by the dark side!

[-Franky-]

could someone convert this code to VB.NET?

Look at post #54. There I wrote where you can find this vb6 example already translated to VB.NET.

[-Franky-]

VB.NET sucks! But I'm sure you can find a kind soul here who has been swayed by the dark side!

VB.NET isn't that bad. It's a lot easier to program there. But also somehow more boring and not as challenging as with VB6.

[VanGoghGaming]

Somehow the whole .NET suite has flown right past me so I have zero experience with any of it but somehow I still doubt it's "a lot easier" as you put it. From what I've read, it would seem quite the contrary. I am also mostly a hobbyist like yourself but if I was going to move to another programming language I would try TwinBasic since it is compatible with VB6. Still waiting for it to mature though (or at least go out of perpetual "Beta"!).

[Niya]

Somehow the whole .NET suite has flown right past me so I have zero experience with any of it but somehow I still doubt it's "a lot easier" as you put it.

It's easier in the sense that you don't have to manually import half the Windows API just do some simple task and you don't need too many clever tricks to get by. The IDE also provides a lot of value in the form of many new features like code refactoring and the intellisense is more powerful. It all adds up to a less stressful experience when trying to get things done. At least that's how I feel.

Others may feel differently. It comes down to familiarity. If you're more familiar with VB6 that's going to feel better but those of us familiar with both tend to favor .Net more. Not all but most. Some people will always prefer VB6 no matter what. Just the way it goes.

[-Franky-]

I am also mostly a hobbyist like yourself but if I was going to move to another programming language I would try TwinBasic since it is compatible with VB6.

I looked at TwinBasic and experimented a bit with it. It's still not quite what I would like it to be. However, the TwinBasic project is going in the right direction and could eventually replace VB6. I can only recommend you to take a look at .NET and try it out.

e.g. I always wrote my WinRT projects with VB6 first and only then translated them to VB.NET. From this you can already see which language I prefer.

[fafalone]

Trying it only cemented my resolve to never use it.

Wound up going the other way; still focused mostly on VB6 and now tB, but I'm learning more C/C++ instead.

[Niya]

Trying it only cemented my resolve to never use it.

Wound up going the other way; still focused mostly on VB6 and now tB, but I'm learning more C/C++ instead.

I'm not surprised. You do a lot of lower level stuff like drivers or fiddling with the inner workings of type libraries and such. .Net isn't going to appeal to someone like you. It is not suited to the kind of programming you do. This is also why you find C/C++ appealing.

I'd also recommend you get comfortable with assembly. I'm not assembly expert but I'm comfortable enough with it to tell you it's not as difficult as you might think. The language itself is actually among the easiest to learn. The difficulty in assembly actually comes from the need to understand how the CPU works, not from the language itself. Based on the types of projects you do, I know you will absolutely love assembly when you get to know it.

[fafalone]

Heh, "WHAT DO YOU MEAN THERE'S NO VarPtr()!??! How will I do ANYTHING!" --me, the first time I ever tried rewriting a project in VB.NET.

I dabbled with 68k a bit way back in high school, because all the best games for my TI-89 calculator were written in it (sometimes my French teacher wondered why I needed my calculator out in her class, LOL), but forgot just about all of it since the 8 years after college in my life, were, well, I forgot a lot... only have the most superficial understanding; the most common instructions, the basic ideas of registers and the stack. It's been on the 'to-do list' for a long, long time, because I'm fascinated by the things people like The trick, wqweto, etc do with thunks in VB6, and would eventually like to be able to do them myself.

I was contemplating an approach of learning x86 and x86_64 simultaneously, since going forward I want to write everything compatible with both like I'm doing now with tB... but there's virtually no beginner-friendly resources for the latter, any recommendations?

[Niya]

Heh, "WHAT DO YOU MEAN THERE'S NO VarPtr()!??! How will I do ANYTHING!" --me, the first time I ever tried rewriting a project in VB.NET.

Haha. I feel you. VarPtr doesn't really fit into .Net all that well. For one thing, objects in .Net are not fixed in memory so you never want to allow programmers to just grab pointers all will-nilly. Another thing is that P/Invoke is very flexible. You have very fine control over how types are marshalled so you never need something like VarPtr when calling into an unmanaged environment like the Win32 API. You can just tell P/Invoke to marshal your parameters as pointers without needing to explicitly do it.

Just for fun, one can write their own VarPtr function if they are so inclined:-

Imports System.Data.OleDb
Imports System.Runtime.InteropServices

Module Module1

    <DllImport("kernel32.dll", EntryPoint:="RtlMoveMemory")>
    Public Sub CopyMemory(ByVal Destination As IntPtr, ByVal Source As IntPtr, ByVal Length As UInteger)
    End Sub

    Sub Main()

        'Unfortunately for this to work we MUST box primitive
        'value types assigning by them to an Object type variable
        'instead of Integer, otherwise VarPtr returns the address
        'to a copy of the value type. By boxing it, we make value types
        'behave like reference types so VarPtr will return the correct address
        Dim a As Object = 12I
        Dim b As Object = 200I

        CopyMemory(VarPtr(a), VarPtr(b), 4)

        'Prints 200 proving the copy operation worked
        Debug.WriteLine(a.ToString)
    End Sub

    'This cannot be made to work on value types so we use the Class
    'constraint to make sure the compiler only allows reference types are passed to VarPtr.
    'If we allow value types to be passed, VarPtr will always return the wrong address because
    'it would be returning the address of a copy, not the original. GCHandle.Alloc
    'is the culprit here as it's first parameter is passed by value. We cannot do anything about that.
    Private Function VarPtr(Of T As Class)(ByVal obj As T) As IntPtr
        Dim h = GCHandle.Alloc(obj, GCHandleType.Pinned)
        Try
            Return h.AddrOfPinnedObject
        Finally
            h.Free()
        End Try
    End Function


End Module

However, I'd recommend no VB.Net programmer ever do that EVER. While the above works it's a disaster waiting to happen. The GC can move those objects in memory at any time so there is potential for VarPtr to return an invalid address.

I think you might have preferred C# though. The C# compiler is far less constrained than the VB.Net compiler and it allows you to do low level programming very easily. The above code would look like this in C#:-

using System;
using System.Diagnostics;

class Program
{
    static void Main()
    {
        unsafe
        {
            int a = 12;
            int b = 200;

            // Get the addresses of a and b
            int* aPtr = &a;
            int* bPtr = &b;

            // Copy the value of b to a
            *aPtr = *bPtr;

            // Prints 200 proving the copy operation worked
            Debug.WriteLine(a.ToString());
        }
    }
}

but there's virtually no beginner-friendly resources for the latter, any recommendations?

Hmmm..Let me see how best I can advise you here because I went though the same struggle. For years I tried to get a handle on assembly but nothing I ever found was beginner friendly enough. It wasn't until I stumbled on a specific article completely by accident did it really click for me. The article was about using the Flat assembler to compile ASM code into machine code and calling it from .Net as a function. To this day I'm not sure why this specific example made it click for me but I think it has something to do with the fact that it was within the context of an environment I was already familiar with, in this case .Net.

To that end, what I'd recommend is that you download trick's assembly VB6 add-in and start writing very simple functions in assembly and call them from VB6. This way it cuts out all the noise like setting up sections, import tables and all that. You can just jump right in and start with something very basic. Things will start clicking for you and you can then start learning more and more at your own pace. I've seen the kind of things you do, trust me, you would be a very capable assembly language programmer. You just need to stop letting it intimidate you.

I've been think about writing a very basic article on using assembly in VB6 or .Net. Nothing fancy, just something simple enough that anybody could start wetting their feet. I really do think it's possible for anyone to learn the basics but as you've said, it's really hard to find something that beginner friendly enough.

[Niya]

I decided to go ahead and make an assembly language article myself. Hopefully it's simple enough for anyone to understand, even if it's a bit long:-
https://www.vbforums.com/showthread....VB6-The-Basics

[dima0909]

Look at post #54. There I wrote where you can find this vb6 example already translated to VB.NET.

I can't do it, I didn't find 54 examples in the post

[VanGoghGaming]

Just got around to revisiting this capture project (from post #41 above) with a fresh approach. It always bothered me that the process of acquiring new frames was done synchronously in an endless loop by repeatedly calling the "CaptureFramePool_TryGetNextFrame" method until it returns a valid object pointer:

While pIDirect3D11CaptureFrame = 0: Call Invoke(pIDirect3D11CaptureFramePool, IDirect3D11CaptureFramePool_TryGetNextFrame, VarPtr(pIDirect3D11CaptureFrame)): Wend

Even if this loop only takes a few milliseconds until a new frame is available in the frame pool, it has many limitations. For example if the capture target window is closed then a new frame will never arrive and the program will be stuck in an endless loop. Using "DoEvents" inside the loop is pretty lame too.

Fortunately, the "CaptureFramePool" object exposes a "FrameArrived" event that signals the arrival of a new frame in the pool buffer so we can fetch it and go about our business. Unfortunately, this event cannot be implemented in VB6 without an adequate "TypeLib" so the solution was to create the event object from scratch (VTable and all) and then make it available with the "CaptureFramePool_AddFrameArrived" method. Apparently, "WinRT" doesn't care this isn't a true "TypedEventHandler" object, as long as it responds to the correct GUID to "QueryInterface" and it exposes the "AddRef", "Release" and "Invoke" methods, it's happy with it!

Now our capturing class can become much more responsive and implement events of its own. There's also the added benefit of detecting when the target window has changed its size or was closed by the user and react accordingly.

The capturing speed has improved a lot as well, it takes only 4-5ms on average to capture, process and render each incoming frame in a PictureBox. So the debate above about needing a WinRT "TypeLib" vs going old school with "DispCallFunc" has reached a conclusion, that is, the performance difference is definitely negligible, even though a "TypeLib" would make things much easier in the long run.

I've put the refactored project in the "CodeBank" for whoever wants to take a look: VB6 - Capture any Window, even in background, with WinRT / Windows.Graphics.Capture

Thanks again -Franky-, you've been an inspiration!

[-Franky-]

@VanGoghGaming Very good work. It's nice to see how an idea to make WinRT accessible for VB6 turns into a completely new and improved project. So if you need more inspiration, I have a VBC_WinRT.zip on ActiveVB where I gradually add more WinRT classes as I find the time.

[VanGoghGaming]

@VanGoghGaming Very good work. It's nice to see how an idea to make WinRT accessible for VB6 turns into a completely new and improved project. So if you need more inspiration, I have a VBC_WinRT.zip on ActiveVB where I gradually add more WinRT classes as I find the time.

I've already downloaded your WinRT project a few days ago. That's exactly where I got the idea of a custom EventHandler object! Man, your project is HUGE! At first I thought there was something wrong with it because VB6 takes a while to load it but if you're patient it works very well once loaded, haha!

Also I took the liberty to make a few modifications to the process of making the EventHandler objects:

- Instead of having a separate .BAS module for each one, I just use one module which holds an array of ITypedEventHandlers(0 To EVENT_HANDLERS_COUNT - 1)

- They all share the same EventHandlerQueryInterface, EventHandlerAddRef, EventHandlerRelease and EventHandlerInvoke procedures. This works well in a single-threaded environment like VB6 but I'm not so sure it would work multi-threaded when they all tried to execute a procedure at the same time, haha!

- I've changed the Object type (late-bound) to IUnknown (early-bound)

- The EventHandler objects don't need a separate IID for each one (although it certainly doesn't hurt), they work just fine with IID_IUnknown. I've seen they get queried for a bunch of different interfaces anyway (IAgileObject, INoMarshal and then some) and for each they return E_NOINTERFACE anyway.

- An EventHandler object doesn't need to hold a full reference to the object that created it (one more thing you need to destroy when cleaning up). A weak reference (like passing them ObjPtr(Me)) is enough for Callback purposes with OleInvoke.

- All of the above are just personal preferences of mine that I'd thought to share. Finally there is a little bug in the process of removing an EventHandler (or unsubscribing from it as they say).

I've seen that other programming languages, like C# for example, have specific operators for subscribing and unsubscribing from such EventHandlers ("+=" and "-=" in C#). Of course this doesn't help us much with VB6. We are stuck with manually calling the interface methods _addEventName and _removeEventName, which works just fine.

Usually the _addEventName method takes two parameters: a pointer to the EventHandler object and an "EventRegistrationToken" which is used later for removing the EventHandler.
The _removeEventName method takes just one parameter, the "EventRegistrationToken" previously obtained.

It was driving me crazy that the _removeEventName method would always fail silently. I mean OleInvoke returns zero (S_OK) but the call to DispCallFunc inside it fails with error 0x80020010 (DISP_E_BADCALLEE) which doesn't say much. Now this wouldn't bear any relevance since usually you only want to unsubscribe from such an EventHandler when you close the app but still it's a nuisance that needed to be addressed.

I've finally managed to fix it today (before writing this post) when I checked the Windows SDK header files for the definition of "EventRegistrationToken" and I've found it defined like this:

typedef struct EventRegistrationToken
    {
    __int64 value;
    }

So it seems to be a 64bit integer and we've been declaring it as "Long" all this time. Changing the declaration to "EventRegistrationToken As Currency" promptly fixed the error! Now I need to upload a new project with this fix included!

[baka]

wanted to try the demo but I can't add the typelib for directx11.
I get an error of reference. (can't add a reference to the specified file)
anyone knows why or how to make it work? im in windows 7

[VanGoghGaming]

The version I uploaded to the CodeBank above doesn't need any TypeLibs but Windows.Graphics.Capture requires at least Windows 10 I'm afraid...

[baka]

I figure it out, the .tlb was corrupted. re-downloaded it and it works.
but I can't run the demo, I dont have the .DLL "combase"

IIDFromString can be switched to ole32
but the other 3 Im not sure.

[-Franky-]

@VanGoghGaming

typedef struct EventRegistrationToken
    {
    __int64 value;
    }

Ohhh. What a stupid mistake on my part. Of course you are right. Is an Int64 -> Currency and not a Long. Ok, Search&Replace on my project to fix the error. Thx

[VanGoghGaming]

Ohhh. What a stupid mistake on my part. Of course you are right. Is an Int64 -> Currency and not a Long. Ok, Search&Replace on my project to fix the error. Thx

No worries mate, these things happen all the time when translating stuff from another language into VB6. Rock on!

Also you would need more than a "Search & Replace" since, right now as far as I've seen, your _removeEventName method calls are incorrectly using two parameters (like the _addEventName ones) instead of just one of type Currency.

I figure it out, the .tlb was corrupted. re-downloaded it and it works.
but I can't run the demo, I dont have the .DLL "combase"

IIDFromString can be switched to ole32
but the other 3 Im not sure.

Baka, the capture process is performed by the Windows.Graphics.Capture API and that absolutely requires Windows 10, that's why you don't have a "combase.dll".

The "D3D11" part is used only for acquiring a "D3D11Surface" and transferring a "Texture2D" from the GPU to the CPU so that we can access its pixels and make a GDI bitmap that can be rendered in a PictureBox!

I don't know why you don't want to move on to Windows 10, you're missing out on a lot of great new features like this. I wouldn't recommend Windows 11 since that's still fairly new but Windows 10 is a very mature operating system by now and it blows Windows 7 out of the water in every possible aspect. In my opinion you're only doing yourself a disservice.

[baka]

I can't move to 10 until I know 100% of all users are using it.
as long theres a % that still uses 7 I need to stay.
also, 7 is great in many ways, even if now old and outdated and lack some features.

but, its nice to see that VB6 can be used this way and still keep it up with features.
I mean, a tool created 25 years ago when windows 98 was the OS and now uses features made in windows 10/11

[VanGoghGaming]

Yep, pushing VB6 limits like this is a wonderful thing to behold, isn't it?