Тестирование полезных кодов и примеров

Option Explicit
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) As Long
 
Private Sub Command1_Click()
    Text1.Text = GetCurrentProcessId
    
    ' Загрузить процессор на 100%
    Do
        DoEvents
    Loop
End Sub
 
Private Sub Command2_Click()
    Dim hwnd As Long
    Dim pid As Long
    
    hwnd = FindWindow(vbNullString, "Program Manager")
    GetWindowThreadProcessId hwnd, pid ' Определить PID процесса Explorer
    
    Text1.Text = pid
End Sub
 
Private Sub Command3_Click()
    Dim i As Long
    
    Do
        For i = 0 To 30000
            DoEvents
        Next
        
        Sleep 50
    Loop
End Sub
 
Private Sub Command4_Click()
    Dim i As Long
    
    Do
        For i = 0 To 15000
            DoEvents
        Next
        
        Sleep 50
    Loop
End Sub
 
Private Sub Command5_Click()
    Text1.Text = GetCurrentProcessId
End Sub
 
Private Sub Command6_Click()
    Dim i As Long
    
    Do
        For i = 0 To 7500
            DoEvents
        Next
        
        Sleep 50
    Loop
End Sub
 
Private Sub Command7_Click()
    Dim hThread As Long
    
    flag = 1
    
    hThread = CreateThread(ByVal 0&, 0, AddressOf thread, ByVal 0&, 0, 0)
    CloseHandle hThread
End Sub
 
Private Sub Form_Load()
    Text1.Text = GetCurrentProcessId
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    flag = 0
    End
End Sub
 
Private Sub Timer1_Timer()
    If Text1.Text = "" Then Exit Sub
    
    If Text1.Text = GetCurrentProcessId Then
        Label1.Caption = "My PID: "
        Label2.Caption = "My PID: "
    Else
        Label1.Caption = "Another PID: "
        Label2.Caption = "Another PID: "
    End If
    
    Label1.Caption = Label1.Caption & GetProcessUsage(Text1.Text) & "%    это показание менее точное как в обычном диспетчере задач" ' Это точно правильно работает
    Label2.Caption = Label2.Caption & GetProcessUsageByCycleTime(Text1.Text) & "%    это показание более точное, как в программе ProcessHacker" ' А вот тут я не очень уверен
End Sub

Option Explicit
'/////////////////////////////////////////////////////////////
'// Модуль определения загрузки ЦП для конкретного процесса //
'// Copyright (c) 07.04.2023 by HackerVlad                  //
'// e-mail: vladislavpeshkov@yandex.ru                      //
'// Версия 2.0                                              //
'/////////////////////////////////////////////////////////////
 
