Taking a screenshot and have it / save it with cCairoSurface
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.
Code:
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
Re: Taking a screenshot and have it / save it with cCairoSurface
Code:
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.
Re: Taking a screenshot and have it / save it with cCairoSurface
YOU ALSO CAN SAVE png with gdiplus
Code:
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
Re: Taking a screenshot and have it / save it with cCairoSurface
Quote:
Originally Posted by
tmighty2
Can somebody tell me how to take a screenshot and (successfully) have it / store it using a cCairoSurface?
Code:
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
Re: Taking a screenshot and have it / save it with cCairoSurface
Thank you. This code is impressiv.
