[RESOLVED] Taking screenshots of forms

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?

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:

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:

Code:

---

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

---

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