Problems getting a window capture with Bitblt and PrintWindow.

Hello, I'm trying to get a window capture through the bitblt capture method and printWindow api, but in both I have the problem with some processes (Mostly games) where it only captures the window showing the white or black content (depending on the computer).

Here I can show how they are observed in each one.

Attachment 186614
[Using Bitblt]

Attachment 186615
[Using PrintWindow]

I have noticed that OBS has Bitblt as a capture method, where it also presents the same problem.
Attachment 186616

But if "Windows 10" capture mode is used, it is solved. Is this mode available to use in vb6?

Attachment 186617

Thank you very much, this has me worried and it would be good to have information!.

Hi
From Windows 10 you can also use the UWP/WinRT namespace Windows.Graphics.Capture (https://learn.microsoft.com/en-us/uw...ew=winrt-22621) in VB6 . Try if you can make a screenshot with this. https://www.activevb.de/cgi-bin/uplo...oad.pl?id=3904

@Franky: A clever piece of code although painful to watch Invoke-ing all those calls without a typelib. I'll hoist RoGetActivationFactory and RoActivateInstance API declares immediately to test WinRT JSON classes :-))

Also note that the link to your ZIP upload will be removed by these forums in a short time. All your previous back-links are removed too which is a shame as the code is solid.

Can you please link *and* paste relevant code in the thread so it becomes searchable in google and with forum's advanced search?

cheers,
</wqw>

This is a difficult problem. Games and videos are difficult to capture images.
But in games or videos, DX or Opengl is used to draw pictures, which naturally cannot be cut off

@wqweto Sorry for the links to the ZIP download. I will revise my code again briefly and then upload a new ZIP here.

Edit: In the ActiveVB Up/Downlod I also have a code for WinRT JSON. Find the VBC_UwpJson.zip there.

For some games you can BitBlt from their window hDC and for others you can't, even though they obviously all use DirectX. I don't know what makes the difference. On the other hand you can always BitBlt from the desktop hDC so just calculate the coordinates of the game window.

Quote:

---

Originally Posted by -Franky-

Edit: In the ActiveVB Up/Downlod I also have a code for WinRT JSON. Find the VBC_UwpJson.zip there.

---

Thanks! Looking at it now.

Btw, in ToString impl is there WindowsDeleteString call missing on the output hString?

cheers,
</wqw>

To answer the initial post, it seems that "PrintWindow" has been modified (since Windows 8.1) to work with DirectX surfaces. Now it has an undocumented parameter (PW_RENDERFULLCONTENT):

Code:

---

Public Const PW_CLIENTONLY = 1, PW_RENDERFULLCONTENT = 2

PrintWindow SourceWindow_hWnd, Destination_hDC, PW_CLIENTONLY Or PW_RENDERFULLCONTENT

---

Just tested this and it seems to be working correctly.

Thank you very much!! -Franky-, VanGoghGaming. The solutions are excellent for this problem.!
VBC_UwpCapturePicker.zip and PrintWindow has surprised me, They got me out of big trouble! :bigyello:

Quote:

---

Originally Posted by wqweto

A clever piece of code although painful to watch Invoke-ing all those calls without a typelib.

---

Is it even possible to include all those objects and their methods in a typelib? So far all the VB6 typelibs I've seen include only DLL function declarations and basic types (long, integer, byte)...

I tried to take a look at Franky's code and got dizzy from all the invoking of "DispCallFunc"!

Quote:

---

Originally Posted by wqweto

Btw, in ToString impl is there WindowsDeleteString call missing on the output hString?
</wqw>

---

If I read that correctly in the MS Docs, hString must be deleted via WindowsDeleteString if it was created with WindowsCreateString. Otherwise not.

Quote:

---

Originally Posted by -Franky-

If I read that correctly in the MS Docs, hString must be deleted via WindowsDeleteString if it was created with WindowsCreateString. Otherwise not.

---

Pretty sure that for every [out] HSTRING *value parameter you have to call WindowsDeleteString when done working with the HSTRING. This is what WinRT/C++ wrappers do when returning HSTRING with return { value, take_ownership_from_abi } which ensures Close method is called on the handle (the method which wraps native WindowsDeleteString).

You already do this in GetInspectable_GetRuntimeClassName which is correct but in most other cases where VarPtr(hString) is populated as an output parameter the HSTRING is leaking (e.g. ToString, GetStringAt, Stringify, GetString in clsJsonArray)

Another possible source of leaks is when missing calling (manually) Release on the raw pointers in Long variables. These could be declared as IUnknown and let VB6 automagically call Release at correct places with no leaks possible.

Otherwise the proof of concept is great, this is something I wanted to research for a long time and will probably invest some time wrapping base WinRT interfaces in a typelib for performance reasons (Invoke-ing is expensive).

cheers,
</wqw>

Quote:

---

Originally Posted by wqweto

Pretty sure that for every [out] HSTRING *value parameter you have to call WindowsDeleteString when done working with the HSTRING. This is what WinRT/C++ wrappers do when returning HSTRING with return { value, take_ownership_from_abi } which ensures Close method is called on the handle (the method which wraps native WindowsDeleteString).

You already do this in GetInspectable_GetRuntimeClassName which is correct but in most other cases where VarPtr(hString) is populated as an output parameter the HSTRING is leaking (e.g. ToString, GetStringAt, Stringify, GetString in clsJsonArray)

Another possible source of leaks is when missing calling (manually) Release on the raw pointers in Long variables. These could be declared as IUnknown and let VB6 automagically call Release at correct places with no leaks possible.

Otherwise the proof of concept is great, this is something I wanted to research for a long time and will probably invest some time wrapping base WinRT interfaces in a typelib for performance reasons (Invoke-ing is expensive).

cheers,
</wqw>

---

OK. then I misunderstood the MS Docs. Thank you for your explanation.

@Franky is it possible to start the capture directly from a supplied window hWnd instead of displaying that "CapturePicker" window every time?

Hi
In the windows.graphics.capture.interop.h there is a function CreateForWindow.

Code:

---

HRESULT CreateForWindow(
  HWND  window,
  REFIID riid,
  void  **result
);

---

REFIID = IID_IGraphicsCaptureItem

Edit: add the following

Code:

---

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 Enum vtb_Interfaces

    ' ...



    ' IGraphicsCaptureItemInterop
    IGraphicsCaptureItemInterop_CreateForWindow = 3
    IGraphicsCaptureItemInterop_CreateForMonitor = 4
End Enum

Private m_pIGraphicsCaptureItemInterop As Long


Private Sub Class_Initialize()


    If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureItem, _
                            IID_IGraphicsCaptureItemInterop, _
                            m_pIGraphicsCaptureItemInterop) Then

    ' ....
