detailnt.pas

《Delphi开发人员指南》配书原码

unit DetailNT;

interface

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

type
  TListType = (ltModules, ltMemory);

  TWinNTDetailForm = class(TBaseDetailForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure DetailTabsChange(Sender: TObject);
  private
    DetailLists: array[TListType] of TStringList;
    procedure ShowList(ListType: TListType);
  public
    procedure NewProcess(ProcessID: DWORD);
  end;

procedure ShowProcessDetails(ProcessID: DWORD);

implementation

uses PSAPI;

{$R *.DFM}

const
  TabStrs: array[0..1] of string[7] = ('Modules', 'Memory');

  { Array of strings which goes into the footer of each list. }
  ACountStrs: array[TListType] of string[31] = (
      'Total Modules: %d', 'Total Pages: %d');

  { Array of strings which goes into the header of each respective list. }
  HeaderStrs: array[TListType] of TDetailStrings = (
    ('Module', 'Base Addr', 'Size', 'Entry Point'),
    ('Page Addr', 'Type', 'Mem Map File', ''));

  SCaptionStr  = 'Details for %s';               // form caption
  SModuleStr   = '%s'#1'$%p'#1'%d bytes'#1'$%p'; // name, addr, size, entry pt
  SMemoryStr   = '$%p'#1'%s'#1'%s';              // addr, type, mem map file

procedure ShowProcessDetails(ProcessID: DWORD);
var
  I: Integer;
begin
  with TWinNTDetailForm.Create(Application) do
    try
      for I := Low(TabStrs) to High(TabStrs) do
        DetailTabs.Tabs.Add(TabStrs[I]);
      NewProcess(ProcessID);
      ShowList(ltModules);
      ShowModal;
    finally
      Free;
    end;
end;

function MemoryTypeToString(Value: DWORD): string;
const
  TypeMask = DWORD($0000000F);
begin
  Result := '';
  case Value and TypeMask of
    1: Result := 'Read-only';
    2: Result := 'Executable';
    4: Result := 'Read/write';
    5: Result := 'Copy on write';
  else
    Result := 'Unknown';
  end;
  if Value and $100 <> 0 then
    Result := Result + ', Shareable';
end;

procedure TWinNTDetailForm.FormCreate(Sender: TObject);
var
  LT: TListType;
begin
  inherited;
  { Dispose of lists }
  for LT := Low(TListType) to High(TListType) do
    DetailLists[LT] := TStringList.Create;
end;

procedure TWinNTDetailForm.FormDestroy(Sender: TObject);
var
  LT: TListType;
begin
  inherited;
  { Dispose of lists }
  for LT := Low(TListType) to High(TListType) do
    DetailLists[LT].Free;
end;

procedure TWinNTDetailForm.NewProcess(ProcessID: DWORD);
const
  AddrMask = DWORD($FFFFF000);
var
  I: Integer;
  Count: DWORD;
  ProcHand: THandle;
  WSPtr: Pointer;
  ModHandles: array[0..$3FFF - 1] of DWORD;
  WorkingSet: array[0..$3FFF - 1] of DWORD;
  ModInfo: TModuleInfo;
  ModName, MapFileName: array[0..MAX_PATH] of char;
begin
  ProcHand := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False,
    ProcessID);
  if ProcHand = 0 then
    raise Exception.Create('No information available for this process/driver');
  try
    EnumProcessModules(ProcHand, @ModHandles, SizeOf(ModHandles), Count);
    for I := 0 to (Count div SizeOf(DWORD)) - 1 do
      if (GetModuleFileNameEx(ProcHand, ModHandles[I], ModName,
        SizeOf(ModName)) > 0) and GetModuleInformation(ProcHand,
        ModHandles[I], @ModInfo, SizeOf(ModInfo)) then
        with ModInfo do
          DetailLists[ltModules].Add(Format(SModuleStr, [ModName, lpBaseOfDll,
            SizeOfImage, EntryPoint]));
    if QueryWorkingSet(ProcHand, @WorkingSet, SizeOf(WorkingSet)) then
      for I := 1 to WorkingSet[0] do
      begin
        WSPtr := Pointer(WorkingSet[I] and AddrMask);
        GetMappedFileName(ProcHand, WSPtr, MapFileName, SizeOf(MapFileName));
        DetailLists[ltMemory].Add(Format(SMemoryStr, [WSPtr,
          MemoryTypeToString(WorkingSet[I]), MapFileName]));
      end;
  finally
    CloseHandle(ProcHand);
  end;
end;

procedure TWinNTDetailForm.ShowList(ListType: TListType);
var
  I: Integer;
begin
  Screen.Cursor := crHourGlass;
  try
    with DetailLB do
    begin
      for I := 0 to 3 do
        Sections[I].Text := HeaderStrs[ListType, i];
      Items.Clear;
      Items.Assign(DetailLists[ListType]);
    end;
     DetailSB.Panels[0].Text := Format(ACountStrs[ListType],
       [DetailLists[ListType].Count]);
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TWinNTDetailForm.DetailTabsChange(Sender: TObject);
begin
  inherited;
  ShowList(TListType(DetailTabs.TabIndex));
end;

end.