Printscreen/screen capture rectangle - convert C++ to VBA

[brickbuilder]

Hello, I have this useful little function written in C++ a couple years ago which takes an x,y point on the screen and extends a rectangle based on width/height (w,h) to take a screenshot of a specified rectangle of the desktop screen.

I'm really hoping that somebody around here might know a bit about how to convert this function to a VBA equivalent.

Thanks!!!!!!!!!!!!!!!!!!!!

ScreenCapture(int x, int y, int w, int h, LPCSTR fname){ 
    HDC hdcSource = GetDC(NULL);
    HDC hdcMemory = CreateCompatibleDC(hdcSource);

    int capX = GetDeviceCaps(hdcSource, HORZRES);
    int capY = GetDeviceCaps(hdcSource, VERTRES);

    HBITMAP hBitmap = CreateCompatibleBitmap(hdcSource, w, h);
    HBITMAP hBitmapOld = (HBITMAP)SelectObject(hdcMemory, hBitmap);

    BitBlt(hdcMemory, 0, 0, w, h, hdcSource, x, y, SRCCOPY);
    hBitmap = (HBITMAP)SelectObject(hdcMemory, hBitmapOld);

    DeleteDC(hdcSource);
    DeleteDC(hdcMemory);

    HPALETTE hpal = NULL;
    if (SaveBitmap(fname, hBitmap, hpal))     'separate saving function
        return true;
    return false;
}

 

[Jaafar Tribak]

See if this works for you (Note that the code will need to be modified in order to work in 64bit OS)

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) 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 DeleteDC Lib "Gdi32" (ByVal hDc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc 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 hDc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Const vbSrcCopy As Long = &HCC0020
Private Const S_OK As Long = 0

Function ScreenCapture( _
        ByVal x As Long, _
        ByVal y As Long, _
        ByVal w As Long, _
        ByVal h As Long, _
        ByVal fname As String _
) As Boolean

    Dim uPic As PicBmp
    Dim IPic As IPictureDisp
    Dim IID_IDispatch As GUID
    Dim hDc As Long, hDcMem As Long, hBmp As Long
    Dim hBmpOld As Long, lRes As Long
    
    On Error GoTo Failure
    hDc = GetDC(0)
    hDcMem = CreateCompatibleDC(hDc)
    hBmp = CreateCompatibleBitmap(hDc, w, h)
    hBmpOld = SelectObject(hDcMem, hBmp)
    lRes = BitBlt(hDcMem, 0, 0, w, h, hDc, x, y, vbSrcCopy)
    hBmp = SelectObject(hDcMem, hBmpOld)
    Call ReleaseDC(0, hDc)
    Call DeleteDC(hDcMem)
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    With uPic
        .Size = Len(uPic)
        .Type = 1 'bitmap
        .hBmp = hBmp
        .hPal = 0
    End With
    lRes = OleCreatePictureIndirect(uPic, IID_IDispatch, True, IPic)
    If lRes = S_OK Then
        stdole.SavePicture IPic, fname
        ScreenCapture = True
    End If
    Exit Function
Failure:
End Function

Here is an example of how to use the function :

Sub Test()
    If ScreenCapture(x:=0, y:=100, w:=800, h:=800, fname:="C:\myScreenPic.bmp") Then
        MsgBox "Screen picture successfully created."
    Else
        MsgBox "Failed to create the screen picture."
    End If
End Sub