Results 1 to 26 of 26

Thread: [VB6] DirectX 11 Desktop Duplication

  1. #1

    Thread Starter
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    [VB6] DirectX 11 Desktop Duplication

    This is a work in progress of a remote control utility. This is the screen capturing part using DirectX 11 (DXGI).

    Code:
    Option Explicit
    DefObj A-Z
    
    #Const SHOW_DELTA = False
    #Const STRETCH_POINTER = False
    
    '=========================================================================
    ' API
    '=========================================================================
    
    '--- DIB Section constants
    Private Const DIB_RGB_COLORS                                As Long = 0 '  color table in RGBs
    '--- for OpenInputDesktop
    Private Const GENERIC_READ                                  As Long = &H80000000
    '--- for SetProcessDpiAwarenessContext
    Private Const DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE_V2    As Long = -4
    '--- for D3DKMTSetProcessSchedulingPriorityClass
    Private Const D3DKMT_SCHEDULINGPRIORITYCLASS_REALTIME       As Long = 5
    
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
    Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits As Long, ByVal Handle As Long, ByVal dw As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
    Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
    Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
    Private Declare Function OpenInputDesktop Lib "user32" (ByVal dwFlags As Long, ByVal fInherit As Boolean, ByVal dwDesiredAccess As Long) As Long
    Private Declare Function CloseDesktop Lib "user32" (ByVal hDesktop As Long) As Long
    Private Declare Function SetThreadDesktop Lib "user32" (ByVal hDesktop As Long) As Long
    Private Declare Function SetProcessDpiAwarenessContext Lib "user32" (ByVal lValue As Long) As Long
    Private Declare Function D3DKMTSetProcessSchedulingPriorityClass Lib "gdi32" (ByVal hProcess As Long, ByVal lPriority As Long) As Long
    Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
            
    Private Type BITMAPINFOHEADER
        biSize              As Long
        biWidth             As Long
        biHeight            As Long
        biPlanes            As Integer
        biBitCount          As Integer
        biCompression       As Long
        biSizeImage         As Long
        biXPelsPerMeter     As Long
        biYPelsPerMeter     As Long
        biClrUsed           As Long
        biClrImportant      As Long
    End Type
    
    Private Type PICTDESC
        lSize               As Long
        lType               As Long
        hBmp                As Long
        hPal                As Long
    End Type
    
    '=========================================================================
    ' Constants and mamber variables
    '=========================================================================
    
    Private m_uCtx                  As UcsDuplicationContext
    Private m_uFrame                As UcsCaptureFrame
    
    Private Type UcsDuplicationContext
        DeviceName          As String
        Width               As Long
        Height              As Long
        Timeout             As Long
        Context             As ID3D11DeviceContext
        Duplication         As IDXGIOutputDuplication
        StageTexture        As ID3D11Texture2D
        DesktopResource     As ID3D11Resource
        InSystemMemory      As Boolean
        Pitch               As Long
        Stride              As Long
        DesktopPicture      As StdPicture
        DesktopBitsPtr      As Long
        PointerPicture      As StdPicture
        PointerBitsPtr      As Long
    End Type
    
    Private Type UcsCaptureFrame
        NumMoveRects        As Long
        MoveRects()         As DXGI_OUTDUPL_MOVE_RECT
        NumDirtyRects       As Long
        DirtyRects()        As D3D11_RECT
        PointerSize         As Long
        PointerShape()      As Byte
        PointerVisible      As Boolean
        PointerPlacement    As D3D11_RECT
        PointerHotspot      As D3D11_POINT
    End Type
    
    '=========================================================================
    ' Error handling
    '=========================================================================
    
    Private Sub PrintError(sFuncName As String)
        Debug.Print Err.Description & " in " & Err.Source, sFuncName
        If MsgBox(Err.Description & " in " & Err.Source, vbCritical Or vbOKCancel, sFuncName) = vbCancel Then
            Unload Me
        End If
    End Sub
    
    '=========================================================================
    ' Methods
    '=========================================================================
    
    Private Function pvEnumOutputDeviceNames() As Collection
        Dim aGUID(0 To 3)   As Long
        Dim pFactory        As IDXGIFactory1
        Dim lIdx            As Long
        Dim lJdx            As Long
        Dim pAdapter        As IDXGIAdapter1
        Dim pOutput         As IDXGIOutput1
        Dim uAdapterDesc    As DXGI_ADAPTER_DESC
        Dim uOutputDesc     As DXGI_OUTPUT_DESC
        
        Set pvEnumOutputDeviceNames = New Collection
        Call IIDFromString(szIID_DXGIFactory1, aGUID(0))
        Set pFactory = CreateDXGIFactory1(aGUID(0))
        For lIdx = 0 To 100
            Set pAdapter = Nothing
            If pFactory.EnumAdapters1(lIdx, pAdapter) < 0 Then
                Exit For
            End If
            pAdapter.GetDesc uAdapterDesc
    '        Debug.Print Replace(uAdapterDesc.Description, vbNullChar, vbNullString)
            For lJdx = 0 To 100
                Set pOutput = Nothing
                If pAdapter.EnumOutputs(lJdx, pOutput) < 0 Then
                    Exit For
                End If
                pOutput.GetDesc uOutputDesc
                pvEnumOutputDeviceNames.Add Array(Replace(uOutputDesc.DeviceName, vbNullChar, vbNullString), _
                    Replace(uAdapterDesc.Description, vbNullChar, vbNullString))
            Next
        Next
    End Function
    
    Private Function pvInitCapture(uCtx As UcsDuplicationContext, ByVal sDeviceName As String, ByVal lTimeout As Long) As Boolean
        Const FUNC_NAME     As String = "pvInitCapture"
        Dim hDesktop        As Long
        Dim aGUID(0 To 3)   As Long
        Dim pFactory        As IDXGIFactory1
        Dim lIdx            As Long
        Dim lJdx            As Long
        Dim pAdapter        As IDXGIAdapter1
        Dim pOutput         As IDXGIOutput1
        Dim pOutput5        As IDXGIOutput5
        Dim uOutputDesc     As DXGI_OUTPUT_DESC
        Dim hResult         As Long
        Dim pD3D11Device    As ID3D11Device
        Dim pDXGIDevice     As IDXGIDevice1
        Dim uTextureDesc    As D3D11_TEXTURE2D_DESC
        Dim uDuplDesc       As DXGI_OUTDUPL_DESC
        Dim uResource       As D3D11_MAPPED_SUBRESOURCE
        
        On Error GoTo EH
        '--- allow capture the secure desktop
        hDesktop = OpenInputDesktop(0, 0, GENERIC_READ)
        If hDesktop <> 0 Then
            Call SetThreadDesktop(hDesktop)
            Call CloseDesktop(hDesktop)
        End If
        On Error Resume Next '--- Windows 10, version 1703 and above
        Call SetProcessDpiAwarenessContext(DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE_V2)
        On Error GoTo EH
        With uCtx
            .DeviceName = vbNullString
            Set .DesktopResource = Nothing
            Set .Duplication = Nothing
            Set .StageTexture = Nothing
            Set .Context = Nothing
            Set .DesktopPicture = Nothing
            Set .PointerPicture = Nothing
            Call IIDFromString(szIID_DXGIFactory1, aGUID(0))
            Set pFactory = CreateDXGIFactory1(aGUID(0))
            For lIdx = 0 To 100
                Set pAdapter = Nothing
                hResult = pFactory.EnumAdapters1(lIdx, pAdapter)
                If hResult = DXGI_ERROR_NOT_FOUND Then
                    Exit For
                End If
                If hResult < 0 Then
                    Err.Raise hResult, "IDXGIFactory1.EnumAdapters1"
                End If
                For lJdx = 0 To 100
                    Set pOutput = Nothing
                    hResult = pAdapter.EnumOutputs(lJdx, pOutput)
                    If hResult = DXGI_ERROR_NOT_FOUND Then
                        Exit For
                    End If
                    If hResult < 0 Then
                        Err.Raise hResult, "IDXGIAdapter1.EnumOutputs"
                    End If
                    pOutput.GetDesc uOutputDesc
                    If LenB(sDeviceName) <> 0 And Not Replace(uOutputDesc.DeviceName, vbNullChar, vbNullString) Like sDeviceName Then
                        GoTo Continue
                    End If
                    If uOutputDesc.AttachedToDesktop <> 0 Then
                        lIdx = 100
                        Exit For
                    End If
    Continue:
                Next
            Next
            If pOutput Is Nothing Then
                GoTo QH
            End If
            .DeviceName = Replace(uOutputDesc.DeviceName, vbNullChar, vbNullString)
            .Width = uOutputDesc.DesktopCoordinates.Right - uOutputDesc.DesktopCoordinates.Left
            .Height = uOutputDesc.DesktopCoordinates.Bottom - uOutputDesc.DesktopCoordinates.Top
            .Timeout = lTimeout
            hResult = D3D11CreateDevice(pAdapter, D3D_DRIVER_TYPE_UNKNOWN, 0, D3D11_CREATE_DEVICE_VIDEO_SUPPORT, ByVal 0, 0, D3D11_SDK_VERSION, pD3D11Device, 0, .Context)
            If hResult < 0 Then
                Err.Raise hResult, "D3D11CreateDevice"
            End If
            Call D3DKMTSetProcessSchedulingPriorityClass(GetCurrentProcess(), D3DKMT_SCHEDULINGPRIORITYCLASS_REALTIME)
            Set pDXGIDevice = pD3D11Device
            pDXGIDevice.SetGPUThreadPriority 7
            pDXGIDevice.SetMaximumFrameLatency 1
            If TypeOf pOutput Is IDXGIOutput5 Then
                Set pOutput5 = pOutput
                Dim aFormats(0 To 3) As DXGI_FORMAT
                aFormats(0) = DXGI_FORMAT_B8G8R8A8_UNORM
                aFormats(1) = DXGI_FORMAT_R8G8B8A8_UNORM
                aFormats(2) = DXGI_FORMAT_R10G10B10A2_UNORM
                aFormats(3) = DXGI_FORMAT_R16G16B16A16_FLOAT
                hResult = pOutput5.DuplicateOutput1(pD3D11Device, 0, UBound(aFormats) + 1, aFormats(0), .Duplication)
                If hResult < 0 Then
                    Err.Raise hResult, "IDXGIOutput5.DuplicateOutput1"
                End If
            Else
                hResult = pOutput.DuplicateOutput(pD3D11Device, .Duplication)
                If hResult < 0 Then
                    Err.Raise hResult, "IDXGIOutput1.DuplicateOutput"
                End If
            End If
            .Duplication.GetDesc uDuplDesc
            .InSystemMemory = (uDuplDesc.DesktopImageInSystemMemory <> 0)
            Debug.Assert uDuplDesc.ModeDesc.Format = DXGI_FORMAT_B8G8R8A8_UNORM
            With uTextureDesc
                .Width = uCtx.Width
                .Height = uCtx.Height
                .MipLevels = 1
                .ArraySize = 1
                .Format = uDuplDesc.ModeDesc.Format
                .SampleDesc.Count = 1
                .SampleDesc.Quality = 0
                .Usage = D3D11_USAGE_STAGING
                .BindFlags = 0
                .CPUAccessFlags = D3D11_CPU_ACCESS_READ
                .MiscFlags = 0
            End With
            Set .StageTexture = pD3D11Device.CreateTexture2D(uTextureDesc)
            hResult = .Context.Map(.StageTexture, 0, D3D11_MAP_READ, 0, uResource)
            If hResult < 0 Then
                Err.Raise hResult, "ID3D11DeviceContext.Map"
            End If
            .Pitch = uResource.RowPitch
            .Stride = uResource.RowPitch / IIf(uDuplDesc.ModeDesc.Format = DXGI_FORMAT_R16G16B16A16_FLOAT, 8, 4)
            .Context.Unmap .StageTexture, 0
        End With
        '--- success
        pvInitCapture = True
    QH:
        Exit Function
    EH:
        PrintError FUNC_NAME
    End Function
    
    Private Function pvCaptureScreen(uCtx As UcsDuplicationContext, oPicDesktop As StdPicture, oPicPointer As StdPicture, uCapture As UcsCaptureFrame) As Boolean
        Const FUNC_NAME     As String = "pvCaptureScreen"
        Const SIZE_OUTDUPL_MOVE_RECT As Long = 24
        Const SIZE_RECT     As Long = 16
        Const BLACK_COLOR   As Long = &HFF000000
        Dim hResult         As Long
        Dim lIdx            As Long
        Dim uResource       As D3D11_MAPPED_SUBRESOURCE
        Dim hMemDC          As Long
        Dim hDib            As Long
        Dim uMapRect        As DXGI_MAPPED_RECT
        Dim lSize           As Long
        Dim dblTimerEx      As Double
        Dim lX              As Long
        Dim lY              As Long
        Dim pTex            As ID3D11Texture2D
        Dim uFrameInfo      As DXGI_OUTDUPL_FRAME_INFO
        Dim aMask(0 To 7)   As Byte
        Dim uPointerInfo    As DXGI_OUTDUPL_POINTER_SHAPE_INFO
    
        On Error GoTo EH
        dblTimerEx = TimerEx
        With uCtx
            If .Duplication Is Nothing Then
                GoTo QH
            End If
            If Not .DesktopResource Is Nothing Then
                .Duplication.ReleaseFrame
                Set .DesktopResource = Nothing
            End If
            hResult = .Duplication.AcquireNextFrame(1, uFrameInfo, .DesktopResource)
            If hResult = DXGI_ERROR_WAIT_TIMEOUT Then
                '--- success
                pvCaptureScreen = True
                GoTo QH
            End If
            If hResult < 0 Then
                GoTo QH
            End If
            If uFrameInfo.LastPresentTime.LowPart <> 0 Or uFrameInfo.LastPresentTime.HighPart <> 0 Then
                Set pTex = .StageTexture
            End If
            '--- init mem dc
            hMemDC = CreateCompatibleDC(0)
            If hMemDC = 0 Then
                GoTo QH
            End If
            '--- capture frame
            hResult = .Duplication.GetFrameMoveRects((UBound(uCapture.MoveRects) + 1) * SIZE_OUTDUPL_MOVE_RECT, uCapture.MoveRects(0), lSize)
            If hResult = DXGI_ERROR_MORE_DATA Then
                ReDim uCapture.MoveRects(0 To lSize \ SIZE_OUTDUPL_MOVE_RECT - 1) As DXGI_OUTDUPL_MOVE_RECT
                hResult = .Duplication.GetFrameMoveRects((UBound(uCapture.MoveRects) + 1) * SIZE_OUTDUPL_MOVE_RECT, uCapture.MoveRects(0), lSize)
            End If
            If hResult < 0 Then
                GoTo QH
            End If
            uCapture.NumMoveRects = lSize / SIZE_OUTDUPL_MOVE_RECT
            hResult = .Duplication.GetFrameDirtyRects((UBound(uCapture.DirtyRects) + 1) * SIZE_RECT, uCapture.DirtyRects(0), lSize)
            If hResult = DXGI_ERROR_MORE_DATA Then
                ReDim uCapture.DirtyRects(0 To lSize \ SIZE_RECT - 1) As D3D11_RECT
                hResult = .Duplication.GetFrameDirtyRects((UBound(uCapture.DirtyRects) + 1) * SIZE_RECT, uCapture.DirtyRects(0), lSize)
            End If
            If hResult < 0 Then
                GoTo QH
            End If
            uCapture.NumDirtyRects = lSize / SIZE_RECT
            If uFrameInfo.PointerShapeBufferSize > 0 Then
                hResult = .Duplication.GetFramePointerShape((UBound(uCapture.PointerShape) + 1), uCapture.PointerShape(0), uCapture.PointerSize, uPointerInfo)
                If hResult = DXGI_ERROR_MORE_DATA Then
                    ReDim uCapture.PointerShape(0 To uCapture.PointerSize - 1) As Byte
                    hResult = .Duplication.GetFramePointerShape((UBound(uCapture.PointerShape) + 1), uCapture.PointerShape(0), uCapture.PointerSize, uPointerInfo)
                End If
                If hResult < 0 Then
                    GoTo QH
                End If
                uCapture.PointerHotspot = uPointerInfo.HotSpot
            End If
            If uFrameInfo.LastMouseUpdateTime.LowPart <> 0 Or uFrameInfo.LastMouseUpdateTime.HighPart <> 0 Then
                uCapture.PointerVisible = (uFrameInfo.PointerPosition.Visible <> 0)
                uCapture.PointerPlacement.Left = uFrameInfo.PointerPosition.Position.X
                uCapture.PointerPlacement.Top = uFrameInfo.PointerPosition.Position.Y
            End If
            '--- copy desktop
            If .DesktopPicture Is Nothing Then
                If Not pvCreateDib(hMemDC, .Width, .Height, hDib, .DesktopBitsPtr) Then
                    GoTo QH
                End If
                If Not pvCreateStdPicture(hDib, .DesktopPicture) Then
                    GoTo QH
                End If
                hDib = 0
                Set oPicDesktop = .DesktopPicture
            End If
            If .InSystemMemory Then
                .Duplication.MapDesktopSurface uMapRect
                For lIdx = 0 To .Height - 1
                    Call CopyMemory(ByVal .DesktopBitsPtr + lIdx * .Width * 4, ByVal uMapRect.pBitsPtr + lIdx * uMapRect.Pitch, .Width * 4)
                Next
                .Duplication.UnMapDesktopSurface
            ElseIf Not pTex Is Nothing Then
                .Context.CopyResource pTex, .DesktopResource
                hResult = .Context.Map(pTex, 0, D3D11_MAP_READ, 0, uResource)
                If hResult < 0 Then
                    Err.Raise hResult, "ID3D11DeviceContext.Map"
                End If
                #If SHOW_DELTA Then
                    For lIdx = 0 To .Height - 1
                        Call CopyMemory(ByVal .DesktopBitsPtr + lIdx * .Width * 4, ByVal uResource.pDataPtr + lIdx * uResource.RowPitch, .Width * 4)
                    Next
                    Const BORDER_COLOR  As Long = &HFFFF0000
                    For lIdx = 0 To uCapture.NumDirty - 1
                        For lX = uCapture.DirtyRects(lIdx).Left To uCapture.DirtyRects(lIdx).Right - 1
                            Call CopyMemory(ByVal .DesktopBitsPtr + (uCapture.DirtyRects(lIdx).Top * .Width + lX) * 4, BORDER_COLOR, 4)
                            Call CopyMemory(ByVal .DesktopBitsPtr + ((uCapture.DirtyRects(lIdx).Bottom - 1) * .Width + lX) * 4, BORDER_COLOR, 4)
                        Next
                        For lY = uCapture.DirtyRects(lIdx).Top To uCapture.DirtyRects(lIdx).Bottom - 1
                            Call CopyMemory(ByVal .DesktopBitsPtr + (lY * .Width + uCapture.DirtyRects(lIdx).Left) * 4, BORDER_COLOR, 4)
                            Call CopyMemory(ByVal .DesktopBitsPtr + (lY * .Width + uCapture.DirtyRects(lIdx).Right - 1) * 4, BORDER_COLOR, 4)
                        Next
                    Next
                #Else
                    For lIdx = 0 To uCapture.NumDirtyRects - 1
                        lX = uCapture.DirtyRects(lIdx).Left
                        For lY = uCapture.DirtyRects(lIdx).Top To uCapture.DirtyRects(lIdx).Bottom - 1
                            Call CopyMemory(ByVal .DesktopBitsPtr + (lY * .Width + lX) * 4, ByVal uResource.pDataPtr + lY * uResource.RowPitch + lX * 4, (uCapture.DirtyRects(lIdx).Right - lX) * 4)
                        Next
                    Next
                #End If
                .Context.Unmap pTex, 0
                uResource.pDataPtr = 0
            End If
            '--- copy pointer
            If uFrameInfo.PointerShapeBufferSize > 0 Then
                If uPointerInfo.Type <> DXGI_OUTDUPL_POINTER_SHAPE_TYPE_COLOR Then
                    uPointerInfo.Height = uPointerInfo.Height \ 2
                End If
                If Not pvCreateDib(hMemDC, uPointerInfo.Width, uPointerInfo.Height, hDib, .PointerBitsPtr) Then
                    GoTo QH
                End If
                If Not pvCreateStdPicture(hDib, .PointerPicture) Then
                    GoTo QH
                End If
                hDib = 0
                Set oPicPointer = .PointerPicture
                Select Case uPointerInfo.Type
                Case DXGI_OUTDUPL_POINTER_SHAPE_TYPE_COLOR
                    For lY = 0 To uPointerInfo.Height - 1
                        Call CopyMemory(ByVal .PointerBitsPtr + lY * uPointerInfo.Width * 4, uCapture.PointerShape(lY * uPointerInfo.Pitch), uPointerInfo.Width * 4)
                    Next
                Case DXGI_OUTDUPL_POINTER_SHAPE_TYPE_MONOCHROME
                    For lIdx = 0 To 7
                        aMask(lIdx) = &H80 \ 2 ^ (lIdx Mod 8)
                    Next
                    '--- collect XOR mask only (skip AND)
                    lIdx = uPointerInfo.Pitch * uPointerInfo.Height
                    For lY = 0 To uPointerInfo.Height - 1
                        For lX = 0 To uPointerInfo.Width - 1
                            If (uCapture.PointerShape(lIdx + lY * uPointerInfo.Pitch + lX \ 8) And aMask(lX Mod 8)) <> 0 Then
                                Call CopyMemory(ByVal .PointerBitsPtr + (lY * uPointerInfo.Width + lX) * 4, BLACK_COLOR, 4)
                            End If
                        Next
                    Next
                Case Else
                    Debug.Print ".PointerInfo.Type=" & Hex(uPointerInfo.Type)
                End Select
                uCapture.PointerPlacement.Right = uPointerInfo.Width
                uCapture.PointerPlacement.Bottom = uPointerInfo.Height
            End If
        End With
        '--- success
        pvCaptureScreen = True
    QH:
        If hDib <> 0 Then
            Call DeleteObject(hDib)
            hDib = 0
        End If
        If hMemDC <> 0 Then
            Call DeleteDC(hMemDC)
            hMemDC = 0
        End If
        If uResource.pDataPtr <> 0 Then
            uCtx.Context.Unmap pTex, 0
        End If
        If Not pTex Is Nothing Then
            Debug.Print "Elapsed=" & Format(TimerEx - dblTimerEx, "0.000")
        End If
        Exit Function
    EH:
        PrintError FUNC_NAME
        Resume QH
    End Function
    
    Private Function pvCreateDib(ByVal hMemDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, hDib As Long, Optional lpBits As Long) As Boolean
        Const FUNC_NAME     As String = "pvCreateDib"
        Dim uHdr            As BITMAPINFOHEADER
        
        On Error GoTo EH
        With uHdr
            .biSize = Len(uHdr)
            .biPlanes = 1
            .biBitCount = 32
            .biWidth = lWidth
            .biHeight = -lHeight
            .biSizeImage = 4 * lWidth * lHeight
        End With
        hDib = CreateDIBSection(hMemDC, uHdr, DIB_RGB_COLORS, lpBits, 0, 0)
        If hDib = 0 Then
            GoTo QH
        End If
        '--- success
        pvCreateDib = True
    QH:
        Exit Function
    EH:
        PrintError FUNC_NAME
        Resume QH
    End Function
    
    Private Function pvCreateStdPicture(hDib As Long, oPic As StdPicture) As Boolean
        Const FUNC_NAME     As String = "pvCreateStdPicture"
        Dim uDesc           As PICTDESC
        Dim aGUID(0 To 3)   As Long
        
        On Error GoTo EH
        With uDesc
            .lSize = Len(uDesc)
            .lType = vbPicTypeBitmap
            .hBmp = hDib
        End With
        '--- IID_IPicture
        aGUID(0) = &H7BF80980
        aGUID(1) = &H101ABF32
        aGUID(2) = &HAA00BB8B
        aGUID(3) = &HAB0C3000
        If OleCreatePictureIndirect(uDesc, aGUID(0), 1, oPic) <> 0 Then
            GoTo QH
        End If
        '--- success
        pvCreateStdPicture = True
    QH:
        Exit Function
    EH:
        PrintError FUNC_NAME
    End Function
    
    Public Property Get TimerEx() As Double
        Dim cFreq           As Currency
        Dim cValue          As Currency
        
        Call QueryPerformanceFrequency(cFreq)
        Call QueryPerformanceCounter(cValue)
        TimerEx = cValue / cFreq
    End Property
    
    '=========================================================================
    ' Control events
    '=========================================================================
    
    Private Sub Form_Load()
        Dim vElem           As Variant
        
        With m_uFrame
            ReDim .MoveRects(0 To 0) As DXGI_OUTDUPL_MOVE_RECT
            ReDim .DirtyRects(0 To 0) As D3D11_RECT
            ReDim .PointerShape(0 To 0) As Byte
        End With
        For Each vElem In pvEnumOutputDeviceNames
            Combo1.AddItem vElem(0)
        Next
        Combo1.ListIndex = 0
    End Sub
    
    Private Sub Form_Resize()
        Dim dblTop          As Double
        
        If WindowState <> vbMinimized Then
            dblTop = Combo1.Top + Combo1.Height + Combo1.Top
            If ScaleHeight - dblTop > 0 Then
                imgDesktop.Move 0, dblTop, ScaleWidth, ScaleHeight - dblTop
            End If
        End If
    End Sub
    
    Private Sub Combo1_Click()
        If Combo1.ListIndex >= 0 Then
            If Not pvInitCapture(m_uCtx, Combo1.Text, Timer1.Interval) Then
                Timer1.Enabled = False
            Else
                Timer1.Enabled = True
                Timer1_Timer
            End If
        End If
    End Sub
    
    Private Sub imgDesktop_Click()
        Timer1.Enabled = Not Timer1.Enabled
    End Sub
    
    ...
    There is a custom DirectX 11 type library (both .idl and .tlb in the archive) with just enough interfaces to instantiate IDXGIOutputDuplication and capture a texture which is then converted to a DIB which is then converted to a StdPicture and placed in a stretching Image control so the scale quality is poor.

    The idea is for a remote screen sharing implementation to transport only screen diffs using GetFrameDirtyRects, GetFrameMoveRects and GetFramePointerShape methods (instead of current full screen capture) with some fast LZ4 compression on top and some Foreward Error Correction implementation over UDP, including UDP hole punching for serverless peer-to-peer connections when both parties happen to be behind NAT or alternative is using STUN/TURN infrastructure as currently provided by google for WebRTC.

    cheers,
    </wqw>
    Attached Files Attached Files

  2. #2
    New Member
    Join Date
    Jun 2019
    Posts
    12

    Re: [VB6] DirectX 11 Desktop Duplication

    This is great work.

    Is it possible to use it as VNC client to capture Unix/Linux desktops?

  3. #3

    Thread Starter
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    Re: [VB6] DirectX 11 Desktop Duplication

    VNC client -- no, because desktop duplication is used for implementing VNC servers on Windows like this one -- a single class VNC Server in VB6.

    We are using this exact class in all our Line-Of-Business applications so that our support team can (optionally) view client's screen on demand when responding to a support call.

    You can use UltraVNC, TightVNC, TigerVNC or whatever VNC client you prefer for your OS (Windows/Linux/MacOS).

    cheers,
    </wqw>

  4. #4
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    673

    Re: [VB6] DirectX 11 Desktop Duplication

    The screenshot speed is really fast, and it doesn't get stuck. It's much faster than printwindow. I don't know if I can specify a window handle to screenshot. It seems that I can't find the code

  5. #5
    New Member
    Join Date
    Aug 2022
    Posts
    13

    Re: [VB6] DirectX 11 Desktop Duplication

    I also couldn't get the image by informing a handle will someone be able to give us a light ?!

  6. #6

    Thread Starter
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    Re: [VB6] DirectX 11 Desktop Duplication

    Quote Originally Posted by android____ View Post
    . . . will someone be able to give us a light ?!
    Doubt it, unless you explain what "informing a handle" means. . .

    cheers,
    </wqw>

  7. #7
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,318

    Re: [VB6] DirectX 11 Desktop Duplication

    In the Windows operating system every window is associated with a numeric value called "handle", commonly abbreviated as "hWnd". The inquiry refers to modifying the code above to capture only the contents of a particular window identified by its "hWnd".

  8. #8
    New Member
    Join Date
    Aug 2022
    Posts
    13

    Re: [VB6] DirectX 11 Desktop Duplication

    exactly that, I believe you need to modify the code for it to capture the image only by the handle and not the entire desktop.

    Thank you for your help

  9. #9

    Thread Starter
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    Re: [VB6] DirectX 11 Desktop Duplication

    Quote Originally Posted by android____ View Post
    exactly that, I believe you need to modify the code for it to capture the image only by the handle and not the entire desktop.

    Thank you for your help
    Yes, you have to modify it as it currently does not capture by hwnd.

  10. #10
    New Member
    Join Date
    Aug 2022
    Posts
    13

    Re: [VB6] DirectX 11 Desktop Duplication

    Thanks friend I'm going to analyze how I can be making this change, in fact I've tried some things but I haven't been successful yet.
    but for now thanks for your attention.

  11. #11
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,318

    Re: [VB6] DirectX 11 Desktop Duplication

    As the name suggests ("Duplication") I think it's intended to copy only the whole desktop. That's only speculation though since the code is hard to understand without proper documentation. One solution would be to modify the CreateDIB function to extract only the bits corresponding to the desired window to be captured. But that is a less than ideal solution...

  12. #12
    New Member
    Join Date
    Aug 2022
    Posts
    13

    Re: [VB6] DirectX 11 Desktop Duplication

    Quote Originally Posted by VanGoghGaming View Post
    As the name suggests ("Duplication") I think it's intended to copy only the whole desktop. That's only speculation though since the code is hard to understand without proper documentation. One solution would be to modify the CreateDIB function to extract only the bits corresponding to the desired window to be captured. But that is a less than ideal solution...
    You're right, I'm going to take a look I thought of the same solution you gave but then I don't think it would be cool. but for now thanks if I manage to evolve let me know here

  13. #13
    New Member
    Join Date
    Aug 2022
    Posts
    13

    Re: [VB6] DirectX 11 Desktop Duplication

    my project is in dll if i add this module the dll does not work in windows 7, it seems that it generates some error in the communication with the tlb of directx11

  14. #14
    New Member
    Join Date
    Aug 2022
    Posts
    13

    Re: [VB6] DirectX 11 Desktop Duplication

    Quote Originally Posted by android____ View Post
    my project is in dll if i add this module the dll does not work in windows 7, it seems that it generates some error in the communication with the tlb of directx11
    I found where the error always appears in the call

    Call IIDFromString(szIID_DXGIFactory1, aGUID(0))

  15. #15

  16. #16
    New Member
    Join Date
    Aug 2022
    Posts
    13

    Re: [VB6] DirectX 11 Desktop Duplication

    Quote Originally Posted by wqweto View Post
    Desktop duplication is a Win8+ feature which might explain the error you're experiencing.

    cheers,
    </wqw>
    yes about the version I managed to solve, the question was the version of windows itself. now I'm focused on trying to capture the print only of the specific window I want through hwnd

  17. #17
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: [VB6] DirectX 11 Desktop Duplication

    应该可以指定屏幕接触的范围。要设置到你窗口的位置,这样只有该区域发生变化的才给你截图。

  18. #18
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,318

    Red face Re: [VB6] DirectX 11 Desktop Duplication

    Quote Originally Posted by xiaoyao View Post
    应该可以指定屏幕接触的范围。要设置到你窗口的位置,这样只有该区域发生变化的才给你截图。
    Google translates that as "It should be possible to specify the range of screen contact. To set it to the position of your window, so that only when the area changes, it will give you a screenshot".

    I'd argue that a simple "BitBlt" from the desktop window would do the same thing in roughly the same time if not faster...

  19. #19
    New Member
    Join Date
    Aug 2022
    Posts
    13

    Re: [VB6] DirectX 11 Desktop Duplication

    Quote Originally Posted by VanGoghGaming View Post
    Google translates that as "It should be possible to specify the range of screen contact. To set it to the position of your window, so that only when the area changes, it will give you a screenshot".

    I'd argue that a simple "BitBlt" from the desktop window would do the same thing in roughly the same time if not faster...
    yes, through BitBlt I can capture the hwnd yes, I really wanted to try to capture it using this code that I thought was cool, more like learning. but thanks for the attention friend I'm trying to do it if I get notice and post it here.

  20. #20
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,318

    Lightbulb Re: [VB6] DirectX 11 Desktop Duplication

    I am also interested in window capture techniques involving DirectX but this code doesn't seem to do that at all. It only works with the whole desktop and BitBlt can also capture the whole desktop. BitBlt can also capture most windows by getting their device context from their hWnd ("hDC=GetDC(hWnd)"). The problem with that is that for certain windows it will return a black screenshot and in those cases a "DirectX" capturing method would come in handy.

    In this post Franky shows an alternative capturing method using "WinRT" but that is not really usable because of repeated calls to "DispCallFunc" that are absolutely killing the capture speed.

  21. #21

    Thread Starter
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Location
    Sofia, Bulgaria
    Posts
    5,120

    Re: [VB6] DirectX 11 Desktop Duplication

    You can make a billion DispCallFunc for the duration of a single whole screen BitBlt so it cannot be a bottleneck in this case.

  22. #22
    New Member
    Join Date
    Aug 2022
    Posts
    13

    Re: [VB6] DirectX 11 Desktop Duplication

    Quote Originally Posted by VanGoghGaming View Post
    I am also interested in window capture techniques involving DirectX but this code doesn't seem to do that at all. It only works with the whole desktop and BitBlt can also capture the whole desktop. BitBlt can also capture most windows by getting their device context from their hWnd ("hDC=GetDC(hWnd)"). The problem with that is that for certain windows it will return a black screenshot and in those cases a "DirectX" capturing method would come in handy.

    In this post Franky shows an alternative capturing method using "WinRT" but that is not really usable because of repeated calls to "DispCallFunc" that are absolutely killing the capture speed.
    Friend is exactly the problem I'm trying to get around, the black screen problem in some cases with bitblt. so I'm trying to explore DirectX.
    I researched about the magnification.dll but I couldn't also make use of this dll in vb6

  23. #23
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,318

    Talking Re: [VB6] DirectX 11 Desktop Duplication

    Quote Originally Posted by android____ View Post
    Friend is exactly the problem I'm trying to get around, the black screen problem in some cases with bitblt. so I'm trying to explore DirectX.
    I researched about the magnification.dll but I couldn't also make use of this dll in vb6
    You should read the post I linked above, there I provided a viable solution to the "BitBlt" black screen by using "PrintWindow" with the "PW_RENDERFULLCONTENT" flag instead!

    You can make a billion DispCallFunc for the duration of a single whole screen BitBlt so it cannot be a bottleneck in this case.
    Yep, it seems you are correct, "DispCallFunc" isn't much of a bottleneck if any. I've replaced most of the "Invokes" from Franky's code (except those using WinRT of course) with direct function calls from your excellent VBD3D11 TypeLib and it didn't make any difference in execution speed at all, it's still as slow as snails. "PrintWindow" is about 4 times faster.

    There are simply way too many function calls for the otherwise "mundane" task of retrieving a simple array of pixels...

  24. #24
    New Member
    Join Date
    Aug 2022
    Posts
    13

    Re: [VB6] DirectX 11 Desktop Duplication

    In this magnification.dll I found it interesting that you can take a print of the desktop and ignore any hwnd that you have in front, it can capture the desktop ignoring a hwnd of the print. but I couldn't simulate in vb6

  25. #25
    New Member
    Join Date
    Aug 2022
    Posts
    13

    Re: [VB6] DirectX 11 Desktop Duplication

    [QUOTE=VanGoghGaming;5602702]You should read the post I linked above, there I provided a viable solution to the "BitBlt" black screen by using "PrintWindow" with the "PW_RENDERFULLCONTENT" flag instead!

    Yes, I forgot to thank you, it worked perfectly
    Thanks

  26. #26
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,318

    Cool Re: [VB6] DirectX 11 Desktop Duplication

    Quote Originally Posted by VanGoghGaming View Post
    Yep, it seems you are correct, "DispCallFunc" isn't much of a bottleneck if any. I've replaced most of the "Invokes" from Franky's code (except those using WinRT of course) with direct function calls from your excellent VBD3D11 TypeLib and it didn't make any difference in execution speed at all, it's still as slow as snails. "PrintWindow" is about 4 times faster.

    There are simply way too many function calls for the otherwise "mundane" task of retrieving a simple array of pixels...
    I'm taking all that back now! It was mostly an "optimization" problem (or lack thereof). Now the capturing speed is better than "PrintWindow", haha! Sample code is available in the original thread here.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width