End Sub

Public Function CaptureHwnd(ByVal hwnd As Long) As Boolean
    If m_pIGraphicsCaptureItemInterop <> 0& And hwnd <> 0& Then
        Dim pIGraphicsCaptureItem As Long
        If Invoke(m_pIGraphicsCaptureItemInterop, _
                  IGraphicsCaptureItemInterop_CreateForWindow, _
                  hwnd, _
                  VarPtr(Str2Guid(IID_IGraphicsCaptureItem)), _
                  VarPtr(pIGraphicsCaptureItem)) = S_OK Then
       
            ' etc.
            ' CaptureHwnd = True
       
            Call Release(pIGraphicsCaptureItem)
        End If
    End If
End Function

---

Hey Franky, thanks for the code sample! I think I got the hang of it now, it's not really difficult once you step through the code in the debugger. I really wish you could do something like CreateObject("Windows.Graphics.Capture") though... Invoking all those methods without instantiating their classes is terribly slow:

Taking a screenshot with this code sample: 92ms
Taking the same screenshot with "PrintWindow" with the "PW_RENDERFULLCONTENT" flag (which probably does the same thing under the hood): 19ms
Taking the same screenshot with "BitBlt" (for comparison purposes): 0.7 ms

All measurements done inside the IDE.

Incidentally I have stumbled upon this piece of code which does exactly the same thing as yours, only using the AutoHotkey scripting language:

https://www.autohotkey.com/boards/vi...yle=17&t=96161

The similarities are uncanny, almost as if it's the same code translated in VB6! :D

Quote:

---

Originally Posted by VanGoghGaming

Hey Franky, thanks for the code sample! I think I got the hang of it now, it's not really difficult once you step through the code in the debugger. I really wish you could do something like CreateObject("Windows.Graphics.Capture") though... Invoking all those methods without instantiating their classes is terribly slow:

