option explicit

dim oFSO, LogFile_full, LogFile_cur, oShell, cur, ver
ver = "1.2"

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("WScript.Shell")

' Make me Admin :) Получаем права Администратора
if WScript.Arguments.Count = 0 then
    if not isAdminRights() then
        Elevate()
        WScript.Quit
    end if
end if

cur = oFSO.GetParentFolderName(WScript.ScriptFullName)

LogFile_full = cur & "\ProcessCPU_Average.csv"
LogFile_cur  = cur & "\ProcessCPU_Current.csv"

on error resume next
if oFSO.FileExists(LogFile_full) then oFSO.DeleteFile(LogFile_full)
if oFSO.FileExists(LogFile_cur)  then oFSO.DeleteFile(LogFile_cur)
if Err.Number <> 0 then msgbox "Ошибка! Закройте, пожалуйста, книги Excel и запустите скрипт еще раз.", vbCritical, "GetCPUUsage v." & ver & " by Dragokas": WScript.Quit 1
on error goto 0

oShell.Popup "Пожалуйста, подождите...", 4, "GetCPUUsage by Dragokas"

CPUTimeToLog
msgbox "Готово." & vblf & "Выложите в теме, где Вам оказывают помощь, файлы:" & vblf & vblf &_
    "1. ProcessCPU_Current.csv" & vblf & "2. ProcessCPU_Average.csv" & vblf & vblf &_
    "упаковав в архив формата zip.", vbInformation, "GetCPUUsage v." & ver & " by Dragokas"
WScript.Quit

Set oFSO = Nothing: Set oShell = Nothing

Sub CPUTimeToLog()
    dim Kernel_t1, User_t1, Total_t1
    dim Kernel_t2, User_t2, Total_t2
    dim oSCR_t1, oSCR_t2, oSCR_PID, oSCR_path, oSCR_Serv, oSCR_parentPID, oTS, WMI, oProcesses, oProcess, Key
    dim Proc_t1, Proc_t2, Delta_Proc, Delta_System, oServices, oService, Service_Name, ParentPID, ParentPath

    'PID -> TotalTime
    set oSCR_t1 = CreateObject("Scripting.Dictionary")
    set oSCR_t2 = CreateObject("Scripting.Dictionary")
    'PID -> Name
    set oSCR_PID = CreateObject("Scripting.Dictionary")
    'PID -> Путь и параметры командной строки
    set oSCR_path = CreateObject("Scripting.Dictionary")
    'PID -> Service
    set oSCR_Serv = CreateObject("Scripting.Dictionary")
    'PID -> ParentPID
    set oSCR_parentPID = CreateObject("Scripting.Dictionary")

    Set WMI = GetObject("winmgmts:\root\cimv2")

    Set oServices = WMI.ExecQuery("SELECT * FROM Win32_Service") 'Получаю имена и описания служб -> привязываю к PID (ключ - это PID)
    For each oService in oServices
        if oSCR_Serv.Exists(oService.ProcessID) then
            oSCR_Serv(oService.ProcessID) = oSCR_Serv(oService.ProcessID) & _
                oService.Name & " (" & oService.Caption & "), "
        else
            oSCR_Serv.Add oService.ProcessID, oService.Name & " (" & oService.Caption & "), "
        end if
    Next

    WScript.Sleep(500) ' Нормализация % скачка CPU, вызванного запуском этого скрипта

    ' 1-я засечка
    Set oProcesses = WMI.ExecQuery("SELECT * FROM Win32_Process")
    For each oProcess in oProcesses
        with oProcess
            Kernel_t1 = Kernel_t1 + cdbl(.KernelModeTime)
            User_t1   = User_t1   + cdbl(.UserModeTime)
            oSCR_t1.Add        .ProcessID, cdbl(.KernelModeTime) + cdbl(.UserModeTime)
            oSCR_PID.Add       .ProcessID, .Caption             'PID -> Name
            oSCR_path.Add      .ProcessID, .ExecutablePath      'PID -> Path
            oSCR_parentPID.Add .ProcessID, .ParentProcessId     'PID -> ParentPID
        end with
    Next
    'Всего времени всех процессов
    Total_t1 = Kernel_t1 + User_t1

    set oTS = oFSO.CreateTextFile(LogFile_full, true)
    oTS.WriteLine "CPU (%);Process Name;PID;Service;Path;ParentPath"

    SpecialSortDict oSCR_t1, true 'Сортировка словаря в обратном порядке по % CPU.
    
    For each Key in oSCR_t1.Keys
        Proc_t1 = oScr_t1(Key)
        if (oSCR_Serv.Exists(Key) and Key <> 0) then Service_Name = oSCR_Serv(Key) else Service_Name = ""
        ParentPID = oSCR_parentPID(Key)
        if (oSCR_path.Exists(ParentPID) and Key <> 0) then ParentPath = oSCR_path(ParentPID) else ParentPath = ""
        oTS.Write round(Proc_t1 / Total_t1 * 100, 2) & ";"      'CPU (%)
        oTS.Write oSCR_PID(Key) & ";"                           'Process Name
        oTS.Write Key & ";"                    'PID
        oTS.Write Service_Name & ";"                            'Service
        oTS.Write oScr_path(Key) & ";"                          'Path
        oTS.Write ParentPath & ";"                    'Parent Path
        oTS.WriteLine ""
    Next
    oTS.Close

    WScript.Sleep(2000) 'выжидаю 2 сек.

    ' 2-я засечка
    Set oProcesses = WMI.ExecQuery("SELECT * FROM Win32_Process")
    For each oProcess in oProcesses
        with oProcess
            Kernel_t2 = Kernel_t2 + cdbl(.KernelModeTime)
            User_t2   = User_t2   + cdbl(.UserModeTime)
            oSCR_t2.Add .ProcessID, cdbl(.KernelModeTime) + cdbl(.UserModeTime)
            if not oSCR_PID.Exists(.ProcessID) then
                oSCR_PID.Add       .ProcessID, .Caption             'PID -> Name (если появились новые)
                oSCR_path.Add      .ProcessID, .ExecutablePath      'PID -> Path (если появились новые)
                oSCR_parentPID.Add .ProcessID, .ParentProcessId     'PID -> ParentPID
            end if
        end with
    Next
    'Всего времени всех процессов
    Total_t2 = Kernel_t2 + User_t2

    ' Словарь PID -> Дельта CPU:
    ' Записываю разницу по формуле:
    ' % нагрузки процесса = Дельта времени процесса / дельта времени системы * 100
    Dim oSCR_delta: set oSCR_delta = CreateObject("Scripting.Dictionary")
    For each Key in oSCR_t2.Keys
        Proc_t1 = oScr_t1(Key)
        Proc_t2 = oScr_t2(Key)
        Delta_Proc   = Proc_t2  - Proc_t1
        Delta_System = Total_t2 - Total_t1
        oSCR_delta.Add key, round(Delta_Proc / Delta_System * 100, 2)
    Next

    SpecialSortDict oSCR_delta, true ' Сортировка словаря в обратном порядке по % CPU.

    set oTS = oFSO.CreateTextFile(LogFile_cur, true)
    oTS.WriteLine "CPU (%);Process Name;PID;Service;Path;ParentPath"

    For each Key in oSCR_delta.Keys
        if (oSCR_Serv.Exists(Key) and Key <> 0) then Service_Name = oSCR_Serv(Key) else Service_Name = ""
        ParentPID = oSCR_parentPID(Key)
        if (oSCR_path.Exists(ParentPID) and Key <> 0) then ParentPath = oSCR_path(ParentPID) else ParentPath = ""
        oTS.Write oSCR_delta(key) & ";"                    'CPU (%)
        oTS.Write oSCR_PID(Key) & ";"                    'Process Name
        oTS.Write Key & ";"                    'PID
        oTS.Write Service_Name & ";"                    'Service
        oTS.Write oScr_path(Key) & ";"                    'Path
        oTS.Write ParentPath & ";"                    'ParentPath
        oTS.WriteLine ""
    Next
    oTS.Close

    Set oProcess = Nothing: set oProcesses = Nothing: set WMI = Nothing: set oTS = Nothing
    Set oSCR_PID = Nothing: set oSCR_t1 = Nothing: set oSCR_t2 = Nothing: set oSCR_path = Nothing
    Set oSCR_Serv = Nothing: set oSCR_parentPID = Nothing
