用Delphi編寫系統進程監控程序

    本程序通過調用kernel32.dll中的幾個API 函數，搜索并列出系統中除本進程外的所有進程的ID、對應的文件說明符、優先級、CPU占有率、線程數、相關進程信息等有關信息，并可中止所選進程。
    本程序運行時會在系統托盤區加入圖標，不會出現在按Ctrl+Alt+Del出現的任務列表中，也不會在任務欄上顯示任務按鈕，在不活動或最小化時會自動隱藏。不會重復運行，若程序已經運行，再想運行時只會激活已經運行的程序。
    本程序避免程序反復運行的方法是比較獨特的。因為筆者在試用網上介紹一些方法后，發現程序從最小化狀態被激活時，單擊窗口最小化按鈕時，窗口卻不能最小化。于是筆者采用了發送和處理自定義消息的方法。在程序運行時先枚舉系統中已有窗口，若發現程序已經運行，就向該程序窗口發送自定義消息，然后結束。已經運行的程序接到自定義消息后顯示出窗口。

//工程文件procviewpro.dpr
program procviewpro;

uses
  Forms, windows, messages,  main in 'procview.pas' {Form1};

{$R *.RES}
{
//這是系統自動的  
begin
  Application.Initialize;
  Application.Title :='系統進程監控';
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
}

var
  myhwnd:hwnd;

begin
  myhwnd := FindWindow(nil, '系統進程監控'); // 查找窗口
  if myhwnd=0 then                           // 沒有發現，繼續運行    
  begin
    Application.Initialize;
    Application.Title :='系統進程監控';
    Application.CreateForm(TForm1, Form1);
    Application.Run;
  end
  else      //發現窗口，發送鼠標單擊系統托盤區消息以激活窗口
    postmessage(myhwnd,WM_SYSTRAYMSG,0,wm_lbuttondown);
    {
     //下面的方法的缺點是：若窗口原先為最小化狀態，激活后單擊窗口最小化按鈕將不能最小化窗口
     showwindow(myhwnd,sw_restore);
     FlashWindow(MYHWND,TRUE);
    }
end.

{
//下面是使用全局原子的方法避免程序反復運行
const
  atomstr='procview';

var
  atom:integer;
begin
  if globalfindatom(atomstr)=0 then
  begin
    atom:=globaladdatom(atomstr);
    with application do
    begin
      Initialize;
      Title := '系統進程監控';
      CreateForm(TForm1, Form1);
      Run;
    end;
    globaldeleteatom(atom);
  end;
end.
}


//單元文件procview.pas
unit procview;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, TLHelp32,Buttons, ComCtrls, ExtCtrls,ShellAPI, MyFlag;

const
  PROCESS_TERMINATE=0;
  SYSTRAY_ID=1;
  WM_SYSTRAYMSG=WM_USER+100;