Taking a screenshot with this code sample: 92ms
Taking the same screenshot with "PrintWindow" with the "PW_RENDERFULLCONTENT" flag (which probably does the same thing under the hood): 19ms
Taking the same screenshot with "BitBlt" (for comparison purposes): 0.7 ms

All measurements done inside the IDE.

Incidentally I have stumbled upon this piece of code which does exactly the same thing as yours, only using the AutoHotkey scripting language:

https://www.autohotkey.com/boards/vi...yle=17&t=96161

The similarities are uncanny, almost as if it's the same code translated in VB6! :D

---

Caught. Let's put it that way. I copied a few things from this AutoHotKey Script and some comes directly from Microsoft examples. :rolleyes:


I think the code is correspondingly slow because of the invoking. BitBlt has the disadvantage that the window has to be in the foreground. Not via the WinRT.

Hey no worries, you did a fine job nevertheless. I did some reading on this WinRT stuff, apparently it's not so easy to instantiate WinRT objects in VB6 (if even possible at all) compared to the rest of COM objects.

BitBlt does work with background windows even if they are completely covered by other windows as long as they are not minimized. It just fails on some windows that use "special" DirectX techniques to draw their content (because it can also work fine with other DirectX windows)...

The code should be sent to codebank

BitBlt cannot work with background windows!

Quote:

---

Originally Posted by xxdoc123

BitBlt cannot work with background windows!

---

While that may have been true in previous versions of Windows, somewhere along the way Microsoft woke up and got their act together. Anyway it's pretty easy to test it yourself, just make a new project with two forms and a timer on each. "Form2" has a "Label" starting with "1" and the timer keeps incrementing it each second. In "Form1" the timer performs "BitBlt" from "Form2.hDC" each second, like this:

Attachment 186645

Form1:

Code:

---

Option Explicit

Private Sub Form_Load()
    Form2.Show
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Unload Form2
End Sub

Private Sub Timer1_Timer()
    BitBlt Me.hDC, 0, 0, Form2.ScaleWidth, Form2.ScaleHeight, Form2.hDC, 0, 0, vbSrcCopy
End Sub

---

Form2:

Code:

---

Option Explicit

Private Sub Timer1_Timer()
    Label1 = Val(Label1) + 1
End Sub

---

Now try to hide "Form2" somewhere in the dark recesses of your desktop, behind a browser window for example. "BitBlt" will continue to work just fine on "Form1", hell it even works if both windows are in the background. :D

Quote:

---

Originally Posted by xxdoc123

The code should be sent to codebank

---

You can do whatever you want with the WinRT code. I make no claim to it. I'm just playing around with WinRT to explore some possibilities for VB6.

Quote:

---

Originally Posted by VanGoghGaming

While that may have been true in previous versions of Windows, somewhere along the way Microsoft woke up and got their act together. Anyway it's pretty easy to test it yourself, just make a new project with two forms and a timer on each. "Form2" has a "Label" starting with "1" and the timer keeps incrementing it each second. In "Form1" the timer performs "BitBlt" from "Form2.hDC" each second, like this:

Attachment 186645

Form1:

Code:

---

Option Explicit

Private Sub Form_Load()
    Form2.Show
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Unload Form2
End Sub

Private Sub Timer1_Timer()
    BitBlt Me.hDC, 0, 0, Form2.ScaleWidth, Form2.ScaleHeight, Form2.hDC, 0, 0, vbSrcCopy
End Sub

---

Form2:

Code:

---

Option Explicit

Private Sub Timer1_Timer()
    Label1 = Val(Label1) + 1
End Sub

---

Now try to hide "Form2" somewhere in the dark recesses of your desktop, behind a browser window for example. "BitBlt" will continue to work just fine on "Form1", hell it even works if both windows are in the background. :D

---

from1 and from2 in the same exe .

if you test form2 in other exe ，you will see different

Quote:

---

Originally Posted by xxdoc123

if you test form2 in other exe ，you will see different

---

Generally it doesn't bode well to make such bold, blanket statements without at least bothering to write 4 simple lines of code... In this example the actual game is running in the background behind the VB6 IDE window:

Attachment 186648

And the full screenshot (which for some reason is too small to read the text when uploaded):

Attachment 186647

