Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,808
- Office Version
- 2016
- Platform
- Windows
I decided to write this code and thought I would share it here in case someone finds it useful .... The code is supposed to print the standard MsgBox... The code can easily be amended to make it work for any other window. A case in point is an imbedded WebBrowser control on a worksheet whose printing along the worksheet parent can be problematic.
The PrintMsgBox Function takes an optional argument (PrintOutFile) for printing to a file.
The code adds a convenient Print Icon at the top-right of the MsgBox client area.
Tested on Excel 2016 x64bit Win10 x64bit.
Workbook Example
1- Code in a Standard Module:
2- Code Usage :
Regards.
The PrintMsgBox Function takes an optional argument (PrintOutFile) for printing to a file.
The code adds a convenient Print Icon at the top-right of the MsgBox client area.
Tested on Excel 2016 x64bit Win10 x64bit.
Workbook Example
1- Code in a Standard Module:
VBA Code:
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type DOCINFO
cbSize As Long
lpszDocName As String
lpszOutput As String
'#if (WINVER >= 0x0400)
lpszDatatype As String
fwType As Long
'#endif /* WINVER */
End Type
#If VBA7 Then
#If Win64 Then
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 "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If
Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) 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 CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
Private Declare PtrSafe Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Long) As LongPtr
Private Declare PtrSafe Function StartDoc Lib "gdi32" Alias "StartDocA" (ByVal hdc As LongPtr, lpdi As DOCINFO) As Long
Private Declare PtrSafe Function StartPage Lib "gdi32" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function EndPage Lib "gdi32" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function EndDoc Lib "gdi32" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (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 SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) 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 GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDefaultPrinter Lib "winspool.drv" Alias "GetDefaultPrinterA" (ByVal sPrinterName As String, lPrinterNameBufferSize As Long) As Long
Private Declare PtrSafe Function SetMapMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nMapMode As Long) As Long
Private Declare PtrSafe Function SetWindowExtEx Lib "gdi32" (ByVal hdc As LongPtr, ByVal nX As Long, ByVal nY As Long, ByVal lpSize As Long) As Long
Private Declare PtrSafe Function SetViewportExtEx Lib "gdi32" (ByVal hdc As LongPtr, ByVal nX As Long, ByVal nY As Long, ByVal lpSize As Long) As Long
Private Declare PtrSafe Function SetViewportOrgEx Lib "gdi32" (ByVal hdc As LongPtr, ByVal nX As Long, ByVal nY As Long, ByVal lpPoint As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private hHook As LongPtr, lPrevButtnProc As LongPtr, hMsgBox As LongPtr, hCopyBmpPtr As LongPtr
#Else
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) 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 CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function PrintWindow Lib "user32" (ByVal hwnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Long) As Long
Private Declare Function StartDoc Lib "gdi32" Alias "StartDocA" (ByVal hdc As Long, lpdi As DOCINFO) As Long
Private Declare Function StartPage Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndPage Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndDoc Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (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 SelectObject Lib "gdi32" (ByVal hdc As Long, 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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDefaultPrinter Lib "winspool.drv" Alias "GetDefaultPrinterA" (ByVal sPrinterName As String, lPrinterNameBufferSize As Long) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
Private Declare Function SetWindowExtEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, ByVal lpSize As Long) As Long
Private Declare Function SetViewportExtEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, ByVal lpSize As Long) As Long
Private Declare Function SetViewportOrgEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, ByVal lpPoint As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private hHook As Long, lPrevButtnProc As Long, hMsgBox As Long, hCopyBmpPtr As Long
#End If
Private sOutPutFile As String
Public Function PrintMsgBox( _
ByVal Prompt As String, _
Optional ByVal Buttons As VbMsgBoxStyle, _
Optional ByVal Title As String, _
Optional PrintOutFile As String _
) As VbMsgBoxResult
Const WH_CBT = 5
If Len(Title) = 0 Then Title = Application
If Len(Trim(PrintOutFile)) = 0 Then PrintOutFile = ""
sOutPutFile = PrintOutFile
hHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, GetModuleHandle(vbNullString), GetCurrentThreadId)
PrintMsgBox = MsgBox(Prompt, Buttons, Title)
End Function
#If Win64 Then
Private Function HookProc(ByVal lCode As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
Dim hPrintBtn As LongLong
#Else
Private Function HookProc(ByVal lCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim hPrintBtn As Long
#End If
Const HC_ACTION = 0
Const HCBT_ACTIVATE = 5
Const GWL_WNDPROC = -4
Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000
Const BS_FLAT = &H8000&
Const BS_BITMAP As Long = &H80
Const BM_SETIMAGE = &HF7&
Const IMAGE_BITMAP = 0
Const SM_CYCAPTION = 4
Dim tClientRect As RECT
Dim sClassName As String * 256, lRet As Long
Dim lButtnHeight As Long
If lCode < HC_ACTION Then
HookProc = CallNextHookEx(hHook, lCode, wParam, lParam)
Exit Function
End If
If lCode = HCBT_ACTIVATE Then
lRet = GetClassName(wParam, sClassName, 256)
If Left$(sClassName, lRet) = "#32770" Then
Call UnhookWindowsHookEx(hHook)
hMsgBox = wParam
Call GetClientRect(hMsgBox, tClientRect)
lButtnHeight = GetSystemMetrics(SM_CYCAPTION)
hPrintBtn = CreateWindowEx(0, "BUTTON", vbNullString, 0 _
+ WS_VISIBLE + WS_CHILD + BS_BITMAP + BS_FLAT, tClientRect.Right - lButtnHeight - 4, _
16, lButtnHeight, lButtnHeight, hMsgBox, 0, GetModuleHandle(vbNullString), 0)
hCopyBmpPtr = FaceIDToBMP(FaceID:=4)
If hPrintBtn Then
Call SendMessage(hPrintBtn, BM_SETIMAGE, IMAGE_BITMAP, hCopyBmpPtr)
lPrevButtnProc = SetWindowLong(hPrintBtn, GWL_WNDPROC, AddressOf PrintBtnProc)
End If
End If
End If
Call CallNextHookEx(hHook, lCode, wParam, lParam)
End Function
#If Win64 Then
Private Function PrintBtnProc(ByVal hwnd As LongLong, ByVal Msg As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
#Else
Private Function PrintBtnProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Const GWL_WNDPROC = -4
Const WM_LBUTTONUP = &H202
Const WM_KILLFOCUS = &H8
Const WM_DESTROY = &H2
Select Case Msg
Case WM_LBUTTONUP
If PrintOutWindow(hMsgBox, sOutPutFile) Then
With CreateObject("Scripting.FileSystemObject")
If Len(sOutPutFile) Then
MsgBox "PrintOut File Ready : " & vbNewLine & .GetFile(sOutPutFile).Path, vbInformation
Else
MsgBox "Printing Done.", vbInformation
End If
End With
End If
Call SendMessage(hwnd, WM_KILLFOCUS, 0, 0)
Case WM_DESTROY
Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevButtnProc)
Call DeleteObject(hCopyBmpPtr)
sOutPutFile = ""
End Select
PrintBtnProc = CallWindowProc(lPrevButtnProc, hwnd, Msg, wParam, ByVal lParam)
End Function
#If Win64 Then
Private Function PrintOutWindow(ByVal hwnd As LongLong, Optional ByVal OutPutFile As String) As Boolean
Dim hPrintDc As LongLong, hMemDC As LongLong, hBmp As LongLong, hPrevBmp As LongLong
#Else
Private Function PrintOutWindow(ByVal hwnd As Long, Optional ByVal OutPutFile As String) As Boolean
Dim hPrintDc As Long, hMemDC As Long, hBmp As Long, hPrevBmp As Long
#End If
Const PW_CLIENTONLY = &H1
Const PW_RENDERFULLCONTENT = &H2
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Const MM_ISOTROPIC = 7
Const PHYSICALWIDTH = 110
Const PHYSICALHEIGHT = 111
Const PHYSICALOFFSETX = 112
Const PHYSICALOFFSETY = 113
Const SRCCOPY = &HCC0020
Dim tDocInfo As DOCINFO, tWinRect As RECT
Dim W As Long, H As Long
Dim DestLeft As Long
Dim DestTop As Long
Dim PgeInchesWidth As Single
Dim PgeInchesHeight As Single
Dim sPrinter As String
sPrinter = GetPrinter
If Len(sPrinter) Then
hPrintDc = CreateDC(0, sPrinter, 0, 0)
With tDocInfo
.cbSize = LenB(tDocInfo)
.lpszDocName = "Window_PrintOut"
If OutPutFile <> vbNullString Then
.lpszOutput = OutPutFile
End If
End With
Call GetWindowRect(hwnd, tWinRect)
W = tWinRect.Right - tWinRect.Left
H = tWinRect.Bottom - tWinRect.Top
If StartDoc(hPrintDc, tDocInfo) Then
If StartPage(hPrintDc) Then
Call SetMapMode(hPrintDc, MM_ISOTROPIC)
Call SetWindowExtEx(hPrintDc, tWinRect.Right, tWinRect.Bottom, 0)
Call SetViewportExtEx(hPrintDc, GetDeviceCaps(hPrintDc, PHYSICALWIDTH), GetDeviceCaps(hPrintDc, PHYSICALHEIGHT), 0)
Call SetViewportOrgEx(hPrintDc, -GetDeviceCaps(hPrintDc, PHYSICALOFFSETX), -GetDeviceCaps(hPrintDc, PHYSICALOFFSETY), 0)
hMemDC = CreateCompatibleDC(hPrintDc)
hBmp = CreateCompatibleBitmap(hPrintDc, W, H)
hPrevBmp = SelectObject(hMemDC, hBmp)
Call PrintWindow(hwnd, hMemDC, PW_RENDERFULLCONTENT)
PgeInchesWidth = (GetDeviceCaps(hPrintDc, PHYSICALWIDTH)) / GetDeviceCaps(hPrintDc, LOGPIXELSX)
PgeInchesHeight = (GetDeviceCaps(hPrintDc, PHYSICALHEIGHT)) / GetDeviceCaps(hPrintDc, LOGPIXELSY)
With Application.ActiveWindow
DestLeft = .ActivePane.PointsToScreenPixelsX(Application.InchesToPoints(PgeInchesWidth)) - .ActivePane.PointsToScreenPixelsX(0)
DestTop = .ActivePane.PointsToScreenPixelsY(Application.InchesToPoints(PgeInchesHeight)) - .ActivePane.PointsToScreenPixelsY(0)
End With
Call BitBlt(hPrintDc, (DestLeft - W) / 2, (DestTop - H) / 2, W, H, hMemDC, 0, 0, SRCCOPY)
PrintOutWindow = True
Else
MsgBox "Printer driver unable to accept data.", vbCritical
End If
Else
MsgBox "Unable to to start Print job.", vbCritical
End If
Else
MsgBox "Unable to retrieve the default printer.", vbCritical
End If
Call EndPage(hPrintDc)
Call EndDoc(hPrintDc)
Call DeleteDC(hPrintDc)
Call SelectObject(hMemDC, hPrevBmp)
Call DeleteDC(hMemDC)
Call DeleteObject(hBmp)
End Function
Private Function GetPrinter() As String
Dim sBuffer As String * 128, lBuffSize As Long
lBuffSize = 128
If GetDefaultPrinter(sBuffer, lBuffSize) Then
GetPrinter = Left(sBuffer, lBuffSize - 1)
End If
End Function
#If Win64 Then
Private Function FaceIDToBMP(ByVal FaceID As Long) As LongLong
Dim hBmpPtr As LongLong
#Else
Private Function FaceIDToBMP(ByVal FaceID As Long) As Long
Dim hBmpPtr As Long
#End If
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const CF_BITMAP = 2
On Error GoTo errHandler
Application.CommandBars.FindControl(ID:=FaceID).CopyFace
Call OpenClipboard(Application.hwnd)
hBmpPtr = GetClipboardData(CF_BITMAP)
If hBmpPtr Then
hCopyBmpPtr = CopyImage(hBmpPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Call DeleteObject(hBmpPtr)
FaceIDToBMP = hCopyBmpPtr
End If
errHandler:
Call EmptyClipboard
Call CloseClipboard
End Function2- Code Usage :
VBA Code:
Option Explicit
Sub MAIN_TEST()
Dim sPrompt As String
sPrompt = "Click on the PRINT icon ===>" & vbNewLine & vbNewLine & String(1000, "X")
PrintMsgBox sPrompt, vbOKOnly, "Print MsgBox Test ...", ThisWorkbook.Path & "\" & "MsgBox.PDF"
End SubRegards.
