This arose out of the incident where it was realized that WMI could not be expected to be reliable across all various computers. The next thing I looked at was API which was positively awful to work with. Based on a suggestion, I decided to try and use tasklist. Note that efforts was made to ensure there are no disk I/Os, which avoids getting into the messy realms of file management. The only annoyance is that the WshExec will pop open a window but that can be managed and is beyond the scope of the question.
The question is - can we make the process more reliable and failsafe? The idea is that it must be consistent across several computer systems, Windows versions, and so on. This makes uses of Windows Host Scripting Model and ADODB recordset. The application already requires ADODB anyway and the code can be updated to be late-bound as well. For testing/development, I left this in early-bound state.
Public Function EnumProcesses() As ADODB.Recordset
Dim WshShell As IWshRuntimeLibrary.WshShell
Dim WshExec As IWshRuntimeLibrary.WshExec
Dim StdOut As IWshRuntimeLibrary.TextStream
Dim Data As ADODB.Recordset
Dim Output As String
Dim ColumnLengths() As Long
Set Data = New ADODB.Recordset
Data.Fields.Append "ImageName", adVarChar, 255
Data.Fields.Append "PID", adInteger, , adFldKeyColumn
Data.Open
Set WshShell = CreateObject("WScript.Shell")
Set WshExec = WshShell.Exec("tasklist")
Set StdOut = WshExec.StdOut
Do While WshExec.Status = WshRunning
If Not StdOut.AtEndOfStream Then
Output = StdOut.ReadLine
Select Case True
Case Len(Output) = 0, _
Output Like "Image Name*"
'Skip
Case Output Like "====*"
Dim SplitColumns As Variant
SplitColumns = Split(Output, " ")
ReDim ColumnLengths(UBound(SplitColumns))
Dim i As Long
For i = 0 To UBound(SplitColumns)
ColumnLengths(i) = Len(SplitColumns(i))
Next
Case Else
Data.AddNew
Data.Fields("ImageName").Value = Mid$(Output, 1, ColumnLengths(0))
Data.Fields("PID").Value = Trim$(Mid$(Output, ColumnLengths(0) + 2, ColumnLengths(1)))
Data.Update
End Select
End If
Loop
Set EnumProcesses = Data
End Function
1 Answer 1
Apart from a performance question regarding ADODB recordsets, I only made one real change to your code. Since there are several fields that are output by the tasklist utility, I would want to capture all of that data just in case I need to expand my database at a later time. So I created a class called OSTask which accepts a single line from the tasklist output and parses it into its component parameters. (This means I could also skip the case you have to calculate column widths.)
Class OSTask
Option Explicit
Private Type InternalData
ImageName As String
PID As Long
SessionName As String 'could also be an Enum: Console, Services
SessionNumber As Long
MemUsage As Long
End Type
Private this As InternalData
Public Property Get ImageName() As String
ImageName = this.ImageName
End Property
Public Property Get PID() As Long
PID = this.PID
End Property
Public Property Get SessionName() As String
SessionName = this.SessionName
End Property
Public Property Get SessionNumber() As Long
SessionNumber = this.SessionNumber
End Property
Public Property Get MemUsage() As Long
MemUsage = this.MemUsage
End Property
Public Sub Init(ByVal taskData As String)
'--- converts a single line output from the Windows command
' shell utility 'tasklist' and parses the data into the
' class properties
Dim pos1 As Long
Dim pos2 As Long
'--- find the end of the task name, looking for double-space
pos1 = InStr(1, taskData, " ", vbTextCompare)
this.ImageName = Trim$(Left$(taskData, pos1))
'--- the next value is a number followed by a single space
Dim i As Long
For i = pos1 To Len(taskData)
If Not Mid$(taskData, i, 1) = " " Then
pos2 = InStr(i, taskData, " ", vbTextCompare)
this.PID = CLng(Mid$(taskData, i, pos2 - i))
Exit For
End If
Next i
'--- next value is the session name
pos1 = pos2 + 1
pos2 = InStr(pos1, taskData, " ", vbTextCompare)
this.SessionName = Trim$(Mid$(taskData, pos1, pos2 - pos1))
'--- the next value is a number followed by a single space
For i = pos2 To Len(taskData)
If Not Mid$(taskData, i, 1) = " " Then
pos2 = InStr(i, taskData, " ", vbTextCompare)
this.SessionNumber = CLng(Mid$(taskData, i, pos2 - i))
Exit For
End If
Next i
'--- next value is the memory usage, a large number in thousands
pos1 = pos2
pos2 = InStr(pos1, taskData, "K", vbTextCompare)
Dim memUsageText As String
memUsageText = Mid$(taskData, pos1, pos2 - pos1)
memUsageText = Replace$(memUsageText, ",", vbNullString)
this.MemUsage = CLng(memUsageText) * 1000
End Sub
All of the properties are read-only in this case by design.
For my example, I converted your function to return a Collection rather than an ADODB.Recordset just to make my own testing simpler. So the only real change is in the Else case of the Select statement.
For my own learning purposes, I reviewed this answer's detailed review of the command shell interactions. Since you specifically stated that you are avoiding disk I/O, the option to pipe the output to a windows temp file is no good. To really prevent the command shell pop-up, you'd have to go with running a cscript under a wscript shell as the poster there indicates. Additionally, I couldn't find any historical information that the tasklist output has changed over time, so I believe your approach should remain viable across different Windows versions.
Here is my main module with my minor edits for testing:
Option Explicit
Sub test()
Dim taskList As Collection
Set taskList = EnumProcesses
Dim task As Variant
For Each task In taskList
Debug.Print task.ImageName & ", " & task.MemUsage
Next task
End Sub
Public Function EnumProcesses() As Collection
Dim WshShell As IWshRuntimeLibrary.WshShell
Dim WshExec As IWshRuntimeLibrary.WshExec
Dim StdOut As IWshRuntimeLibrary.TextStream
Dim Data As Collection
Dim Output As String
Dim ColumnLengths() As Long
Set WshShell = CreateObject("WScript.Shell")
Set WshExec = WshShell.Exec("tasklist")
Set StdOut = WshExec.StdOut
Set Data = New Collection
Do While WshExec.Status = WshRunning
If Not StdOut.AtEndOfStream Then
Output = StdOut.ReadLine
Select Case True
Case Len(Output) = 0, _
Output Like "Image Name*"
'Skip
Case Output Like "====*"
'Skip
Case Else
Dim thisTask As OSTask
Set thisTask = New OSTask
thisTask.Init Output
Data.Add thisTask
End Select
End If
Loop
Set EnumProcesses = Data
End Function