Speeding up my macro

[Ed in Aus]

Hey can anyone help me speed up a macro... it is fairly large so any help will more than likeley speed it up, what it does is basically prints all documents that are listed in the Excel spreadsheet. There are a few different formats that it prints i.e. Excel, Word and PDF (it actually closes the instance of Adobe afterwards too).

I think the spot it may be sped up are with word maybe being open minimised or something but can't get it to work...

'-------------------------------------------------------
Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szexeFile As String * 260
End Type
'-------------------------------------------------------
Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, _
ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long

Declare Function ProcessFirst Lib "kernel32.dll" Alias "Process32First" (ByVal hSnapshot As Long, _
uProcess As PROCESSENTRY32) As Long

Declare Function ProcessNext Lib "kernel32.dll" Alias "Process32Next" (ByVal hSnapshot As Long, _
uProcess As PROCESSENTRY32) As Long

Declare Function CreateToolhelpSnapshot Lib "kernel32.dll" Alias "CreateToolhelp32Snapshot" ( _
ByVal lFlags As Long, lProcessID As Long) As Long

Declare Function TerminateProcess Lib "kernel32.dll" (ByVal ApphProcess As Long, _
ByVal uExitCode As Long) As Long

Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
'-------------------------------------------------------
Public Sub KillProcess(NameProcess As String)
Const PROCESS_ALL_ACCESS = &H1F0FFF
Const TH32CS_SNAPPROCESS As Long = 2&
Dim uProcess  As PROCESSENTRY32
Dim RProcessFound As Long
Dim hSnapshot As Long
Dim SzExename As String
Dim ExitCode As Long
Dim MyProcess As Long
Dim AppKill As Boolean
Dim AppCount As Integer
Dim i As Integer
Dim WinDirEnv As String
        
       If NameProcess <> "" Then
          AppCount = 0

          uProcess.dwSize = Len(uProcess)
          hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
          RProcessFound = ProcessFirst(hSnapshot, uProcess)
 
          Do
            i = InStr(1, uProcess.szexeFile, Chr(0))
            SzExename = LCase$(Left$(uProcess.szexeFile, i - 1))
            WinDirEnv = Environ("Windir") + "\"
            WinDirEnv = LCase$(WinDirEnv)
        
            If Right$(SzExename, Len(NameProcess)) = LCase$(NameProcess) Then
               AppCount = AppCount + 1
               MyProcess = OpenProcess(PROCESS_ALL_ACCESS, False, uProcess.th32ProcessID)
               AppKill = TerminateProcess(MyProcess, ExitCode)
               Call CloseHandle(MyProcess)
            End If
            RProcessFound = ProcessNext(hSnapshot, uProcess)
          Loop While RProcessFound
          Call CloseHandle(hSnapshot)
       End If

End Sub
Sub Print_out_induction()

Dim r, c As Long
r = 2
Application.StatusBar = True
Application.ScreenUpdating = False
ans2 = InputBox("Please select one of the following..." & vbNewLine & vbNewLine _
& "For ESC Employee enter   1" & vbNewLine _
& "For Eurocare enter           2" & vbNewLine _
& "For Shoalhaven enter       3" & vbNewLine _
& "For All other enter            4" & vbNewLine, _
"Enter which Timesheets")
If ans2 = "" Then Exit Sub

If ans2 = "1" Then
Workbooks.Open ("L:\Best Practice Manual\Procedure Documents\Induction\Employees\Form 13 - Council Timesheets.xls")
    ActiveWindow.SelectedSheets.PrintOut Copies:=5, Collate:=True
    ActiveWindow.Close
ElseIf ans2 = "2" Then
Workbooks.Open ("L:\Best Practice Manual\Procedure Documents\Induction\Employees\Form 13 - EuroCare Timesheet.xls")
    ActiveWindow.SelectedSheets.PrintOut Copies:=5, Collate:=True
    ActiveWindow.Close
ElseIf ans2 = "3" Then
Workbooks.Open ("L:\Best Practice Manual\Procedure Documents\Induction\Employees\Form 13 - Shoal Water Timesheet.xls")
    ActiveWindow.SelectedSheets.PrintOut Copies:=5, Collate:=True
    ActiveWindow.Close
ElseIf ans2 = "4" Then
nocopy = 1
Do Until nocopy = 6
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open("L:\Best Practice Manual\Procedure Documents\Induction\Employees\Form 13 - Timesheet.doc")
wrdDoc.PrintOut
wrdDoc.Close
wrdApp.Quit
nocopy = nocopy + 1
Loop
End If
ans3 = MsgBox("Do you need WWCC Forms?", vbYesNo, "WWCC Forms")

'set drive where files are stored
drive = "L:\Best Practice Manual\Procedure Documents\Induction\Employees\"

'checking which printing code we need
Do Until Cells(r + 1, 1) = ""

Cells(r, 1).Select
Application.StatusBar = "### Now Printing ###   " & ActiveCell.Value
If Right(Cells(r, 1), 4) = ".xls" Then GoTo verExcel
If Right(Cells(r, 1), 4) = ".doc" Then GoTo verWord
If Right(Cells(r, 1), 4) = ".pdf" Then GoTo PDF
If Right(Cells(r, 1), 4) = ".xps" Then GoTo XPS
If Right(Cells(r, 1), 4) = ".*" Then GoTo OTHER
'excel
verExcel:
    Workbooks.Open FileName:=drive & ActiveCell.Value
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    ActiveWindow.Close
GoTo Skippy

'word
verWord:
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open(drive & ActiveCell.Value)
wrdDoc.PrintOut
wrdDoc.Close
wrdApp.Quit
GoTo Skippy

'PDF
PDF:
If ans3 = vbNo Then
If ActiveCell.Value Like "*WWCC*" Then GoTo Skippy:
End If
Shell "U:\Program Files (x86)\Adobe\Reader 8.0\Reader\AcroRd32.exe /p /h " & Chr(34) & drive & ActiveCell.Value & Chr(34), vbNormalFocus
Call KillProcess("AcroRd32.exe")
GoTo Skippy:

'XPS Couldn't get this one to work (Citrix)
XPS:
MsgBox "You have to manually print the form " & ActiveCell, , "Manual Print"

GoTo Skippy: 'had this in here just in case more had to be added to the process

OTHER:
MsgBox "Unexpected file type of " & Right(ActiveCell, 4), , "Unexpected File Type"

Skippy:
r = r + 1
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "All paperwork has been printed!"
End Sub

 

[Ed in Aus]

Bump

 

[Jacophile]

Hi Ed.
Maybe some text to explain how the code works would be helpful.

 

[Ed in Aus]

This code basically loops through a main sheet that lists all the documents need to be printed out, everything works i just want to make it a bit faster... there seems to be a bit of a delay with some of the word docs but that could just be the network here at work.

There is a section for Word, Excel, PDF and other (which is basically an error handler)

Each section has its seperate way to print I think this is where I can save time the secitons that are specific to printing say the word and PDF documents

Do you need more details than that?

 

[sumcc]

Add the following at the beginning of your macro:

Application.Screenupdate=false

 

[Ed in Aus]

its there already...

sumcc Re: Speeding up my macro

--------------------------------------------------------------------------------
Add the following at the beginning of your macro:

Application.Screenupdate=false

 

[Ed in Aus]

bump

 

[thinksriniii]

Hi Ed,

I have used these to speed up my macro and it helped. May be you can try these.

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual 'Speed up Macro

and at the end of the macro

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.StatusBar = False
Application.Calculation = xlCalc

Cheers,
Dave