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

Thread: Microsoft Print to PDF Suppress "printing" Dialogue

  1. #1
    Board Regular
    Join Date
    Aug 2019
    Posts
    76
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Microsoft Print to PDF Suppress "printing" Dialogue

    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-...nting-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:
    Option Explicit
    
    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
    '// The SendMessage function sends the specified message to a window or windows.
    '// The function calls the window procedure for the specified window and does not
    '// return until the window procedure has processed the message.
    '// The PostMessage function, in contrast, posts a message to a thread’s message
    '// queue and returns immediately.
    '//
    '// PARAMETERS:
    '//
    '// hwnd
    '// Identifies the window whose window procedure will receive the message.
    '// If this parameter is HWND_BROADCAST, the message is sent to all top-level
    '// windows in the system, including disabled or invisible unowned windows,
    '// overlapped windows, and pop-up windows; but the message is not sent to child windows.
    
    '// Msg
    '// Specifies the message to be sent.
    
    '// wParam
    '// Specifies additional message-specific information.
    
    '// lParam
    '// Specifies additional message-specific information.
    
    '//////////////////////////////////////////////////////////////////////////
    '// The IsWindow function determines whether the specified window handle
    '// identifies an existing window.
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    '// PARAMETERS:
    '// hWnd
    '// Specifies the window handle.
    
    '//////////////////////////////////////////////////////////////////////////
    '//
    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
    
    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()
    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()
    fncScreenUpdating State:=False
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    fncScreenUpdating State:=True
    End Sub
    '-----------------------------
    Last edited by Davavo; Sep 23rd, 2019 at 10:48 AM.

  2. #2
    Board Regular gallen's Avatar
    Join Date
    Jun 2011
    Location
    Manchester UK
    Posts
    1,902
    Post Thanks / Like
    Mentioned
    21 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Microsoft Print to PDF Suppress "printing" Dialogue

    does this not suppress your messages?
    Code:
    Application.DisplayAlerts = False

    - forum use guidelines, forum rules and terms of use

    - Try searching for your answer first, see how

    - Read the FAQs

    - List of BB codes


  3. #3
    Board Regular
    Join Date
    Aug 2019
    Posts
    76
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Microsoft Print to PDF Suppress "printing" Dialogue

    Quote Originally Posted by gallen View Post
    does this not suppress your messages?
    Code:
    Application.DisplayAlerts = False
    hi, thanks for your suggestion.

    No, it has no effect.
    I should have added that to the post.

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

    Default Re: Microsoft Print to PDF Suppress "printing" Dialogue

    Do you have Office 32bit or 64bit ?
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


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

  5. #5
    Board Regular
    Join Date
    Aug 2019
    Posts
    76
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Microsoft Print to PDF Suppress "printing" Dialogue

    Quote Originally Posted by Jaafar Tribak View Post
    Do you have Office 32bit or 64bit ?
    Hi, thank you for your response.

    i am using 64bit.

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

    Default Re: Microsoft Print to PDF Suppress "printing" Dialogue

    The code in the link you posted suppresses the redrawing of the whole computer screen plus it lacks error handling so it causes the screen to freeze .

    An alternative method would be to set a temporary windows cbt hook and remove it when the printing is completed as follows :


    1- In a Standard Module:
    Code:
    Option Explicit
    
    #If  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 hCBTHook As LongPtr
    
    #Else 
        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 hCBTHook As Long
    
    #End  If
    
    
    
    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
    
    
    #If  VBA7 Then
        Private Function CBTProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    #Else 
        Private Function CBTProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    #End  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

    2- Code Usage : (change spdfPath as required)
    Code:
    Sub Test()
    
        Dim sPrinter As String, spdfPath As String
        
        sPrinter = "Microsoft Print to PDF"
        spdfPath = ThisWorkbook.Path & "\Test.pdf"  '<== change path as rquired.    
        
        On Error GoTo errHandler
        
        SuppressPrintingDlg = True
            
            ActiveWindow.SelectedSheets.PrintOut , , 1, , ActivePrinter:=sPrinter, _
            Printtofile:=False, Collate:=True, PrToFileName:=spdfPath, Ignoreprintareas:=False
            
        SuppressPrintingDlg = False    
        
    errHandler:
            If Err.Number = 0 Then
                Debug.Print "done Printing."
            Else
                SuppressPrintingDlg = False
                MsgBox hCBTHook & vbTab & "Runtime Error " & Err.Number & " !" & _
                vbNewLine & vbNewLine & Err.Description
            End If
        
    End Sub

    Note that is will only suppres the "printing" popup window but the code will still tie the application UI until the printing is completed... An alternative to prevent locking the UI while printing is by printing from a seperate excel instance created on the fly.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


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

  7. #7
    Board Regular
    Join Date
    Aug 2019
    Posts
    76
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Microsoft Print to PDF Suppress "printing" Dialogue

    wow, thanks for this!

    I am sorry i didn't reply sooner, I have been away and apparently not getting notifications from this thread.
    I will try and implement this now.
    Last edited by Davavo; Sep 28th, 2019 at 10:00 AM.

  8. #8
    Board Regular
    Join Date
    Aug 2019
    Posts
    76
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Microsoft Print to PDF Suppress "printing" Dialogue

    Quote Originally Posted by Jaafar Tribak View Post
    The code in the link you posted suppresses the redrawing of the whole computer screen plus it lacks error handling so it causes the screen to freeze .

    An alternative method would be to set a temporary windows cbt hook and remove it when the printing is completed as follows :


    1- In a Standard Module:
    Code:
    Option Explicit
    
    #If  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 hCBTHook As LongPtr
    
    #Else 
        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 hCBTHook As Long
    
    #End  If
    
    
    
    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
    
    
    #If  VBA7 Then
        Private Function CBTProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    #Else 
        Private Function CBTProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    #End  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

    2- Code Usage : (change spdfPath as required)
    Code:
    Sub Test()
    
        Dim sPrinter As String, spdfPath As String
        
        sPrinter = "Microsoft Print to PDF"
        spdfPath = ThisWorkbook.Path & "\Test.pdf"  '<== change path as rquired.    
        
        On Error GoTo errHandler
        
        SuppressPrintingDlg = True
            
            ActiveWindow.SelectedSheets.PrintOut , , 1, , ActivePrinter:=sPrinter, _
            Printtofile:=False, Collate:=True, PrToFileName:=spdfPath, Ignoreprintareas:=False
            
        SuppressPrintingDlg = False    
        
    errHandler:
            If Err.Number = 0 Then
                Debug.Print "done Printing."
            Else
                SuppressPrintingDlg = False
                MsgBox hCBTHook & vbTab & "Runtime Error " & Err.Number & " !" & _
                vbNewLine & vbNewLine & Err.Description
            End If
        
    End Sub

    Note that is will only suppress the "printing" popup window but the code will still tie the application UI until the printing is completed... An alternative to prevent locking the UI while printing is by printing from a separate excel instance created on the fly.
    Thanks again for this, it works at suppressing the 'now printing' pop up box. But unfortunately it doesn't stop the screen jumping back and forth.
    Do you know how to stop this? The macro takes a couple of minutes to work through 60 odd entries. It copies all of the entries form one table to another, then it looks at column A, reads the hyperlink path, opens the linked file, creates and saves the pdf, changes the hyperlink to the pdf path, then moves the original file to another directory.

    While it is doing this, I would like to stop the flicking back and forth from the table sheet to whatever the blank screen is that pops up with the printing dialog (now suppressed).
    Is there a message box that would act as a placeholder, "Please wait, now printing" sort of thing, tat would stop the screen jumping but allow the macro to run in the background ?

    Thanks for any help. Really appreciated!

    Code:
    Option Explicit
    
    Sub ArchiveEXP()
    
    
    'define variables ----------------------------------------------------------------------------------------------------------------------------------------------------------
    
    
    Dim wb As Workbook
    Dim SWS As Worksheet
    Dim TWS As Worksheet
    Dim LTM As Worksheet
    Dim TExpArchive As TableObject
    Dim TExpenses As TableObject
    
    
    
    
    Dim NowUsedRows As Long
    Dim UsedRows As Long
    Dim i As Long
    
    
    Dim SWB As Workbook
    Dim Summary As Worksheet
    Dim Detail As Worksheet
    
    
    Dim strPName As String 'active printer name
    
    
    Dim pdfpath As String 'the path that the pdf will be saved to
    
    
    Dim hFullPath As String 'the full path of the hyperlink on the expenses sheet record
    Dim hFullFileName As String 'the full file name of same
    Dim hFileName As String 'the full file name minus the extension
    
    
    Dim TargetDir As String
    Dim SourceDir As String
    
    
    Dim ExpBinDir As String
    Dim CCBinDir As String
    Dim INVBinDir As String
    Dim NewExpBinDir As String
    Dim NewCCBinDir As String
    Dim NewINVBinDir As String
    
    
    Dim fso As Object
    
    
    Dim myPDfArchiveDir As String
    Dim myArchiveDir As String
    Dim myExpPath As String
    
    
    
    
    
    
    'set worksheets ------------------------------------------------------------------------------------------------------------------------------------------------------------
    
    
    Set wb = ThisWorkbook
    Set SWS = wb.Sheets("Expenses")
    Set TWS = wb.Sheets("Expenses Archive")
    Set LTM = wb.Sheets("LTM")
    
    
    
    
    'turn off hogs -------------------------------------------------------------------------------------------------------------------------------------------------------------
    
    
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    
    '-------------------------------------------------------------------------------
    
    
    If wb.Sheets("LTM").Range("C3") = "" Then
    msgbox "Archive Not Selected. Please go to 'Settings' and choose a folder"
    Sheets("Dashboard").Select
    
    
    
    
    GoTo ResetSettings        'exit the sub
    
    
    End If
    
    
    If wb.Sheets("LTM").Range("C4") = "" Then
    msgbox "Archive Not Selected. Please go to 'Settings' and choose a folder"
    Sheets("Dashboard").Select
    GoTo ResetSettings        'exit the sub
    
    
    End If
    
    
    myPDfArchiveDir = wb.Sheets("LTM").Range("C3")
    myArchiveDir = wb.Sheets("LTM").Range("C4")
    myExpPath = wb.Sheets("LTM").Range("C5")
    
    
    
    
    'create a directory for this type of record.  Each type of record (CCCard, Invoice, Expense claim) should have its own directory -------------------------------------------
    
    
    'BinDir = myArchiveDir & Format(Now, "yyyy-mm-dd h-mm-ss")
    
    
    '---------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    
    
    ExpBinDir = myArchiveDir & "\UsedExpenses\"
    Call Backup_Folder2(ExpBinDir, CreateObject("scripting.filesystemobject"))
    
    
    CCBinDir = myArchiveDir & "\UsedCCRecords\"
    Call Backup_Folder2(CCBinDir, CreateObject("scripting.filesystemobject"))
    
    
    INVBinDir = myArchiveDir & "\UsedInvoices\"
    Call Backup_Folder2(INVBinDir, CreateObject("scripting.filesystemobject"))
    
    
    NewExpBinDir = ExpBinDir & "\" & Format(Now, "yyyy-mm-dd h-mm-ss")
    Call Backup_Folder2(NewExpBinDir, CreateObject("scripting.filesystemobject"))
    
    
    NewCCBinDir = CCBinDir & "\" & Format(Now, "yyyy-mm-dd h-mm-ss")
    Call Backup_Folder2(NewCCBinDir, CreateObject("scripting.filesystemobject"))
    
    
    NewINVBinDir = INVBinDir & "\" & Format(Now, "yyyy-mm-dd h-mm-ss")
    Call Backup_Folder2(NewINVBinDir, CreateObject("scripting.filesystemobject"))
    
    
    
    
    '------------------------------------------------------------------------------------------------------------------------------------------------------------------
    
    
    'Force User Confirmation ---------------------------------------------------------------------------------------------------------------------------------------------------
    
    
    
    
    Dim Result As Variant
    Result = msgbox("This Process Cannot be Undone!" & Chr(13) & Chr(13) & "Are you sure you want to archive these records?", vbOKCancel + vbExclamation, "WARNING")
      
        If Result = vbCancel Then
    
    
            msgbox "Cancelled!"
    
    
        GoTo ResetSettings      'exit the sub
    
    
        Else
    
    
        End If
    
    
    Sheets("Expenses").Activate
    
    
    
    
        If Sheets("Expenses").FilterMode Then
        
            Dim Result2 As Variant
            
            Result2 = msgbox("List is filtered" & Chr(13) & Chr(13) & "Pressing 'OK' will archive both visible and hidden rows" & Chr(13) & Chr(13) & "Do you want to continue", vbCritical + vbOKCancel)
            
            If Result2 = vbOK Then
                
                Sheets("Expenses").ShowAllData
                    
                Else
                
                Sheets("Expenses").Activate
                
                Exit Sub
                
            End If
        End If
    
    
    
    
    msgbox "Please wait while files are archived, this may take a few moments"
    
    
    'remove protection
    wb.Sheets("Expenses Archive").Unprotect Password:="Dave"
    wb.Sheets("Expenses").Unprotect Password:="Dave"
    
    
    
    
    'remove filters and totals
        
    If Sheets("Expenses").FilterMode Then Sheets("Expenses").ShowAllData
    If Sheets("Expenses Archive").FilterMode Then Sheets("Expenses Archive").ShowAllData
    
    
    With TWS.ListObjects("TExpArchive")
                   .ShowTotals = False
    End With
    
    
    With SWS.ListObjects("TExpenses")
                   .ShowTotals = False
    End With
    
    
    
    
        
    '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
    
    
    i = UsedRows
    
    
    'Call Backup_Folder2(SourceDir, CreateObject("scripting.filesystemobject"))
    
    
    
    
    Application.ScreenUpdating = False
    
    
    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, but we only want to save one
            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
        
            'MsgBox "hFullPath = " & hFullPath
            'MsgBox "hFullFileName = " & hFullFileName
            'MsgBox "hFileName = " & hFileName
        
        
        'For i = 2 To NowUsedRows '------------------------------------------------------------------------------------------------------------------------start for loop
        'TWS.Range("A" & i) = myPDFArchiveDir & hFileName & ".pdf"
        'Next i
        '------------------------------------------------------------------------------------------------------------------------------------------------end for loop
        
        
        Set SWB = Workbooks.Open(hFullPath)
                  
            With SWB
                      
                    'do the pdfs -----------------------------------------------------------------------------------------------------------------------------------------------------------
                      
                    pdfpath = myPDfArchiveDir & hFileName & ".pdf"
                     
                    Sheets("Summary").Select
                    Sheets("Summary").Unprotect Password:="Dave"
                    Sheets("Summary").Range("K10") = pdfpath                    'write the filename to a cell, for visual reference from hardcopy.
                    Sheets("Summary").Protect Password:="Dave"
                  
                    strPName = Application.ActivePrinter                        'this records the current printer so that the setting csan be returned to previous after exporting the file to pdf
                  
                    Sheets(Array("Summary", "Detail")).Select
                    
                    'expression.PrintOut (From, To, Copies, Preview, ActivePrinter, PrintToFile, Collate, PrToFileName, IgnorePrintAreas)
                    'printtofile true/false doesnt seem to have any effect.  Time will tell so be aware this setting may be incorrect.
                    'The activeprinter should be set to whatever your system calls the pdf printer, i dont know if it is standard.  I will include a little script for finding out.
                    
                    'ActiveWindow.SelectedSheets.PrintOut , , 1, , ActivePrinter:="Microsoft Print to PDF", Printtofile:=False, Collate:=True, PrToFileName:=pdfPath, Ignoreprintareas:=False
                  
                  
                  Call TestSuppress(pdfpath)
                  
                    Application.ActivePrinter = strPName                        'returns the printere settings to whatever they were prior to running the script.
                                                                                'handy if you dont want irrate collegues
                
                    SWB.Close SaveChanges:=False                        'this is important if you dont want multiple instances of excel running and issues with the VBA editor
                    Set SWB = Nothing                                   'i dont know why this happens but it seems to be a fairly commomn issue.  This methoid of closing seems to work.
                
                
                'Name TWS.Range("A" & i).Hyperlinks(1).Address As StrFile
            
                'Now Move the excel file and change the hyperlink -----------------------------------------------------------------------------------------------------------------------------------------------------------------------
            
            
                Dim istring As String
               
                'If TWS.Cells(i, 2) <> "" And TWS.Cells(i, 1) = "" Then
                istring = i - 1
                
                
                Name hFullPath As NewExpBinDir & "\" & hFileName & ".xlsx"
                
         
                '--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
            End With
        
    
    
          End If
    End If
        
    Skip:
    
    
    Loop
    
    
    Application.DisplayAlerts = True
    
    
    Call changehyperlink(UsedRows)
    
    
    Call NewTableTExpenses
    
    
    Call fitwidthEXPArch
    
    
        wb.Sheets("Expenses Archive").Unprotect Password:="Dave"
        Rows(1).RowHeight = 30
    
    
    'get the subtotals
    
    
    With Sheets("Expenses Archive").ListObjects("TExpArchive") '---------------------------------------------------start With
                   
                   .ShowTotals = True
                   .ListColumns("Miles").TotalsCalculation = xlTotalsCalculationSum
                   .ListColumns("Mode").TotalsCalculation = xlTotalsCalculationSum
                   .ListColumns("Other Expenses").TotalsCalculation = xlTotalsCalculationSum
                   .ListColumns("Subsistance").TotalsCalculation = xlTotalsCalculationSum
                   .ListColumns("Financial Loss").TotalsCalculation = xlTotalsCalculationSum
                   .ListColumns("Meals").TotalsCalculation = xlTotalsCalculationSum
                   .ListColumns("Accom").TotalsCalculation = xlTotalsCalculationSum
                   
                   .ListColumns("Task Number").TotalsCalculation = xlTotalsCalculationNone
                   
    End With '--------------------------------------------------------------------------------------------end with
    
    
    With ThisWorkbook.Sheets("Expenses Archive")
    Range("B2").Select
    End With
    
    
      
      'End All IMPORTs with this
      '-----------------------
      
      
    'Message Box when tasks are completed
    msgbox "The Record has been updated and your files have been archived!", vbOKOnly + vbInformation, ""
    
    
    '-------------------------------------------------------------------------------------------------------------------------------------------------------------
    
    
    ResetSettings:
      'Reset Hogs
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    
    
    'Reprotect
        With wb.Sheets("Expenses")
        .Protect Password:="Dave", AllowFiltering:=True
        .EnableSelection = xlUnlockedCells
        .EnableSelection = xlNoRestrictions
        End With
            
        With wb.Sheets("Expenses Archive")
        .Protect Password:="Dave", AllowFiltering:=True
        .EnableSelection = xlUnlockedCells
        .EnableSelection = xlNoRestrictions
        End With
    
    
    Application.CutCopyMode = False
    
    
    Sheets("Expenses").Activate
    Sheets("Expenses Archive").Activate
    End Sub

    Code:
    Sub changehyperlink(UsedRows As Long)    
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim NowUsedRows As Long
        Dim i As Long
        
        Dim myPDfArchiveDir As String
        Dim hFullPath As String
        Dim hFullFileName As String
        Dim hFileName As String
        Dim istring As String
        Dim istring2 As String
        
        Set wb = ThisWorkbook
        Set ws = wb.Sheets("Expenses Archive")
        
        myPDfArchiveDir = wb.Sheets("LTM").Range("C3")
        
        NowUsedRows = ws.Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row
        
        Call killfilterEXPArch
        
        For i = UsedRows + 1 To NowUsedRows '-----------------------------------------------------------------------------------------------------------------Start For Loop
            
            UsedRows = UsedRows + 1
            
            If UsedRows < 3 Then
            istring = 1
            Else
            
            istring = ws.Range("A" & UsedRows).Offset(-1, 0) + 1
           
            hFullPath = ws.Range("A" & UsedRows).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
            
            ws.Hyperlinks.Add ws.Range("A" & UsedRows), Address:="file:///" & myPDfArchiveDir & hFileName & ".pdf", TextToDisplay:=istring
            ws.Range("A" & UsedRows) = ws.Range("A" & UsedRows).Offset(-1, 0) + 1
            
            End If
        Next i '------------------------------------------------------------------------------------------------------------------------------------------End For Loop
    
    
    End Sub

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

    Default Re: Microsoft Print to PDF Suppress "printing" Dialogue

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

    Common sense is not so common.


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

  10. #10
    Board Regular
    Join Date
    Aug 2019
    Posts
    76
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Microsoft Print to PDF Suppress "printing" Dialogue

    Quote Originally Posted by Jaafar Tribak View Post
    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.
    Hi, sorry for the messy code. This is literally the first thing i have ever coded, (My "Hello World"), and this archive sub is just a part of it. I have been picking up best practice as I go but i realise it is a bit Frankensteinian. It has been a bit of a struggle to be honest.

    I have tried whacking in

    Code:
    Application.ScreenUpdating = FalseApplication.EnableEvents = False
    Application.Calculation = xlCalculationManual
    directly before the loop that does the pdfs but it has no effect. ALso just tried putting it into the code you gave me so that it turns everything off on each loop. But it still flip flaps back and forth. Really rubbish looking.

    How do I go about the drastic measure of turn off the desktop drawing via the Windows API ? Is it dangerous or something?

Some videos you may like

User Tag List

Tags for this Thread

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
  •