This is a work in progress of a remote control utility. This is the screen capturing part using DirectX 11 (DXGI).
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>
Code:
Option Explicit
DefObj A-Z
'--- DIB Section constants
Private Const DIB_RGB_COLORS As Long = 0 ' color table in RGBs
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 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
Private Type UcsDuplicationContext
DeviceName As String
Width As Long
Height As Long
Timeout As Long
Context As ID3D11DeviceContext
StageTexture As ID3D11Texture2D
Duplication As IDXGIOutputDuplication
DesktopResource As ID3D11Resource
InSystemMemory As Boolean
FrameInfo As DXGI_OUTDUPL_FRAME_INFO
MoveRects() As DXGI_OUTDUPL_MOVE_RECT
NumMove As Long
DirtyRects() As D3D11_RECT
NumDirty As Long
PointerShape() As Byte
PointerInfo As DXGI_OUTDUPL_POINTER_SHAPE_INFO
End Type
Private m_uCtx As UcsDuplicationContext
Private Sub PrintError(sFuncName As String)
Debug.Print Err.Description & " in " & sFuncName
If MsgBox(Err.Description, vbCritical Or vbOKCancel, sFuncName) = vbCancel Then
Unload Me
End If
End Sub
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 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 uOutputDesc As DXGI_OUTPUT_DESC
Dim hResult As Long
Dim pDevice As ID3D11Device
Dim uTextureDesc As D3D11_TEXTURE2D_DESC
Dim uDuplDesc As DXGI_OUTDUPL_DESC
On Error GoTo EH
With uCtx
.DeviceName = vbNullString
Set .DesktopResource = Nothing
Set .Duplication = Nothing
Set .StageTexture = Nothing
Set .Context = Nothing
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
For lJdx = 0 To 100
Set pOutput = Nothing
If pAdapter.EnumOutputs(lJdx, pOutput) <> 0 Then
Exit For
End If
pOutput.GetDesc uOutputDesc
If Replace(uOutputDesc.DeviceName, vbNullChar, vbNullString) Like sDeviceName Or LenB(sDeviceName) = 0 Then
lIdx = 100
Exit For
End If
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, 0, ByVal 0, 0, D3D11_SDK_VERSION, pDevice, 0, .Context)
If hResult < 0 Then
Err.Raise hResult
End If
With uTextureDesc
.Width = uCtx.Width
.Height = uCtx.Height
.MipLevels = 1
.ArraySize = 1
.Format = DXGI_FORMAT_B8G8R8A8_UNORM
.SampleDesc.Count = 1
.SampleDesc.Quality = 0
.Usage = D3D11_USAGE_STAGING
.BindFlags = 0
.CPUAccessFlags = D3D11_CPU_ACCESS_READ
.MiscFlags = 0
End With
Set .StageTexture = pDevice.CreateTexture2D(uTextureDesc)
Set .Duplication = pOutput.DuplicateOutput(pDevice)
.Duplication.GetDesc uDuplDesc
.InSystemMemory = (uDuplDesc.DesktopImageInSystemMemory <> 0)
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
'--- success
pvInitCapture = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Private Function pvCaptureScreen(uCtx As UcsDuplicationContext, oPicDesktop As StdPicture, oPicPointer As StdPicture) As Boolean
Const FUNC_NAME As String = "pvCaptureScreen"
Const SIZE_OUTDUPL_MOVE_RECT As Long = 24
Const SIZE_RECT As Long = 16
Const BORDER_COLOR As Long = &HFFFF0000
Dim hResult As Long
Dim lIdx As Long
Dim uResource As D3D11_MAPPED_SUBRESOURCE
Dim hMemDC As Long
Dim hPointerDib As Long
Dim hDib As Long
Dim lpBits 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 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(.Timeout / 2, .FrameInfo, .DesktopResource)
If hResult = DXGI_ERROR_WAIT_TIMEOUT Then
'--- success
pvCaptureScreen = True
GoTo QH
End If
If hResult < 0 Then
GoTo QH
End If
hResult = .Duplication.GetFrameMoveRects((UBound(.MoveRects) + 1) * SIZE_OUTDUPL_MOVE_RECT, .MoveRects(0), lSize)
If hResult = DXGI_ERROR_MORE_DATA Then
ReDim .MoveRects(0 To lSize \ SIZE_OUTDUPL_MOVE_RECT - 1) As DXGI_OUTDUPL_MOVE_RECT
hResult = .Duplication.GetFrameMoveRects((UBound(.MoveRects) + 1) * SIZE_OUTDUPL_MOVE_RECT, .MoveRects(0), lSize)
End If
If hResult < 0 Then
GoTo QH
End If
.NumMove = lSize / SIZE_OUTDUPL_MOVE_RECT
hResult = .Duplication.GetFrameDirtyRects((UBound(.DirtyRects) + 1) * SIZE_RECT, .DirtyRects(0), lSize)
If hResult = DXGI_ERROR_MORE_DATA Then
ReDim .DirtyRects(0 To lSize \ SIZE_RECT - 1) As D3D11_RECT
hResult = .Duplication.GetFrameDirtyRects((UBound(.DirtyRects) + 1) * SIZE_RECT, .DirtyRects(0), lSize)
End If
If hResult < 0 Then
GoTo QH
End If
.NumDirty = lSize / SIZE_RECT
'--- init mem dc
hMemDC = CreateCompatibleDC(0)
If hMemDC = 0 Then
GoTo QH
End If
'--- copy Pointer
hResult = .Duplication.GetFramePointerShape((UBound(.PointerShape) + 1), .PointerShape(0), lSize, uPointerInfo)
If hResult = DXGI_ERROR_MORE_DATA Then
ReDim .PointerShape(0 To lSize - 1) As Byte
hResult = .Duplication.GetFramePointerShape((UBound(.PointerShape) + 1), .PointerShape(0), lSize, uPointerInfo)
End If
If hResult < 0 Then
GoTo QH
End If
If lSize > 0 Then
.PointerInfo = uPointerInfo
Select Case .PointerInfo.Type
Case DXGI_OUTDUPL_POINTER_SHAPE_TYPE_COLOR
If Not pvCreateDib(hMemDC, .PointerInfo.Width, .PointerInfo.Height, hPointerDib, lpBits) Then
GoTo QH
End If
For lIdx = 0 To .PointerInfo.Height - 1
Call CopyMemory(ByVal lpBits + lIdx * .PointerInfo.Width * 4, .PointerShape(lIdx * .PointerInfo.Pitch), .PointerInfo.Width * 4)
Next
If Not pvCreateStdPicture(hPointerDib, oPicPointer) Then
GoTo QH
End If
hPointerDib = 0
Case Else
' Debug.Print ".PointerInfo.Type=" & Hex(.PointerInfo.Type) & ", ";
End Select
End If
'--- copy to DIB
If Not pvCreateDib(hMemDC, .Width, .Height, hDib, lpBits) Then
GoTo QH
End If
If .InSystemMemory Then
.Duplication.MapDesktopSurface uMapRect
For lIdx = 0 To .Height - 1
Call CopyMemory(ByVal lpBits + lIdx * .Width * 4, ByVal uMapRect.pBitsPtr + lIdx * uMapRect.Pitch, .Width * 4)
Next
.Duplication.UnMapDesktopSurface
Else
.Context.CopyResource .StageTexture, .DesktopResource
.Context.Map .StageTexture, 0, D3D11_MAP_READ, 0, uResource
For lIdx = 0 To .Height - 1
Call CopyMemory(ByVal lpBits + lIdx * .Width * 4, ByVal uResource.pDataPtr + lIdx * uResource.RowPitch, .Width * 4)
Next
For lIdx = 0 To .NumDirty - 1
lY = .DirtyRects(lIdx).Top
For lX = .DirtyRects(lIdx).Left To .DirtyRects(lIdx).Right - 1
Call CopyMemory(ByVal lpBits + (.DirtyRects(lIdx).Top * .Width + lX) * 4, BORDER_COLOR, 4)
Call CopyMemory(ByVal lpBits + ((.DirtyRects(lIdx).Bottom - 1) * .Width + lX) * 4, BORDER_COLOR, 4)
Next
lX = .DirtyRects(lIdx).Left
For lY = .DirtyRects(lIdx).Top To .DirtyRects(lIdx).Bottom - 1
Call CopyMemory(ByVal lpBits + (lY * .Width + .DirtyRects(lIdx).Left) * 4, BORDER_COLOR, 4)
Call CopyMemory(ByVal lpBits + (lY * .Width + .DirtyRects(lIdx).Right - 1) * 4, BORDER_COLOR, 4)
Next
Next
' For lIdx = 0 To .NumDirty - 1
' Debug.Print "(" & .DirtyRects(lIdx).Left & ";" & .DirtyRects(lIdx).Left & "-" & .DirtyRects(lIdx).Right & ";" & .DirtyRects(lIdx).Bottom & "), ";
' lX = .DirtyRects(lIdx).Left
' For lY = .DirtyRects(lIdx).Top To .DirtyRects(lIdx).Bottom - 1
' Call CopyMemory(ByVal lpBits + (lY * .Width + lX) * 4, ByVal uResource.pDataPtr + lY * uResource.RowPitch + lX * 4, (.DirtyRects(lIdx).Right - lX) * 4)
' Next
' Next
.Context.Unmap .StageTexture, 0
End If
End With
If Not pvCreateStdPicture(hDib, oPicDesktop) Then
GoTo QH
End If
hDib = 0
'--- success
pvCaptureScreen = True
QH:
If hPointerDib <> 0 Then
Call DeleteObject(hPointerDib)
hPointerDib = 0
End If
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 uCtx.StageTexture, 0
End If
' If Not oPicDesktop 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
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
imgDesktop.Move 0, dblTop, ScaleWidth, ScaleHeight - dblTop
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
Private Sub Timer1_Timer()
Dim oPicDesktop As StdPicture
Dim oPicPointer As StdPicture
If pvCaptureScreen(m_uCtx, oPicDesktop, oPicPointer) Then
If Not oPicDesktop Is Nothing Then
Set imgDesktop.Picture = oPicDesktop
End If
If Not oPicPointer Is Nothing Then
Set imgPointer.Picture = oPicPointer
End If
With m_uCtx.FrameInfo.PointerPosition
imgPointer.Visible = .Visible
If .Visible Then
imgPointer.Move _
imgDesktop.Left + ScaleX(.Position.X, vbPixels) * imgDesktop.Width \ ScaleX(m_uCtx.Width, vbPixels), _
imgDesktop.Top + ScaleY(.Position.Y, vbPixels) * imgDesktop.Height \ ScaleX(m_uCtx.Height, vbPixels), _
ScaleX(m_uCtx.PointerInfo.Width, vbPixels) * imgDesktop.Width \ ScaleX(m_uCtx.Width, vbPixels), _
ScaleY(m_uCtx.PointerInfo.Height, vbPixels) * imgDesktop.Height \ ScaleX(m_uCtx.Height, vbPixels)
End If
End With
ElseIf Not pvInitCapture(m_uCtx, m_uCtx.DeviceName, Timer1.Interval) Then
Timer1.Enabled = False
End If
End Sub
Private Sub Command1_Click()
Dim dblTargetHeight As Double
dblTargetHeight = imgDesktop.Width * m_uCtx.Height \ m_uCtx.Width
Height = imgDesktop.Top + dblTargetHeight + (Height - ScaleHeight)
End SubThe 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>