当前位置:学Delphi网文档资料技术资料其他

Delphi编程设置系统工作CPU个数

减小字体 增大字体 作者:佚名  来源:转载  发布时间:2011-02-18 12:42:35

unit main;  
interface 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
  Dialogs, TlHelp32, mytool, 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 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. 

Tags:

作者:佚名
  • 好的评价 如果您觉得此文章好,就请您
      0%(0)
  • 差的评价 如果您觉得此文章差,就请您
      0%(0)

文章评论评论内容只代表网友观点,与本站立场无关!

   评论摘要(共 0 条,得分 0 分,平均 0 分) 查看完整评论

广告位置B