thanks ,In my memory, I can't take screenshots in the background used bitblt if some form out of the range of the display . So I used printwindow instead~

some hacker can hook dx and screenshot.but can not find any code ~

Quote:

---

Originally Posted by -Franky-

Hi
In the windows.graphics.capture.interop.h there is a function CreateForWindow.

Code:

---

HRESULT CreateForWindow(
  HWND  window,
  REFIID riid,
  void  **result
);

---

REFIID = IID_IGraphicsCaptureItem

Edit: add the following

Code:

---

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 Enum vtb_Interfaces

    ' ...



    ' IGraphicsCaptureItemInterop
    IGraphicsCaptureItemInterop_CreateForWindow = 3
    IGraphicsCaptureItemInterop_CreateForMonitor = 4
End Enum

Private m_pIGraphicsCaptureItemInterop As Long


Private Sub Class_Initialize()


    If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureItem, _
                            IID_IGraphicsCaptureItemInterop, _
                            m_pIGraphicsCaptureItemInterop) Then

    ' ....
End Sub

Public Function CaptureHwnd(ByVal hwnd As Long) As Boolean
    If m_pIGraphicsCaptureItemInterop <> 0& And hwnd <> 0& Then
        Dim pIGraphicsCaptureItem As Long
        If Invoke(m_pIGraphicsCaptureItemInterop, _
                  IGraphicsCaptureItemInterop_CreateForWindow, _
                  hwnd, _
                  VarPtr(Str2Guid(IID_IGraphicsCaptureItem)), _
                  VarPtr(pIGraphicsCaptureItem)) = S_OK Then
       
            ' etc.
            ' CaptureHwnd = True
       
            Call Release(pIGraphicsCaptureItem)
        End If
    End If
End Function

---

---

thank you but how can add it to the cls?

If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureItem, IID_IGraphicsCaptureItemInterop, m_pIGraphicsCaptureItemInterop) Then

Dim bolIsSupported As Boolean

If Invoke(pIGraphicsCaptureSessionStatics, IGraphicsCaptureSessionStatics_IsSupported, VarPtr(bolIsSupported)) = S_OK Then may be not return S_OK

thanks .

Thank you very much!! -Franky-, VanGoghGaming. The solutions are excellent for this problem.!

Quote:

---

Originally Posted by xxdoc123

thank you but how can add it to the cls?

If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureItem, IID_IGraphicsCaptureItemInterop, m_pIGraphicsCaptureItemInterop) Then

Dim bolIsSupported As Boolean

If Invoke(pIGraphicsCaptureSessionStatics, IGraphicsCaptureSessionStatics_IsSupported, VarPtr(bolIsSupported)) = S_OK Then may be not return S_OK

thanks .

---

First: The WinRT code works on Windows 10 and higher. What does the Debug.Print "0x" & Hex$(varRet) return in the OleInvoke function when you call IGraphicsCaptureSessionStatics.IsSupported?


The call GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureItem.... goes after IGraphicsCaptureSessionStatics.IsSupported. If IGraphicsCaptureSessionStatics.IsSupported already fails, then the rest won't work either.

thanks。i have modiy the cls and work fine

Code:

---

......
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}"


' ----==== Enums ====----
Private Enum vtb_Interfaces
  ....
    ' IGraphicsCaptureItemInterop
    IGraphicsCaptureItemInterop_CreateForWindow = 3
    IGraphicsCaptureItemInterop_CreateForMonitor = 4
End Enum


Private m_pIGraphicsCaptureItemInterop As Long

' ----==== Events ====----
' Variable to hold 'ChoseCaptureFormHwnd' property value
Private m_bChoseCaptureFormHwnd As Boolean

Public Property Get ChoseCaptureFormHwnd() As Boolean
    ChoseCaptureFormHwnd = m_bChoseCaptureFormHwnd
End Property

Public Property Let ChoseCaptureFormHwnd(ByVal bValue As Boolean)
    m_bChoseCaptureFormHwnd = bValue
End Property

' ----==== Class ====----
Private Sub Class_Initialize()

    m_bolIsInitialized = False
    m_bolIsCapturePickerCreated = False
   
    m_bChoseCaptureFormHwnd = False

End Sub

