Page 1 of 2 12 LastLast
Results 1 to 10 of 12

Thread: Print UserForm with Height of 2500 onto either several pages or squeezed onto 1 page.
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Jul 2012
    Posts
    8
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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.

  2. #2
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,390
    Post Thanks / Like
    Mentioned
    40 Post(s)
    Tagged
    3 Thread(s)

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

    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.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  3. #3
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,390
    Post Thanks / Like
    Mentioned
    40 Post(s)
    Tagged
    3 Thread(s)

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

    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:
    '\\This code takes a screenshot of a verically scrollable userform
    '\\and create a IPic Object for the *entire* client area.
    
    '\\The Ipicture Object can then be loaded into a control
    '\\via its Picture Property,copied to the clipboard as a BITMAP
    '\\and pasted to a worksheet for subsequent printing and/or saved to disk as a BMP file.
    
    '\\Contrary to the native 'PrintForm' Method of the userform object model
    '\\this code permits printing the full scrollable area (Not just the currently visible part of the form)
    
    '\\Code written by Jaafar Tribak @ MrExcel.com on 24/01/2018.
    
    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
        #If  VBA7 Then
            hPic As LongPtr
            hPal As LongPtr
        #Else 
           hPic As Long
           hPal As Long
        #End  If
    End Type
    
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
    End Type
    
    #If  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
    #Else 
        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
    #End  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
    
    
    #If  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
    #Else 
        Dim hwnd As Long
        Dim hDc As Long, hInitDC As Long, hMemDC1 As Long, hMemDC2 As Long
        Dim hBmp1 As Long, hBmp2 As Long
    #End  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
    
    
    #If  VBA7 Then
    Private Sub ShowCopyingUpdate(ByVal hDc As LongPtr)
        Dim hNewFont As LongPtr
    #Else 
    Private Sub ShowCopyingUpdate(ByVal hDc As Long)
        Dim hNewFont As Long
    #End  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
    
    #If  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
    #Else 
    Private Function CreatePicture(ByVal BMP As Long, Optional ByVal PasteToNewSheetAsShape As Boolean, _
        Optional ByVal SaveBmpToFilePathName As String) As IPicture
        Dim hCopy As Long
    #End  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
        
        '\\Take a snapshot of the *entire" userform, paste it on a new worksheet as a shape
        '\\and save it to the 'temp' folder as a BMP file.
        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
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  4. #4
    New Member
    Join Date
    Jun 2019
    Posts
    5
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    Quote Originally Posted by Jaafar Tribak View Post
    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:
    '\\This code takes a screenshot of a verically scrollable userform
    '\\and create a IPic Object for the *entire* client area.
    
    '\\The Ipicture Object can then be loaded into a control
    '\\via its Picture Property,copied to the clipboard as a BITMAP
    '\\and pasted to a worksheet for subsequent printing and/or saved to disk as a BMP file.
    
    '\\Contrary to the native 'PrintForm' Method of the userform object model
    '\\this code permits printing the full scrollable area (Not just the currently visible part of the form)
    
    '\\Code written by Jaafar Tribak @ MrExcel.com on 24/01/2018.
    
    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
        #If  VBA7 Then
            hPic As LongPtr
            hPal As LongPtr
        #Else 
           hPic As Long
           hPal As Long
        #End  If
    End Type
    
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
    End Type
    
    #If  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
    #Else 
        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
    #End  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
    
    
    #If  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
    #Else 
        Dim hwnd As Long
        Dim hDc As Long, hInitDC As Long, hMemDC1 As Long, hMemDC2 As Long
        Dim hBmp1 As Long, hBmp2 As Long
    #End  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
    
    
    #If  VBA7 Then
    Private Sub ShowCopyingUpdate(ByVal hDc As LongPtr)
        Dim hNewFont As LongPtr
    #Else 
    Private Sub ShowCopyingUpdate(ByVal hDc As Long)
        Dim hNewFont As Long
    #End  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
    
    #If  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
    #Else 
    Private Function CreatePicture(ByVal BMP As Long, Optional ByVal PasteToNewSheetAsShape As Boolean, _
        Optional ByVal SaveBmpToFilePathName As String) As IPicture
        Dim hCopy As Long
    #End  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
        
        '\\Take a snapshot of the *entire" userform, paste it on a new worksheet as a shape
        '\\and save it to the 'temp' folder as a BMP file.
        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


    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.

  5. #5
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,390
    Post Thanks / Like
    Mentioned
    40 Post(s)
    Tagged
    3 Thread(s)

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

    I could print only the ones that appear in the screen.
    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 by Jaafar Tribak; Jun 3rd, 2019 at 08:30 AM.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  6. #6
    New Member
    Join Date
    Jun 2019
    Posts
    5
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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.

  7. #7
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,390
    Post Thanks / Like
    Mentioned
    40 Post(s)
    Tagged
    3 Thread(s)

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

    @ E30000546
    Hi,

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

    Regards.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  8. #8
    New Member
    Join Date
    Jun 2019
    Posts
    5
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    Quote Originally Posted by Jaafar Tribak View Post
    @ E30000546
    Hi,

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

    Regards.

    Hi,
    Yes I have one vertical scroll bar as it assist me in viewing all the contents.

    Regards.

  9. #9
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,390
    Post Thanks / Like
    Mentioned
    40 Post(s)
    Tagged
    3 Thread(s)

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

    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.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  10. #10
    New Member
    Join Date
    Jun 2019
    Posts
    5
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    Quote Originally Posted by Jaafar Tribak View Post
    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.
    Hi there,
    I am using Windows 10, having 64 bits with MS Office 2013 (Excel 2013)

    Thanks a lot for your help.
    Warmest regards.

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •