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.
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
I am digging up this old thread as I too have been researching this topic and I wonder if anyone knows if there is a solution to this ..

As the OP said, there seems to be no native or easy way of printing the full userform including the areas that are not visible due to the large scrollheight.

Any thoughts ?

Regards.
 
Upvote 0
Hi all,

I am publishing here this code that I have just finished writing and I hope you find it useful to overcome the problem with the PrintForm Method which only prints the visible client area and fails to print the parts that are not currently scrolled into view.

Basically, the code takes a screenshot of a verically scrollable userform and create a IPic Object for the *entire* client area + the form frame and title bar .. The Ipicture Object can then be loaded into a control via its Picture property, or optionally copied to the clipboard as a BITMAP and pasted to a worksheet as a shape for subsequent printing and/or saved to disk as a BMP file.

Workbook demo


1- Code in a Stadard Module:
Code: 
[B][COLOR=#008000]'\\This code takes a screenshot of a verically scrollable userform[/COLOR][/B]
[B][COLOR=#008000]'\\and create a IPic Object for the *entire* client area.[/COLOR][/B]

[B][COLOR=#008000]'\\The Ipicture Object can then be loaded into a control[/COLOR][/B]
[B][COLOR=#008000]'\\via its Picture Property,copied to the clipboard as a BITMAP[/COLOR][/B]
[B][COLOR=#008000]'\\and pasted to a worksheet for subsequent printing and/or saved to disk as a BMP file.[/COLOR][/B]

[B][COLOR=#008000]'\\Contrary to the native 'PrintForm' Method of the userform object model[/COLOR][/B]
[B][COLOR=#008000]'\\this code permits printing the full scrollable area (Not just the currently visible part of the form)[/COLOR][/B]

[B][COLOR=#008000]'\\Code written by Jaafar Tribak @ MrExcel.com on 24/01/2018.[/COLOR][/B]

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 IAccessible, 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 GetWindowRect 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
[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 IAccessible, 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 GetWindowRect 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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const SRCCOPY = &HCC0020
Private Const IMAGE_BITMAP = 0
Private Const PICTYPE_BITMAP = 1
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2
Private Const S_OK = 0
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88
Private Const POINTS_PER_INCH = 72
Private Const SM_CYDLGFRAME = 8
Private Const SM_CYCAPTION = 4

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


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Dim hwnd As LongPtr
    Dim hDc As LongPtr, hInitDC As LongPtr, hMemDC1 As LongPtr, hMemDC2 As LongPtr
    Dim hBmp1 As LongPtr, hBmp2 As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Dim hwnd As Long
    Dim hDc As Long, hInitDC As Long, hMemDC1 As Long, hMemDC2 As Long
    Dim hBmp1 As Long, hBmp2 As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim Wdth As Long, Hght1 As Long, Hght2 As Long
    Dim lInitScrollBarVal As Long
    Dim sngVal As Single
    Dim sngPrevScrollTop As Single
    Dim tFormRect1 As RECT
    Dim tFormRect2 As RECT
    Dim tPt As POINTAPI
    Dim tpt1 As POINTAPI
    Dim tpt2 As POINTAPI
        
    On Error GoTo errHandler
 
    With UForm
        .ScrollTop = 0
        lInitScrollBarVal = .ScrollBars
        .ScrollBars = fmScrollBarsVertical
        DoEvents

        WindowFromAccessibleObject UForm, hwnd
       
        GetWindowRect hwnd, tFormRect1
        GetWindowRect hwnd, tFormRect2
    
        With tFormRect1
            tpt1.x = .Left: tpt1.y = .Top
            tpt2.x = .Right: tpt2.y = .Bottom
            ScreenToClient hwnd, tpt1
            ScreenToClient hwnd, tpt2
            .Left = tpt1.x: .Top = tpt1.y
            .Right = tpt2.x: .Bottom = tpt2.y
        End With
      
        sngVal = IIf(.ScrollHeight >= .InsideHeight, .ScrollHeight, .InsideHeight)
       
        With tFormRect1
            Wdth = .Right - .Left: Hght1 = PTtoPX(CDbl(sngVal), True) + GetSystemMetrics(4) + GetSystemMetrics(8)
            Hght2 = .Bottom - .Top
        End With
    
        hDc = GetDC(hwnd)
        hMemDC1 = CreateCompatibleDC(hDc)
        hBmp1 = CreateCompatibleBitmap(hDc, Wdth, Hght1)
        DeleteObject SelectObject(hMemDC1, hBmp1)
        
        hInitDC = GetDC(0)
        hMemDC2 = CreateCompatibleDC(hInitDC)
        hBmp2 = CreateCompatibleBitmap(hInitDC, Wdth, Hght2)
        DeleteObject SelectObject(hMemDC2, hBmp2)
        
        Call BitBlt(hMemDC1, 0, 0, Wdth, Hght1, hDc, tFormRect1.Left, tFormRect1.Top, SRCCOPY)
    
        Call ShowCopyingUpdate(hDc)
      
        With tFormRect2:  tPt.x = .Left: tPt.y = .Top:  End With
     
        Call BitBlt(hMemDC2, 0, 0, Wdth, Hght2, hInitDC, tFormRect2.Left, tFormRect2.Top, SRCCOPY)
        
        sngPrevScrollTop = 0
    
        Do
            With tFormRect2
                Call BitBlt(hInitDC, .Left, .Top, Wdth, Hght2, hMemDC2, 0, 0, SRCCOPY)
            End With
            sngPrevScrollTop = .ScrollTop
            .Scroll 0, fmScrollActionLineDown
            .Repaint
            Call BitBlt(hMemDC1, 0, PTtoPX(.ScrollTop, True) + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME), _
            Wdth, Hght1, hDc, tFormRect1.Left, tFormRect1.Top + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME), SRCCOPY)
        Loop Until sngPrevScrollTop >= .ScrollTop
    
        .ScrollBars = lInitScrollBarVal
        .ScrollTop = 0
 
    End With

    Set IPictureFromUserForm = CreatePicture(hBmp1, PasteToNewSheetAsShape, SaveBmpToFilePathName)

errHandler:
    ReleaseDC 0, hInitDC
    ReleaseDC 0, hDc
    DeleteObject hMemDC1
    DeleteObject hMemDC2
    DeleteObject hBmp1
    DeleteObject hBmp2
End Function


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Private Sub ShowCopyingUpdate(ByVal hDc As LongPtr)
    Dim hNewFont As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Private Sub ShowCopyingUpdate(ByVal hDc As Long)
    Dim hNewFont As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Dim tFont As LOGFONT, sCopying As String
    
    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))
    SetTextColor hDc, vbRed
    SetBkMode hDc, 1
    Call TextOut(hDc, 4, 10, sCopying, Len(sCopying))
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
    
    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 PasteToNewSheetAsShape Then
            If Not ThisWorkbook.ProtectStructure Then
                OpenClipboard 0
                EmptyClipboard
                SetClipboardData CF_BITMAP, BMP
                CloseClipboard
                ThisWorkbook.Worksheets.Add.Paste
            End If
        End If
        If Len(SaveBmpToFilePathName) Then
            SaveBmpToFilePathName = SaveBmpToFilePathName & ".bmp"
            stdole.SavePicture iPic, SaveBmpToFilePathName
        End If
    End If
End Function

Private Function ScreenDPI(bVert As Boolean) As Long
    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
    PTtoPX = Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function


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

Private Sub CommandButton1_Click()
    Dim iPic As IPicture
    
[B][COLOR=#008000]    '\\Take a snapshot of the *entire" userform, paste it on a new worksheet as a shape[/COLOR][/B]
[B][COLOR=#008000]    '\\and save it to the 'temp' folder as a BMP file.[/COLOR][/B]
    Set iPic = IPictureFromUserForm( _
        UForm:=Me, _
        PasteToNewSheetAsShape:=True, _
        SaveBmpToFilePathName:=Environ("Temp") & "\UserForm1.bmp" _
    )
    
    If Not iPic Is Nothing Then
        MsgBox "Picture Object from userform successfully created !", vbInformation
    Else
        MsgBox "Failed to create Picture Object.", vbExclamation
    End If
End Sub
 
Upvote 0
Jaafar Tribak said:
Hi all,

I am publishing here this code that I have just finished writing and I hope you find it useful to overcome the problem with the PrintForm Method which only prints the visible client area and fails to print the parts that are not currently scrolled into view.

Basically, the code takes a screenshot of a verically scrollable userform and create a IPic Object for the *entire* client area + the form frame and title bar .. The Ipicture Object can then be loaded into a control via its Picture property, or optionally copied to the clipboard as a BITMAP and pasted to a worksheet as a shape for subsequent printing and/or saved to disk as a BMP file.

Workbook demo


1- Code in a Stadard Module:
Code: 
[B][COLOR=#008000]'\\This code takes a screenshot of a verically scrollable userform[/COLOR][/B]
[B][COLOR=#008000]'\\and create a IPic Object for the *entire* client area.[/COLOR][/B]

[B][COLOR=#008000]'\\The Ipicture Object can then be loaded into a control[/COLOR][/B]
[B][COLOR=#008000]'\\via its Picture Property,copied to the clipboard as a BITMAP[/COLOR][/B]
[B][COLOR=#008000]'\\and pasted to a worksheet for subsequent printing and/or saved to disk as a BMP file.[/COLOR][/B]

[B][COLOR=#008000]'\\Contrary to the native 'PrintForm' Method of the userform object model[/COLOR][/B]
[B][COLOR=#008000]'\\this code permits printing the full scrollable area (Not just the currently visible part of the form)[/COLOR][/B]

[B][COLOR=#008000]'\\Code written by Jaafar Tribak @ MrExcel.com on 24/01/2018.[/COLOR][/B]

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 IAccessible, 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 GetWindowRect 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
[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 IAccessible, 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 GetWindowRect 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
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const SRCCOPY = &HCC0020
Private Const IMAGE_BITMAP = 0
Private Const PICTYPE_BITMAP = 1
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2
Private Const S_OK = 0
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88
Private Const POINTS_PER_INCH = 72
Private Const SM_CYDLGFRAME = 8
Private Const SM_CYCAPTION = 4

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


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Dim hwnd As LongPtr
    Dim hDc As LongPtr, hInitDC As LongPtr, hMemDC1 As LongPtr, hMemDC2 As LongPtr
    Dim hBmp1 As LongPtr, hBmp2 As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Dim hwnd As Long
    Dim hDc As Long, hInitDC As Long, hMemDC1 As Long, hMemDC2 As Long
    Dim hBmp1 As Long, hBmp2 As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Dim Wdth As Long, Hght1 As Long, Hght2 As Long
    Dim lInitScrollBarVal As Long
    Dim sngVal As Single
    Dim sngPrevScrollTop As Single
    Dim tFormRect1 As RECT
    Dim tFormRect2 As RECT
    Dim tPt As POINTAPI
    Dim tpt1 As POINTAPI
    Dim tpt2 As POINTAPI
        
    On Error GoTo errHandler
 
    With UForm
        .ScrollTop = 0
        lInitScrollBarVal = .ScrollBars
        .ScrollBars = fmScrollBarsVertical
        DoEvents

        WindowFromAccessibleObject UForm, hwnd
       
        GetWindowRect hwnd, tFormRect1
        GetWindowRect hwnd, tFormRect2
    
        With tFormRect1
            tpt1.x = .Left: tpt1.y = .Top
            tpt2.x = .Right: tpt2.y = .Bottom
            ScreenToClient hwnd, tpt1
            ScreenToClient hwnd, tpt2
            .Left = tpt1.x: .Top = tpt1.y
            .Right = tpt2.x: .Bottom = tpt2.y
        End With
      
        sngVal = IIf(.ScrollHeight >= .InsideHeight, .ScrollHeight, .InsideHeight)
       
        With tFormRect1
            Wdth = .Right - .Left: Hght1 = PTtoPX(CDbl(sngVal), True) + GetSystemMetrics(4) + GetSystemMetrics(8)
            Hght2 = .Bottom - .Top
        End With
    
        hDc = GetDC(hwnd)
        hMemDC1 = CreateCompatibleDC(hDc)
        hBmp1 = CreateCompatibleBitmap(hDc, Wdth, Hght1)
        DeleteObject SelectObject(hMemDC1, hBmp1)
        
        hInitDC = GetDC(0)
        hMemDC2 = CreateCompatibleDC(hInitDC)
        hBmp2 = CreateCompatibleBitmap(hInitDC, Wdth, Hght2)
        DeleteObject SelectObject(hMemDC2, hBmp2)
        
        Call BitBlt(hMemDC1, 0, 0, Wdth, Hght1, hDc, tFormRect1.Left, tFormRect1.Top, SRCCOPY)
    
        Call ShowCopyingUpdate(hDc)
      
        With tFormRect2:  tPt.x = .Left: tPt.y = .Top:  End With
     
        Call BitBlt(hMemDC2, 0, 0, Wdth, Hght2, hInitDC, tFormRect2.Left, tFormRect2.Top, SRCCOPY)
        
        sngPrevScrollTop = 0
    
        Do
            With tFormRect2
                Call BitBlt(hInitDC, .Left, .Top, Wdth, Hght2, hMemDC2, 0, 0, SRCCOPY)
            End With
            sngPrevScrollTop = .ScrollTop
            .Scroll 0, fmScrollActionLineDown
            .Repaint
            Call BitBlt(hMemDC1, 0, PTtoPX(.ScrollTop, True) + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME), _
            Wdth, Hght1, hDc, tFormRect1.Left, tFormRect1.Top + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME), SRCCOPY)
        Loop Until sngPrevScrollTop >= .ScrollTop
    
        .ScrollBars = lInitScrollBarVal
        .ScrollTop = 0
 
    End With

    Set IPictureFromUserForm = CreatePicture(hBmp1, PasteToNewSheetAsShape, SaveBmpToFilePathName)

errHandler:
    ReleaseDC 0, hInitDC
    ReleaseDC 0, hDc
    DeleteObject hMemDC1
    DeleteObject hMemDC2
    DeleteObject hBmp1
    DeleteObject hBmp2
End Function


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
Private Sub ShowCopyingUpdate(ByVal hDc As LongPtr)
    Dim hNewFont As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
Private Sub ShowCopyingUpdate(ByVal hDc As Long)
    Dim hNewFont As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    Dim tFont As LOGFONT, sCopying As String
    
    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))
    SetTextColor hDc, vbRed
    SetBkMode hDc, 1
    Call TextOut(hDc, 4, 10, sCopying, Len(sCopying))
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
    
    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 PasteToNewSheetAsShape Then
            If Not ThisWorkbook.ProtectStructure Then
                OpenClipboard 0
                EmptyClipboard
                SetClipboardData CF_BITMAP, BMP
                CloseClipboard
                ThisWorkbook.Worksheets.Add.Paste
            End If
        End If
        If Len(SaveBmpToFilePathName) Then
            SaveBmpToFilePathName = SaveBmpToFilePathName & ".bmp"
            stdole.SavePicture iPic, SaveBmpToFilePathName
        End If
    End If
End Function

Private Function ScreenDPI(bVert As Boolean) As Long
    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
    PTtoPX = Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function


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

Private Sub CommandButton1_Click()
    Dim iPic As IPicture
    
[B][COLOR=#008000]    '\\Take a snapshot of the *entire" userform, paste it on a new worksheet as a shape[/COLOR][/B]
[B][COLOR=#008000]    '\\and save it to the 'temp' folder as a BMP file.[/COLOR][/B]
    Set iPic = IPictureFromUserForm( _
        UForm:=Me, _
        PasteToNewSheetAsShape:=True, _
        SaveBmpToFilePathName:=Environ("Temp") & "\UserForm1.bmp" _
    )
    
    If Not iPic Is Nothing Then
        MsgBox "Picture Object from userform successfully created !", vbInformation
    Else
        MsgBox "Failed to create Picture Object.", vbExclamation
    End If
End Sub
Click to expand...



Dear Jaafar,
Lot of thanks for your help.

However, for your kind information, I am using 64 bit, MS Office 2013.

As requested in my earlier post, I have a User form where it is to be printed and provided to client. The data entered in that User form is to be recorded in Excel sheet. I could record the data in Excel Sheet but I have been defeated to print whole of User Form which actually fits in A4 sized paper. I could print only the ones that appear in the screen. Looks like it prints out screen shots as you have rightly pointed out.

Is there any other ways to get this done. Your valuable advice would highly be appreciate and with your assistance, I could get some other idea where I can make use of it. Thanks for that.
 
Upvote 0
I could print only the ones that appear in the screen.
Click to expand...

Hi,

Why is the userform not fully displayed on the screen ? Is it somehow off-screen or is it because the userform window is smaller than the its actual content and has to be scrolled Up_Down or Left_Right ?

Would zooming out the userform right before printing and then restoring the initial zoom afterwards give you a satisfactory result?

Regards.
 
Last edited:
Upvote 0
Hi Jaafar,
My user form is quite big where less than have the A4 sized paper is to be filled with personal information and remaining part is to be written with wording having at least 20 - 25 lines with Arial Narrow font of size of 11. All these data could be recorded in Excel sheet but I could not print out complete User Form which is to be provided to client.

I have tried with your codes but still it did not work. I would appreciate if you can explain me in detail.

Thanks for your tips and advises.

Regards.
 
Upvote 0
@ E30000546
Hi,

Does the userform have any scrollbars that allows you to scroll the contents of the userform for viewing all its contents?

Regards.
 
Upvote 0
Ok- Which versions of excel and windows are you using ? (Bitness included - ie : 32bit or 64bit)

I can't promise anything but I'll revise the code afterwards and see if I fix the issue we are experiencing.

Regards.
 
Upvote 0
Jaafar Tribak said:
Ok- Which versions of excel and windows are you using ? (Bitness included - ie : 32bit or 64bit)

I can't promise anything but I'll revise the code afterwards and see if I fix the issue we are experiencing.

Regards.
Click to expand...

Hi there,
I am using Windows 10, having 64 bits with MS Office 2013 (Excel 2013)

Thanks a lot for your help.
Warmest regards.
 
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
652
rlv01
R
R
  • Question Question
Printing a narrow but long worksheet as a PDF without page-breaks
Replies
0
Views
729
RawlinsCross
R
L
  • Question Question
VBA works on work PC but not home PC
Replies
3
Views
2K
rollis13
rollis13

Forum statistics

Threads
1,223,249
Messages
6,171,031
Members
452,374
Latest member
keccles

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