bunu deneyebilirsiniz
Dim created As Boolean
Dim stopTimer As Boolean
Sub Start_Click()
Dim row As Long, col As Long, i As Long
Set cores = GetCores
Optimize (False)
For Each core In cores
row = WorksheetFunction.RoundDown(i / 4, 0)
col = (i - 4 * row) Mod 4
If Not (created) Then
If Not (row = 0 And col = 0) Then
Range("CORE").Copy
Range("CORE").Offset(2 * row, 2 * col).PasteSpecial
Range("CORE").Offset(2 * row, 2 * col).Cells(1, 1).Value = "Core " & (i + 1)
End If
End If
Range("CORE").Offset(2 * row, 2 * col).Cells(2, 1).Value = core.PercentProcessorTime & "%"
i = i + 1
Next
Range("CPU").Value = Range("CORE").Offset(2 * row, 2 * col).Cells(2, 1).Value
Range("CORE").Offset(2 * row, 2 * col).Cells(2, 1).Value = ""
If Not (created) Then Range("CORE").Offset(2 * row, 2 * col).Delete xlShiftUp
created = True
Optimize (True)
DoEvents
If Not (stopTimer) Then Application.OnTime DateAdd("s", 2, DateTime.Now), "Start_Click"
stopTimer = False
End Sub
Sub EndTimer()
stopTimer = True
End Sub
Function GetCores()
Dim objWMIService, cores, Proc, strQuery
strQuery = "select * from Win32_PerfFormattedData_PerfOS_Processor"
Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\cimv2")
Set cores = objWMIService.ExecQuery(strQuery, , 48)
Set GetCores = cores
End Function
Sub Optimize(opt As Boolean)
Application.ScreenUpdating = opt
Application.Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual)
End Sub
Sub test()
Range("D5").Value = GetCores
End Sub
birde böyle bir kod var
Function ProcessorID() As String
On Error GoTo Error_Handler
' Using late binding to avoid a Reference problem
Dim strComputer As String
Dim objWMIService As Object
Dim colItems As Object
Dim objItem As Object
strComputer = "." 'Get info for the current computer
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Processor", , 48)
For Each objItem In colItems
ProcessorID = Nz(objItem.ProcessorID, 0)
Next
Error_Handler_Exit:
On Error Resume Next
Set objItem = Nothing
Set colItems = Nothing
Set objWMIService = Nothing
Exit Function
Error_Handler:
MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Error Source: ProcessorID" & vbCrLf & "Error Description: " & _
Err.Description, vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
(11/01/2020, 09:04)accessman yazdı: [ -> ]birde böyle bir kod var
Function ProcessorID() As String
On Error GoTo Error_Handler
' Using late binding to avoid a Reference problem
Dim strComputer As String
Dim objWMIService As Object
Dim colItems As Object
Dim objItem As Object
strComputer = "." 'Get info for the current computer
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Processor", , 48)
For Each objItem In colItems
ProcessorID = Nz(objItem.ProcessorID, 0)
Next
Error_Handler_Exit:
On Error Resume Next
Set objItem = Nothing
Set colItems = Nothing
Set objWMIService = Nothing
Exit Function
Error_Handler:
MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Error Source: ProcessorID" & vbCrLf & "Error Description: " & _
Err.Description, vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
Üstad kodlar hata veriyor ikiside, acaba imports etmedim diyemi veriyor? Kütüphaneleri neler bunların?