Public Function Init()
    Dim tGdipStartupInput  As GDIPlusStartupInput
    Dim tGdipStartupOutput As GdiplusStartupOutput

    If m_bChoseCaptureFormHwnd = False Then
        Dim pIGraphicsCaptureSessionStatics As Long

        If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureSession, IID_IGraphicsCaptureSessionStatics, pIGraphicsCaptureSessionStatics) Then
            Dim bolIsSupported As Boolean

            If Invoke(pIGraphicsCaptureSessionStatics, IGraphicsCaptureSessionStatics_IsSupported, VarPtr(bolIsSupported)) = S_OK Then

                If bolIsSupported Then
                    If GetActivateInstance(WindowsGraphicsCaptureGraphicsCapturePicker, IID_IGraphicsCapturePicker, m_pIGraphicsCapturePicker) Then
                       
                        If m_bolIsInitialized = False Then

                            tGdipStartupInput.GdiPlusVersion = GdiPlusVersion

                            If GdiplusStartup(m_lngGdipToken, tGdipStartupInput, tGdipStartupOutput) = OK Then
                                m_bolIsInitialized = True

                            End If
                       
                        End If
                    End If
                End If
            End If

            Call Release(pIGraphicsCaptureSessionStatics)
        End If

    Else

       

        If GetActivationFactory(WindowsGraphicsCaptureGraphicsCaptureItem, IID_IGraphicsCaptureItemInterop, m_pIGraphicsCaptureItemInterop) Then
            '        Dim bolIsSupported As Boolean
            '        If Invoke(m_pIGraphicsCaptureItemInterop, _
            '                  IGraphicsCaptureSessionStatics_IsSupported, _
            '                  VarPtr(bolIsSupported)) = S_OK Then
            '            If bolIsSupported Then
            ''                If GetActivateInstance(WindowsGraphicsCaptureGraphicsCapturePicker, _
            ''                                      IID_IGraphicsCapturePicker, _
            ''                                      m_pIGraphicsCapturePicker) Then
           
            If m_bolIsInitialized = False Then
                tGdipStartupInput.GdiPlusVersion = GdiPlusVersion

                If GdiplusStartup(m_lngGdipToken, tGdipStartupInput, tGdipStartupOutput) = OK Then
                    m_bolIsInitialized = True
                    '
                End If
           
            End If

            '                End If
            '            End If
            '        End If
            'Call Release(m_pIGraphicsCaptureItemInterop)
        End If
    End If
   
End Function

Public Function CaptureHwnd(ByVal hwnd As Long) As Boolean

    If m_pIGraphicsCaptureItemInterop <> 0& And hwnd <> 0& Then
        Dim pIGraphicsCaptureItem As Long

        If Invoke(m_pIGraphicsCaptureItemInterop, IGraphicsCaptureItemInterop_CreateForWindow, hwnd, VarPtr(Str2Guid(IID_IGraphicsCaptureItem)), VarPtr(pIGraphicsCaptureItem)) = S_OK Then
       
            Call StartCapture(pIGraphicsCaptureItem)
            CaptureHwnd = True
       
            Call Release(pIGraphicsCaptureItem)
        End If
    End If
End Function

---

Code:

---

VERSION 5.00
Begin VB.Form frmMain
  Caption        =  "Form1"
  ClientHeight    =  7320
  ClientLeft      =  60
  ClientTop      =  408
  ClientWidth    =  9180
  LinkTopic      =  "Form1"
  ScaleHeight    =  610
  ScaleMode      =  3  'Pixel
  ScaleWidth      =  765
  StartUpPosition =  3  '窗口缺省
  Begin VB.TextBox txtHwnd
      Height          =  372
      Left            =  7080
      TabIndex        =  3
      Top            =  240
      Width          =  732
  End
  Begin VB.CommandButton Command2
      Caption        =  "capture hwnd"
      Height          =  552
      Left            =  4200
      TabIndex        =  2
      Top            =  120
      Width          =  2628
  End
  Begin VB.PictureBox Picture1
      Height          =  6375
      Left            =  120
      ScaleHeight    =  6324
      ScaleWidth      =  8820
      TabIndex        =  1
      Top            =  720
      Width          =  8865
  End
  Begin VB.CommandButton Command1
      Caption        =  "Show CapturePicker"
      Height          =  555
      Left            =  150
      TabIndex        =  0
      Top            =  120
      Width          =  3945
  End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Autor: F. Sch黮er ([email protected])
