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.
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