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:

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
Sort by date Sort by votes
does this not suppress your messages?
Code: 
Application.DisplayAlerts = False
 
Upvote 0
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

[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 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 hCBTHook As Long

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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


[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


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"  [COLOR=#008000]'<== change path as rquired.[/COLOR]    
    
    On Error GoTo errHandler
    
    [COLOR=#ff0000][B]SuppressPrintingDlg = True[/B][/COLOR]
        
        ActiveWindow.SelectedSheets.PrintOut , , 1, , ActivePrinter:=sPrinter, _
        Printtofile:=False, Collate:=True, PrToFileName:=spdfPath, Ignoreprintareas:=False
        
    [B][COLOR=#ff0000]SuppressPrintingDlg = False[/COLOR][/B]    
    
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.
 
Upvote 0
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:
Upvote 0
Jaafar Tribak said:
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

[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 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 hCBTHook As Long

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  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


[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


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"  [COLOR=#008000]'<== change path as rquired.[/COLOR]    
    
    On Error GoTo errHandler
    
    [COLOR=#ff0000][B]SuppressPrintingDlg = True[/B][/COLOR]
        
        ActiveWindow.SelectedSheets.PrintOut , , 1, , ActivePrinter:=sPrinter, _
        Printtofile:=False, Collate:=True, PrToFileName:=spdfPath, Ignoreprintareas:=False
        
    [B][COLOR=#ff0000]SuppressPrintingDlg = False[/COLOR][/B]    
    
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.
Click to expand...

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
 
Upvote 0
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.
 
Upvote 0
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...

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?
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
What is wrong with this VBA code: userForm get hand ico for pointer on hover
2
Replies
15
Views
502
RoryA
RoryA
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
278
huiettcm
H
A
  • Question
Ask VBA how to Print separate PDF
Replies
6
Views
652
ceranes
C
kelly mort
  • Solved
VBA Code to close an opened pdf amendment needed
2
Replies
11
Views
2K
mugginsjr
M
N
  • Solved
VBA Excel opens Word - Split Screen to Windows Planes
Replies
5
Views
637
NdNoviceHlp
NdNoviceHlp

Forum statistics

Threads
1,214,646
Messages
6,120,715
Members
448,985
Latest member
chocbudda

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