' Datum: 08/2022

Option Explicit

Private cCapturePicker As clsCapturePicker

Private Sub Command2_Click()
    cCapturePicker.ChoseCaptureFormHwnd = True
    cCapturePicker.Init
    If cCapturePicker.CaptureHwnd(Val(txtHwnd.Text)) Then
        If Not cCapturePicker.CapturePicture Is Nothing Then
            Picture1.Picture = cCapturePicker.CapturePicture
        Else
            Picture1.Picture = LoadPicture()
        End If

    Else
        Picture1.Picture = LoadPicture()
    End If

End Sub

Private Sub Form_Load()
    Command1.Enabled = False
    Set cCapturePicker = New clsCapturePicker
    cCapturePicker.ChoseCaptureFormHwnd = False
    cCapturePicker.Init

    If cCapturePicker.IsInitialized Then
        If cCapturePicker.CreateCapturePicker(Me.hwnd) Then
            Command1.Enabled = True
        End If
    End If
    txtHwnd.Text = Me.hwnd
   
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Set cCapturePicker = Nothing
End Sub

Private Sub Command1_Click()
    If cCapturePicker.PickSingleItemAsync Then
        If Not cCapturePicker.CapturePicture Is Nothing Then
            Picture1.Picture = cCapturePicker.CapturePicture
        Else
            Picture1.Picture = LoadPicture()
        End If
    Else
        Picture1.Picture = LoadPicture()
    End If
End Sub

---

Quote:

---

Originally Posted by -Franky-

