Option Explicit
Private Type uPicDesc
Size As Long
type As Long
#If VBA7 Then
hPic As LongPtr
hPal As LongPtr
#Else
hPic As Long
hPal As Long
#End If
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#If Win64 Then
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, ByRef lpRect As RECT) As Long
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleaut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Dim hDC As LongPtr, hDCMem As LongPtr, hBmp As LongPtr, hBmpOld As LongPtr, TargethWnd As LongPtr, hLib As LongPtr
#Else
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 CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function PrintWindow Lib "user32" (ByVal hwnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Dim hDC As Long, hDCMem As Long, hBmp As Long, hBmpOld As Long, TargethWnd As Long, hLib As Long
#End If
Private Const PICTYPE_BITMAP As Long = &H1
Private Const VBSRCCOPY As Long = &HCC0020
Private Const BASEPATH As String = "D:\TEMP"
Public Sub CaptureWindow(ByVal Target As Object, Optional ByVal Filename As String, Optional ByVal WindowVisible As Boolean = True)
Dim IID_IPicture As GUID, uPicInfo As uPicDesc
Dim IPic As IPicture, Result As Long
On Error GoTo ErrHandler
IUnknown_GetWindow Target, VarPtr(TargethWnd)
If TargethWnd = 0 Then
MsgBox "There was an error with the object that you're trying to screencapture. Please check the CaptureWindow argument and try again.", , "Problem with the target object"
Exit Sub
Else
GetImageOfObject WindowVisible
End If
With IID_IPicture
.Data1 = &H7BF80981
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.type = PICTYPE_BITMAP
.hPic = hBmp
.hPal = 0
End With
hLib = LoadLibrary("oleAut32.dll")
If hLib Then
Result = OleCreatePictureIndirectAut(uPicInfo, IID_IPicture, True, IPic)
Else
Result = OleCreatePictureIndirectPro(uPicInfo, IID_IPicture, True, IPic)
End If
If Not Result Then
If Len(Filename) = 0 Then Filename = BASEPATH & "\ImageCapture_" & Format(Now, "yymmdd-hhnnss") & ".bmp"
SavePicture IPic, Filename
End If
ErrHandler:
FreeLibrary hLib
DeleteObject hBmp
DeleteDC hDCMem
ReleaseDC TargethWnd, hDC
If Err.Number <> 0 Then MsgBox Err.Number & ": " & Err.Description, , "Error"
End Sub
Private Sub GetImageOfObject(Optional ByVal WindowVisible As Boolean = True)
Dim TargetRect As RECT, Result As Long
GetWindowRect TargethWnd, TargetRect
With TargetRect
hDC = GetDC(TargethWnd)
hDCMem = CreateCompatibleDC(hDC)
hBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
hBmpOld = SelectObject(hDCMem, hBmp)
If WindowVisible Then
Result = BitBlt(hDCMem, 0, 0, .Right - .Left, .Bottom - .Top, hDC, .Left, .Top, VBSRCCOPY)
Else
PrintWindow TargethWnd, hDCMem, False
End If
hBmp = SelectObject(hDCMem, hBmpOld)
End With
End Sub