frmmain.pas

在delphi中实现windows核心编程.原书光盘代码核心编程.原书光盘代码

unit FrmMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls;

type
  TMainForm = class(TForm)
    ListBox1: TListBox;
    Label1: TLabel;
    Label2: TLabel;
    ListView1: TListView;
    Label3: TLabel;
    procedure ListBox1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
  private
    procedure EnumerateModules(ProcessHandle: THandle; ProcessId: Cardinal);
  end;

var
  MainForm: TMainForm;

implementation

uses
  Psapi, Pdh; 

{$R *.DFM}

procedure PdhCheck(const Error: Longint);
begin
  if Error <> ERROR_SUCCESS then raise Exception.Create('Error: ' + IntToHex(8, Error));
end;

function GetProcessCount: Int64;
var
  Query: HQUERY;
  Counter: HCOUNTER;
  Value: TPdhFmtCounterValue;
begin
  PdhCheck(PdhOpenQuery(nil, 0, Query));
  try
    PdhCheck(PdhAddCounter(Query, PChar('\Objects\Processes'), 0, Counter));
    PdhCheck(PdhCollectQueryData(Query));
    PdhCheck(PdhGetFormattedCounterValue(Counter, PDH_FMT_LARGE, nil, Value));
    Result := Value.largeValue;
  finally
    PdhRemoveCounter(Counter);
    PdhCloseQuery(Query);
  end;
end;

function EnableDebugPrivilege(const Enable: Boolean): Boolean;
const
  PrivAttrs: array[Boolean] of DWORD = (0, SE_PRIVILEGE_ENABLED);
var
  Token: THandle;
  TokenPriv: TTokenPrivileges;
  ReturnLength: Cardinal;
begin
  Result := False;
  if OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, Token) then
  begin
    LookupPrivilegeValue(nil, 'SeDebugPrivilege', TokenPriv.Privileges[0].Luid);
    TokenPriv.PrivilegeCount := 1;
    TokenPriv.Privileges[0].Attributes := PrivAttrs[Enable];
    AdjustTokenPrivileges(Token, False, TokenPriv, SizeOf(TokenPriv), nil, ReturnLength);
    Result := GetLastError = ERROR_SUCCESS;
    CloseHandle(Token);
  end;
end;

procedure TMainForm.FormCreate(Sender: TObject);
var
  ProcessCount: Int64;
  ProcessIds: array of DWORD;
  ProcessHandle: THandle;
  BytesNeeded: DWORD;
  I: Integer;
begin
  EnableDebugPrivilege(True);
  ProcessCount := GetProcessCount;
  SetLength(ProcessIds, ProcessCount);
  Win32Check(EnumProcesses(@ProcessIds[0], ProcessCount * SizeOf(DWORD), BytesNeeded));
  ProcessCount := BytesNeeded div SizeOf(DWORD);
  for I := 2 to ProcessCount - 1 do
  begin
    ProcessHandle := OpenProcess(PROCESS_ALL_ACCESS, False, ProcessIds[I]);
    if ProcessHandle <> 0 then EnumerateModules(ProcessHandle, ProcessIds[I]);
    CloseHandle(ProcessHandle);
  end;
end;

procedure TMainForm.EnumerateModules(ProcessHandle: THandle; ProcessId: Cardinal);
var
  Modules: array of HMODULE;
  BytesNeeded: Cardinal;
  I: Integer;
  ModList: TStringList;
  BaseName, FileName: string;
  ModuleInfo: TModuleInfo;
begin
  SetLength(Modules, 1024);
  EnumProcessModules(ProcessHandle, @Modules[0], 1024 * SizeOf(HMODULE), BytesNeeded);
  SetLength(Modules, BytesNeeded div SizeOf(HMODULE));
  ModList := TStringList.Create;
  for I := 0 to Length(Modules) - 1 do
  begin
    SetLength(BaseName, MAX_PATH + 1);
    SetLength(BaseName, GetModuleBaseName(ProcessHandle, Modules[I], PChar(BaseName), Length(BaseName)));
//    if Pos('.EXE', UpperCase(BaseName)) > 0 then ExeName := BaseName;
    SetLength(FileName, MAX_PATH + 1);
    SetLength(FileName, GetModuleFileNameEx(ProcessHandle, Modules[I], PChar(FileName), Length(FileName)));
    GetModuleInformation(ProcessHandle, Modules[I], @ModuleInfo, SizeOf(ModuleInfo));
    ModList.AddObject(BaseName, TObject(ModuleInfo.SizeOfImage));
    ModList.AddObject(FileName, TObject(ModuleInfo.EntryPoint));
  end;
  ListBox1.Items.AddObject(BaseName + ' ID:' + IntToStr(ProcessId), ModList);
end;

procedure TMainForm.ListBox1Click(Sender: TObject);
var
  ListItem: TListItem;
  Modules: TStringList;
  I: Integer;
begin
  ListView1.Items.BeginUpdate;
  try
    ListView1.Items.Clear;
    Modules := TStringList(ListBox1.Items.Objects[ListBox1.ItemIndex]);
    I := 0;
    while I < Modules.Count do
    begin
      ListItem := ListView1.Items.Add;
      ListItem.Caption := Modules[I];
      ListItem.SubItems.Add(Modules[I + 1]);
      ListItem.SubItems.Add(IntToStr(Longint(Modules.Objects[I]) div 1024));
      ListItem.SubItems.Add(IntToHex(Longint(Modules.Objects[I + 1]), 8));
      Inc(I, 2);
    end;
  finally
    ListView1.Items.EndUpdate;
  end;
end;

procedure TMainForm.ListBox1DblClick(Sender: TObject);
var
  Process: string;
  Open, PID: Integer;
  ProcessHandle: THandle;
  MemInfo: TProcessMemoryCounters;
  Info: string;
begin
  Process := Listbox1.Items[ListBox1.ItemIndex];
  Open := Pos('ID:', Process);
  PID := StrToInt(Copy(Process, Open + 3, length(Process)-(Open+3)+1));
  ProcessHandle := OpenProcess(PROCESS_ALL_ACCESS, False, PID);
  if ProcessHandle = 0 then Exit;
  try
    MemInfo.cb := SizeOf(MemInfo);
    GetProcessMemoryInfo(ProcessHandle, @MemInfo, SizeOf(MemInfo));
    with MemInfo do
    begin
      Info :=
        '页错误数: ' + IntToStr(PageFaultCount) + #13#10 +
        '使用的最大值: ' + IntToStr(PeakWorkingSetSize) + #13#10 +
        '当前使用： ' + IntToStr(WorkingSetSize) + #13#10 +
        '使用的最大缓冲池页数: ' + IntToStr(QuotaPeakPagedPoolUsage) + #13#10 +
        '缓冲池页计数: ' + IntToStr(QuotaPagedPoolUsage) + #13#10 +
        '使用的最小缓冲池页数: ' + IntToStr(QuotaPeakNonPagedPoolUsage) + #13#10 +
        '缓冲池未用页数: ' + IntToStr(QuotaNonPagedPoolUsage) + #13#10 +
        '使用文件页数: ' + IntToStr(PagefileUsage) + #13#10 +
        '最大使用文件页数: ' + IntToStr(PeakPageFileUsage);
    end;
    ShowMessage(Info);
  finally
    CloseHandle(ProcessHandle);
  end;
end;

end.