GFSetPriorityClass/GFSetPriorityClass.frm

VERSION 5.00
Begin VB.Form Mfrm
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4755
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4755
   StartUpPosition =   3 'Windows‑Standard
End
Attribute VB_Name = "Mfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis.
'
'NOTE: GFSetPriorityClass could be extended by GFProcessEXENameList_Create().
'
'GFSetPriorityClass
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal Flags As Long, ByVal ProcessID As Long) As Long 'http://tokyo.cool.ne.jp/masapico/api_CreateToolhelp32Snapshot.html
Private Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, ByRef ProcessEntry As PROCESSENTRY32) As Long 'http://tokyo.cool.ne.jp/masapico/api_Process32First.html
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnap As Long, ByRef ProcessEntry As PROCESSENTRY32) As Long 'http://tokyo.cool.ne.jp/masapico/api_Process32Next.html
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
'GFSetPriorityClass
'possible Win32 priorities
Const NORMAL_PRIORITY_CLASS = &H20
Const IDLE_PRIORITY_CLASS = &H40
Const HIGH_PRIORITY_CLASS = &H80
Const REALTIME_PRIORITY_CLASS = &H100
'end of priorities
Const TH32CS_SNAPPROCESS = &H2
Const PROCESS_SET_INFORMATION = &H200 'WINNT.H
Const MAX_PATH = 260
'GFSetPriorityClass
Private Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szExeFile As String * MAX_PATH
End Type

Private Sub Form_Load()
    'on error resume next
    Debug.Print GFSetPriorityClass("wintop.exe", "c:\windows\", HIGH_PRIORITY_CLASS)
End Sub

Private Function GFSetPriorityClass(ByVal ProcessEXEName As String, ByVal ProcessDirectoryNameOrNothing As String, ByVal ProcessPriorityNewConstant As Long) As Boolean
    'on error resume next 'returns True for priority has been set, False if not; read VC++ (5.0) help for further information
    Dim SnapShotHandle As Long
    Dim ProcessID As Long
    Dim ProcessHandle As Long
    Dim CurrentProcessFileName As String
    Dim CurrentProcessDirectoryName As String
    Dim PROCESSENTRY32Var As PROCESSENTRY32
    Dim ProcessLoop As Integer
    '
    'NOTE: this function searches a self‑created Win32 process snapshot list for
    'the process whose exe name and optional whose directory name is equal
    'to the passed values (capitalization ignored).
    'Pass the directory name when it is probable that the exe name could
    'appear twice.
    '
    'verify
    Select Case ProcessPriorityNewConstant
    Case NORMAL_PRIORITY_CLASS
    Case IDLE_PRIORITY_CLASS
    Case HIGH_PRIORITY_CLASS
    Case REALTIME_PRIORITY_CLASS
    Case Else
        GoTo Error:
    End Select
    If Not (ProcessDirectoryNameOrNothing = "") Then
        If Not (Right$(ProcessDirectoryNameOrNothing, 1) = "\") Then ProcessDirectoryNameOrNothing = ProcessDirectoryNameOrNothing + "\" 'compared with directory format returned by GetDirectoryName()
    End If
    'preset
    SnapShotHandle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&)
    PROCESSENTRY32Var.dwSize = Len(PROCESSENTRY32Var)
    ProcessID = 0 'preset (error)
    ProcessHandle = 0 'preset (error)
    'begin; create process list to get process ID
    If Process32First(SnapShotHandle, PROCESSENTRY32Var) = 0 Then GoTo Error: 'verify
    CurrentProcessFileName = GetFileName(Left$(PROCESSENTRY32Var.szExeFile, InStr(1, PROCESSENTRY32Var.szExeFile, Chr$(0), vbBinaryCompare) ‑ 1))
    CurrentProcessDirectoryName = GetDirectoryName(PROCESSENTRY32Var.szExeFile)
    Do
        'data of first process already requested
        If UCase$(CurrentProcessFileName) = UCase$(ProcessEXEName) Then
            If (UCase$(CurrentProcessDirectoryName) = UCase$(ProcessDirectoryNameOrNothing)) Or _
                (ProcessDirectoryNameOrNothing = "") Then
                ProcessID = PROCESSENTRY32Var.th32ProcessID
                Exit Do
            Else
                'stay in loop
            End If
        End If
        If Process32Next(SnapShotHandle, PROCESSENTRY32Var) = False Then Exit Do 'verify
        CurrentProcessFileName = GetFileName(Left$(PROCESSENTRY32Var.szExeFile, InStr(1, PROCESSENTRY32Var.szExeFile, Chr$(0), vbBinaryCompare) ‑ 1))
        CurrentProcessDirectoryName = GetDirectoryName(PROCESSENTRY32Var.szExeFile)
        ProcessLoop = ProcessLoop + 1
    Loop Until (ProcessLoop = 32767) 'avoid endless loop
    'get process handle and set priority
    ProcessHandle = OpenProcess(PROCESS_SET_INFORMATION, 0&, ProcessID)
    If SetPriorityClass(ProcessHandle, ProcessPriorityNewConstant) = 0 Then GoTo Error: 'verify
    GFSetPriorityClass = True 'ok
    Exit Function
Error:
    GFSetPriorityClass = False 'error
    Exit Function
End Function

Private Function GetFileName(ByVal GetFileNameName As String) As String
    On Error Resume Next 'returns chars after last backslash or nothing
    Dim GetFileNameLoop As Integer
    GetFileName = "" 'reset
    For GetFileNameLoop = Len(GetFileNameName) To 1 Step (‑1)
        If Mid$(GetFileNameName, GetFileNameLoop, 1) = "\" Then
            GetFileName = Right$(GetFileNameName, Len(GetFileNameName) ‑ GetFileNameLoop)
            Exit For
        End If
    Next GetFileNameLoop
End Function

Private Function GetDirectoryName(ByVal GetDirectoryNameName As String) As String
    On Error Resume Next 'returns chars from string beginning to (including) last backslash or nothing
    Dim GetDirectoryNameLoop As Integer
    GetDirectoryName = "" 'reset
    For GetDirectoryNameLoop = Len(GetDirectoryNameName) To 1 Step (‑1)
        If Mid$(GetDirectoryNameName, GetDirectoryNameLoop, 1) = "\" Then
            GetDirectoryName = Left$(GetDirectoryNameName, GetDirectoryNameLoop)
            Exit For
        End If
    Next GetDirectoryNameLoop
End Function


[END OF FILE]