Print UserForm with Height of 2500 onto either several pages or squeezed onto 1 page.

T

tomhoney

New Member
Joined
Jul 19, 2012
Messages
8
Hi,

I've done a lot of researching around this and I'm still having problems getting to the bottom of it. I have a UserForm that has a height of 2500 (goes off the bottom of the screen). It has a scroll bar on the right and it has about 517 of height visible at any one time.

I have obviously tried the built in single line UserForm1.PrintForm solution, but this will only print the currently visible section of the form. I then tried Tom Olgivy's code for transferring the userform to an excel worksheet and fitting to a single page, but that again only pastes and prints what is currently visible on the screen.

I am beginning to think that I need to write some sort of Macro that scrolls through the form section by section and print screens each available amount that can fit on a screen, until it's daisy chained the whole thing onto a worksheet or something. This seems absolutely ridiculous and there MUST be a better way of doing it.

So the form's full size is 2500 as I said, and also it contains toggle buttons, tick boxes and text. I just want to be able to copy THE FULL FORM and paste it somewhere. Any help is very much appreciated!

I'm using Excel 2003.
 
Sort by date Sort by votes
Back to this thread.

The code in post #3 doesn't seem to work at least on my excel 2016 64bit... I have rewritten the entire code and hopefully it should now work as expected. This is not an elegant solution but, hopefully, a working hack.

Basically, the code grabs a screen capture of the entire userform's client area and place the resulting bitmap in the clipboard.

Additionally, it permits pasting the capture to the worksheet as a shape and\or saving it to disk as bmp file.


Workbook Example Update.


1- API code in a Standard Module:
Code: 
Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
       hPic As Long
       hPal As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Type

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

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As Any, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As LongPtr) As LongPtr
    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 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 SelectObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirect64 Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirect32 Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As any, phwnd As Long) As Long
    Private Declare Function GetDC 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 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 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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function OleCreatePictureIndirect64 Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function OleCreatePictureIndirect32 Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hDc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If



Public Function IPictureFromUserForm( _
        ByVal UForm As Object, _
        Optional ByVal PasteToNewSheetAsShape As Boolean, _
        Optional ByVal SaveBmpToFilePathName As String _
    ) _
    As IPicture

    Const SRCCOPY = &HCC0020
    Const SM_CYDLGFRAME = 8
    Const SM_CYCAPTION = 4
    Const SM_CXVSCROLL = 2

    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        Dim hwnd As LongPtr, hDc As LongPtr, hMemDC As LongPtr, hBmp As LongPtr
        Dim hScreenDc As LongPtr, hScreenMemDc As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Dim hwnd As Long, hDc As Long, hMemDC As Long, hBmp As Long
        Dim hScreenDc As Long, hScreenMemDc As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim tClientRect As RECT
    Dim lWidth As Long, lHeight As Long, lInitScrollBarVal As Long
    Dim sngVal As Single, sngPrevScrollTop As Single
    Dim YOffset As Long    
    
    On Error GoTo errHandler
    With UForm
        .ScrollTop = 0
        lInitScrollBarVal = .ScrollBars
        .ScrollBars = fmScrollBarsVertical
        DoEvents
        Call WindowFromAccessibleObject(UForm, hwnd)
        Call GetClientRect(hwnd, tClientRect)
        sngVal = IIf(.ScrollHeight >= .InsideHeight, .ScrollHeight, .InsideHeight)
        With tClientRect
            lWidth = .Right - .Left - GetSystemMetrics(SM_CXVSCROLL): lHeight = PTtoPX(CDbl(sngVal), True)
        End With
        hDc = GetDC(hwnd)
        hMemDC = CreateCompatibleDC(0)
        hBmp = CreateCompatibleBitmap(hDc, lWidth, lHeight)
        Call DeleteObject(SelectObject(hMemDC, hBmp))
        Call BitBlt(hMemDC, 0, 0, lWidth, lHeight, hDc, tClientRect.Left, tClientRect.Top, SRCCOPY)
        DisableClientAreaUpdate(hwnd, hScreenDc, hScreenMemDc) = True
        Call ShowProgress(hScreenMemDc, tClientRect)
        DoEvents
        sngPrevScrollTop = 0
        Do
            DoEvents
            sngPrevScrollTop = .ScrollTop
            .Scroll 0, fmScrollActionPageDown
            .Repaint
            YOffset = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME)
            Call BitBlt(hMemDC, 0, PTtoPX(.ScrollTop, True) + YOffset, _
            lWidth, lHeight, hDc, tClientRect.Left, tClientRect.Top + YOffset, SRCCOPY)
            Call FreezeClientAreaNow(hwnd, hScreenDc, hScreenMemDc)
            'Sleep 1000 '<== Edit for testing
        Loop Until sngPrevScrollTop >= .ScrollTop
        .ScrollBars = lInitScrollBarVal
        .ScrollTop = 0
    End With
    Set IPictureFromUserForm = CreatePicture(hBmp, PasteToNewSheetAsShape, SaveBmpToFilePathName)
    
