限制由for循环调用的可执行文件的实例数
我有一个程序，导出文本文件，然后由可执行文件运行模拟，每个通常需要5到10分钟。
我已经创build了一个for循环运行这个过程For Each文本文件。 我最初编写了一个单独的可执行文件的代码，VBAmacros将调用这个代码，并且这将运行每个模拟系列。 我希望能够同时运行更多，所以我直接将macros传送给VBA，但这会导致每个模拟同时运行，并使处理器陷入瘫痪。
有没有办法允许有限次数的模拟运行？
编辑：对不起，我用手机写了这个，因为我的电脑当时陷入了这个确切的问题。 这是代码。 我有一个运行一个模拟的function，将所需的exe文件（每个模拟文件都相同）和input.txt文件移动到它自己的子文件夹中，第二个函数在列表框select上循环运行第一个函数：
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
编辑：最近实现了这个循环。 想知道不断循环的效率（或缺乏），直到处理器数量下降得足够低。
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
编辑 ：好的，这里是一个你想要做的事情的testing实现。 我正在使用一个简单的VBScript模拟你的EXE（所以我正在监视“WINSCRIPT”）
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
难道答案就像在你的循环中等待一定的时间一样简单。 这可以在一定程度上控制进程的数量。 这会踢一个，等五分钟，踢下一个，等五分钟，踢下一个等。
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
如果这还不够好，我有一些可以使用的VBA函数。
'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
只要提供proc名称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
你可能想要这个。 它会返回find该进程的时间。 如果它比你想运行更多。 不要开始另一个。
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
像这样的东西
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