Microsoft Print to PDF Suppress "printing" Dialogue

D

Davavo

Board Regular
Joined
Aug 3, 2019
Messages
82
Hi, I wonder if anyone knows how to do this? I would really appreciate some help.

I did find something i think is the answer but it is very old and i have no idea how to use it.

I have a macro that runs through an excel sheet, reads an address of otehr workbooks from hyperlinks in column A, and then creates a pdf from each.
This is the code for creating the PDF's
Code: 
ActiveWindow.SelectedSheets.PrintOut , , 1, , ActivePrinter:="Microsoft Print to PDF", Printtofile:=False, Collate:=True, PrToFileName:=pdfPath, Ignoreprintareas:=False

Only this print method works.

The problem is that as it runs through this, it constantly p[ops up with a little dialog that says "printing bla bla", then it switches to the sheet, then switches to the next dialog as it works its way thought he sheet.

This is very ugly.

The usual methods of suppressing screen updating don't work on this dialog. i.e. I have already declared

Code: 
Application.EnableEvents = FalseApplication.Calculation = xlCalculationManual
Application.ScreenUpdating = False

I did find the following at https://www.mrexcel.com/forum/excel-questions/13057-hide-now-printing-vba.html

which i think is supposed to do the job, but as you can see, it was posted in 2002 and to be honest, i dont understand it, how to implement it, or what i need to be aware of to not break anything. .. ie return settings to normal, as this seems to work at a deeper level than i am used to.

Any help would be really appreciated.

Many thanks
D



Code: 
[COLOR=#333333][FONT=monospace]Option Explicit[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]    (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// The SendMessage function sends the specified message to a window or windows.[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// The function calls the window procedure for the specified window and does not[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// return until the window procedure has processed the message.[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// The PostMessage function, in contrast, posts a message to a thread’s message[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// queue and returns immediately.[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'//[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// PARAMETERS:[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'//[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// hwnd[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// Identifies the window whose window procedure will receive the message.[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// If this parameter is HWND_BROADCAST, the message is sent to all top-level[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// windows in the system, including disabled or invisible unowned windows,[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// overlapped windows, and pop-up windows; but the message is not sent to child windows.[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]'// Msg[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// Specifies the message to be sent.[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]'// wParam[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// Specifies additional message-specific information.[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]'// lParam[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// Specifies additional message-specific information.[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]'//////////////////////////////////////////////////////////////////////////[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// The IsWindow function determines whether the specified window handle[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// identifies an existing window.[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// PARAMETERS:[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// hWnd[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'// Specifies the window handle.[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]'//////////////////////////////////////////////////////////////////////////[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'//[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, _[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]    lpRect As Long, ByVal bErase As Long) As Long[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]Private Declare Function GetDesktopWindow Lib "user32" () As Long[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]Public Function fncScreenUpdating(State As Boolean, Optional Window_hWnd As Long = 0)[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]Const WM_SETREDRAW = &HB[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]Const WM_PAINT = &HF[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]If Window_hWnd = 0 Then[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]    Window_hWnd = GetDesktopWindow()[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]Else[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]    If IsWindow(hwnd:=Window_hWnd) = False Then[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]        Exit Function[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]    End If[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]End If[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]If State = True Then[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]    Call SendMessage(hwnd:=Window_hWnd, wMsg:=WM_SETREDRAW, wParam:=1, lParam:=0)[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]    Call InvalidateRect(hwnd:=Window_hWnd, lpRect:=0, bErase:=True)[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]    Call UpdateWindow(hwnd:=Window_hWnd)[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]Else[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]    Call SendMessage(hwnd:=Window_hWnd, wMsg:=WM_SETREDRAW, wParam:=0, lParam:=0)[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]End If[/FONT][/COLOR]

[COLOR=#333333][FONT=monospace]End Function[/FONT][/COLOR]


[COLOR=#333333][FONT=monospace]'-----------------------------[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]Sub PrintDirect()[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]fncScreenUpdating State:=False[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]ActiveWindow.SelectedSheets.PrintOut Copies:=1[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]fncScreenUpdating State:=True[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]End Sub[/FONT][/COLOR]
[COLOR=#333333][FONT=monospace]'-----------------------------[/FONT][/COLOR]
 
Last edited:
Sort by date Sort by votes
Jaafar Tribak said:
Difficult for me to follow the code you posted ... As a general rule, you could avoid activating and selecting sheets & ranges and still work with them. Also, setting Application.ScreenUpdating to False and turning Calculation Mode to Manual could help.

A more drasctic measure is to turn off the desktop drawing via the Windows API (as per your initial post) while the macro is running.

Regards.
Click to expand...


Thanks again Jaafar, I got what you were saying.

I have tried to adapt the code for 64 bit using the ms docs page and your code, but I am unsure which need to be Ptrsafe.
Having changed all 'Long' declarations to Longptr I am getting a type mismatch error. I dont know if this is related.

Could you, (or anyone) explain this in a little more detail or tell me which variable need to be declared Ptr safe, or figure out why the type mismatch error?

Thanks again.

Code: 
Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then '---------------------------------------------------------------------no clue which variables require Ptrsafe declaration. 


Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As LongPtr, ByVal bErase As LongPtr) As LongPtr
Private Declare PtrSafe Function UpdateWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 


Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If






Public Function fncScreenUpdating(State As Boolean, Optional Window_hWnd As Long = 0)
Const WM_SETREDRAW = &HB
Const WM_PAINT = &HF


If Window_hWnd = 0 Then
    Window_hWnd = GetDesktopWindow() '----------------------------------------------type mismatch here
Else
    If IsWindow(hwnd:=Window_hWnd) = False Then
        Exit Function
    End If
End If


If State = True Then
    Call SendMessage(hwnd:=Window_hWnd, wMsg:=WM_SETREDRAW, wParam:=1, lParam:=0)
    Call InvalidateRect(hwnd:=Window_hWnd, lpRect:=0, bErase:=True)
    Call UpdateWindow(hwnd:=Window_hWnd)
Else
    Call SendMessage(hwnd:=Window_hWnd, wMsg:=WM_SETREDRAW, wParam:=0, lParam:=0)
End If


End Function




'-----------------------------
Sub PrintDirect(pdfpath As String)
fncScreenUpdating State:=False


ActiveWindow.SelectedSheets.PrintOut , , 1, , ActivePrinter:="Microsoft Print to PDF", Printtofile:=False, Collate:=True, PrToFileName:=pdfpath, Ignoreprintareas:=False


'ActiveWindow.SelectedSheets.PrintOut Copies:=1


fncScreenUpdating State:=True
End Sub
'----------------------------
 
Upvote 0

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Hi Davavo,

As I said, I think the way you wrote the code is the reason the screen jumps around while the code is runnig ... I suggest you read on how to write code without the need to activate sheets, select ranges etc ..

Anyway, the following code should suppress the popup 'printing dialog' and should also prevent the excel screen from jumping back and forth while the code is executing and should work on 64bit.


In a standard Module:
Code: 
Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    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 UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) 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 ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function EnableWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal fEnable As Long) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As LongPtr, ByVal bErase As LongPtr) As LongPtr
    Private Declare PtrSafe Function UpdateWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr

    Private hCBTHook As LongPtr

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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 UnhookWindowsHookEx Lib "user32" (ByVal hhk 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 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 ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long
    Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

    Private hCBTHook As Long

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If



Public Property Let API_Application_ScreenUpdating(ByVal EnableUpdate As Boolean)

    Const WM_SETREDRAW = &HB
    Const WM_PAINT = &HF
    
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        Dim hwnd As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Dim hwnd As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    
    hwnd = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    hwnd = FindWindowEx(hwnd, 0, "EXCEL7", vbNullString)
    
    If EnableUpdate Then
        Call SendMessage(hwnd, WM_SETREDRAW, 1, 0)
        Call InvalidateRect(hwnd, 0, True)
        Call UpdateWindow(hwnd)
    Else
        Call SendMessage(hwnd, WM_SETREDRAW, 0, 0)
    End If

End Property


Public Property Let SuppressPrintingDlg(ByVal Suppress As Boolean)

    Const WH_CBT = &H5
    
    If Suppress Then
        hCBTHook = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, GetModuleHandle(vbNullString), GetCurrentThreadId)
    Else
        UnhookWindowsHookEx hCBTHook
    End If
    
End Property


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function CBTProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function CBTProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Const HCBT_ACTIVATE = &H5
    Dim sClassName As String * 256, lRet As Long

    If nCode = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sClassName, 256)
        If Left(sClassName, lRet) = "bosa_sdm_XL9" Then
            UnhookWindowsHookEx hCBTHook
            EnableWindow wParam, 1
            ShowWindow wParam, 0
        End If
    End If
    Call CallNextHookEx(hCBTHook, nCode, wParam, lParam)
 