Hi
From Windows 10 you can also use the UWP/WinRT namespace Windows.Graphics.Capture (https://learn.microsoft.com/en-us/uw...ew=winrt-22621) in VB6 . Try if you can make a screenshot with this. https://www.activevb.de/cgi-bin/uplo...oad.pl?id=3904

---

I am trying to replace these two GDI+ functions with standard GDI alternatives (mainly for didactic purposes):

Code:

---

GdipCreateBitmapFromScan0 tD3D11_TEXTURE2D_DESC.Width, tD3D11_TEXTURE2D_DESC.Height, tD3D11_MAPPED_SUBRESOURCE.RowPitch, PixelFormats.PixelFormat32bppARGB,  tD3D11_MAPPED_SUBRESOURCE.pData, pBitmap

GdipCreateHBITMAPFromBitmap pBitmap, hBitmap, &HFFFFFFFF

---

These function calls create a GDI "hBitmap" from the pixel data provided by "tD3D11_MAPPED_SUBRESOURCE.pData". I have tried to replace them by:

Code:

---

Dim hDC As Long, hBitmap As Long, bmiBitmapInfo As BITMAPINFO, lRet As Long
    hDC = GetDC(0)
    hBitmap = CreateCompatibleBitmap(hDC, tD3D11_TEXTURE2D_DESC.Width, tD3D11_TEXTURE2D_DESC.Height)
    hDC = ReleaseDC(0, hDC)
    With bmiBitmapInfo.bmiHeader
          .biSize = LenB(bmiBitmapInfo.bmiHeader): .biPlanes = 1: .biBitCount = 32: .biCompression = BI_RGB
          .biWidth = tD3D11_TEXTURE2D_DESC.Width: .biHeight = -tD3D11_TEXTURE2D_DESC.Height
          .biSizeImage = (((.biWidth * .biBitCount) + 31) \ 32) * 4 * tD3D11_TEXTURE2D_DESC.Height
    End With
    lRet = SetDIBits(0, hBitmap, 0, tD3D11_TEXTURE2D_DESC.Height, ByVal tD3D11_MAPPED_SUBRESOURCE.pData, bmiBitmapInfo, DIB_RGB_COLORS)

---

This works to some extent, as in I do end up with a "hBitmap" containing the source pixels, however the image is all garbled as if the pixels are somehow misaligned in memory.

I have a feeling that the parameter "tD3D11_MAPPED_SUBRESOURCE.RowPitch" might have something to do with this but I don't see how I can incorporate that into the call to "SetDIBits". I have read the "Pitch" remarks from the documentation on D3D11_MAPPED_SUBRESOURCE but I still don't understand what's really going on under the covers.

Maybe someone with more experience in GDI Bitmaps can chime in with some advice?

I've been working on making a WinRT typelib/tB interface package... The stumbling block isn't HSTRING; that's straightforward. The issue I have is some of these insane things that look like dynamically defined interface templates.

Quote:

---

Originally Posted by fafalone

The issue I have is some of these insane things that look like dynamically defined interface templates.

---

I can understand you well that this is not easy to implement. I also sometimes have problems with various WinRT interfaces and don't know how to approach them. Unfortunately, what is very easy in .Net cannot always be replicated in VB6.

This is what I mean. The code captures the whole window (Form1.hWnd) and puts the screenshot in the Picturebox below the two buttons. The first "hBitmap" (made with GDI+) is displayed correctly and the second one (made with SetDIBits) is displayed all warped. I'll be damned if I know what's causing it, the code above looks spot-on whichever way I look at it...

Attachment 187453

try dxgi?

Quote:

---

Originally Posted by VanGoghGaming

The first "hBitmap" (made with GDI+) is displayed correctly and the second one (made with SetDIBits) is displayed all warped

---

tD3D11_MAPPED_SUBRESOURCE.RowPitch gives you back the stride value. For 32bpp this would typically be = Width * 4. The D3D11_MAPPED_SUBRESOURCE documentation says:
For D3D_FEATURE_LEVEL_10_0 and higher, the pointer is aligned to 16 bytes. For lower than D3D_FEATURE_LEVEL_10_0, the pointer is aligned to 4 bytes.
You calculate the stride value yourself here:
.biSizeImage = (((.biWidth * .biBitCount) + 31) \ 32) * 4 * tD3D11_TEXTURE2D_DESC.Height
Try the following:
.biSizeImage = tD3D11_MAPPED_SUBRESOURCE.RowPitch * tD3D11_TEXTURE2D_DESC.Height

Quote:

---

Originally Posted by -Franky-

tD3D11_MAPPED_SUBRESOURCE.RowPitch gives you back the stride value. For 32bpp this would typically be = Width * 4. The D3D11_MAPPED_SUBRESOURCE documentation says:
For D3D_FEATURE_LEVEL_10_0 and higher, the pointer is aligned to 16 bytes. For lower than D3D_FEATURE_LEVEL_10_0, the pointer is aligned to 4 bytes.

---

Yeah I've already read that paragraph in MSDN 3 times and it still doesn't make much sense. I have no idea what's a "stride". Also tD3D11_TEXTURE2D_DESC.Width is 621 for this screenshot and 621*4=2484 while tD3D11_MAPPED_SUBRESOURCE.RowPitch=2560 so I don't know where is this difference coming from, maybe some sort of padding? If so then how can you remove it?

Quote:

---

You calculate the stride value yourself here:
.biSizeImage = (((.biWidth * .biBitCount) + 31) \ 32) * 4 * tD3D11_TEXTURE2D_DESC.Height
Try the following:
.biSizeImage = tD3D11_MAPPED_SUBRESOURCE.RowPitch * tD3D11_TEXTURE2D_DESC.Height

---

Unfortunately this also doesn't work (it would have been too easy if it did, haha)! Furthermore the documentation about BITMAPINFOHEADER says that:

Code:

---

biSizeImage

Specifies the size, in bytes, of the image. This can be set to 0 for uncompressed RGB bitmaps.

---

And that seems to be correct, setting "biSizeImage" to zero makes absolutely no difference...

I have a feeling the solution to this issue should be rather easy and it's still eluding us...

Quote:

---

Originally Posted by VanGoghGaming

...I have no idea what's a "stride".

---

It's an info-attribute, related to making "looped copies".
(representing the pointer-offset to add, before you start your next loop over zerobased x-Values in the current row)

When it is larger than the ImageWidth (or in case of "RowPitch" larger than Width*BytesPerPixel),
then you have to make a copy in a loop (Row-by-Row).

Either via CopyMemory (into a truly consecutive DIB-allocation first, before you Blit-Out your DIB) -
or (in case you want to avoid an intermediate DIB-allocation) by Blitting directly in that loop (defining your DIB to be only "one Row in Height").

Olaf

Thanks for explaining how stuff works, Olaf. You rock as usual! I've finally managed to get it right with the following code using CopyMemory to an intermediate array:

Code:

---

Dim bytePixelData() As Byte
ReDim bytePixelData(0 To tD3D11_TEXTURE2D_DESC.Width * tD3D11_TEXTURE2D_DESC.Height * 4 - 1)
With bmiBitmapInfo.bmiHeader
    .biSize = LenB(bmiBitmapInfo.bmiHeader): .biPlanes = 1: .biBitCount = 32: .biCompression = BI_RGB
    .biWidth = tD3D11_TEXTURE2D_DESC.Width: .biHeight = -tD3D11_TEXTURE2D_DESC.Height
End With
For i = 0 To tD3D11_TEXTURE2D_DESC.Height - 1
    CopyMemory bytePixelData(i * tD3D11_TEXTURE2D_DESC.Width * 4), ByVal tD3D11_MAPPED_SUBRESOURCE.pData + i * tD3D11_MAPPED_SUBRESOURCE.RowPitch, tD3D11_TEXTURE2D_DESC.Width * 4
Next i
SetDIBits 0, hBitmap, 0, tD3D11_TEXTURE2D_DESC.Height, bytePixelData(0), bmiBitmapInfo, DIB_RGB_COLORS

---

However the following code doesn't work as expected:

Code:

---

For i = 0 To tD3D11_TEXTURE2D_DESC.Height - 1
    SetDIBits 0, hBitmap, i, 1, ByVal tD3D11_MAPPED_SUBRESOURCE.pData + i * tD3D11_MAPPED_SUBRESOURCE.RowPitch, bmiBitmapInfo, DIB_RGB_COLORS
Next i

---

Is it not possible to blit one row at a time in a "hBitmap" with "SetDIBits"?

Quote:

---

Originally Posted by VanGoghGaming

Is it not possible to blit one row at a time in a "hBitmap" with "SetDIBits"?

---

It isn't, ... but you get similar performance when you use StretchDIBits instead:
- without Stretching anything
- but with RowIndex i in the DstY-Param
- the number of Rows set to 1
- and BIHeader.biHeight Member also at 1 (or -1)

Olaf

Actually it seems "SetDIBits" does work with one row at a time, but blitting needed to start in reversed order. This took a LOT of "trial and error" but the following code works perfectly:

Code:

---

For i = 0 To tD3D11_TEXTURE2D_DESC.Height - 1
    SetDIBits 0, hBitmap, tD3D11_TEXTURE2D_DESC.Height - i - 1, 1, ByVal tD3D11_MAPPED_SUBRESOURCE.pData + i * tD3D11_MAPPED_SUBRESOURCE.RowPitch, bmiBitmapInfo, DIB_RGB_COLORS
Next i

---

CopyMemory to an intermediate array no longer needed! :D

Looks like I spoke too soon... CopyMemory is noticeably faster than calling SetDIBits in a loop, so yeah, speed is king! :D

@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

Code:

---

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

Code:

---

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

Code:

---

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):

