main.pas

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

      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);
          Inc(FModules_Cnt);
          Inc(FModules_Size, modBaseSize);
        end;
        Next := Module32Next(SnapProcHandle, ModuleEntry);
      end;
      CloseHandle(SnapProcHandle);
    end;
    AlphaSort;
    ListViewFocusFirstItem(ModulesListView);
  finally
    Items.EndUpdate;
  end;
end;

function TMainForm.CheckProcessesChange: Boolean;
var
  SnapProcHandle: THandle;
  ProcessEntry: TProcessEntry32;
  Next: Boolean;
  ProcessCount: Integer;
  FindItem: TListItem;
begin
  Result := False;
  ProcessCount := 0;
  SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if SnapProcHandle <> THandle(-1) then
  begin
    ProcessEntry.dwSize := Sizeof(ProcessEntry);
    Next := Process32First(SnapProcHandle, ProcessEntry);
    while Next and (not Result) do
    begin
      Inc(ProcessCount);
      FindItem := ProcessListView.FindData(0, Pointer(ProcessEntry.th32ProcessID), True, False);
      if FindItem = nil then
        Result := True
      else
      with FindItem do
        Result := (SubItems.Objects[1] <> Pointer(ProcessEntry.pcPriClassBase)) or
         (SubItems.Objects[2] <> Pointer(ProcessEntry.cntThreads));
      Next := Process32Next(SnapProcHandle, ProcessEntry);
    end;
    CloseHandle(SnapProcHandle);
  end;
  Result := Result or (ProcessCount <> ProcessListView.Items.Count);
end;

function TMainForm.FocusedFileName: TFileName;
begin
  if (ActiveControl = ProcessListView) and (ProcessListView.ItemFocused <> nil) then
    Result := ProcessListView.ItemFocused.SubItems[4] else
  if (ActiveControl = ModulesListView) and (ModulesListView.ItemFocused <> nil) then
    Result := ModulesListView.ItemFocused.SubItems[7] else
  Result := '';
end;

procedure TMainForm.KillProcess(ProcessID: DWORD);
var
  ProcessHandle: THandle;
begin
  ProcessHandle := OpenProcess(PROCESS_ALL_ACCESS{PROCESS_TERMINATE}, False, ProcessID);
  if ProcessHandle <> 0 then
  begin
    TerminateProcess(ProcessHandle, 0);
    if WaitForSingleObject(ProcessHandle, 10000) = WAIT_TIMEOUT then
      MessBox(sWaitTimeout, MB_ICONWARNING);
    CloseHandle(ProcessHandle);
    BuildProcessList;
  end else
    MessBox(sCantOpenForTerminate, MB_ICONERROR);
end;

function TMainForm.SummaryInfo: string;
begin
  if (ActiveControl = ProcessListView) then
    Result := Format(sProcessesSummary , [FProcess_Cnt, FThreads_Cnt]) else
  if (ActiveControl = ModulesListView) then
    Result := Format(sModulesSummary , [FModules_Cnt, IntToExtended(FModules_Size)]) else
  Result := '';
end;

procedure TMainForm.TimerRefresh;
begin
  if not Application.Terminated and IsWindowEnabled(Handle) and CheckProcessesChange then
  begin
    BuildProcessList;
    if BeepOnChange1.Checked then MessageBeep(MB_OK);
  end;
end;

procedure TMainForm.UpdateStatusLine(SummaryOnly: Boolean = False);
var
  FileName: TFileName;
begin
  FileName := FocusedFileName;
  with StatusBar.Panels do
  begin
    BeginUpdate;
    if not SummaryOnly then
    begin
      Items[0].Text := '';
      Items[1].Text := '';
      if VersionResourceAvailable(FileName) then
      try
        with TJclFileVersionInfo.Create(FileName) do
        try
          StatusBar.Panels.Items[0].Text := FileVersion;
          StatusBar.Panels.Items[1].Text := FileDescription;
        finally
          Free;
        end;
      except
      end else
        Items[0].Text := sNotFound;
    end;
    Items[2].Text := SummaryInfo;
    EndUpdate;
  end;
end;

procedure TMainForm.ProcessListViewCompare(Sender: TObject; Item1,
  Item2: TListItem; Data: Integer; var Compare: Integer);
begin
  LVCompare(TListView(Sender), Item1, Item2, Compare);
end;

procedure TMainForm.ProcessListViewColumnClick(Sender: TObject;
  Column: TListColumn);
begin
  LVColumnClick(Column);
end;

procedure TMainForm.ProcessListViewEnter(Sender: TObject);
begin
  UpdateStatusLine;
end;

procedure TMainForm.Exit1Execute(Sender: TObject);
begin
  Close;
end;

procedure TMainForm.BeepOnChange1Execute(Sender: TObject);
begin