errHandler:
    DisableClientAreaUpdate(hwnd, hScreenDc, hScreenMemDc) = False
    Call ReleaseDC(0, hDc)
    Call DeleteObject(hMemDC)
    Call DeleteObject(hBmp)
    
End Function


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Sub ShowProgress(ByVal hDc As LongPtr, ByRef tRect As RECT)
    
    Dim hNewFont As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Sub ShowProgress(ByVal hDc As Long, ByRef tRect As RECT)
    
    Dim hNewFont As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Const SM_CYCAPTION = 4
    Const SM_CYDLGFRAME = 8
    Dim tFont As LOGFONT, sCopying As String, YOffset As Long
    
    sCopying = "Capturing UserForm Screen ... Please Wait"
    With tFont
        .lfHeight = 18: .lfFaceName = "Arial" & Chr(0): .lfWeight = 900
    End With
    hNewFont = (CreateFontIndirect(tFont))
    Call DeleteObject(SelectObject(hDc, hNewFont))
    Call SetTextColor(hDc, vbRed)
    Call SetBkMode(hDc, 1)
    YOffset = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME) + 10
    Call TextOut(hDc, tRect.Left + 20, tRect.Top + YOffset, sCopying, Len(sCopying))
    
End Sub


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Property Let DisableClientAreaUpdate(ByVal hwnd As LongPtr, ByRef hDc As LongPtr, _
    ByRef hMemDC As LongPtr, Enable As Boolean)
    
    Static hBmp As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Property Let DisableClientAreaUpdate(ByVal hwnd As Long, ByRef hDc As Long, _
    ByRef hMemDC As Long, Enable As Boolean)
    
    Static hBmp As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Const SRCCOPY = &HCC0020
    Const GWL_EXSTYLE = (-20)
    Const WS_EX_LAYERED = &H80000
    Const LWA_ALPHA = &H2&
    Dim tWndRect As RECT
    
    If Enable Then
        With tWndRect
            Call GetWindowRect(hwnd, tWndRect)
            hDc = GetDC(0)
            hMemDC = CreateCompatibleDC(0)
            hBmp = CreateCompatibleBitmap(hDc, .Right - .Left, .Bottom - .Top)
            Call DeleteObject(SelectObject(hMemDC, hBmp))
            Call BitBlt(hMemDC, 0, 0, .Right - .Left, .Bottom - .Top, hDc, .Left, .Top, SRCCOPY)
        End With
    Else
        Call ReleaseDC(0, hDc)
        Call DeleteObject(hMemDC)
        Call DeleteObject(hBmp)
    End If
    Call SetWindowLong(hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
    Call SetLayeredWindowAttributes(hwnd, 0, IIf(Enable, 0, 255), LWA_ALPHA)

End Property


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Sub FreezeClientAreaNow(ByVal hwnd As LongPtr, ByVal hDc As LongPtr, hMemDC As LongPtr)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Sub FreezeClientAreaNow(ByVal hwnd As Long, ByVal hDc As Long, hMemDC As Long)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Const SRCCOPY = &HCC0020
    Dim tWndRect As RECT

    GetWindowRect hwnd, tWndRect
    With tWndRect
        If GetActiveWindow = hwnd Or GetActiveWindow = Application.hwnd Then
            Call BitBlt(hDc, .Left, .Top, .Right - .Left, .Bottom - .Top, hMemDC, 0, 0, SRCCOPY)
        End If
    End With

End Sub


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function CreatePicture(ByVal BMP As LongPtr, Optional ByVal PasteToNewSheetAsShape As Boolean, _
    Optional ByVal SaveBmpToFilePathName As String) As IPicture
    
    Dim hCopy As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function CreatePicture(ByVal BMP As Long, Optional ByVal PasteToNewSheetAsShape As Boolean, _
    Optional ByVal SaveBmpToFilePathName As String) As IPicture
    
    Dim hCopy As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    
    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = 0
    Dim lRet As Long
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim iPic As IPicture

    hCopy = CopyImage(BMP, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hCopy
        .hPal = 0
    End With
    
    If InStr(1, Application.OperatingSystem, "32-bit") Then
        lRet = OleCreatePictureIndirect32(uPicinfo, IID_IDispatch, True, iPic)
    End If
    
    If InStr(1, Application.OperatingSystem, "64-bit") Then
        lRet = OleCreatePictureIndirect64(uPicinfo, IID_IDispatch, True, iPic)
    End If
    
    If lRet = S_OK Then
        Set CreatePicture = iPic
            If Not ThisWorkbook.ProtectStructure Then
                Call OpenClipboard(0)
                Call EmptyClipboard
                Call SetClipboardData(CF_BITMAP, BMP)
                Call CloseClipboard
                If PasteToNewSheetAsShape Then
                    ThisWorkbook.Worksheets.Add.Paste
                End If
        End If
        If Len(SaveBmpToFilePathName) Then
            Call stdole.SavePicture(iPic, SaveBmpToFilePathName)
        End If
    End If
    
End Function


Private Function ScreenDPI(bVert As Boolean) As Long
    Const LOGPIXELSY = 90
    Const LOGPIXELSX = 88
    Static lDPI(1), lDC
    
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function
 
Private Function PTtoPX(Points As Double, bVert As Boolean) As Long
    Const POINTS_PER_INCH = 72
    PTtoPX = Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function



2- Code Usage example in the UserForm Module:
Code: 
Option Explicit

Private Sub CommandButton1_Click()

    Dim iPic As IPicture
    
    'Take a screen capture of the entire userform client area
    'and place it in the clipboard.
    Set iPic = IPictureFromUserForm(UForm:=Me)
    
    If Not iPic Is Nothing Then
        MsgBox "Picture successfully created and copied to clipboard !", vbInformation
    Else
        MsgBox "Failed to create Picture Object.", vbExclamation
    End If
    
End Sub

Hope you this can be of use to others.

Regards.
 
Upvote 0

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Correction in API declarations :

Updated workbook example.

Code: 
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
   [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
 
Upvote 0
UPDATE.

Public Function SaveScrollableUserForm( _ ByVal UForm As UserForm, _ ByVal OutFilePathName As String, _ Optional ByVal ClientAreaOnly As Boolean = True, _ Optional ByVal PasteToNewSheetAsShape As Boolean _ ) _ As StdPicture

The SaveScrollableUserForm function saves the userform scrollable client area to disk as an image file and returns an ole StdPicture object ... Optionnally, the function also copies the image to the clipboard and pastes it as a shape in a new worksheet.

File image formats supported : BMP, DIB, RLE, JPEG, JPG, JPE, JFIF, GIF, TIFF, TIF, PNG


SrollableUserFormImageToDisk.xlsm



1- API code in a Standard Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Const NULL_PTR = 0^
#Else
    Const NULL_PTR = 0&
#End If

#If VBA7 Then

   #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    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 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 SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    'GDIPlus
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
    Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As LongPtr, ByVal Filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare 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 Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    'GDIPlus
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
    Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As LongPtr, ByVal Filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
End Type

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

'GDIPlus
Private Type GdiplusStartupInput
    GdiplusVersion            As Long
    DebugEventCallback        As LongPtr
    SuppressBackgroundThread  As LongPtr
    SuppressExternalCodecs    As Long
End Type

Private Type EncoderParameter
    GUID            As GUID
    NumberOfValues  As Long
    Type            As Long
    Value           As LongPtr
End Type

Private Type EncoderParameters
    Count       As Long
    Parameter   As EncoderParameter
End Type




Public Function SaveScrollableUserForm( _
        ByVal UForm As UserForm, _
        ByVal OutFilePathName As String, _
        Optional ByVal ClientAreaOnly As Boolean = True, _
        Optional ByVal PasteToNewSheetAsShape As Boolean _
    ) _
    As StdPicture
 
    ' Takes a screen capture of the entire userform or the client area
    ' and saves the image file to disk.
    ' ====================================================
        '  Image file formats accepted :                  '
        '  BMP,DIB,RLE,JPEG,JPG,JPE,JFIF,GIF,TIFF,TIF,PNG '
    ' ====================================================
    'Function Return : ole StdPicture Object.
 
    Const SRCCOPY = &HCC0020
    Const SM_CYDLGFRAME = 8&
    Const SM_CYCAPTION = 4&
    Const SM_CXVSCROLL = 2&

    Dim hWnd As LongPtr, hDC As LongPtr, hMemDC As LongPtr, hBmp As LongPtr
    Dim hScreenDc As LongPtr, hScreenMemDc As LongPtr
    Dim tClientRect As RECT
    Dim lWidth As Long, lHeight As Long, lInitScrollBarVal As Long
    Dim sngVal As Single, sngPrevScrollTop As Single
    Dim YOffset As Long
 
    On Error GoTo errHandler
    With UForm
        .ScrollTop = 0&
        lInitScrollBarVal = .ScrollBars
        .ScrollBars = fmScrollBarsVertical
        DoEvents
        Call IUnknown_GetWindow(UForm, VarPtr(hWnd))
        Call GetClientRect(hWnd, tClientRect)
        sngVal = IIf(.ScrollHeight >= .InsideHeight, .ScrollHeight, .InsideHeight)
        With tClientRect
            If ClientAreaOnly Then
                lWidth = .Right - .Left - GetSystemMetrics(SM_CXVSCROLL)
                lHeight = PTtoPX(CDbl(sngVal), True, UForm.Zoom)
            Else
                lWidth = .Right - .Left: lHeight = PTtoPX(CDbl(sngVal), True, UForm.Zoom)
            End If
        End With
        hDC = GetDC(hWnd)
        hMemDC = CreateCompatibleDC(0&)
        hBmp = CreateCompatibleBitmap(hDC, lWidth, lHeight)
        Call DeleteObject(SelectObject(hMemDC, hBmp))
        Call BitBlt(hMemDC, 0&, 0&, lWidth, lHeight, hDC, tClientRect.Left, _
            tClientRect.Top - IIf(ClientAreaOnly, 0&, GetSystemMetrics(SM_CYCAPTION)), SRCCOPY)
        DisableClientAreaUpdate(hWnd, hScreenDc, hScreenMemDc) = True
        Call ShowProgress(hScreenMemDc, tClientRect)
        DoEvents
        sngPrevScrollTop = 0&
        Do
            DoEvents
            sngPrevScrollTop = .ScrollTop
            .Scroll 0&, fmScrollActionPageDown
            .Repaint
            YOffset = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME)
            Call BitBlt(hMemDC, 0&, PTtoPX(.ScrollTop, True, UForm.Zoom) + YOffset, _
            lWidth, lHeight, hDC, tClientRect.Left, tClientRect.Top + YOffset, SRCCOPY)
            Call FreezeClientAreaNow(hWnd, hScreenDc, hScreenMemDc)
            'Sleep 1000& '<== Edit for testing
        Loop Until sngPrevScrollTop >= .ScrollTop
        .ScrollBars = lInitScrollBarVal
        .ScrollTop = 0&
    End With
    Set SaveScrollableUserForm = CreatePicture(hBmp, PasteToNewSheetAsShape, OutFilePathName)
 
errHandler:
    DisableClientAreaUpdate(hWnd, hScreenDc, hScreenMemDc) = False
    Call ReleaseDC(0, hDC)
    Call DeleteObject(hMemDC)
    Call DeleteObject(hBmp)
 
End Function

Private Sub ShowProgress(ByVal hDC As LongPtr, ByRef tRect As RECT)

    Const SM_CYCAPTION = 4&
    Const SM_CYDLGFRAME = 8&
 
    Dim hNewFont As LongPtr
    Dim tFont As LOGFONT, sCopying As String, YOffset As Long
 
    sCopying = "Capturing UserForm Screen ... Please Wait"
    With tFont
        .lfHeight = 18&: .lfFaceName = "Arial" & Chr(0&): .lfWeight = 900&
    End With
    hNewFont = (CreateFontIndirect(tFont))
    Call DeleteObject(SelectObject(hDC, hNewFont))
    Call SetTextColor(hDC, vbRed)
    Call SetBkMode(hDC, 1&)
    YOffset = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME) + 10&
    Call TextOut(hDC, tRect.Left + 20&, tRect.Top + YOffset, sCopying, Len(sCopying))
 
End Sub

Private Property Let DisableClientAreaUpdate( _
    ByVal hWnd As LongPtr, _
    ByRef hDC As LongPtr, _
    ByRef hMemDC As LongPtr, _
    Enable As Boolean _
)
    Const SRCCOPY = &HCC0020
    Const GWL_EXSTYLE = (-20&)
    Const WS_EX_LAYERED = &H80000
    Const LWA_ALPHA = &H2&
 
    Static hBmp As LongPtr
    Dim tWndRect As RECT
 
    If Enable Then
        With tWndRect
            Call GetWindowRect(hWnd, tWndRect)
            hDC = GetDC(0&)
            hMemDC = CreateCompatibleDC(0&)
            hBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
            Call DeleteObject(SelectObject(hMemDC, hBmp))
            Call BitBlt(hMemDC, 0&, 0&, .Right - .Left, .Bottom - .Top, hDC, .Left, .Top, SRCCOPY)
        End With
    Else
        Call ReleaseDC(0&, hDC)
        Call DeleteObject(hMemDC)
        Call DeleteObject(hBmp)
    End If
    Call SetWindowLong(hWnd, GWL_EXSTYLE, GetWindowLong(hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
    Call SetLayeredWindowAttributes(hWnd, 0&, IIf(Enable, 0&, 255&), LWA_ALPHA)

End Property

Private Sub FreezeClientAreaNow(ByVal hWnd As LongPtr, ByVal hDC As LongPtr, hMemDC As LongPtr)

    Const SRCCOPY = &HCC0020
    Dim tWndRect As RECT

    Call GetWindowRect(hWnd, tWndRect)
    With tWndRect
        If GetActiveWindow = hWnd Or GetActiveWindow = Application.hWnd Then
            Call BitBlt(hDC, .Left, .Top, .Right - .Left, .Bottom - .Top, hMemDC, 0&, 0&, SRCCOPY)
        End If
    End With

End Sub

Private Function CreatePicture( _
    ByVal BMP As LongPtr, _
    Optional ByVal PasteToNewSheetAsShape As Boolean, _
    Optional ByVal OutFilePathName As String _
) As StdPicture
 
    Const IMAGE_BITMAP = 0&
    Const PICTYPE_BITMAP = 1&
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2&
    Const S_OK = 0&
 
    Dim hCopy As LongPtr
    Dim lRet As Long
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim oPic As StdPicture

    hCopy = CopyImage(BMP, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0&) = &HC0
        .Data4(7&) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hCopy
        .hPal = 0&
    End With
 
    lRet = OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, oPic)
 
    If lRet = S_OK Then
        Set CreatePicture = oPic
        If PasteToNewSheetAsShape Then
            If Not ThisWorkbook.ProtectStructure Then
                Call OpenClipboard(0&)
                Call EmptyClipboard
                Call SetClipboardData(CF_BITMAP, hCopy)
                Call CloseClipboard
                ThisWorkbook.Worksheets.Add.Paste
            End If
        End If
   
        If Len(OutFilePathName) Then
            Call SaveUserFormToDisk(hCopy, OutFilePathName)
        End If
    End If
 
End Function

Private Function ScreenDPI(bVert As Boolean) As Long
    Const LOGPIXELSY = 90&
    Const LOGPIXELSX = 88&
    Static lDPI(1), lDC
 
    If lDPI(0&) = 0& Then
        lDC = GetDC(0&)
        lDPI(0&) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1&) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0&, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function
 
Private Function PTtoPX(Points As Double, bVert As Boolean, ByVal Zoom As Long) As Long
    Const POINTS_PER_INCH = 72&
    PTtoPX = (Zoom / 100&) * Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function

Private Function SaveUserFormToDisk( _
    ByVal hBmp As LongPtr, _
    ByVal FullFilename As String _
) As Boolean

    Const S_OK = &H0
    Const PW_CLIENTONLY = &H1
    Const PW_RENDERFULLCONTENT = &H2
    Const INVALID_FILE_ATTRIBUTES = -1&

    Dim hDC As LongPtr, hMemDC As LongPtr
    Dim hMemBmp As LongPtr, hPrevBmp As LongPtr
    Dim tRect As RECT
 
    'GDIPlus
    Dim tEncoder As GUID, tSI As GdiplusStartupInput, TParams As EncoderParameters
    Dim GDIPToken As LongPtr, hBitmap As LongPtr, lRet As Long
    Dim sPathFile As String, sExt As String, sFormatCLSID As String
 
 
    On Error GoTo errHandler
 
    sExt = Right(FullFilename, Len(FullFilename) - InStrRev(FullFilename, "."))
 
    Select Case UCase(sExt)
        Case "BMP", "DIB", "RLE"
            sFormatCLSID = "{557cf400-1a04-11d3-9a73-0000f81ef32e}"
        Case "JPEG", "JPG", "JPE", "JFIF"
            sFormatCLSID = "{557cf401-1a04-11d3-9a73-0000f81ef32e}"
        Case "GIF"
            sFormatCLSID = "{557cf402-1a04-11d3-9a73-0000f81ef32e}"
        Case "TIFF", "TIF"
            sFormatCLSID = "{557cf405-1a04-11d3-9a73-0000f81ef32e}"
        Case "PNG"
            sFormatCLSID = "{557cf406-1a04-11d3-9a73-0000f81ef32e}"
    End Select
 
    tSI.GdiplusVersion = 1&
    lRet = GdiplusStartup(GDIPToken, tSI)
    If lRet = S_OK Then
        lRet = GdipCreateBitmapFromHBITMAP(hBmp, NULL_PTR, hBitmap)
        If lRet = S_OK Then
            CLSIDFromString StrPtr(sFormatCLSID), tEncoder
            TParams.Count = 1&
            lRet = GdipSaveImageToFile(hBitmap, StrPtr(FullFilename), tEncoder, TParams)
            If lRet = S_OK Then
                If GetFileAttributes(FullFilename) <> INVALID_FILE_ATTRIBUTES Then
                    SaveUserFormToDisk = True
                End If
            End If
        End If
    End If
 
errHandler:

    Call GdipDisposeImage(hBitmap)
    Call GdiplusShutdown(GDIPToken)
    Call DeleteObject(hBmp)
 
End Function


2- Code Usage Example in the UserForm Module:
VBA Code: 
Option Explicit

Private Sub CommandButton1_Click()

    'Saving form scrollable client area to disk as image file.

    Dim oPic As StdPicture
    Dim vFileSaveName As Variant, vFileFilter As Variant

    vFileFilter = "File BMP (*.BMP),*.BMP, File PNG (*.PNG),*.PNG,File Gif (*.GIF),*.GIF,File JPEG (*.JPG),*.JPG,"
    vFileFilter = vFileFilter & "File JPE (*.JPE),*.JPE,File DIB (*.DIB),*.DIB,File RLE (*.RLE),*.RLE,"
    vFileFilter = vFileFilter & "File JFIF (*.JFIF),*.JFIF,File TIFF (*.TIFF),*.TIFF,"
    vFileFilter = vFileFilter & "File TIF (*.TIF),*.TIF"

    vFileSaveName = Application.GetSaveAsFilename("", vFileFilter)

    If vFileSaveName <> "False" Then
        Set oPic = SaveScrollableUserForm(UForm:=Me, OutFilePathName:=vFileSaveName, ClientAreaOnly:=True)
        If Len(Dir(vFileSaveName)) Then
            MsgBox "UserForm Client Area Image Saved As: " & vFileSaveName, vbInformation, "SavingUserFormToDisk."
        Else
            MsgBox "Failed to save Image to disk."
        End If
    End If
 
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
1K
AndyEd
A
A
  • Solved
Calendar issue
Replies
1
Views
2K
AndyEd
A
gravanoc
  • Question Question
Page Layout issues between 2010 and modern 365
Replies
1
Views
657
rlv01
R
R
  • Question Question
Printing a narrow but long worksheet as a PDF without page-breaks
Replies
0
Views
742
RawlinsCross
R
L
  • Question Question
VBA works on work PC but not home PC
Replies
3
Views
2K
rollis13
rollis13

Forum statistics

Threads
1,224,833
Messages
6,181,242
Members
453,026
Latest member
cknader

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top