有些程序运行在多个CPU的系统上运行不稳定,为了解决这个问题,写了一个更改进程工作CPU个数的程序 源代码如下: unit main; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, TlHelp32, StdCtrls, Buttons; type TfrmMain = class(TForm) Button1: TButton; Button2: TButton; OpenDialog1: TOpenDialog; Button3: TButton; GroupBox1: TGroupBox; Label1: TLabel; Edit1: TEdit; SpeedButton1: TSpeedButton; Label3: TLabel; RadioButton1: TRadioButton; RadioButton2: TRadioButton; RadioButton4: TRadioButton; RadioButton5: TRadioButton; RadioButton3: TRadioButton; RadioButton6: TRadioButton; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure SpeedButton1Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure Button3Click(Sender: TObject); private { Private declarations } public { Public declarations } function Getcpu_num(): DWORD; end; var frmMain: TfrmMain; function SetProcessCPU_NUM: boolean; implementation {$R *.dfm} function Max(a, b: integer): integer; begin if a > b then result := a else result := b; end; function SetCPUProcessByFullPath(ModuleFullPath: string; AppName: string = ''; real_CPU_NUM: DWORD = 1): integer; var lppe: TPROCESSENTRY32; found: boolean; ProcessList: THandle; ModuleList: Thandle; pm: TMODULEENTRY32; h: Thandle; a: DWORD; ModuleName: string; AppProcessId: DWORD; // 线程ID begin Result := 0; AppProcessId := GetCurrentProcessId; if Length(AppName) = 0 then AppName := ExtractFileName(ModuleFullPath); lppe.dwSize := sizeof(TPROCESSENTRY32); pm.dwSize := sizeof(TMODULEENTRY32); ProcessList := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); found := Process32First(ProcessList, lppe); while found do //进程列表 begin if StrIComp(PChar(StrPas(lppe.szExeFile)), PChar(AppName)) = 0 then //应用程序名字是否相同? begin ModuleList := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, lppe.th32ProcessID); found := module32first(ModuleList, pm); while found do //模块列表 begin ModuleName := StrPas(pm.szexepath); ModuleName := copy(ModuleName, max(1, pos(':', ModuleName) - 1), MaxInt); if StrIComp(pchar(ModuleName), pchar(ModuleFullPath)) = 0 then //是否包含要找的模块 begin if AppProcessId <> lppe.th32ProcessID then begin h := openprocess(PROCESS_ALL_ACCESS, TRUE, lppe.th32ProcessID); if SetProcessAffinityMask(h, real_CPU_NUM) then inc(Result); end; break; end; found := module32next(ModuleList, pm); end; closehandle(ModuleList); end; found := Process32Next(ProcessList, lppe); end; closehandle(ProcessList); end; function TfrmMain.Getcpu_num(): DWORD; begin if RadioButton1.Checked then result := $0001 else if RadioButton2.Checked then result := $0002 else if RadioButton3.Checked then result := $0003 else if RadioButton4.Checked then result := $000F else if RadioButton5.Checked then result := $007F else if RadioButton6.Checked then result := $0007; end; procedure TfrmMain.Button1Click(Sender: TObject); var i, cpu_num: integer; begin //例如系统有2个CPU,参数说明如下 //1: 表示进程在第一个CPU上运行 //2: 表示进程在第二个CPU上运行 //3: 表示进程同时在二个CPU上运行 cpu_num := Getcpu_num; i := SetCPUProcessByFullPath(edit1.Text, '', cpu_num); if i < 1 then ShowMessage('设置失败!') else ShowMessage('设置成功!') end; procedure TfrmMain.Button2Click(Sender: TObject); var CPU_NUM: DWORD; h: THandle; begin cpu_num := Getcpu_num; h := GetCurrentProcess(); if SetProcessAffinityMask(h, CPU_NUM) then ShowMessage('设置成功!'); end; procedure TfrmMain.Button3Click(Sender: TObject); begin Close; end; procedure TfrmMain.FormCreate(Sender: TObject); var lpSystemInfo:SYSTEM_INFO; begin GetSystemInfo(lpSystemInfo); Label3.Caption := Label3.Caption + IntToStr(lpSystemInfo.dwNumberOfProcessors); RadioButton1.Checked := True; if lpSystemInfo.dwNumberOfProcessors <= 1 then begin RadioButton2.Enabled := False; RadioButton3.Enabled := False; RadioButton4.Enabled := False; RadioButton5.Enabled := False; RadioButton6.Enabled := False; end else if lpSystemInfo.dwNumberOfProcessors = 2 then begin RadioButton4.Enabled := False; RadioButton5.Enabled := False; RadioButton6.Enabled := False; end else if lpSystemInfo.dwNumberOfProcessors = 4 then begin RadioButton6.Enabled := False; end else if lpSystemInfo.dwNumberOfProcessors = 8 then begin // end; SetProcessCPU_NUM; end; procedure TfrmMain.SpeedButton1Click(Sender: TObject); begin if OpenDialog1.Execute then begin Edit1.Text := OpenDialog1.FileName; end; end; //当系统CPU个数超过4个时,设置进程CPU个数为4 function SetProcessCPU_NUM: boolean; var lpSystemInfo:SYSTEM_INFO; CPU_NUM: DWORD; h: THandle; begin result := true; GetSystemInfo(lpSystemInfo); if lpSystemInfo.dwNumberOfProcessors > 4 then begin cpu_num := $000F; h := GetCurrentProcess(); result := SetProcessAffinityMask(h, CPU_NUM); end; end; end.