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
'--- 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 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
pContext As ID3D11DeviceContext
pStageTexture As ID3D11Texture2D
pDuplication As IDXGIOutputDuplication
pTexture As ID3D11Texture2D
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, sDeviceName As String) 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
On Error GoTo EH
With uCtx
.DeviceName = vbNullString
Set .pTexture = Nothing
Set .pDuplication = Nothing
Set .pStageTexture = Nothing
Set .pContext = 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
hResult = D3D11CreateDevice(pAdapter, D3D_DRIVER_TYPE_UNKNOWN, 0, 0, ByVal 0, 0, D3D11_SDK_VERSION, pDevice, 0, .pContext)
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 .pStageTexture = pDevice.CreateTexture2D(uTextureDesc)
Set .pDuplication = pOutput.DuplicateOutput(pDevice)
End With
'--- success
pvInitCapture = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Private Function pvCaptureScreen(uCtx As UcsDuplicationContext, oPic As StdPicture) As Boolean
Const FUNC_NAME As String = "pvCaptureScreen"
Dim hResult As Long
Dim aGUID(0 To 3) As Long
Dim lIdx As Long
Dim uFrameInfo As DXGI_OUTDUPL_FRAME_INFO
Dim uResource As D3D11_MAPPED_SUBRESOURCE
Dim hMemDC As Long
Dim hDib As Long
Dim lpBits As Long
Dim uDesc As PICTDESC
Dim uDuplDesc As DXGI_OUTDUPL_DESC
Dim uMapRect As DXGI_MAPPED_RECT
On Error GoTo EH
With uCtx
If .pDuplication Is Nothing Then
GoTo QH
End If
If Not .pTexture Is Nothing Then
.pDuplication.ReleaseFrame
Set .pTexture = Nothing
End If
hResult = .pDuplication.AcquireNextFrame(100, uFrameInfo, .pTexture)
If hResult < 0 Then
GoTo QH
End If
hMemDC = CreateCompatibleDC(0)
If hMemDC = 0 Then
GoTo QH
End If
If Not pvCreateDib(hMemDC, .Width, .Height, hDib, lpBits) Then
GoTo QH
End If
.pDuplication.GetDesc uDuplDesc
If uDuplDesc.DesktopImageInSystemMemory <> 0 Then
.pDuplication.MapDesktopSurface uMapRect
For lIdx = 0 To .Height - 1
Call CopyMemory(ByVal lpBits + lIdx * .Width * 4, ByVal uMapRect.pBitsPtr + lIdx * uMapRect.Pitch, .Width * 4)
Next
Else
.pContext.CopyResource .pStageTexture, .pTexture
.pContext.Map .pStageTexture, 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
End If
End With
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
hDib = 0
'--- success
pvCaptureScreen = True
QH:
If hDib <> 0 Then
Call DeleteObject(hDib)
hDib = hDib
End If
If hMemDC <> 0 Then
Call DeleteDC(hMemDC)
hMemDC = 0
End If
If uResource.pDataPtr <> 0 Then
uCtx.pContext.Unmap uCtx.pStageTexture, 0
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 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
Image1.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) Then
Timer1.Enabled = False
Else
Timer1.Enabled = True
Timer1_Timer
End If
End If
End Sub
Private Sub Image1_Click()
Timer1.Enabled = Not Timer1.Enabled
End Sub
Private Sub Timer1_Timer()
Dim oPic As StdPicture
If pvCaptureScreen(m_uCtx, oPic) Then
Set Image1.Picture = oPic
ElseIf Not pvInitCapture(m_uCtx, m_uCtx.DeviceName) Then
Timer1.Enabled = False
End If
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>