Taking a screenshot and have it / save it with cCairoSurface

[tmighty2]

Hello!

Can somebody tell me how to take a screenshot and (successfully) have it / store it using a cCairoSurface?

The following code creates an image of the desired size, however it is transparent (that is why I filled it with a solid color before binding just to make sure, but it didn't help).

Thank you for pointing out where I went wrong.

Option Explicit

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" ( _
    ByVal hDestDC As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hSrcDC As Long, _
    ByVal XSrc As Long, _
    ByVal YSrc As Long, _
    ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function GetDIBits Lib "gdi32" ( _
    ByVal hdc As Long, _
    ByVal hBitmap As Long, _
    ByVal uStartScan As Long, _
    ByVal cScanLines As Long, _
    lpvBits As Any, _
    lpbi As BITMAPINFO, _
    ByVal uUsage As Long) 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 RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Private Sub TakeScreenshot(Optional ByVal uHwndDefault0AlsoDesktopHwnd As Long = 0, Optional ByVal uSavePath As String = "", Optional ByVal uLeft As Long = 0, Optional ByVal uTop As Long = 0, Optional ByVal uWidth As Long = 0, Optional ByVal uHeight As Long = 0)

    Dim lHwnd As Long
    If uHwndDefault0AlsoDesktopHwnd <> 0 Then
        lHwnd = uHwndDefault0AlsoDesktopHwnd
    Else
        lHwnd = GetDesktopWindow()
    End If

    Dim rc As RECT
    If uWidth > 0 And uHeight > 0 Then
        GetWindowRect lHwnd, rc
    Else
        rc.Left = uLeft
        rc.Top = uTop
        rc.Right = uLeft + uWidth
        rc.Bottom = uTop + uHeight
    End If

    Dim hdcSrc As Long
    hdcSrc = GetWindowDC(lHwnd)
    
    Dim hDCMemory As Long
    hDCMemory = CreateCompatibleDC(hdcSrc)
    
    Dim lWidth&
    Dim lHeight&
    lWidth = rc.Right - rc.Left
    lHeight = rc.Bottom - rc.Top
    
    
    Dim hBmp As Long
    hBmp = CreateCompatibleBitmap(hdcSrc, lWidth, lHeight)

    Dim hBmpPrev&
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    
    BitBlt hDCMemory, rc.Left, rc.Top, lWidth, lHeight, hdcSrc, uLeft, uTop, vbSrcCopy

    Dim bmpInfo As BITMAPINFO
    Dim arrPixelData() As Long
    ReDim arrPixelData(((lWidth) * (lHeight)) - 1)

    With bmpInfo.bmiHeader
        .biSize = Len(bmpInfo.bmiHeader)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = 0
        .biSizeImage = 0
        .biXPelsPerMeter = 0
        .biYPelsPerMeter = 0
        .biClrUsed = 0
        .biClrImportant = 0
    End With

    GetDIBits hDCMemory, hBmp, 0, lWidth * lHeight, arrPixelData(0), bmpInfo, 0

    Dim nSrf As cCairoSurface
    Set nSrf = Cairo.CreateSurface(uWidth, uHeight, ImageSurface)

    Dim CC As cCairoContext
    Set CC = nSrf.CreateContext
    CC.Fill , Cairo.CreateSolidPatternLng(vbRed, 1) 'fill with solid color

    Dim b As Boolean
    b = nSrf.BindToArrayLong(arrPixelData, True)
    
    Dim ret As cairo_status_enm
    ret = nSrf.WriteContentToPngFile("d:\myscreenshot.png")
    
    If ret = CAIRO_STATUS_SUCCESS Then
        'ok
    Else
        Debug.Assert False
    End If
    
End Sub

Private Sub Form_Load()

    TakeScreenshot 0, "d:\test\myshot.png", 300, 300, 1000, 1000

End Sub

[VanGoghGaming]

HDCSrc = GetDC(0) ' Desktop hDC

That's what you use to create a CompatibleDC and CompatibleBitmap.

GetDesktopWindow returns a virtual hWnd that is not suitable for bitmap operations.

[xiaoyao]

YOU ALSO CAN SAVE png with gdiplus

 Sub TakeScreenshot(Optional ByVal uHwndDefault0AlsoDesktopHwnd As Long = 0, Optional ByVal uSavePath As String = "", _
  Optional ByVal uLeft As Long = 0, Optional ByVal uTop As Long = 0, Optional ByVal uWidth As Long = 0, Optional ByVal uHeight As Long = 0)
    Dim lHwnd As Long
    If uHwndDefault0AlsoDesktopHwnd <> 0 Then
        lHwnd = uHwndDefault0AlsoDesktopHwnd
    Else
        lHwnd = GetDesktopWindow()
    End If

    Dim rc As RECT
    If uWidth = 0 And uHeight = 0 Then
        GetWindowRect lHwnd, rc
        uWidth = rc.Right - rc.Left
        uHeight = rc.Bottom - rc.Top
    End If

    Dim hdcSrc As Long
    hdcSrc = GetWindowDC(lHwnd)
    
    Dim hDCMemory As Long
    hDCMemory = CreateCompatibleDC(hdcSrc)
    
    Dim hBmp As Long
    hBmp = CreateCompatibleBitmap(hdcSrc, uWidth, uHeight)

    Dim hBmpPrev&
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    
    BitBlt hDCMemory, 0, 0, uWidth, uHeight, hdcSrc, uLeft, uTop, vbSrcCopy
    
    Dim BmpInfo As BITMAPINFO
    Dim arrPixelData() As Long
    ReDim arrPixelData((uWidth * uHeight) - 1)
    

   Dim nSrf As cCairoSurface
    Set nSrf = Cairo.CreateSurface(uWidth, uHeight, ImageSurface)

'    Dim CC As cCairoContext
'    Set CC = nSrf.CreateContext
    'CC.Fill , Cairo.CreateSolidPatternLng(vbRed, 1) 'fill with solid color

    Dim b As Boolean
    b = nSrf.BindToArrayLong(arrPixelData, True)
    
'   Dim Bmp As bitmap
'    GetGDIObject hBmp, Len(Bmp), Bmp
'    With BmpInfo.bmiHeader
'        .biSize = Len(BmpInfo.bmiHeader)
'        .biWidth = uWidth
'        .biHeight = -uHeight
'        .biPlanes = 1
'        .biBitCount = 32
'        .biCompression = 0
'        '.biSizeImage = 4& * .biHeight * .biHeight
'        .biXPelsPerMeter = 0
'        .biYPelsPerMeter = 0
'        .biClrUsed = 0
'        .biClrImportant = 0
'    End With
'    Dim BUFFER() As Byte
'    ReDim BUFFER(Bmp.bmWidthBytes * Bmp.bmHeight - 1) As Byte    '???????????????
   ' b = nSrf.BindToArray(BUFFER, True)
    'GetDIBits hDCMemory, hBmp, 0, Bmp.bmHeight, BUFFER(0), BmpInfo, 0
    
    
    With BmpInfo.bmiHeader
        .biSize = Len(BmpInfo.bmiHeader)
        .biWidth = uWidth
        .biHeight = -uHeight
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = 0
        .biSizeImage = 4& * .biHeight * .biHeight
        .biXPelsPerMeter = 0
        .biYPelsPerMeter = 0
        .biClrUsed = 0
        .biClrImportant = 0
    End With
    Dim hDIB As Long
    Const DIB_RGB_COLORS As Long = 0&
 

    GetDIBits hDCMemory, hBmp, 0, uHeight, arrPixelData(0), BmpInfo, 0
 


    
    Dim ret As cairo_status_enm
    ret = nSrf.WriteContentToPngFile(uSavePath)
    
    If ret = CAIRO_STATUS_SUCCESS Then
        'ok
    Else
        Debug.Assert False
    End If
    
End Sub

[Schmidt]

Can somebody tell me how to take a screenshot and (successfully) have it / store it using a cCairoSurface?

Option Explicit

Private Declare Function CreateDCW Lib "gdi32" (ByVal lpszDriver As Long, Optional ByVal lpszDevice As Long, Optional ByVal lpszOutput As Long, Optional ByVal lpInitData As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
 
Private Sub Form_Load()
  Set Me.Picture = GetDisplaySurface.Picture
End Sub
 
Public Function GetDisplaySurface(Optional ByVal D As cDisplay) As cCairoSurface
    If D Is Nothing Then Set D = New_c.Displays(1) 'use the default-display, in case the Opt. Param was left out
    
    Dim W As Long: W = D.AbsoluteRight - D.AbsoluteLeft
    Dim H As Long: H = D.AbsoluteBottom - D.AbsoluteTop
    Dim S As Long: S = CreateDCW(StrPtr("DISPLAY")) 'creates a Src-hDC which covers all Monitors
  
    Set GetDisplaySurface = Cairo.CreateWin32Surface(W, H) 'this creates a Cairo 32bpp with an internal hDC
    BitBlt GetDisplaySurface.GetDC(), 0, 0, W, H, S, D.AbsoluteLeft, D.AbsoluteTop, vbSrcCopy
    ReleaseDC 0, S
 
    With GetDisplaySurface.CreateContext 'correct the Alpha-Channel (in case the Display was not operating in 32BPP-mode)
        .Operator = CAIRO_OPERATOR_DEST_ATOP
        .Paint 1, Cairo.CreateSolidPatternLng(0)
    End With
End Function

Note, that the code above is still using the "naive" BitBlt-based copy ...
(which might not catch DirectX-Window-Contents properly, as e.g. from a playing Video- or Game-window)

The two Methods marked in Red above, are what's simplifying the whole thing (no need to create your own memory-DC).

Olaf

[tmighty2]

Thank you. This code is impressiv.