Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set Services = objWMIService.ExecQuery("Select * from Win32_Service")
Set fso = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(0)
i = 0
Do
    If objFolder.GetDetailsOf("", i) = "公司" Then  '非中文系统自行修改
        Exit Do
    Else
        i = i+1
    End If
Loop

For Each objService in Services
    path = GetPath(objService.PathName)
    If fso.GetExtensionName(path) = "" Then path = path & ".exe"
    If fso.FileExists(path) Then Set objFolder = objShell.NameSpace(fso.GetParentFolderName(path))
    Set objItem = objFolder.ParseName(fso.GetFileName(path))
    comp = objFolder.GetDetailsOf(objItem, i)
    If comp = "" Then comp = "未知"
    info = info & "服务："& objService.DisplayName &" 制造商："& comp & vbCrLF
Next
fso.CreateTextFile("info.txt", true).WriteLine info
MsgBox "完成"

Function GetPath(strng)
    Dim re
    Set re = New RegExp
    re.Pattern = "^""?(.+\\[^\\\s""]+).*"
    GetPath = re.Replace(strng,"$1")
    Set regEx = Nothing
End Function
复制代码