在VB中如何让线程或进程在指定的CPU上运行

代码如下：

Option Explicit

Private Declare Function WTSEnumerateProcesses Lib "wtsapi32.dll" Alias "WTSEnumerateProcessesA" (ByVal hServer As Long, ByVal Reserved As Long, ByVal Version As Long, ByRef ppProcessInfo As Long, ByRef pCount As Long) As Long
Private Declare Function SetProcessAffinityMask Lib "kernel32.dll" (ByVal hProcess As Long, ByVal dwProcessAffinityMask As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Sub WTSFreeMemory Lib "wtsapi32.dll" (ByVal pMemory As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Const WTS_CURRENT_SERVER_HANDLE = 0&
Private Type WTS_PROCESS_INFO
    SessionID As Long
    ProcessID As Long
    pProcessName As Long
    pUserSid As Long
End Type

Public Sub Main()
    Call SetAffinityByEXE("notepad.exe")
End Sub

Private Sub SetAffinityByEXE(strImageName As String)
    Const PROCESS_QUERY_INFORMATION = 1024
    Const PROCESS_VM_READ = 16
    Const MAX_PATH = 260
    Const STANDARD_RIGHTS_REQUIRED = &HF0000
    Const SYNCHRONIZE = &H100000
    Const PROCESS_ALL_ACCESS = &H1F0FFF
    Const TH32CS_SNAPPROCESS = &H2&
    Const hNull = 0
    Const WIN95_System_Found = 1
    Const WINNT_System_Found = 2
    Const Default_Log_Size = 10000000
    Const Default_Log_Days = 0
    Const SPECIFIC_RIGHTS_ALL = &HFFFF
    Const STANDARD_RIGHTS_ALL = &H1F0000

    Dim BitMasks() As Long, NumMasks As Long, LoopMasks As Long
    Dim MyMask As Long
    Const AffinityMask As Long = &HF ' 00001111b

    Dim lngPID As Long
    Dim lngHwndProcess
    lngPID = GetProcessID(strImageName)

    If lngPID = 0 Then
        MsgBox "Could Not Get process ID of " & strImageName, vbCritical, "Error"
        Exit Sub
    End If
    lngHwndProcess = OpenProcess(PROCESS_ALL_ACCESS, 0, lngPID)
    If lngHwndProcess = 0 Then
        MsgBox "Could Not obtain a handle For the Process ID: " & lngPID, vbCritical, "Error"
        Exit Sub
    End If
    BitMasks() = GetBitMasks(AffinityMask)

    'Use CPU0
    MyMask = BitMasks(0)
    'Use CPU1
    'MyMask = BitMasks(1)
    'Use CPU0 and CPU1
    'MyMask = BitMasks(0) Or BitMasks(1)
    'The CPUs to use are specified by the array index.
    'To use CPUs 0, 2, and 4, you would use:
    'MyMask = BitMasks(0) Or BitMasks(2) Or BitMasks(4)
    'To Set Affinity, pass the application h
    '     andle and your custom affinity mask:
    'SetProcessAffinityMask(lngHwndProcess,
    '     MyMask)
    'Use GetCurrentProcess() API instead of
    '     lngHwndProcess to set affinity on the current app.

    If SetProcessAffinityMask(lngHwndProcess, MyMask) = 1 Then
        MsgBox "Affinity Set", vbInformation, "Success"
    Else
        MsgBox "Failed To Set Affinity", vbCritical, "Failure"
    End If
End Sub

Private Function GetBitMasks(ByVal inValue As Long) As Long()
    Dim RetArr() As Long, NumRet As Long
    Dim LoopBits As Long, BitMask As Long
    Const HighBit As Long = &H80000000
    ReDim RetArr(0 To 31) As Long

    For LoopBits = 0 To 30
        BitMask = 2 ^ LoopBits
        If (inValue And BitMask) Then
            RetArr(NumRet) = BitMask
            NumRet = NumRet + 1
        End If
    Next LoopBits
    If (inValue And HighBit) Then
        RetArr(NumRet) = HighBit
        NumRet = NumRet + 1
    End If
    If (NumRet > 0) Then ' Trim unused array items and return array
        If (NumRet < 32) Then ReDim Preserve RetArr(0 To NumRet - 1) As Long
        GetBitMasks = RetArr
    End If
End Function

Private Function GetProcessID(strProcessName As String) As Long
    Dim RetVal As Long
    Dim Count As Long
    Dim i As Integer
    Dim lpBuffer As Long
    Dim p As Long
    Dim udtProcessInfo As WTS_PROCESS_INFO
    Dim lngProcessID As Long
    Dim strTempProcessName As String
   
    RetVal = WTSEnumerateProcesses(WTS_CURRENT_SERVER_HANDLE, 0&, 1, lpBuffer, Count)
    If RetVal Then ' WTSEnumerateProcesses was successful
        p = lpBuffer
        For i = 1 To Count
            ' Count is the number of Structures in the buffer
            ' WTSEnumerateProcesses returns a pointer, so copy it to a
            ' WTS_PROCESS_INO UDT so you can access its members
            CopyMemory udtProcessInfo, ByVal p, LenB(udtProcessInfo)
            ' Add items to the ListView control
            lngProcessID = CLng(udtProcessInfo.ProcessID)
            ' Since pProcessName contains a pointer,call GetStringFromLP to get the
            ' variable length string it points to
            If udtProcessInfo.ProcessID = 0 Then
                'MsgBox "System Idle Process"
            Else
                strTempProcessName = GetStringFromLP(udtProcessInfo.pProcessName)
                If UCase(strTempProcessName) = UCase(strProcessName) Then
                    GetProcessID = lngProcessID
                End If
            End If
            p = p + LenB(udtProcessInfo)
        Next i
        WTSFreeMemory lpBuffer 'Free your memory buffer
    Else
        MsgBox "Error", vbCritical, "Fatal Error"
    End If
End Function

Private Function GetStringFromLP(ByVal StrPtr As Long) As String
    Dim b As Byte
    Dim tempStr As String
    Dim bufferStr As String
    Dim Done As Boolean
   
    Done = False
    Do
        ' Get the byte/character that StrPtr is pointing to.
        CopyMemory b, ByVal StrPtr, 1
        If b = 0 Then ' If you've found a null character, then you're done.
            Done = True
        Else
            tempStr = Chr$(b) ' Get the character For the byte's value
            bufferStr = bufferStr & tempStr 'Add it To the String
            StrPtr = StrPtr + 1 ' Increment the pointer To Next byte/char
        End If
    Loop Until Done
    GetStringFromLP = bufferStr
End Function

 

摘自：网络整理

---

★VB部分相关文章推荐：★

---