type
  TForm1 = class(TForm)
    lvSysProc: TListView;
    lblSysProc: TLabel;
    lblAboutProc: TLabel;
    lvAboutProc: TListView;
    lblCountSysProc: TLabel;
    lblCountAboutProc: TLabel;
    Panel1: TPanel;
    btnDetermine: TButton;
    btnRefresh: TButton;
    lblOthers: TLabel;
    lblEmail: TLabel;
    MyFlag1: TMyFlag;
    procedure btnRefreshClick(Sender: TObject);
    procedure btnDetermineClick(Sender: TObject);
    procedure lvSysProcClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure AppOnMinimize(Sender:TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDeactivate(Sender: TObject);
    procedure lblEmailClick(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
    { Private declarations }
    fshandle:thandle;
    FormOldHeight,FormOldWidth:Integer;
    procedure SysTrayOnClick(var message:TMessage);message WM_SYSTRAYMSG;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  idid: dword;
  fp32:tprocessentry32;
  fm32:tmoduleentry32;
  SysTrayIcon:TNotifyIconData;

implementation

{$R *.DFM}

function RegisterServiceProcess(dwProcessID,dwType:integer):integer;stdcall;external 'KERNEL32.DLL';

procedure TForm1.btnRefreshClick(Sender: TObject);
var
  clp:bool;
  newitem1:Tlistitem;
  MyIcon:TIcon;

  IconIndex:word;
  ProcFile : array[0..MAX_PATH] of char;

begin
  MyIcon:=TIcon.create;
  lvSysProc.Items.clear;
  lvSysProc.SmallImages.clear;
  fshandle:=CreateToolhelp32Snapshot(th32cs_snapprocess,0);
  fp32.dwsize:=sizeof(fp32);
  clp:=process32first(fshandle,fp32);
  IconIndex:=0;
  while integer(clp)<>0 do
  begin
    if fp32.th32processid<>getcurrentprocessid then
    begin
      newitem1:=lvSysProc.items.add;
      {
      newitem1.caption:=fp32.szexefile;
      MyIcon.Handle:=ExtractIcon(Form1.Handle,fp32.szexefile,0);
      }

      StrCopy(ProcFile,fp32.szExeFile);
      newitem1.caption:=ProcFile;
      MyIcon.Handle:=ExtractAssociatedIcon(HINSTANCE,ProcFile,IconIndex);
       
      if MyIcon.Handle<>0 then
      begin
        with lvSysProc do
        begin
          NewItem1.ImageIndex:=smallimages.addicon(MyIcon);
        end;
      end;
      with newitem1.subitems do
      begin
        add(IntToHex(fp32.th32processid,4));
        Add(IntToHex(fp32.th32ParentProcessID,4));
        Add(IntToHex(fp32.pcPriClassBase,4));
        Add(IntToHex(fp32.cntUsage,4));
        Add(IntToStr(fp32.cntThreads));
      end;
    end;
    clp:=process32next(fshandle,fp32);
  end;
  closehandle(fshandle);
  lblCountSysProc.caption:=IntToStr(lvSysProc.items.count);
  MyIcon.Free;
end;

procedure TForm1.btnDetermineClick(Sender: TObject);
var
  processhndle:thandle;
begin
  with lvSysProc do
  begin
    if selected=nil then
    begin
      messagebox(form1.handle,'請先選擇要終止的進程!','操作提示',MB_OK+MB_ICONINFORMATION);
    end
    else
    begin
      if messagebox(form1.handle,pchar('終止'+itemfocused.caption+'?')
         ,'終止進程',mb_yesno+MB_ICONWARNING+MB_DEFBUTTON2)=mryes then
      begin
        idid:=strtoint('$'+itemfocused.subitems[0]);
        processhndle:=openprocess(PROCESS_TERMINATE,bool(0),idid);
        if integer(terminateprocess(processhndle,0))=0 then
          messagebox(form1.handle,pchar('不能終止'+itemfocused.caption+'!')
             ,'操作失敗',mb_ok+MB_ICONERROR)
        else
        begin
          Selected.Delete;
          lvAboutProc.Items.Clear;
          lblCountSysProc.caption:=inttostr(lvSysProc.items.count);
          lblCountAboutProc.caption:='';
        end
      end;
    end;
  end;
end;

procedure TForm1.lvSysProcClick(Sender: TObject);
var
  newitem2:Tlistitem;
  clp:bool;
begin
  if lvSysProc.selected<>nil then
  begin
    idid:=strtoint('$'+lvSysProc.itemfocused.subitems[0]);
    lvAboutProc.items.Clear;
    fshandle:=CreateToolhelp32Snapshot(th32cs_snapmodule,idid);
    fm32.dwsize:=sizeof(fm32);
    clp:=Module32First(fshandle,fm32);
    while integer(clp)<>0 do
    begin
      newitem2:=lvAboutProc.Items.add;
      with newitem2 do
      begin
        caption:=fm32.szexepath;
        with newitem2.subitems do
        begin
          add(IntToHex(fm32.th32moduleid,4));
          add(IntToHex(fm32.GlblcntUsage,4));
          add(IntToHex(fm32.proccntUsage,4));
        end;
      end;
      clp:=Module32Next(fshandle,fm32);
    end;
    closehandle(fshandle);
    lblCountAboutProc.Caption:=IntToStr(lvAboutProc.items.count);
  end
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  with application do
  begin
    showwindow(handle,SW_HIDE);    //隱藏任務欄上的任務按鈕
    OnMinimize:=AppOnMinimize;     //最小化時自動隱藏
    OnDeactivate:=FormDeactivate;  //不活動時自動隱藏
    OnActivate:=btnRefreshClick;
  end;
  RegisterServiceProcess(GetcurrentProcessID,1); //將程序注冊為系統服務程序，以避免出現在任務列表中
  with SysTrayIcon do
  begin
    cbSize:=sizeof(SysTrayIcon);
    wnd:=Handle;
    uID:=SYSTRAY_ID;
    uFlags:=NIF_ICON OR NIF_MESSAGE OR NIF_TIP;
    uCallBackMessage:=WM_SYSTRAYMSG;
    hIcon:=Application.Icon.Handle;
    szTip:='系統進程監控';
  end;
  Shell_NotifyIcon(NIM_ADD,@SysTrayIcon);  //將程序圖標加入系統托盤區
  with lvSysProc do
  begin
    SmallImages:=TImageList.CreateSize(16,16);
    SmallImages.ShareImages:=True;
  end;
  FormOldWidth:=self.Width;
  FormOldHeight:=self.Height;
end;

//最小化時自動隱藏
procedure Tform1.AppOnMinimize(Sender:TObject);
begin
  ShowWindow(application.handle,SW_HIDE);
end;

//響應鼠標在系統托盤區圖標上點擊
procedure tform1.SysTrayOnClick(var message:TMessage);
begin
  with message do
  begin
    if (lparam=wm_lbuttondown) or (lparam=wm_rbuttondown) then
    begin
      application.restore;
      SetForegroundWindow(Handle);
      showwindow(application.handle,SW_HIDE);
    end;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Shell_NotifyIcon(NIM_DELETE,@SysTrayIcon);     //取消系統托盤區圖標
  RegisterServiceProcess(GetcurrentProcessID,0); //取消系統服務程序的注冊
  lvSysProc.SmallImages.Free;
end;

//不活動時自動隱藏
procedure TForm1.FormDeactivate(Sender: TObject);
begin
  application.minimize;
end;


procedure TForm1.lblEmailClick(Sender: TObject);
begin
  if ShellExecute(Handle,'Open',Pchar('Mailto:purpleendurer@163.com'),nil,nil,SW_SHOW)<33 then
MessageBox(form1.Handle,'無法啟動電子郵件軟件!','我很遺憾',MB_ICONINFORMATION+MB_OK);
end;

//當窗體大小改變時調整各組件位置
procedure TForm1.FormResize(Sender: TObject);
begin
with panel1 do top:=top+self.Height-FormOldHeight;
with lvSysProc do
begin
width:=width+self.Width-FormOldWidth;
end;

with lvAboutProc do
begin
height:=height+self.Height-FormOldHeight;
width:=width+self.Width-FormOldWidth;
end;
FormOldWidth:=self.Width;
FormOldHeight:=self.Height;
end;

end.

以上程序在Delphi 2，Windows 95中文版和Delphi 5,Windows 97中文版中均能正常編譯和運行。大家有什么問題請Email to:purpleendurer@163.com與我討論。

作者：黃志斌
廣西河池地區經濟學校 郵編:547000
Email: purpleendurer@163.com