unitmain.pas

delphi进程管理源码示例免费下载,机会不多

unit UnitMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, UnitCF, TLHELP32, ExtCtrls, ComCtrls, psapi,
  ToolWin, ImgList, Menus,ShellAPI;//, XPMan;
const
  KILL_NOERR        = 0;
  KILL_NOTSUPPORTED = -1;
  KILL_ERR_OPENPROCESS = -2;
  KILL_ERR_TERMINATEPROCESS = -3;
  ENUM_NOERR        = 0;
  ENUM_NOTSUPPORTED = -1;
  ENUM_ERR_OPENPROCESSTOKEN = -2;
  ENUM_ERR_LookupPrivilegeValue = -3;
  ENUM_ERR_AdjustTokenPrivileges = -4;
  SE_DEBUG_NAME     = 'SeDebugPrivilege';
type
  OSVersion = (OsXX, win95, win97, win98, win98SE, ME, NT3, NT4, win2K, XP);

type

  TButForm1 = class(TButForm)
    ToolBar1: TToolBar;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    ToolButton3: TToolButton;
    ToolButton4: TToolButton;
    ToolButton5: TToolButton;
    ToolButton6: TToolButton;
    lvw_prc: TListView;
    pgc2: TPageControl;
    modules: TTabSheet;
    lvw_mod: TListView;
    memory: TTabSheet;
    lvw_mem: TListView;
    device: TTabSheet;
    lvw_dev: TListView;
    ImageList1: TImageList;
    ImageList2: TImageList;
    ImageList3: TImageList;
    MainMenu1: TMainMenu;
    O1: TMenuItem;
    H1: TMenuItem;
    R1: TMenuItem;
    T1: TMenuItem;
    N2: TMenuItem;
    X1: TMenuItem;
    F1: TMenuItem;
    N7: TMenuItem;
    PopupMenu1: TPopupMenu;
    K1: TMenuItem;
    PopupMenu2: TPopupMenu;
    N8: TMenuItem;
    N9: TMenuItem;
    N10: TMenuItem;
    N11: TMenuItem;
    N12: TMenuItem;
    w1: TMenuItem;
    pm1: TPopupMenu;
    pm2: TPopupMenu;
    w2: TMenuItem;
    N13: TMenuItem;
    ImageList4: TImageList;
    procedure FormResize(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ToolButton1Click(Sender: TObject);
    procedure lvw_prcClick(Sender: TObject);
    procedure pgc2Change(Sender: TObject);
    procedure K1Click(Sender: TObject);
    procedure R1Click(Sender: TObject);
    procedure ToolButton2Click(Sender: TObject);
    procedure X1Click(Sender: TObject);
    procedure N8Click(Sender: TObject);
    procedure N9Click(Sender: TObject);
    procedure N10Click(Sender: TObject);
    procedure w1Click(Sender: TObject);
    procedure w2Click(Sender: TObject);
    procedure N13Click(Sender: TObject);
    procedure lvw_modDblClick(Sender: TObject);
    procedure PopupMenu2Popup(Sender: TObject);
    procedure pm1Popup(Sender: TObject);
    procedure pm2Popup(Sender: TObject);

  private
    { Private declarations }

  public
    { Public declarations }
    procedure PsList;
    procedure Devlist;
  end;
var
  ButForm1          : TButForm1;
implementation

{$R *.dfm}
type
  TPDWord = ^DWORD;
  PVMCounters = ^TVMCounters;
  TVMCounters = record
    PeakVirtualSize: ULONG;
    VirtualSize: ULONG;
    PagedFaultCount: ULONG;
    PeakWorkingSetSize: ULONG;
    WorkingSetSize: ULONG;
    QuotaPeakPagedPoolUsage: ULONG;
    QuotaPagedPoolUsage: ULONG;
    QuotaPeakNonPagedPoolUsage: ULONG;
    QuotaNonPagedPoolUsage: ULONG;
    PagefileUsage: ULONG;
    PeakPagefileUsage: ULONG;
  end;
const
  ProcessVMCounters = 3;
function NtQueryInformationProcess
  (
  ProcessHandle: Thandle;
  PrcInfoClass: DWORD;
  PrcInfo: Pointer;
  PrcInfoLength: ULONG;
  returnlength: TPDWord
  ):
  DWORD; stdcall; external 'ntdll.dll' name 'NtQueryInformationProcess';
function GetPrcVMCounters(PID: DWORD): tstringlist;
var
  status            : DWORD;
  retlen            : DWORD;
  VMInfo            : TVMCounters;
  hProcess          : Thandle;
begin
  result := tstringlist.Create;
  hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, FALSE, PID);
  status := NtQueryInformationProcess
    (
    hProcess,
    ProcessVMCounters,
    @VMInfo,
    sizeof(TVMCounters),
    @retlen
    );
  if (status <> 0) then
  begin
    exit;
  end;
  with result do
  begin
    Add('进程虚拟地址空间的最大数值 :  ' + IntToStr(VMInfo.PeakVirtualSize) + '  Byte');
    Add('进程的虚拟地址空间的大小 :  ' + IntToStr(VMInfo.VirtualSize) + '  Byte');
    Add('进程分页错误数目 :  ' + IntToStr(VMInfo.PagedFaultCount) + '  Byte');
    Add('进程的工作集列表的最大值 :  ' + IntToStr(VMInfo.PeakWorkingSetSize) + '  Byte');
    Add('进程的工作集列表的大小 :  ' + IntToStr(VMInfo.WorkingSetSize) + '  Byte'); // <--- 就是这个鸟
    Add('填充到进程的分页池的峰值的最大值 :  ' + IntToStr(VMInfo.QuotaPeakPagedPoolUsage) + '  Byte');
    Add('填充到进程的分页池的峰值大小 :  ' + IntToStr(VMInfo.QuotaPagedPoolUsage) + '  Byte');
    Add('填充到进程的非分页池的峰值的最大值 :  ' + IntToStr(VMInfo.QuotaNonPagedPoolUsage) + '  Byte');
    Add('填充到进程的分页池的峰值大小 :  ' + IntToStr(VMInfo.QuotaNonPagedPoolUsage) + '  Byte');
    Add('进程多使用的页文件页的最大值 :  ' + IntToStr(VMInfo.PeakPagefileUsage) + '  Byte');
  end;