Attachment 187466

And the demo project: Attachment 187486, 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.

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.

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...

Code:

---

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...

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

Code:

---

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:

Code:

---

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.

Quote:

---

Originally Posted by VanGoghGaming

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:-

Code:

---

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.

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! :D

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:

Code:

---

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

---

Quote:

---

Originally Posted by VanGoghGaming

@Franky
Attachment 187466

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

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:

Code:

---

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:

Code:

---

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

---

Quote:

---

Originally Posted by VanGoghGaming

Attachment 187466

---

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

Quote:

---

Originally Posted by 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:

Code:

---

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:

Code:

---

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

Attachment 187482

Quote:

---

Originally Posted by -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.

---

Is there a TypeLib available for WinRT?

Quote:

---

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?

Quote:

---

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!

Quote:

---

Originally Posted by 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

Code:

---

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

Code:

---

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

Code:

---

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):

Attachment 187466

And the demo project: Attachment 187486, 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?

Quote:

---

Originally Posted by dima0909

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.

Quote:

---

Originally Posted by 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:

---

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.

Quote:

---

Originally Posted by -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.

---

Quote:

---

Originally Posted by VanGoghGaming

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.

Quote:

---

Originally Posted by -Franky-

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.

Quote:

---

Originally Posted by 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.

---

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. :rolleyes: It doesn't matter whether it's with a TLB or in the classic way via DispCallFunc.

Quote:

---

Originally Posted by fafalone

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.

could someone convert this code to VB.NET?

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

Quote:

---

Originally Posted by dima0909

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.