Limiting number of instances of executables called by a for loop - vba

Question

I have a program that exports text files which which are then used by an executable to run simulations which take generally 5 to 10 minutes each.
I have created a for loop which runs this process For Each text file. I originally wrote code for a separate executable, which the VBA macro would call, and this would run each simulation in series. I wanted to be able to run more in parallel, so I transferred the macro directly to VBA, but this causes every simulation to run simultaneously and brings the processor to a crawl.
Is there a way to allow for a limited number of simulations to run at one time?
EDIT: Sorry, I wrote this using a phone, because my computer was bogged down with this exact problem at the time. Here is the code. I have a function for running one simulation which moves the required exe (same for every simulation) and input.txt file into its own subfolder, and a second function which runs the first function on a loop over listbox selections:
Function RunSimulations() As Boolean
For k = 0 To myListBox.ListCount - 1
If myListBox.Selected(k) = True Then
SimulateOne(myListBox.List(k))
End If
End If
Next k
End Function
Function SimulateOne(inputFName As String) As Boolean
Dim currPath As String, inptPath As String, simsPath As String
Dim destPath As String, origFile As String, destFile As String
'Defines various folder paths
currPath = ThisWorkbook.Path & "\"
inptPath = currPath & INPUT_FOLDERNAME & "\"
simsPath = currPath & SIMS_FOLDERNAME & "\"
If Len(Dir(simsPath, vbDirectory)) = 0 Then MkDir simsPath
destPath = simsPath & Replace(inputFName, ".txt", "") & "\"
If Len(Dir(destPath, vbDirectory)) = 0 Then MkDir destPath
'Move input files from "input_files" to subfolders within "simulations"
origFile = inptPath & inputFName
destFile = destPath & INPUT_FILENAME 'Changes name to "INPUT.TXT"
If Len(Dir(destFile)) <> 0 Then SetAttr destFile, vbNormal: Kill destFile
If Len(Dir(origFile)) <> 0 Then
FileCopy origFile, destFile
Else
SimulateOne = False
Exit Function
End If
If Len(Dir(currPath & EXE_FILENAME)) <> 0 Then
'Moves exe files to new subfolder within "simulations"
FileCopy currPath & EXE_FILENAME, destPath & EXE_FILENAME
'Run exe
ChDrive Left(destPath, 1)
ChDir destPath
Shell (destPath & EXE_FILENAME)
SimulateOne = True
Else
SimulateOne = False
Exit Function
End If
End Function
EDIT: Implemented this loop recently. Wondering about the efficiency (or lack thereof) of the loop that goes constantly until the processor count drops low enough.
For k = 0 To myListBox.ListCount - 1
Do While ProcessRunningCount(EXE_FILENAME) >= processLimit
Application.Wait (Now + TimeValue("0:00:05"))
Loop
If myListBox.Selected(k) = True Then runResult = SimulateOne(myListBox.List(k))
Next k

Answer 1

EDIT: OK here is a tested implementation of the sort of thing you want to do. I'm using a simple vbscript to simulate your exe (so I'm monitoring "wscript.exe")
Dim colFiles As Collection 'has items to be processed
'sets up the items to be processed and kicks off the runs
Sub InitSimulations()
Dim x As Long, arr(1 To 20) As String
Set colFiles = New Collection
For x = 1 To 20
colFiles.Add "File_" & x
Next x
RunSimulations
End Sub
'Initially called by InitSimulations, then calls itself periodically
' to check whether a new run needs to be started
Sub RunSimulations()
Const MAX_PROCESSES As Long = 5
Dim sFile As String
'below our threshold?
If HowMany("wscript.exe") < MAX_PROCESSES Then
'any left to process?
If colFiles.Count > 0 Then
sFile = colFiles(1)
colFiles.Remove 1
SimulateOne sFile
Debug.Print Now, "Kicked off " & sFile
End If
End If
'Calls itself again in one second if any still remaining to process
' if your processes are long-running then can adjust for longer delay
If colFiles.Count > 0 Then
Application.OnTime Now + TimeSerial(0, 0, 1), "RunSimulations", , True
End If
End Sub
'Launch a simulation process
Sub SimulateOne(FileName)
Shell "wscript.exe ""C:\_Stuff\Test.vbs"""
'not doing anything with FileName...
'test vbs has one line: WScript.Sleep 10000
End Sub
'Count how many "procName" processes are running
Function HowMany(procName As String) As Long
Dim objWMIService, colProcess, processName
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colProcess = objWMIService.ExecQuery _
("Select * from Win32_Process where Name = '" & procName & "'")
HowMany = colProcess.Count
End Function

