main.pas

Jedi Code Library JCL JVCL 组件包 JCL+JVCL超过300个组件的非可视/可视大型组件包。

unit Main;

{$I JCL.INC}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, ImgList, StdCtrls, ToolWin, Menus, ActnList, ExtCtrls, IniFiles;

const
  UM_ACTIVATEMAINFORM = WM_USER + $100;

type
  TMainForm = class(TForm)
    ProcessListView: TListView;
    PriorityImagesList: TImageList;
    MainMenu: TMainMenu;
    ActionList1: TActionList;
    Exit1: TAction;
    ExitItem: TMenuItem;
    File1: TMenuItem;
    StatusBar: TStatusBar;
    Tools1: TMenuItem;
    Terminate1: TAction;
    TerminateItem: TMenuItem;
    Refresh1: TAction;
    RefreshItem: TMenuItem;
    About1: TAction;
    Help1: TMenuItem;
    AboutItem: TMenuItem;
    HotTrack1: TAction;
    HotTrackItem: TMenuItem;
    SaveToFile1: TAction;
    SaveItem: TMenuItem;
    N2: TMenuItem;
    FileProperties1: TAction;
    FilePropItem: TMenuItem;
    PopupMenu: TPopupMenu;
    RefreshItemP: TMenuItem;
    SaveItemP: TMenuItem;
    TerminateItemP: TMenuItem;
    PropertyItemP: TMenuItem;
    N3: TMenuItem;
    ChangePriority1: TAction;
    ChangePriorityItem: TMenuItem;
    N5: TMenuItem;
    ChangePriorityItemP: TMenuItem;
    BottomPanel: TPanel;
    ModulesListView: TListView;
    ThreadsListView: TListView;
    Splitter2: TSplitter;
    Splitter1: TSplitter;
    Views1: TMenuItem;
    N1: TMenuItem;
    Copy1: TAction;
    CopyItem: TMenuItem;
    CopyItemP: TMenuItem;
    DumpHeap1: TAction;
    DumpHeapItem: TMenuItem;
    DumpHeapItemP: TMenuItem;
    DumpMemory1: TAction;
    DumpMemory11: TMenuItem;
    MemoryList1: TMenuItem;
    Options1: TMenuItem;
    CoolBar1: TCoolBar;
    ToolBar1: TToolBar;
    RefreshButton: TToolButton;
    HottrackButton: TToolButton;
    ToolButton7: TToolButton;
    CopyButton: TToolButton;
    SaveButton: TToolButton;
    ToolButton3: TToolButton;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    ToolButton4: TToolButton;
    ChangePriButton: TToolButton;
    KillButton: TToolButton;
    PropertyButton: TToolButton;
    ToolButton5: TToolButton;
    InfoTip1: TAction;
    ToolButton8: TToolButton;
    InfoTip2: TMenuItem;
    BeepOnChange1: TAction;
    ToolButton9: TToolButton;
    Beeponchange2: TMenuItem;
    CheckImageBase1: TAction;
    ToolButton11: TToolButton;
    CheckImageBase2: TMenuItem;
    DumpModules1: TAction;
    ToolButton6: TToolButton;
    Moduleslist1: TMenuItem;
    N4: TMenuItem;
    Moduleslist2: TMenuItem;
    DumpPE1: TAction;
    DumpPEfile1: TMenuItem;
    ToolButton10: TToolButton;
    DumpPEfile2: TMenuItem;
    SendMail1: TAction;
    Support1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure ProcessListViewCompare(Sender: TObject; Item1,
      Item2: TListItem; Data: Integer; var Compare: Integer);
    procedure ProcessListViewColumnClick(Sender: TObject;
      Column: TListColumn);
    procedure Exit1Execute(Sender: TObject);
    procedure Terminate1Execute(Sender: TObject);
    procedure Refresh1Execute(Sender: TObject);
    procedure About1Execute(Sender: TObject);
    procedure Terminate1Update(Sender: TObject);
    procedure HotTrack1Execute(Sender: TObject);
    procedure SaveToFile1Update(Sender: TObject);
    procedure SaveToFile1Execute(Sender: TObject);
    procedure FileProperties1Update(Sender: TObject);
    procedure FileProperties1Execute(Sender: TObject);
    procedure ProcessListViewEnter(Sender: TObject);
    procedure ChangePriority1Execute(Sender: TObject);
    procedure Copy1Execute(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure StatusBarResize(Sender: TObject);
    procedure DumpHeap1Execute(Sender: TObject);
    procedure DumpMemory1Execute(Sender: TObject);
    procedure ProcessListViewSelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure ModulesListViewSelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure ProcessListViewInfoTip(Sender: TObject; Item: TListItem;
      var InfoTip: string);
    procedure ModulesListViewInfoTip(Sender: TObject; Item: TListItem;
      var InfoTip: string);
    procedure InfoTip1Execute(Sender: TObject);
    procedure BeepOnChange1Execute(Sender: TObject);
    procedure CheckImageBase1Execute(Sender: TObject);
    procedure ModulesListViewCustomDrawItem(Sender: TCustomListView;
      Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
    procedure DumpModules1Execute(Sender: TObject);
    procedure DumpPE1Update(Sender: TObject);
    procedure ProcessListViewDblClick(Sender: TObject);
    procedure DumpPE1Execute(Sender: TObject);
    procedure SendMail1Execute(Sender: TObject);
    procedure CoolBar1Resize(Sender: TObject);
  private
    FDisableUpdate: Boolean;
    FProcess_Cnt, FThreads_Cnt, FModules_Cnt, FModules_Size: LongWord;
    FIniFile: TIniFile;
    procedure BuildModulesList(ProcessID: DWORD);
    procedure BuildProcessList(Rebuild: Boolean = False);
    procedure BuildThreadsList(ProcessID: DWORD);
    function CheckProcessesChange: Boolean;
    function FocusedFileName: TFileName;
    procedure KillProcess(ProcessID: DWORD);
    procedure LoadSettings;
    procedure RebuildViewsMenuHotKeys;
    procedure SaveSettings;
    function SummaryInfo: string;
    procedure TimerRefresh;
    procedure UpdateListViewsOptions;
    procedure UpdateStatusLine(SummaryOnly: Boolean = False);
    procedure ViewsMenuClick(Sender: TObject);
    procedure WMTimer(var Msg: TWMTimer); message WM_TIMER;
    procedure WMMenuChar(var Msg: TWMMenuChar); message WM_MENUCHAR;
    procedure UMActivateMainForm(var Msg: TMessage); message UM_ACTIVATEMAINFORM;
  public
    procedure AddToViewsMenu(AForm: TForm; const ACaption: string);
    procedure DeleteFromViewsMenu(AForm: TForm);
  end;

var
  MainForm: TMainForm;

implementation

{$R *.DFM}

uses
  TLHelp32, About, ShellAPI, ChangePriority, HeapDump, MemoryDump, Global,
  CommCtrl, JclShell, JclSysInfo, JclFileUtils, JclAppInst, ModulesDump,
  ToolsUtils, FindDlg, PsApi;

resourcestring
  sCantOpenForTerminate = 'Can''t open this process for terminate.';
  sKill = 'Do you really want to kill process "%s" ?';
  sNotFound = 'Not found';
  sSaveProcessesList = 'ToolHelp process list';
  sSaveModulesList = 'Modules used by process %s';
  sSaveThreadsList = 'Threads created by process %s';
  sWaitTimeout = 'Timeout.';
  sProcessesSummary = 'Processes: %d, Threads: %d';
  sModulesSummary = 'Cnt: %d, Tot.Size: %.0n';
  sNotRelocated = '[base]';

const
  PROCESS_CLASS_IDLE          = 4;
  PROCESS_CLASS_NORMAL        = 8;
  PROCESS_CLASS_HIGH          = 13;
  PROCESS_CLASS_TIMECRITICAL  = 24;

function GetPriorityIconIndex(Priority: DWORD): Integer;
begin
  case Priority of
    PROCESS_CLASS_IDLE: Result := 0;
    PROCESS_CLASS_HIGH: Result := 1;
    PROCESS_CLASS_TIMECRITICAL: Result := 2;
  else
    Result := -1;
  end;
end;

function GetProcessVersion(Version: DWORD): string;
var
  C: array[0..2] of Char;
begin
  C[0] := Chr(Lo(LOWORD(Version)));
  C[1] := Chr(Hi(LOWORD(Version)));
  if C[0] < #32 then C[0] := '_';
  if C[1] < #32 then C[1] := '_';
  C[2] := #0;
  Result := Format('%s %d.%d', [C, Hi(HIWORD(Version)), Lo(HIWORD(Version))]);
end;

{ TMainForm }

procedure TMainForm.FormCreate(Sender: TObject);
var
  FileInfo: TSHFileInfo;
  ImageListHandle: THandle;
begin
  {$IFDEF DELPHI5_UP}
  ProcessListView.OnInfoTip := ProcessListViewInfoTip;
  ModulesListView.OnInfoTip := ModulesListViewInfoTip;
  {$ELSE DELPHI5_UP}
  InfoTip1.Visible := False;
  {$ENDIF DELPHI5_UP}
  FIniFile := TIniFile.Create(ChangeFileExt(Application.ExeName, '.ini'));
  LoadSettings;
  ImageListHandle := SHGetFileInfo('', 0, FileInfo, SizeOf(FileInfo),
    SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  SendMessage(ProcessListView.Handle, LVM_SETIMAGELIST, LVSIL_SMALL, ImageListHandle);
  SetTimer(Handle, 1, 500, nil);
  BuildProcessList;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  SaveSettings;
  FIniFile.UpdateFile;
  FIniFile.Free;
  Win32Check(KillTimer(Handle, 1));
end;

procedure TMainForm.BuildProcessList(Rebuild: Boolean = False);
var
  SnapProcHandle, ProcessHandle: THandle;
  ProcessEntry: TProcessEntry32;
  Next: Boolean;
  FileInfo: TSHFileInfo;
  ProcessVersion: DWORD;
  FindItem: TListItem;
  I: Integer;
  ProcList: TList;
  Added, Changed: Boolean;

  procedure CheckChanged;
begin
  if ProcessListView.ItemFocused = FindItem then Changed := True;
end;

begin
  if FDisableUpdate then Exit;
  ProcList := TList.Create;
  Added := False;
  Changed := False;
  with ProcessListView do
  try
    FDisableUpdate := True;
    try
      if Rebuild then
      begin
        Screen.Cursor := crHourGlass;
        Items.BeginUpdate;
        Items.Clear;
        FProcess_Cnt := 0;
        FThreads_Cnt := 0;
      end else
        SendMessage(Handle, WM_SETREDRAW, 0, 0);
      SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
      if SnapProcHandle <> THandle(-1) then
      begin
        ProcessEntry.dwSize := Sizeof(ProcessEntry);
        Next := Process32First(SnapProcHandle, ProcessEntry);
        while Next do
        begin
          ProcList.Add(Pointer(ProcessEntry.th32ProcessID));
          FindItem := FindData(0, Pointer(ProcessEntry.th32ProcessID), True, False);
          with ProcessEntry do if FindItem = nil then
          begin // New Process
            Added := True;
            if IsWin2k then
            begin
              ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, th32ProcessID);
              if Handle <> 0 then
              begin
                if GetModuleFileNameEx(ProcessHandle, 0, szExeFile, SizeOf(szExeFile)) = 0 then
                  StrPCopy(szExeFile, '[Idle]');
                CloseHandle(ProcessHandle);
              end;
            end;
            ProcessVersion := SHGetFileInfo(szExeFile, 0, FileInfo, Sizeof(FileInfo), SHGFI_EXETYPE);
            SHGetFileInfo(szExeFile, 0, FileInfo, Sizeof(FileInfo), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
            with Items.Add, ProcessEntry do
            begin
              Caption := AnsiLowerCase(ExtractFileName(szExeFile));
              Data := Pointer(th32ProcessID);
              ImageIndex := FileInfo.iIcon;
              StateIndex := GetPriorityIconIndex(pcPriClassBase);
              SubItems.AddObject(Format('%.8x', [th32ProcessID]), Pointer(th32ProcessID));
              SubItems.AddObject(Format('%d', [pcPriClassBase]), Pointer(pcPriClassBase));
              SubItems.AddObject(Format('%d', [cntThreads]), Pointer(cntThreads));
              SubItems.AddObject(GetProcessVersion(ProcessVersion), Pointer(ProcessVersion));
              SubItems.Add(szExeFile);
              SubItems.AddObject(Format('(%.8x)', [th32ParentProcessID]), Pointer(th32ParentProcessID));
              Inc(FProcess_Cnt);
              Inc(FThreads_Cnt, cntThreads);
            end;
          end else
          with FindItem do
          begin // Any changes in existing process ?
            if SubItems.Objects[1] <> Pointer(pcPriClassBase) then
            begin
              SubItems.Objects[1] := Pointer(pcPriClassBase);
              SubItems.Strings[1] := Format('%d', [pcPriClassBase]);
              StateIndex := GetPriorityIconIndex(pcPriClassBase);
            end;
            if SubItems.Objects[2] <> Pointer(cntThreads) then
            begin
              Inc(FThreads_Cnt, cntThreads - DWORD(SubItems.Objects[2]));
              SubItems.Objects[2] := Pointer(cntThreads);
              SubItems.Strings[2] := Format('%d', [cntThreads]);
              CheckChanged;
            end;
          end;
          Next := Process32Next(SnapProcHandle, ProcessEntry);
        end;
        CloseHandle(SnapProcHandle);
      end;
      if Added then // find the names of parent processes
      begin
        for I := 0 to Items.Count - 1 do
        begin
          FindItem := FindData(0, Items[I].SubItems.Objects[5], True, False);
          if FindItem <> nil then Items[I].SubItems[5] := FindItem.Caption;
        end;
        AlphaSort;
      end;
      for I := Items.Count - 1 downto 0 do // delete non-existing processes
        if ProcList.IndexOf(Items[I].Data) = -1 then
        begin
          Dec(FProcess_Cnt);
          Dec(FThreads_Cnt, DWORD(Items[I].SubItems.Objects[2]));
          Items.Delete(I);
        end;
      if GetNextItem(nil, sdAll, [isSelected]) = nil then
      begin
        if ItemFocused = nil then ItemFocused := Items[0];
        ItemFocused.Selected := True;
      end else
        if Changed then BuildThreadsList(DWORD(ItemFocused.Data));
      UpdateStatusLine(True);
    finally
      if Rebuild then
        Items.EndUpdate
      else
        SendMessage(Handle, WM_SETREDRAW, 1, 0);
    end;
  finally
    FDisableUpdate := False;
    ProcList.Free;
    Screen.Cursor := crDefault;
  end;
end;

procedure TMainForm.BuildThreadsList(ProcessID: DWORD);
var
  SnapProcHandle: THandle;
  ThreadEntry: TThreadEntry32;
  Next: Boolean;
begin
  with ThreadsListView do
  try
    Items.BeginUpdate;
    Items.Clear;
    SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
    if SnapProcHandle <> THandle(-1) then
    begin
      ThreadEntry.dwSize := Sizeof(ThreadEntry);
      Next := Thread32First(SnapProcHandle, ThreadEntry);
      while Next do
      begin
        if ThreadEntry.th32OwnerProcessID = ProcessID then
          with Items.Add, ThreadEntry do
          begin
            Caption := Format('%.8x', [th32ThreadID]);
            Data := Pointer(th32ThreadID);
            SubItems.AddObject(Format('%d', [tpDeltaPri]), Pointer(tpDeltaPri));
          end;
        Next := Thread32Next(SnapProcHandle, ThreadEntry);
      end;
      CloseHandle(SnapProcHandle);
    end;
    AlphaSort;
    ListViewFocusFirstItem(ThreadsListView);
  finally
    Items.EndUpdate;
  end;
end;

procedure TMainForm.BuildModulesList(ProcessID: DWORD);
var
  SnapProcHandle: THandle;
  ModuleEntry: TModuleEntry32;
  Next: Boolean;
  ImageBase: DWORD;
begin
  with ModulesListView do
  try
    Items.BeginUpdate;
    Items.Clear;
    FModules_Cnt := 0;
    FModules_Size := 0;
    SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcessID);
    if SnapProcHandle <> THandle(-1) then
    begin
      ModuleEntry.dwSize := Sizeof(ModuleEntry);
      Next := Module32First(SnapProcHandle, ModuleEntry);
      while Next do
      begin
        with Items.Add, ModuleEntry do
        begin
          Caption := AnsiLowerCase(szModule);
          SubItems.AddObject(Format('%.8x', [th32ModuleID]), Pointer(th32ModuleID));
          if CheckImageBase1.Checked then
          begin
            ImageBase := GetImageBase(szExePath);
            if ImageBase = DWORD(modBaseAddr) then
              SubItems.AddObject(sNotRelocated, Pointer(0))
            else
             SubItems.AddObject(Format('%.8x', [ImageBase]), Pointer(ImageBase));
          end else
            SubItems.Add('');
          SubItems.AddObject(Format('%p', [modBaseAddr]), Pointer(modBaseAddr));
          SubItems.AddObject(Format('%.0n', [IntToExtended(modBaseSize)]), Pointer(modBaseSize));
          SubItems.AddObject(Format('%d', [GlblcntUsage]), Pointer(GlblcntUsage));
          SubItems.AddObject(Format('%d', [ProccntUsage]), Pointer(ProccntUsage));
          SubItems.AddObject(Format('%.8x', [hModule]), Pointer(hModule));
          SubItems.Add(szExePath);