' Декларации API
Private Declare Function NtQuerySystemInformation Lib "ntdll.dll" (ByVal infoClass As Long, Buffer As Any, ByVal BufferSize As Long, ret As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (srcAddr As Any, ByRef dstValue As Long) As Long
Private Declare Function GetMem8 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function QueryProcessCycleTime Lib "kernel32" (ByVal ProcessHandle As Long, CycleTime As Currency) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32" (ByRef lpPerformanceCount As Currency) As Long
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 Const SystemProcessInformation As Long = &H5
Private Const STATUS_INFO_LENGTH_MISMATCH As Long = &HC0000004
Private Const STATUS_SUCCESS As Long = 0
Private Const PROCESS_QUERY_LIMITED_INFORMATION As Long = &H1000
 
' Типы
Private Type SYSTEM_INFO
    dwOemID                     As Long
    dwPageSize                  As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask       As Long
    dwNumberOfProcessors        As Long
    dwProcessorType             As Long
    dwAllocationGranularity     As Long
    wProcessorLevel             As Integer
    wProcessorRevision          As Integer
End Type
 
' Вычислить загрузку ЦП конкретного запущенного процесса
Public Function GetProcessUsage(Optional pid As Long) As Single
    Dim buf() As Byte
    Dim ret As Long
    Dim getpid As Long
    Dim Offset As Long
    Dim deltaOffset As Long
    Dim UserTime As Currency
    Dim KernelTime As Currency
    Dim UserTimeRet As Currency
    Dim KernelTimeRet As Currency
    Dim GetProcessUsageRet As Currency
    Static OldUserTime As Currency
    Static OldKernelTime As Currency
    Static FirstRun As Boolean
    Dim SInfo As SYSTEM_INFO
    
    If pid = 0 Then pid = GetCurrentProcessId
    
    If NtQuerySystemInformation(SystemProcessInformation, ByVal 0&, 0&, ret) = STATUS_INFO_LENGTH_MISMATCH Then
        ReDim buf(ret - 1)
        
        If NtQuerySystemInformation(SystemProcessInformation, buf(0), ret, ret) = STATUS_SUCCESS Then
            Do
                GetMem4 buf(Offset + &H44), getpid
                If getpid = pid Then ' Эти значения ни чем не отличаются от полученных с помощью GetProcessTimes
                    GetMem8 buf(Offset + &H28), UserTime
                    GetMem8 buf(Offset + &H30), KernelTime
                    Exit Do
                End If
                
                GetMem4 buf(Offset), deltaOffset
                Offset = Offset + deltaOffset
            Loop While deltaOffset
        End If
    End If
    
    If UserTime > 0 And KernelTime > 0 Then
        If FirstRun = False Then
            FirstRun = True
            
            OldUserTime = UserTime
            OldKernelTime = KernelTime
            GetProcessUsage = "0"
            Exit Function
        Else
            GetSystemInfo SInfo
            
            UserTimeRet = (UserTime - OldUserTime)
            KernelTimeRet = (KernelTime - OldKernelTime)
            
            GetProcessUsageRet = (UserTimeRet + KernelTimeRet) / 10 / SInfo.dwNumberOfProcessors
            If GetProcessUsageRet > 100 Then GetProcessUsageRet = 100
            
            GetProcessUsage = Round(GetProcessUsageRet, 2)
            
            OldUserTime = UserTime
            OldKernelTime = KernelTime
        End If
    Else
        GetProcessUsage = "0" ' Иногда UserTime или KernelTime почему-то может быть сразу нулём
    End If
End Function
 
' Вычислить загрузку ЦП конкретного запущенного процесса для Windows Vista и выше
Public Function GetProcessUsageByCycleTime(Optional pid As Long) As Single
    Dim hProc As Long
    Dim CycleTime As Currency
    Dim CyclesDelta As Currency
    Dim ProcessCycles As Currency
    Dim ProcessCycleDelta As Currency
    Dim SInfo As SYSTEM_INFO
    Dim ProcessUsagePercent As Single
    Static OldProcessCycles As Currency
    Static OldCycleTime As Currency
    Static FirstRun As Boolean
    
    If pid = 0 Then
        hProc = GetCurrentProcess()
    Else
        hProc = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, 0, pid)
    End If
    
    If hProc <> 0 Then
        QueryProcessCycleTime hProc, ProcessCycles
        
        If ProcessCycles > 0 Then
            GetSystemInfo SInfo
            
            If FirstRun = False Then
                FirstRun = True
                
                OldProcessCycles = ProcessCycles
                QueryPerformanceCounter OldCycleTime ' Здесь оказывается важно ещё запоминать QueryPerformanceCounter
                
                GetProcessUsageByCycleTime = 0
                Exit Function
            Else
                QueryPerformanceCounter CycleTime
                CyclesDelta = CycleTime - OldCycleTime
                
                ProcessCycleDelta = ProcessCycles - OldProcessCycles
                ProcessUsagePercent = ProcessCycleDelta / CyclesDelta / SInfo.dwNumberOfProcessors / 10
                
                If ProcessUsagePercent > 100 Then ProcessUsagePercent = 100
                
                GetProcessUsageByCycleTime = Round(ProcessUsagePercent, 2)
                
                OldProcessCycles = ProcessCycles
                OldCycleTime = CycleTime
            End If
        End If
        
        If pid <> 0 Then CloseHandle hProc
    End If
End Function

Option Explicit
 
Public Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, _
                                                     ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, _
                                                     lpThreadId As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Public flag As Long
 
Public Sub thread(ByVal unUse As Long)
 
    Do
    Loop While GetFlag()
    
End Sub
 
Private Function GetFlag() As Long
    GetFlag = flag
End Function