main.pas

全世界知名的Open Source Delphi开发组织JCL的作品。JCL包含了很多Delphi和C++Builder中的可重用单元

{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL) - Delphi Tools                                                   }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is Main.pas.                                                                   }
{                                                                                                  }
{ The Initial Developer of the Original Code is Petr Vones. Portions created by Petr Vones are     }
{ Copyright (C) of Petr Vones. All Rights Reserved.                                                }
{                                                                                                  }
{ Contributor(s):                                                                                  }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Last modified: $Date: 2006-05-30 00:02:45 +0200 (mar., 30 mai 2006) $                                                      }
{                                                                                                  }
{**************************************************************************************************}

unit Main;

{$I jcl.inc}
{$IFDEF SUPPORTS_PLATFORM_WARNINGS}
  {$WARN SYMBOL_PLATFORM OFF}
{$ENDIF SUPPORTS_PLATFORM_WARNINGS}

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 COMPILER5_UP}
  ProcessListView.OnInfoTip := ProcessListViewInfoTip;
  ModulesListView.OnInfoTip := ModulesListViewInfoTip;
  {$ELSE COMPILER5_UP}
  InfoTip1.Visible := False;
  {$ENDIF COMPILER5_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);