Print userform spreadsheet control

[depcdivr]

Is there a way to print a spreadsheet control that is in a userform?

I tried using

me.printform

which prints the form but makes the spreadsheet control microscopic. Is there a fix for this?

I woudl really hate to have to move all of the data to a new spreadsheet, then reformat it, print it and then delete it. Seems like a lot of work for something that should be simple.

 

[Jaafar Tribak]

You are right -I tested it- The PrintForm method makes the spreadsheet control hardly visible. Have no idea why but I know these OWC controls can be problematic.

The only solution I can think of is to reinvent the wheel and do some raw printing via the windows api. This workaround proved more difficult than I initially thought. In fact, i've done some extensive googling but nothing really came up for VBA mainly because one cannot get the Printer DC in office.


Workbook demo.

1- Add a new Standard module to your project and place the following code in it :

Option Explicit

Private Type POINTAPI
  x As Long
  y As Long
End Type

Private Type DOCINFO
    cbSize As Long
    lpszName As String
    lpszOutput As Long
End Type

Private Declare Function FindWindow Lib "user32.dll" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) 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 SelectObject Lib "gdi32" _
(ByVal hDC As Long, _
ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Private Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
 
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function GetWindowDC Lib "user32.dll" _
(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 GetDeviceCaps Lib "gdi32" ( _
ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Declare Function StartDoc& Lib "gdi32" _
Alias "StartDocA" (ByVal hcs As Long, lpDI As DOCINFO)

Private Declare Function StartPage& Lib "gdi32" (ByVal hcs As Long)

Private Declare Function EndPage& Lib "gdi32" (ByVal hcs As Long)

Private Declare Function EndDoc& Lib "gdi32" (ByVal hcs As Long)

Private Declare Function DeleteDC& Lib "gdi32" (ByVal hDC As Long)

Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const PointsPerInch = 72
Private Const SRCCOPY As Long = &HCC0020


'---------------'
'Public routine.'
'---------------'
Public Sub PrintUserForm(ByVal UF As Object)

    Const ZOOM_FACTOR = 4 '<--- Change this value as needed.
    Dim MyDoc As DOCINFO
    Dim hwnd As Long
    Dim lBmp As Long
    Dim lMemoryDC As Long
    Dim lDCfrm As Long
    Dim lDC As Long
    
    'Store the useform hwnd.
    hwnd = FindWindow(vbNullString, UF.Caption)
    
    'Store the userform wndow dc.
    lDCfrm = GetWindowDC(hwnd)
    
    'create a memory dc.
    lMemoryDC = CreateCompatibleDC(lDCfrm)
    
    'create a compatible bmp.
    lBmp = CreateCompatibleBitmap _
    (lDCfrm, PTtoPX(UF.Width, False), PTtoPX(UF.Height, True))
    
    'select the bmp to the memory dc.
    DeleteObject SelectObject(lMemoryDC, lBmp)
    
    'copy the userform onto the memory dc.
    BitBlt lMemoryDC, 0, 0, PTtoPX(UF.Width, False), PTtoPX(UF.Height, True), _
    lDCfrm, 0, 0, SRCCOPY
    
    'Initialize the DOCINFO srtucture.
    MyDoc.lpszName = "Form_PrintOut"
    MyDoc.lpszOutput = 0
    MyDoc.cbSize = LenB(MyDoc)
    
    'Show the Win Print Dlg.
    lDC = Show_PrintDlg
    
    'Start a new print job.
    Call StartDoc(lDC, MyDoc)
    
    Call StartPage(lDC)
    
    'Print the userform.( May need to adjust the zoom factor ! )
    BitBlt lDC, PTtoPX(UF.Left, False), PTtoPX(UF.Top, True), _
    PTtoPX(UF.Width, False) * ZOOM_FACTOR, PTtoPX(UF.Height, True) * ZOOM_FACTOR, _
    lMemoryDC, 0, 0, SRCCOPY
    
    Call EndPage(lDC)
    
    'End the printing.
    Call EndDoc(lDC)
    
    'CleanUp.
    Call DeleteDC(lDC)
    
    Call ReleaseDC(0, lDCfrm)
    Call ReleaseDC(lMemoryDC, 0)

End Sub


'------------------'
'Private routines .'
'------------------'
Private Function Show_PrintDlg() As Long

    Dim dlg As Object
    
    Const cdlPDPrintSetup = 64
    Const cdlPDReturnDC As Long = &H100
    
    'Show the print dlg to retrieve the printer dc.
    Set dlg = UserForm1.Controls.Add("MSComDlg.CommonDialog.1", "cd1")
    
    With dlg
        .CancelError = False
        .Flags = cdlPDPrintSetup + cdlPDReturnDC
        .ShowPrinter
        Show_PrintDlg = .hDC
    End With

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

2- Add a commandbutton to your userform and assign the following code to it :

Option Explicit

Private Sub CommandButton1_Click()
    Call PrintUserForm(Me)
End Sub

Note: You may need to adjust the zoom factor in the PrintUserForm routine for a more refined result.

 

[Norie]

Can't you just copy and paste from the control to a 'real' worksheet?

I was definitely be able to do it manually but I can't seem to get it in code.

Jaafar, do you think it's possible?

Well I seem to have got something, this worked for me.

    Me.Spreadsheet1.Worksheets(1).Cells.Copy
    
    With ThisWorkbook.Worksheets(1)
    
        Application.Goto .Range("A1")
                
        .Paste

    End With

 

[Jaafar Tribak]

Can't you just copy and paste from the control to a 'real' worksheet?

I was definitely be able to do it manually but I can't seem to get it in code.

Jaafar, do you think it's possible?

Well I seem to have got something, this worked for me.

    Me.Spreadsheet1.Worksheets(1).Cells.Copy
    
    With ThisWorkbook.Worksheets(1)
    
        Application.Goto .Range("A1")
                
        .Paste

    End With

Hi Norie.

I think the OP is asking about printing a spreadsheet control embeeded in a userform not in a worksheet. I guess one could copy and paste the data from the spreadsheet control into a worksheet but the code I posted prints everything ie: The userForm and all its controls. - Thanks.

 

[Norie]

Good point Jaafar.

The code I posted only copies the data, and formatting*, from the spreadsheet control in the userform to a worksheet.

* Not sure if it will copy all formatting. only checked with font, background colour etc.