End Function


Code Usage example : (Change the spdfPath as required)
Code: 
Sub Test()

    Dim sPrinter As String, spdfPath As String
    
    sPrinter = "Microsoft Print to PDF"
    spdfPath = "C:\test\test.pdf" [COLOR=#008000][B] '<== change path as rquired.[/B][/COLOR]
    
    On Error GoTo errHandler
    
    API_Application_ScreenUpdating = False
    SuppressPrintingDlg = True
    Application.StatusBar = "Printing in progress ..."
    
        ActiveWindow.SelectedSheets.PrintOut , , 1, , ActivePrinter:=sPrinter, _
        Printtofile:=False, Collate:=True, PrToFileName:=spdfPath, Ignoreprintareas:=False
    
    API_Application_ScreenUpdating = True
    SuppressPrintingDlg = False
    Application.StatusBar = False
    
    
errHandler:

        Application.StatusBar = False
        If Err.Number = 0 Then
            Debug.Print "done Printing."
            MsgBox "Printing Finished."
        Else
            API_Application_ScreenUpdating = True
            SuppressPrintingDlg = False
            MsgBox hCBTHook & vbTab & "Runtime Error " & Err.Number & " !" & _
            vbNewLine & vbNewLine & Err.Description
        End If
    
End Sub
 
Upvote 0
Hello again Jaafar,

i was really good of you to go to so much trouble, thank you so much!

It didnt quite stop it but when i reverted to the original without the suppress sub, it has stopped doing it, so whatever happened, it is now working without the jumping back and forth between loops.
I dont actually know what changed but maybe i removed an instance of activate or select as you suggested.
I will take your advice and tried to remove as many instances of this as possible.

Jaafar Tribak said:
Hi Davavo,

As I said, I think the way you wrote the code is the reason the screen jumps around while the code is runnig ... I suggest you read on how to write code without the need to activate sheets, select ranges etc ..

Anyway, the following code should suppress the popup 'printing dialog' and should also prevent the excel screen from jumping back and forth while the code is executing and should work on 64bit.


In a standard Module:
Code: 
Option Explicit

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    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 UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) 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 ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function EnableWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal fEnable As Long) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As LongPtr, ByVal bErase As LongPtr) As LongPtr
    Private Declare PtrSafe Function UpdateWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr

    Private hCBTHook As LongPtr

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    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 UnhookWindowsHookEx Lib "user32" (ByVal hhk 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 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 ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long
    Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

    Private hCBTHook As Long

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If



Public Property Let API_Application_ScreenUpdating(ByVal EnableUpdate As Boolean)

    Const WM_SETREDRAW = &HB
    Const WM_PAINT = &HF
    
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hwnd As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hwnd As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    hwnd = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    hwnd = FindWindowEx(hwnd, 0, "EXCEL7", vbNullString)
    
    If EnableUpdate Then
        Call SendMessage(hwnd, WM_SETREDRAW, 1, 0)
        Call InvalidateRect(hwnd, 0, True)
        Call UpdateWindow(hwnd)
    Else
        Call SendMessage(hwnd, WM_SETREDRAW, 0, 0)
    End If

End Property


Public Property Let SuppressPrintingDlg(ByVal Suppress As Boolean)

    Const WH_CBT = &H5
    
    If Suppress Then
        hCBTHook = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, GetModuleHandle(vbNullString), GetCurrentThreadId)
    Else
        UnhookWindowsHookEx hCBTHook
    End If
    
