Keskustelu: Ohjelmointikysymykset: VB6: vb aikaa prosessille

Attribute VB_Name = "modProcessPriority"
Option Explicit

' (c) Copyright 2003 Andrew Novick.
' You may use this code in your projects, including projects
' that you sell so long as there is substantial additional
' content.  All other rights including rights to publication
' are reserved.

Private Declare Function GetCurrentProcess _
        Lib "kernel32" () As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetCurrentThread Lib "kernel32" () As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function SetThreadPriority Lib "kernel32" _
          (ByVal hThread As Long, ByVal nPriority As Long) As Long
Private Declare Function GetThreadPriority Lib "kernel32" (ByVal hThread As Long) As Long


Private Const THREAD_BASE_PRIORITY_LOWRT As Long = 15  ' value that gets a thread to LowRealtime-1
Private Const THREAD_BASE_PRIORITY_MAX As Long = 2     ' maximum thread base priority boost
Private Const THREAD_BASE_PRIORITY_MIN  As Long = -2   ' minimum thread base priority boost
Private Const THREAD_BASE_PRIORITY_IDLE  As Long = -15 ' value that gets a thread to idle


Public Enum ThreadPriority
    THREAD_PRIORITY_LOWEST = -2
    THREAD_PRIORITY_BELOW_NORMAL = -1
    THREAD_PRIORITY_NORMAL = 0
    THREAD_PRIORITY_HIGHEST = 2
    THREAD_PRIORITY_ABOVE_NORMAL = 1
    THREAD_PRIORITY_TIME_CRITICAL = 15  ' THREAD_BASE_PRIORITY_LOWRT
    THREAD_PRIORITY_IDLE = -15         'THREAD_BASE_PRIORITY_IDLE
End Enum

' Win32 API declarations
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) 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 SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long
Private Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

' Used by the OpenProcess API call
Private Const PROCESS_QUERY_INFORMATION As Long = &H400
Private Const PROCESS_SET_INFORMATION As Long = &H200

' Used by SetPriorityClass
Private Const NORMAL_PRIORITY_CLASS = &H20
Private Const BELOW_NORMAL_PRIORITY_CLASS = 16384
Private Const ABOVE_NORMAL_PRIORITY_CLASS = 32768
Private Const IDLE_PRIORITY_CLASS = &H40
Private Const HIGH_PRIORITY_CLASS = &H80
Private Const REALTIME_PRIORITY_CLASS = &H100

Public Enum ProcessPriorities
   ppidle = IDLE_PRIORITY_CLASS
   ppbelownormal = BELOW_NORMAL_PRIORITY_CLASS
   ppAboveNormal = ABOVE_NORMAL_PRIORITY_CLASS
   ppNormal = NORMAL_PRIORITY_CLASS
   ppHigh = HIGH_PRIORITY_CLASS
   ppRealtime = REALTIME_PRIORITY_CLASS
End Enum

Public Function ProcessPriorityName(ByVal Priority As ProcessPriorities) As String

    Dim sName As String

    Select Case Priority
        Case ppidle
            sName = "Idle"
        Case ppbelownormal
            sName = "Below Normal"
        Case ppNormal
            sName = "Normal"
        Case ppAboveNormal
            sName = "Above Normal"
        Case ppHigh
            sName = "High"
        Case ppRealtime
            sName = "Realtime"
        Case Else
            sName = "Unknown:" & CStr(Priority)
    End Select

    ProcessPriorityName = sName

End Function
Public Function ProcessPriorityGet(Optional ByVal ProcessID As Long, Optional ByVal hWnd As Long) As Long

    ' Gets the process priority identified by an Id, a hWnd
    ' or if not identified, then the current process
   Dim hProc As Long
   Const fdwAccess As Long = PROCESS_QUERY_INFORMATION

   ' If not passed a PID, then find value from hWnd.
   If ProcessID = 0 Then
        If hWnd <> 0 Then
            Call GetWindowThreadProcessId(hWnd, ProcessID)
        Else
            ProcessID = GetCurrentProcessId()
        End If
   End If

   ' Need to open process with simple query rights,
   ' get the current setting, and close handle.
   hProc = OpenProcess(fdwAccess, 0&, ProcessID)
   ProcessPriorityGet = GetPriorityClass(hProc)
   Call CloseHandle(hProc)
