Created
April 6, 2022 15:27
-
-
Save jeff123wang/4acce6809e8e307c286fe4797ccb02a5 to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
' 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