[RESOLVED] Taking screenshots of forms

[chris223b]

I need an app to be able to take a screenshot of itself and save that out to a file to use for a journalling features which will track what was on the screen at the time a given control was clicked on. Ideally I just wanted to implement this as a function which can be called with a one liner whenever this is used.

The journalling feature is all done, and for screenshots I tried using this technique I found in an old post:

https://www.developerfusion.com/thre...form-as-image/

The example captures to the clipboard when fired but uses a button as a separate event to save the file. I just added the code for the button onto the end to make it capture and save in one step.

The problem I'm having is that there seems to need to be a separate process to execute with user intervention for capturing to the clipboard to complete. As it stands, if I run it the first time it gives a runtime error as the clipboard data is invalid. Then on rerunning it will save the screenshot from the first run. Then on a third rerun the screenshot from the second etc etc.

No way of doing this (including having the capture/save as separate functions) seems to work unless the execution stops. Eg trying

CALL Capture_Screenshot
CALL Save_Screenshot

won't work, but if I plonk a messagebox in between the two calls to break the execution it then will. I've even tried insanely messy attempts to workaround like pasting the screenshot into an imagebox on a hidden form and save the contents of the imagebox or using a timer to call the save, still doesn't work. There needs to be a total break in execution somewhere for the clipboard to update and I can't have this as it needs to happen silently.

Any ideas? Or an alternative approach to doing the capture?

[jpbro]

Mostly ChatGPTs work, but I tweaked it a bit to support capturing the whole desktop (hwnd = 0) and to use a BitBlt/PrintWindow fallback, and raise errors for failures.

To use it, add a cScreenshot class to your project with this code:

Option Explicit