End Property


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Function CBTProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Function CBTProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Const HCBT_ACTIVATE = &H5
    Dim sClassName As String * 256, lRet As Long

    If nCode = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sClassName, 256)
        If Left(sClassName, lRet) = "bosa_sdm_XL9" Then
            UnhookWindowsHookEx hCBTHook
            EnableWindow wParam, 1
            ShowWindow wParam, 0
        End If
    End If
    Call CallNextHookEx(hCBTHook, nCode, wParam, lParam)
 
End Function


Code Usage example : (Change the spdfPath as required)
Code: 
Sub Test()

    Dim sPrinter As String, spdfPath As String
    
    sPrinter = "Microsoft Print to PDF"
    spdfPath = "C:\test\test.pdf" [COLOR=#008000][B] '<== change path as rquired.[/B][/COLOR]
    
    On Error GoTo errHandler
    
    API_Application_ScreenUpdating = False
    SuppressPrintingDlg = True
    Application.StatusBar = "Printing in progress ..."
    
        ActiveWindow.SelectedSheets.PrintOut , , 1, , ActivePrinter:=sPrinter, _
        Printtofile:=False, Collate:=True, PrToFileName:=spdfPath, Ignoreprintareas:=False
    
    API_Application_ScreenUpdating = True
    SuppressPrintingDlg = False
    Application.StatusBar = False
    
    
errHandler:

        Application.StatusBar = False
        If Err.Number = 0 Then
            Debug.Print "done Printing."
            MsgBox "Printing Finished."
        Else
            API_Application_ScreenUpdating = True
            SuppressPrintingDlg = False
            MsgBox hCBTHook & vbTab & "Runtime Error " & Err.Number & " !" & _
            vbNewLine & vbNewLine & Err.Description
        End If
    
End Sub
Click to expand...
 
Last edited:
Upvote 0
Davavo said:
It didnt quite stop it but when i reverted to the original without the suppress sub, it has stopped doing it, so whatever happened, it is now working without the jumping back and forth between loops.
Click to expand...

Glad to have helped and thank you for the feedback.

Regards.
 
Upvote 0
Davavo said:
Hello again Jaafar,

i was really good of you to go to so much trouble, thank you so much!

It didnt quite stop it but when i reverted to the original without the suppress sub, it has stopped doing it, so whatever happened, it is now working without the jumping back and forth between loops.
I dont actually know what changed but maybe i removed an instance of activate or select as you suggested.
I will take your advice and tried to remove as many instances of this as possible.
Click to expand...


Hello again Jaafar,

it turns out i was wrong, this had not solved the issue, so I thought I should post again.
I actually wasnt calling the script to print the pdf's at all, but everything else gave the impression it was working, hence no screen jump.

So, you solution does suppress the print dialog, but the screen still jumps to and from the sheet with each loop.
I followed your instructions and removed all of the code that used select or activate, but still no joy.

It turns out that this problem occurs because 'open' overrides
Code: 
Application.ScreenUpdating = False

The solution is to open the workbook in a new instance of excel that is hidden.
This also suppresses the dialog.

Full code is now
Code: 
'Copy Records to archive sheet-----------------------------------------------------------------------------------------------------------------------------------------------UsedRows = TWS.Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row


SWS.Range("TExpenses").Copy
TWS.Range("A" & UsedRows + 1).PasteSpecial Paste:=xlPasteAll


'---------------------------------------------------------------------------


NowUsedRows = TWS.Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row


Dim app As New Excel.Application
    app.Visible = False
    
i = UsedRows


Do While i <= NowUsedRows - 1


i = i + 1
    
If i = 2 Then


GoTo Doit
    
    Else
    
        'the same hyperlink exists on each line from the same claim.
        If TWS.Range("A" & i).Hyperlinks(1).Address = TWS.Range("A" & i - 1).Hyperlinks(1).Address Then


    GoTo Skip
    
    Else
    
Doit:


    hFullPath = TWS.Range("A" & i).Hyperlinks(1).Address                                    'the full path of the hyperlink
    hFullFileName = Right(hFullPath, Len(hFullPath) - InStrRev(hFullPath, "\"))             'the filename including the extension
    hFileName = Left(hFullFileName, (InStr(hFullFileName, ".") - 1))                        'the filename minus the extension
    
                                                                        'Visible is False by default, so this isn't necessary
    Dim SWB As Excel.Workbook


    Set SWB = app.Workbooks.Add(hFullPath)                                                  'Open the hyperlink and set as Source Workbook
              
        With SWB                                                                            'turn that workbook into a pdf and save it to the pdf archive


                'do the pdfs -----------------------------------------------------------------------------------------------------------------------------------------------------------
                  
                pdfpath = myPDfArchiveDir & hFileName & ".pdf"                              'create the path for the pdf
                
                SWB.Sheets("Summary").Unprotect Password:="****"
                SWB.Sheets("Summary").Range("K10") = pdfpath                                'write the filename to a cell, for visual reference from hardcopy.
                SWB.Sheets("Summary").Protect Password:="****"
              
                strPName = Application.ActivePrinter                                        'this records the current printer so that the setting csan be returned to previous after exporting the file to pdf
                
                SWB.Sheets(Array("Summary", "Detail")).PrintOut , , 1, , ActivePrinter:="Microsoft Print to PDF", Printtofile:=False, Collate:=True, PrToFileName:=pdfpath, Ignoreprintareas:=False
                              
                Application.ActivePrinter = strPName                                        'returns the printere settings to whatever they were prior to running the script.
                                                                                      
                SWB.Close SaveChanges:=False                                                'close the workbook


               'Now Move the excel file and change the hyperlink -------------------------------------------------------------------------------------------------------------------------------------------------
               
                Name hFullPath As NewExpBinDir & "\" & hFileName & ".xlsx"          'move the xlsx file to the bin so that is is not processed again in the next batch
        
               '--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
        End With
    
     End If
     End If
     
Skip:


Loop


 app.Quit                                                                   'quit the app
 Set app = Nothing


Application.DisplayAlerts = True


Call changehyperlink(UsedRows)


Unload UserForm9

The solution was from here https://stackoverflow.com/questions/579797/open-excel-file-for-reading-with-vba-without-display
(hope thats ok to post mods)

In the comments there is the followingf which i could use some guidance on...

"I strongly recommend that you lock down the app session before opening the target workbook: ` App.AutomationSecurity = msoAutomationSecurityForceDisable ` ` App.EnableEvents = False ` ` App.Calculation = xlCalculationManual ` - And you might consider enumerating the AddIns collection and disabling them, too: slow add-in startups will delay the launch of the app session."

Hope this helps someone else and thanks again Jaafar.
 
Last edited:
Upvote 0
Davavo said:
"I strongly recommend that you lock down the app session before opening the target workbook: ` App.AutomationSecurity = msoAutomationSecurityForceDisable ` ` App.EnableEvents = False ` ` App.Calculation = xlCalculationManual ` - And you might consider enumerating the AddIns collection and disabling them, too: slow add-in startups will delay the launch of the app session."

Hope this helps someone else and thanks again Jaafar.
Click to expand...

I have placed

Code: 
[COLOR=#242729][FONT=Arial]App.AutomationSecurity = msoAutomationSecurityForceDisable
App.EnableEvents = False[/FONT][/COLOR]

where the app is opened and
Code: 
[COLOR=#242729][FONT=Arial]App.Calculation = xlCalculationManual [/FONT][/COLOR]
where the workbook is opened in each loop.

Any help on "enumerating the AddIns collection and disabling them, too:" would be appreciated.
 
Last edited:
Upvote 0
Any help on "enumerating the AddIns collection and disabling them, too:" would be appreciated.
Click to expand...

Hi,

You could try something like this :
Code: 
Sub ConnectComAddIns(ByVal Connect As Boolean)

    Dim oCom As COMAddIn
    
    If Connect Then
        For Each oCom In Application.COMAddIns
            If oCom.Connect Then
                oCom.Connect = False
                oCom.Connect = True
            End If
        Next
     Else
        For Each oCom In Application.COMAddIns
            If oCom.Connect Then
                oCom.Connect = False
            End If
        Next oCom
     End If
 
End Sub


Sub InstallAddins(ByVal Install As Boolean)


    Dim oAddin As AddIn
    
    If Install Then
        For Each oAddin In Application.AddIns
            If oAddin.Installed = False Then
                oAddin.Installed = True
            End If
        Next
    Else
        For Each oAddin In Application.AddIns
            If oAddin.Installed Then
                oAddin.Installed = False
            End If
        Next
    End If


End Sub

Then just run this to uninstall the addins :
Code: 
Sub Test()
    'Uninstall all addins
    Call ConnectComAddIns(Connect:=False)
    Call InstallAddins(Install:=False)
End Sub

I would be careful with this as I am not sure if the uninstalled addins with the above code will remain uninstalled when you subsequently open excel in which case you will need to somehow store the addins that were uninstalled beforehand and re-install them when done.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
0
Views
170
Jaafar Tribak
Jaafar Tribak
A
  • Question Question
What is wrong with this VBA code: userForm get hand ico for pointer on hover
2
Replies
15
Views
1K
RoryA
RoryA
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
310
Minh Tuan VN
M
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
749
Jaafar Tribak
Jaafar Tribak
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
745
huiettcm
H

Forum statistics

Threads
1,223,248
Messages
6,171,027
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