vbacpuwmido-while

I want the code to wait until the CPU usage drops below 60%


The following code is using for measuring CPU % usage.

Public Sub Macro1()

Dim strComputer As String
Dim objWMIService As Object
Dim colItems As Object
Dim objItem As Object

strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_PerfFormattedData_PerfOS_Processor", , 48)

For Each objItem In colItems
    Debug.Print objItem.PercentProcessorTime
Next
    
End Sub

I have got the above code from this link: https://analystcave.com/excel-measuring-cpu-usage-in-vba-and-other-performance-metrics/#comment-184350.

I want the code to wait until the CPU usage drops below 60%.


Solution

  • you could try something like this:

    (I would probably put a Sleep() in there too to help reduce it spinning to fast)

    Sub Test()
    
        Debug.Print "Starting"
        Call PauseWhileBusy
        Debug.Print "Done"
    
    End Sub
    
    Sub PauseWhileBusy(Optional ByVal lMaxPercent As Long = 60, Optional ByVal strComputer As String = ".")
        
        Dim colItems As Object
        Dim objItem As Object
        Dim bTooBusy As Boolean
        
        With GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
            Do
                Set colItems = .ExecQuery("Select * from Win32_Processor")
                For Each objItem In colItems
                    Debug.Print "Current Load:", objItem.LoadPercentage
                    bTooBusy = objItem.LoadPercentage > lMaxPercent
                Next
                DoEvents
            Loop While bTooBusy
            
        End With
    End Sub