I put this together for another project, but it came up in another thread so I'm posting it here. It's just a snippet, but I think it's worthy of the codebank.
I just threw it all into a Form1 for demo purposes, but it can easily be copy-pasted into a BAS module if you wanted. The FullScreenBitmap procedure is already Public, so it'll just copy-paste with no modifications.
(And fixed small problem in the initial post. So if you grabbed this immediately after I posted it, re-grab it. The problem was fixed about 2 hours after the initial post.)
(Also fixed small problem with the FullScreenRect function.)
I just threw it all into a Form1 for demo purposes, but it can easily be copy-pasted into a BAS module if you wanted. The FullScreenBitmap procedure is already Public, so it'll just copy-paste with no modifications.
(And fixed small problem in the initial post. So if you grabbed this immediately after I posted it, re-grab it. The problem was fixed about 2 hours after the initial post.)
(Also fixed small problem with the FullScreenRect function.)
Code:
Option Explicit
'
Private Type RECT
Left As Long
Top As Long
Right As Long ' This is +1 (right - left = width)
Bottom As Long ' This is +1 (bottom - top = height)
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hpal As Long
Reserved As Long
End Type
Private Type GUID
' Globally Unique Identifiers (GUID).
' This is Microsoft's form of the Universally Unique Identifier (UUID).
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
'
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
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 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 hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
'
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'
Private Sub Form_Load()
' Just to test it.
Me.AutoRedraw = True
Set Me.Picture = FullScreenBitmap
End Sub
Private Function FullScreenRect() As RECT
' Calls to GetSystemMetrics get this done, and it's across all monitors.
'
Const SM_XVIRTUALSCREEN As Long = 76&
Const SM_YVIRTUALSCREEN As Long = 77&
Const SM_CXVIRTUALSCREEN As Long = 78&
Const SM_CYVIRTUALSCREEN As Long = 79&
FullScreenRect.Left = GetSystemMetrics(SM_XVIRTUALSCREEN)
FullScreenRect.Top = GetSystemMetrics(SM_YVIRTUALSCREEN)
FullScreenRect.Right = GetSystemMetrics(SM_CXVIRTUALSCREEN) + FullScreenRect.Left
FullScreenRect.Bottom = GetSystemMetrics(SM_CYVIRTUALSCREEN) + FullScreenRect.Top
End Function
Public Function FullScreenBitmap() As Picture
' Gets the full desktop (across all monitors) and returns it as a Picture object.
'
' Get desktop size.
Dim FullRect As RECT
FullRect = FullScreenRect
Dim w As Long, h As Long
w = FullRect.Right - FullRect.Left
h = FullRect.Bottom - FullRect.Top
'
' Get the screen's bitmap.
Dim hWndScreen As Long
hWndScreen = GetDesktopWindow ' Get a handle to the window to capture.
Dim hDCSrc As Long
hDCSrc = GetWindowDC(hWndScreen) ' Get the proper device context.
Dim hDCMemory As Long
hDCMemory = CreateCompatibleDC(hDCSrc) ' Create a memory device context for the copy process.
Dim hBmp As Long
hBmp = CreateCompatibleBitmap(hDCSrc, w, h) ' Create a bitmap and place it in the memory DC.
Dim hBmpPrev As Long
hBmpPrev = SelectObject(hDCMemory, hBmp)
Call BitBlt(hDCMemory, 0&, 0&, w, h, hDCSrc, FullRect.Left, FullRect.Top, vbSrcCopy) ' Copy the on-screen image into the memory DC.
hBmp = SelectObject(hDCMemory, hBmpPrev) ' Remove the new copy of the the on-screen image.
Call DeleteDC(hDCMemory) ' Release the device context resources back to the system.
Call ReleaseDC(hWndScreen, hDCSrc)
'
' Fill in OLE IDispatch Interface ID.
Dim IID_IDispatch As GUID
IID_IDispatch.Data1 = &H20400
IID_IDispatch.Data4(0&) = &HC0
IID_IDispatch.Data4(7&) = &H46
'
' Fill Pic with necessary parts.
Dim pic As PicBmp
pic.Size = LenB(pic) ' Length of structure.
pic.Type = vbPicTypeBitmap ' Type of Picture (bitmap).
pic.hBmp = hBmp ' Handle to bitmap.
pic.hpal = 0&
'
' Create OLE Picture object and return it.
Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, FullScreenBitmap)
End Function