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...
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...
Code:
'-------------------------------------------------------
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