Answer 2

Could the answer be as simple as waiting a certain amount of time in your loop. That could control the number of processes to some degree. This will kick one off, wait five minutes, kick off the next, wait five minutes, kick off the next etc..
Function RunSimulations() As Boolean
For k = 0 To myListBox.ListCount - 1
If myListBox.Selected(k) = True Then
SimulateOne(myListBox.List(k))
Application.Wait (Now + TimeValue("0:05:00"))
End If
Next k
End Function
If that isn't good enough I have some VBA functions that can be used.
'API Calls - place these at the top of your code with your globals
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function EnumProcesses Lib "PSAPI.DLL" ( _
lpidProcess As Long, ByVal cb As Long, cbNeeded As Long) As Long
Private Declare Function EnumProcessModules Lib "PSAPI.DLL" ( _
ByVal hProcess As Long, lphModule As Long, ByVal cb As Long, lpcbNeeded As Long) As Long
Private Declare Function GetModuleBaseName Lib "PSAPI.DLL" Alias "GetModuleBaseNameA" ( _
ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_QUERY_INFORMATION = &H400
Just feed the proc name b = IsProcessRunning("ProcName.exe")
Private Function IsProcessRunning(ByVal sProcess As String) As Boolean
'Check to see if a process is currently running
Const MAX_PATH As Long = 260
Dim lProcesses() As Long
Dim lModules() As Long
Dim N As Long
Dim lRet As Long
Dim hProcess As Long
Dim sName As String
sProcess = UCase$(sProcess)
ReDim lProcesses(1023) As Long
If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
For N = 0 To (lRet \ 4) - 1
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
If hProcess Then
ReDim lModules(1023)
If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
sName = String$(MAX_PATH, vbNullChar)
GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
sName = Left$(sName, InStr(sName, vbNullChar) - 1)
If sProcess = UCase$(sName) Then
IsProcessRunning = True
Exit Function
End If
End If
End If
CloseHandle hProcess
Next N
End If
End Function
You probably want this one. It will return the number of time it finds the process. If it is more than you want running. Don't kick off another.
Private Function ProcessRunningCount(ByVal sProcess As String) As Long
'Check to see if how many occurences of a process are currently running
Const MAX_PATH As Long = 260
Dim lProcesses() As Long
Dim lModules() As Long
Dim N As Long
Dim lRet As Long
Dim hProcess As Long
Dim sName As String
Dim lCount As Long
sProcess = UCase$(sProcess)
ReDim lProcesses(1023) As Long
lCount = 0
If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
For N = 0 To (lRet \ 4) - 1
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
If hProcess Then
ReDim lModules(1023)
If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
sName = String$(MAX_PATH, vbNullChar)
GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
sName = Left$(sName, InStr(sName, vbNullChar) - 1)
If sProcess = UCase$(sName) Then
lCount = lCount + 1
End If
End If
End If
CloseHandle hProcess
Next N
End If
ProcessRunningCount = lCount
End Function
Something like this
Function RunSimulations() As Boolean
For k = 0 To myListBox.ListCount - 1
Do While ProcessRunningCount("chrome.exe") >= 5 'Enter you proc name here
Application.Wait (Now + TimeValue("0:00:10"))
Loop
If myListBox.Selected(k) = True Then
SimulateOne(myListBox.List(k))
End If
Next k
End Function