End Function
Public Function ProcessPrioritySet( _
            Optional ByVal ProcessID As Long, _
            Optional ByVal hWnd As Long, _
            Optional ByVal Priority As ProcessPriorities = NORMAL_PRIORITY_CLASS _
            ) As Long

   Dim hProc As Long
   Const fdwAccess1 As Long = PROCESS_QUERY_INFORMATION Or PROCESS_SET_INFORMATION
   Const fdwAccess2 As Long = PROCESS_QUERY_INFORMATION

   ' If not passed a PID, then find value from hWnd.
   If ProcessID = 0 Then
        If hWnd <> 0 Then
            Call GetWindowThreadProcessId(hWnd, ProcessID)
        Else
            ProcessID = GetCurrentProcessId()
        End If
   End If

   ' Need to open process with setinfo rights.
   hProc = OpenProcess(fdwAccess1, 0&, ProcessID)
   If hProc Then
      ' Attempt to set new priority.
      Call SetPriorityClass(hProc, Priority)
   Else
      ' Weren't allowed to setinfo, so just open to
      ' enable return of current priority setting.
      hProc = OpenProcess(fdwAccess2, 0&, ProcessID)
   End If

   ' Get current/new setting.
   ProcessPrioritySet = GetPriorityClass(hProc)
   ' Clean up.
   Call CloseHandle(hProc)
End Function

Public Function ProcessThreadPrioritySet( _
            Optional ByVal Priority As ThreadPriority = THREAD_PRIORITY_NORMAL _
            ) As ThreadPriority

   Dim hThread As Long
   Dim rc As Long

   ' Set's the priority of the current thread

    hThread = GetCurrentThread()


   ' Need to open process with setinfo rights.
   rc = SetThreadPriority(hThread, Priority)

   ProcessThreadPrioritySet = GetThreadPriority(hThread)

End Function

Private Const THREAD_BASE_PRIORITY_IDLE As Long = -15
Private Const THREAD_BASE_PRIORITY_LOWRT As Long = 15
Private Const THREAD_BASE_PRIORITY_MIN As Long = -2
Private Const THREAD_BASE_PRIORITY_MAX As Long = 2
Private Const THREAD_PRIORITY_LOWEST As Long = THREAD_BASE_PRIORITY_MIN
Private Const THREAD_PRIORITY_HIGHEST As Long = THREAD_BASE_PRIORITY_MAX
Private Const THREAD_PRIORITY_BELOW_NORMAL As Long = (THREAD_PRIORITY_LOWEST + 1)
Private Const THREAD_PRIORITY_ABOVE_NORMAL As Long = (THREAD_PRIORITY_HIGHEST - 1)
Private Const THREAD_PRIORITY_IDLE As Long = THREAD_BASE_PRIORITY_IDLE
Private Const THREAD_PRIORITY_NORMAL As Long = 0
Private Const THREAD_PRIORITY_TIME_CRITICAL As Long = THREAD_BASE_PRIORITY_LOWRT
Private Const HIGH_PRIORITY_CLASS As Long = &H80
Private Const IDLE_PRIORITY_CLASS As Long = &H40
Private Const NORMAL_PRIORITY_CLASS As Long = &H20
Private Const REALTIME_PRIORITY_CLASS As Long = &H100
Private Declare Function SetThreadPriority Lib "kernel32" (ByVal hThread As Long, ByVal nPriority As Long) As Long
Private Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long
Private Declare Function GetThreadPriority Lib "kernel32" (ByVal hThread As Long) As Long
Private Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long
Private Declare Function GetCurrentThread Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long


Sub Muuta()
If a = 1 Then SetPriority THREAD_PRIORITY_LOWEST, IDLE_PRIORITY_CLASS
If a = 2 Then SetPriority THREAD_PRIORITY_NORMAL, HIGH_PRIORITY_CLASS
If a = 3 Then SetPriority THREAD_PRIORITY_TIME_CRITICAL, REALTIME_PRIORITY_CLASS
End Sub


Sub SetPriority(ByVal lThreadPriority As Long, ByVal lClassPriority As Long)
   Dim hThread As Long, hProcess As Long
   hThread = GetCurrentThread
   hProcess = GetCurrentProcess
   SetThreadPriority hThread, lThreadPriority
   SetPriorityClass hProcess, lClassPriority
End Sub