Private Declare Function GetWindowRect Lib "user32" ( _
                                       ByVal hwnd As Long, _
                                       ByRef lpRect As RECT) 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 DeleteDC 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 DeleteObject Lib "gdi32" ( _
                                      ByVal hObject As Long) As Long

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 OleCreatePictureIndirect Lib "olepro32.dll" ( _
                                                  ByRef PicDesc As PICTDESC, _
                                                  ByRef RefIID As GUID, _
                                                  ByVal fPictureOwnsHandle As Long, _
                                                  ByRef 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 Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Type PICTDESC
   cbSizeofStruct As Long
   picType As Long
   hImage As Long
   xExt As Long
   yExt As Long
End Type

Private Const SRCCOPY As Long = &HCC0020
Private Const PICTYPE_BITMAP As Long = 1

Private Const PW_CLIENTONLY As Long = &H1
Private Const PW_RENDERFULLCONTENT As Long = &H2

Public Function CaptureWindowByHwnd(ByVal hwnd As Long) As StdPicture
   Dim rc As RECT
   Dim width As Long
   Dim height As Long

   Dim hWndDC As Long
   Dim hMemDC As Long
   Dim hBmp As Long
   Dim hOldBmp As Long

   If hwnd = 0 Then hwnd = GetDesktopWindow  ' Use 0 for Hwnd to capture entire desktop

   If GetWindowRect(hwnd, rc) = 0 Then Err.Raise vbObjectError, , "Could not get Window rectangle!"

   width = rc.Right - rc.Left
   height = rc.Bottom - rc.Top

   If width <= 0 Or height <= 0 Then Err.Raise vbObjectError, , "Bad Window rectangle!"

   hWndDC = GetWindowDC(hwnd)
   If hWndDC = 0 Then Err.Raise vbObjectError, , "Could not get Window DC!"
   
   hMemDC = CreateCompatibleDC(hWndDC)
   If hMemDC = 0 Then
      ReleaseDC hwnd, hWndDC
      Err.Raise vbObjectError, , "Could not create memory DC!"
   End If

   hBmp = CreateCompatibleBitmap(hWndDC, width, height)
   If hBmp = 0 Then
      DeleteDC hMemDC
      ReleaseDC hwnd, hWndDC
      Err.Raise vbObjectError, , "Could not create compatible bitmap!"
   End If

   hOldBmp = SelectObject(hMemDC, hBmp)

   ' Try PrintWindow first to capture windows that are covered, minimized, off-screen, hardware-rendered, or using something like WebView2/DirectComposition
   ' https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-printwindow
   ' If PrintWindow fails, we'll try BitBlt (but that might capture incomplete data in the above scenarios...maybe better than nothing though)
   If PrintWindow(hwnd, hMemDC, PW_RENDERFULLCONTENT) <> 0 Then
      ' OK!
      Set CaptureWindowByHwnd = BitmapHandleToPicture(hBmp)
      
      ' Ownership of hBmp has been transferred to StdPicture.
      hBmp = 0
   Else
      Debug.Print Err.LastDllError
      Debug.Assert False   ' Failed!! Maybe old version of Windows??? Will try BitBlt method
   End If
   
   If hBmp <> 0 Then
      ' PrintWindow failed, try BitBlt
      If BitBlt(hMemDC, 0, 0, width, height, hWndDC, 0, 0, SRCCOPY) <> 0 Then
         Set CaptureWindowByHwnd = BitmapHandleToPicture(hBmp)
   
         ' Ownership of hBmp has been transferred to StdPicture.
         hBmp = 0
      End If
   End If
   
   If hOldBmp <> 0 Then SelectObject hMemDC, hOldBmp
   If hBmp <> 0 Then DeleteObject hBmp

   DeleteDC hMemDC
   ReleaseDC hwnd, hWndDC
End Function

Private Function BitmapHandleToPicture(ByVal hBmp As Long) As StdPicture
   Dim Pic As PICTDESC
   Dim IID_IDispatch As GUID
   Dim oPic As IPicture

   ' OleCreatePictureIndirect needs to know what interface we want back.
   '
   ' In this case we ask for IDispatch:
   '
   '   IID_IDispatch = {00020400-0000-0000-C000-000000000046}
   '
   ' This is the standard COM interface ID for IDispatch.
   '
   ' Why IDispatch instead of IPicture?
   '   VB6's StdPicture is automation-friendly, so requesting IDispatch
   '   is a common/reliable way to get back an object VB can assign to
   '   StdPicture/IPicture.
   '
   ' GUID memory layout:
   '
   '   Data1    = 00020400
   '   Data2    = 0000
   '   Data3    = 0000
   '   Data4(0) = C0
   '   Data4(1) = 00
   '   Data4(2) = 00
   '   Data4(3) = 00
   '   Data4(4) = 00
   '   Data4(5) = 00
   '   Data4(6) = 00
   '   Data4(7) = 46
   '
   ' Unassigned numeric fields default to zero in VB6, so we only need
   ' to set Data1, Data4(0), and Data4(7).
   With IID_IDispatch
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
   End With

   ' Fill a PICTDESC structure describing the bitmap handle.
   '
   ' cbSizeofStruct:
   '   Required by OleCreatePictureIndirect so OLE knows which version/
   '   size of the structure we are passing.
   '
   ' picType:
   '   PICTYPE_BITMAP = 1
   '   This tells OLE that hImage is an HBITMAP.
   '
   ' hImage:
   '   The actual bitmap handle that will be wrapped in a StdPicture.
   With Pic
      .cbSizeofStruct = Len(Pic)
      .picType = PICTYPE_BITMAP
      .hImage = hBmp
   End With

   ' Third argument:
   '
   '   fPictureOwnsHandle = 1
   '
   ' This is important. It tells the created StdPicture object that it
   ' owns hBmp and should delete the bitmap when the picture is destroyed.
   '
   ' Because of that, the caller must NOT call DeleteObject(hBmp) after
   ' this function succeeds. Set your local hBmp variable to 0 after a
   ' successful call to prevent double-free / invalid-handle problems.
   '
   ' Return value:
   '   S_OK = 0
   If OleCreatePictureIndirect(Pic, IID_IDispatch, 1, oPic) = 0 Then
      Set BitmapHandleToPicture = oPic
   End If
End Function

Then take a screenshot of your app window and save it like so:

Private Sub Command1_Click()
   Dim lo_Screenshot As New CScreenshot
   Dim lo_Pic As StdPicture
   
   Set lo_Pic = lo_Screenshot.CaptureWindowByHwnd(Me.hwnd)  ' Take a screenshot of this app's window and stuff it in a StdPicture object
   
   SavePicture lo_Pic, "<SOMEFOLDERPATH>\screenshot.bmp" ' Save the BMP somewhere
End Sub

[chris223b]

Sorry for delay, this seems to work perfectly so far! Thank you!