End Sub

Sub Elevate()
    Dim colOS, oOS, strOSLong, oShellApp
    Const DQ = """"
    Set colOS = GetObject("winmgmts:\root\cimv2").ExecQuery("Select * from Win32_OperatingSystem")
    For Each oOS In colOS: strOSLong = oOS.Version: Next
    If Left(strOSLong, 1) = "6" and Not isAdminRights Then
        Set oShellApp = CreateObject("Shell.Application")
        oShellApp.ShellExecute WScript.FullName, DQ & WScript.ScriptFullName & DQ & " " & DQ & "Twice" & DQ, "", "runas", 1
        WScript.Quit
    End If
    set oOS = Nothing: set colOS = Nothing: set oShellApp = Nothing
End Sub

Function isAdminRights()
    Dim oReg, strKey, intErrNum, flagAccess
    Const KQV = &H1, KSV = &H2, HKCU = &H80000001, HKLM = &H80000002
    Set oReg = GetObject("winmgmts:root\default:StdRegProv")
    strKey = "System\CurrentControlSet\Control\Session Manager"
    intErrNum = oReg.CheckAccess(HKLM, strKey, KQV + KSV, flagAccess)
    isAdminRights = flagAccess
    Set oReg = Nothing
End Function

'Сортировка словаря методом вставок -> исходный словарь реконструируется
Sub SpecialSortDict(inDict, Reverse)
    Dim arrPos: arrPos = inDict.keys                    'Инициализация массива позиций ключей словаря
    Dim arrTemp: arrTemp = inDict.Items                 'Виртуализация значений словаря

    Dim i, j, xItem
    For i = 1 To UBound(arrTemp)                        'Сортировка методом вставок
        For j = i To 1 Step -1
            If arrTemp(j) < arrTemp(j - 1) Then
                xItem = arrTemp(j)                      'Обмен значений
                arrTemp(j) = arrTemp(j - 1)
                arrTemp(j - 1) = xItem
                xItem = arrPos(j)                       'Обмен ключей
                arrPos(j) = arrPos(j - 1)
                arrPos(j - 1) = xItem
            Else
                Exit For
            End If
        Next
    Next

    dim iStart, iEnd, iStep
    if Reverse then iStep = -1: iStart = UBound(arrPos): iEnd = 0 else iStep = 1: iStart = 0: iEnd = UBound(arrPos)

    Dim virtDict: Set virtDict = CreateObject("Scripting.Dictionary")   
    For i = iStart To iEnd step iStep                         'Расставляем значения в виртуальный словарь согласно массива ключей
        virtDict.Add arrPos(i), inDict(arrPos(i))
    Next

    Set inDict = virtDict
End Sub