end;
//============================================================
function ShowFileProperties(FileName: String; Wnd: HWND):Boolean;

var

  sfi: TSHELLEXECUTEINFO;

begin

  with sfi do

  begin

    cbSize := SizeOf(sfi);

    lpFile := PAnsiChar(FileName);

    Wnd := Wnd;
    
    fMask :=SEE_MASK_NOCLOSEPROCESS or  SEE_MASK_INVOKEIDLIST or SEE_MASK_FLAG_NO_UI;

    lpVerb := PAnsiChar('properties');

    lpIDList := nil;

    lpDirectory := nil;

    nShow := 0;

    hInstApp := 0;

    lpParameters := nil;

    dwHotKey := 0;

    hIcon := 0;

    hkeyClass := 0;

    hProcess := 0;

    lpClass := nil;

  end;

  Result := ShellExecuteEX(@sfi);

end;
//=================================================================================
function getTaskExeMem(PID: DWORD): string;
var
  status            : DWORD;
  retlen            : DWORD;
  VMInfo            : TVMCounters;
  hProcess          : Thandle;
begin
  if PID = 0 then
  begin
    result := '0';
    exit;
  end;
  hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, FALSE, PID);
  status := NtQueryInformationProcess
    (
    hProcess,
    ProcessVMCounters,
    @VMInfo,
    sizeof(TVMCounters),
    @retlen
    );
  if (status <> 0) then
  begin
    exit;
  end;
  result := FORMATFLOAT('#0.00', (VMInfo.WorkingSetSize / 1048576)) + ' MB';
end;

function getTaskExeVirtualMem(PID: DWORD): string;
var
  status            : DWORD;
  retlen            : DWORD;
  VMInfo            : TVMCounters;
  hProcess          : Thandle;
begin
  if PID = 0 then
  begin result := '0';
    exit;
  end;
  hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, FALSE, PID);
  status := NtQueryInformationProcess
    (
    hProcess,
    ProcessVMCounters,
    @VMInfo,
    sizeof(TVMCounters),
    @retlen
    );
  if (status <> 0) then
  begin
    exit;
  end;
  result := FORMATFLOAT('#0.00', (VMInfo.VirtualSize / 1000000)) + ' MB';
end;
//翻译页面的类型
function MemoryTypeToString(Value: DWORD): string;
const
  TypeMask          = DWORD($0000000F);
begin
  result := '';
  case Value and TypeMask of
    1: result := '只读';
    2: result := '可运行的';
    4: result := '读/写';
    5: result := '复制写';
  else
    result := '未知';
  end;
  if Value and $100 <> 0 then
    result := result + ', 可共享';
end;

procedure ErrorMessage;
var
  MsgBuf            : string;
