Skip to content

Instantly share code, notes, and snippets.

@jeff123wang
Created April 6, 2022 15:27
Show Gist options
  • Save jeff123wang/4acce6809e8e307c286fe4797ccb02a5 to your computer and use it in GitHub Desktop.
Save jeff123wang/4acce6809e8e307c286fe4797ccb02a5 to your computer and use it in GitHub Desktop.
' this method first get a DC entire window.
' then turn it into a memory bitmap.
' then create a iPicture interface using the bitmap.
' the benefit of using OleCreatePictureIndirect is that we don't need to worry about filling
' out bitmap header infomation manually.
' it is easier than other method in my git.
' You can also use GDI+, or even DotNet API, which provides simplified API than GDI.
' But i like low level API better.
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
Const DC_BRUSH = 18
Private Declare PtrSafe Function Rectangle Lib "Gdi32" (ByVal hDc As LongPtr, _
ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare PtrSafe Function SetDCBrushColor Lib "Gdi32" (ByVal hDc As LongPtr, ByVal colorref As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "Gdi32" (ByVal hDc As Long) As Long
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "Gdi32" (ByVal hDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "Gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "Gdi32" (ByVal hDc As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
Private Declare PtrSafe 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 PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare PtrSafe Function GetStockObject Lib "Gdi32" (ByVal nIndex As Long) 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 _
)
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
Dim fnum As Integer
'On Error GoTo Failure
hDc = GetDC(0) ' get current screen
hDcMem = CreateCompatibleDC(hDc)
hBmp = CreateCompatibleBitmap(hDc, w, h)
hBmpOld = SelectObject(hDcMem, hBmp)
lRes = BitBlt(hDcMem, 0, 0, w, h, hDc, x, y, vbSrcCopy)
SelectObject hDcMem, GetStockObject(DC_BRUSH)
SetDCBrushColor hDcMem, RGB(100, 0, 0)
Rectangle hDcMem, 0, 0, 100, 200
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 ' handle to a bitmap.
.hPal = 0
End With
' no need to define BitMap header.
lRes = OleCreatePictureIndirect(uPic, IID_IDispatch, True, IPic)
If lRes = S_OK Then
stdole.SavePicture IPic, fname ' you can either save picture or use it in a userform.
Set ScreenCapture = IPic
End If
Exit Function
Failure:
End Function
Sub Test()
If ScreenCapture(x:=0, y:=100, w:=800, h:=800, fname:="D:\myScreenPic.bmp") Is Nothing Then
MsgBox "Failed to create the screen picture."
Else
MsgBox "Screen picture successfully created."
End If
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment