I have seen many instances, where a user will want to Shell out to an application, do some things and then proceed with there routine, once the shelled Application has finished.
What you have found is that the Shell function runs other programs asynchronously ie. your routine continues to run after the Shell call. This may be ok unless your routine needs to get data from the resultant shelled application which may NOT have completed it's task. If so then you need to know when the shelled routine has finished & terminated it's process.
There are a few routines that accomplish this, but the following 2 routines I believe are a little more robust.
as I have found that some process code constants are different. The following codes should ?
take care of this. (Tested Win98, XP)
The 1st routine will (as an example - so substitute your Application);
i) Shells out to the Applet = Calculator (As everyone who runs Windows should have this)
ii) Allows you to work with the calculator THEN
iii) When you have closed this down, continues with the Macro.
Just substitute you Application requirements here, but the basics remain the same......
See notes in the code:
The 2nd routine will (as an example - so substitute your Application);
i) Shells out to the Batch process.
ii) Your procedure waits for the Application to finish processing
iii) When the Application has signal an end to it's processing, continues with the Macro.
Just substitute you Application requirements here, but the basics remain the same......
See notes in the code:
A practical application of the Above ? Have a look @ ZipBook and Email it.
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" ( _
ByVal lnghProcess As Long, _
lpExitCode As Long) As Long
'// If your going to be working with Systems that support security
'// settings eg NT, XP the access will be checked against any
'// security descriptor for the target process, so use this Const
'// Sets all possible access flags for the process object.
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Public Function ShlProc_IsRunning(ShellReturnValue As Long) As Boolean
Dim lnghProcess As Long
Dim lExitCode As Long
Dim lRet As Long
'//Get the process handle
lnghProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, ShellReturnValue)
If lnghProcess <> 0 Then
'// The GetExitCodeProcess function retrieves the
'// termination status of the specified process.
GetExitCodeProcess lnghProcess, lExitCode
If lExitCode <> 0 Then
'// Process still ALIVE!
ShlProc_IsRunning = True
Else
'// YES...finished @ last
ShlProc_IsRunning = False
End If
End If
End Function
Sub ShellTester()
Dim RetVal As Long
'//
'// When you Shell out to an Application the Return Value
'// is the Applications Task ID
'// in order to determine if it has Terminated we need to check
'// if there is an existing process object
'// > OpenProcess function opens an existing process object.
'//
On Error Resume Next
'// On WinXP Calc.exe @ C:\WINDOWS\System32\
'// On Win9x Calc.exe @ C:\WINDOWS\
RetVal = Shell("C:\WINDOWS\System32\CALC.EXE", 1)
On Error GoTo 0
If RetVal = 0 Then MsgBox "NoGo!" & vbCr & "Check your Path": End
'// Ok, lets loop until the App process is terminated!
Do While ShlProc_IsRunning(RetVal) = True
DoEvents
Loop
MsgBox "Program finished!" & vbCr & "Lets continue on now!"
End Sub
Option Explicit
'//The Shell function runs other programs asynchronously so what
'//What you basically have to do is Open the existing Process
'//for the running Application and, LOOP & WAIT for the processes return state
'//ie when the specified process is in the signaled state
'//or a timeout occurs.
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" ( _
ByVal hProcess As Long, _
lpExitCode As Long) As Long
'&HFFFF
Private Const SYNCHRONIZE = &H100000
'// Note:SYNCHRONIZE Windows NT/2000
Private Const INFINITE = &HFFFF 'OR -1&
'// INFINITE, the function’s time-out interval never elapses.
Private Const STILL_ACTIVE = &H103
Public Function ShellAndWait(ByVal BatFile As String)
'
' Shells a new process and waits for it to complete.
' Calling application is totally non-responsive while
' new process executes.
'
Dim PID As Long
Dim hProcess As Long
Dim nRet As Long
'// Unlike other Functions Shell generates an error
'// instead of returning a 0 so handling the error
'// = Application NOT started.
On Error Resume Next
PID = Shell(BatFile, vbMinimizedNoFocus)
If Err Then
'// handle the error here and End
MsgBox "Could NOT exercute:= " & BatFile
End
End If
On Error GoTo 0
'// SYNCHRONIZE For Windows NT/2000:
'// Enables using the process handle in any of the wait
'// functions to wait for the process to terminate.
'// obviously with NT you need access rights.
hProcess = OpenProcess(SYNCHRONIZE, False, PID)
'// Just set the dwMilliseconds to INFINITE to initiate a Loop
nRet = WaitForSingleObject(hProcess, INFINITE)
Do
GetExitCodeProcess hProcess, nRet
DoEvents
Loop While nRet = STILL_ACTIVE
CloseHandle hProcess
End Function
Sub OpenFileAndWait()
Dim sApp As String
'// Define the Application FullPath here
sApp = "C:\A\Batch.bat"
'sApp = "C:\windows\system32\calc.exe"
'// Lets DoIt
ShellAndWait sApp
'// Tell me if Successful
MsgBox "Finished running task!"
End Sub
Fonts:
A simple routine to get Excels Font list. Lists to Column A start @ A2. The basics of this you could use in a routine for listing and displaying Fonts ( See here for a comprehensive listing )
Getting the font list was noted when playing around with the FindControl method for commandbars, of which I will show some routines latter.
Option Explicit
Sub GetFonts()
Dim Fonts
Dim x As Integer
x = 1
Set Fonts = Application.CommandBars.FindControl(ID:=1728)
On Error Resume Next
Do
Cells(x + 1, 1) = Fonts.List(x)
If Err Then Exit Do
x = x + 1
Loop
On Error GoTo 0
Range("A1").FormulaR1C1 = "=""Font List = "" & COUNTA(R[1]C:R[" & x - 1 & "]C)"
With Range("A1")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Name = "Arial"
.Font.FontStyle = "Bold"
.Font.Size = 10
.Font.ColorIndex = 5
.Interior.ColorIndex = 15
End With
Columns("A:A").EntireColumn.AutoFit
Set Fonts = Nothing
End Sub
Option Explicit
Dim Aantal As Single, Aantal2 As Single
Dim i As Single, x As Integer
Dim FontList
Dim ActSht As String
Dim OldStBar As Boolean
Sub ListFonts()
'//////////////////////////////
'// //
'// Modified by Ivan F Moala //
'// 15th June 2002 //
'// //
'//////////////////////////////
With Application
.DisplayStatusBar = True
.ScreenUpdating = False
End With
On Error GoTo WhatHappened
Set FontList = Application.CommandBars.FindControl(ID:=1728)
For x = 1 To FontList.ListCount
Application.StatusBar = "Adding " & x & " of " & _
FontList.ListCount & _
" FontName:= " & FontList.List(x)
Sheets.Add After:=Worksheets(Sheets.Count)
ActiveSheet.Name = FontList.List(x)
With ActiveWindow
.DisplayGridlines = False
.Zoom = 78
End With
'------------------------------------------------------------------
' Generate Actual Fontdisplay
'------------------------------------------------------------------
Aantal = 46
Aantal2 = 1
Range("C4").Select
For i = 33 To 255
FormatCells FontList.List(x), 20, 5
If i = Aantal Then
Range("A7").Select
ActiveCell.Offset(Aantal2, 0).Activate
Aantal = Aantal + 15
Aantal2 = Aantal2 + 4
FormatCells FontList.List(x), 20, 5
End If
ActiveCell.Value = " " + Chr(i) + " "
ActiveCell.Offset(0, 1).Activate
Next i
'------------------------------------------------------------------
' Generate ARIAL Fontdisplay
'------------------------------------------------------------------
Aantal = 46
Aantal2 = 1
Range("C5").Select
For i = 33 To 255
FormatCells "Arial", 10, 0
If i = Aantal Then
Range("A8").Select
ActiveCell.Offset(Aantal2, 0).Activate
Aantal = Aantal + 15
Aantal2 = Aantal2 + 4
FormatCells "Arial", 10, 0
End If
ActiveCell.Value = " " + Chr(i) + " "
ActiveCell.Offset(0, 1).Activate
Next i
'------------------------------------------------------------------
' Generate Number Fontdisplay
'------------------------------------------------------------------
Aantal = 46
Aantal2 = 1
Range("C6").Select
For i = 33 To 255
FormatCells "Arial", 8, 0
If i = Aantal Then
Range("A9").Select
ActiveCell.Offset(Aantal2, 0).Activate
Aantal = Aantal + 15
Aantal2 = Aantal2 + 4
FormatCells "Arial", 10, 0
End If
ActiveCell.Value = i
ActiveCell.Offset(0, 1).Activate
Next i
[A1].Select
[A2] = FontList.List(x)
Next
With Sheets(ActSht)
.Select
.Name = "TOC"
End With
With Application
.StatusBar = False
.DisplayStatusBar = OldStBar
.ScreenUpdating = True
End With
End Sub
Sub FormatCells(sFnt As String, Sz As Double, iC As Double)
With Selection
.Font.Name = sFnt
.Font.ColorIndex = iC
.Font.Size = Sz
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.CurrentRegion.Borders.LineStyle = xlContinuous
End With
End Sub
Sub Add_TableOfContents()
Dim x As Double
For x = 1 To ActiveWorkbook.Sheets.Count
If Sheets(x).Name <> ActiveSheet.Name Then
ActiveSheet.Hyperlinks.Add Anchor:=Cells(x + 2, 1), _
Address:="", _
SubAddress:="'" & Sheets(x).Name & "'!A2"
End If
Next x
Look up [Shell Function] in the VBA Editor for more help, but basically the Shell command is used to start your executable and will open a window unless you specify otherwise ie Show minimized, Maximized etc. For more helpful links see here;
Environmental Variables, Show [About] form, GetColumn Letter,Processor speed, Computer info,