begin
  FormatMessage(
    FORMAT_MESSAGE_ALLOCATE_BUFFER or
    FORMAT_MESSAGE_FROM_SYSTEM or
    FORMAT_MESSAGE_IGNORE_INSERTS,
    nil,
    GetLastError(),
    LANG_NEUTRAL,                       //MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), // Default language
    @MsgBuf,
    sizeof(MsgBuf),
    nil
    );
  MessageBox(0, PChar(MsgBuf), ' 错误 ', MB_OK);
  raise EAbort.Create('');
end;

procedure GetTokenInfo(ProcessID: Thandle);
var
  InfoBuffer        : TTokenPrivileges;
  i                 : integer;
  ucPrivilegeName   : PChar;
  dwPrivilegeNameSize, dwInfoBufferSize: DWORD;
  hToken, hProcess  : Thandle;
  s                 : string;
begin
  hProcess := OpenProcess(PROCESS_ALL_ACCESS,
    true, ProcessID);
  if hProcess = 0 then
    ErrorMessage;
  //get token handle from process handle
  if (OpenProcessToken(hProcess,
    TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY or TOKEN_READ, hToken) = FALSE) then
  begin
    ErrorMessage;
  end;
  dwInfoBufferSize := 0;
  if GetTokenInformation(hToken, TokenPrivileges, @InfoBuffer,
    sizeof(TTokenPrivileges), dwInfoBufferSize) = FALSE then
  begin
    ErrorMessage;
  end;
  ucPrivilegeName := strAlloc(128);
  exit;
  s := 'aaaa';
  strPcopy(ucPrivilegeName, s);
  s := strpas(ucPrivilegeName);
  ShowMessage(s);
  dwPrivilegeNameSize := 1000;
  for i := 0 to InfoBuffer.PrivilegeCount - 1 do
  begin
    if LookupPrivilegeName(nil, InfoBuffer.Privileges[i].Luid,
      ucPrivilegeName, dwPrivilegeNameSize) = FALSE then
    begin
      ErrorMessage;
    end;
    ShowMessage(s);
  end;
  strDispose(ucPrivilegeName);
  CloseHandle(hProcess);
end;

function EnableDebugPrivilegeNT: integer;
var
  hToken            : Thandle;
  DebugValue        : TLargeInteger;
  tkp               : TTokenPrivileges;
  returnlength      : DWORD;
  PreviousState     : TTokenPrivileges;
begin
  if (OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY or TOKEN_READ, hToken) = FALSE) then
    result := ENUM_ERR_OPENPROCESSTOKEN
  else
  begin
    if (LookupPrivilegeValue(nil, SE_DEBUG_NAME, DebugValue) = FALSE) then
      result := ENUM_ERR_LookupPrivilegeValue
    else
    begin
      returnlength := 0;
      tkp.PrivilegeCount := 1;
      tkp.Privileges[0].Luid := DebugValue;
      tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(TTokenPrivileges), PreviousState, returnlength);
      if (GetLastError <> ERROR_SUCCESS) then
        result := ENUM_ERR_AdjustTokenPrivileges
      else
        result := ENUM_NOERR;
    end;
  end;
end;
function ABSKILL_Pid(PID: longint): integer;
var
  hProcess          : Thandle;
  TermSucc          : BOOL;
begin
  hProcess := OpenProcess(PROCESS_ALL_ACCESS, true, PID);
  if (hProcess = 0) then
  begin
    result := KILL_ERR_OPENPROCESS;
  end
  else
  begin
    TermSucc := TerminateProcess(hProcess, 0);
    if (TermSucc = FALSE) then
      result := KILL_ERR_TERMINATEPROCESS
    else
      result := KILL_NOERR;
  end;
end;
procedure dFile(FileName: string);   //98下删可恶的东西真烦人
var
  buffer: array [0..4095] of Byte;
  max, n: LongInt;
  i: Integer;
  fs: TFileStream;

  procedure RandomizeBuffer;
  var
    i: Integer;
  begin
    for i := Low(buffer) to High(buffer) do
      buffer[i] := Random(256);
  end;
begin
  fs := TFilestream.Create(FileName, fmOpenReadWrite or fmShareExclusive);
  try
    for i := 1 to 3 do
    begin
      RandomizeBuffer;
      max         := fs.Size;
      fs.Position := 0;
      while max>0 do
      begin
        if max>SizeOf(buffer) then
          n := SizeOf(buffer)
        else
          n := max;
        fs.Write(Buffer, n);
        max := max - n;