2005年07月25日

Win32プロセス情報をまるごと取得する方法

WindowsNT、2000、XP
上で動作する各プログラムの
CPU使用率、メモリ使用量、優先順位、
ハンドル数、スレッド数などを取得するには、
どうすればよいか悩んだことかはありませんか?

Win32SDKのヘルプを見ても、
残念ですが、その解決方法は記載されておりません。
ところが、実際に各プロセスの上記情報を取得できる
非公開の(隠された)APIが存在するのです。

我々がMicrosoftOfficeと同等の
ワープロや表計算ソフトをつくったとして、
それらソフトはオリジナルよりも高速に
動作するでしょうか?
おそらく答えは「No」ではないでしょうか。
そこには我々が知り得ない
数々の非公開テクニックがあるからです。

ではさっそく、そのプログラムを公開しましょう。
今回あなたが実際にプログラムを実行して確認出来るように、
Delphiソースを、すべて公開しますから、安心してくださいね。

このプログラムは、
Windowsのタスクマネージャのプロセス一覧と
ほぼ同等の機能を持っています。
約1秒間隔で、Windowsが管理するプロセス情報から、

「NtQuerySystemInformation」

という隠れAPI関数で、各プロセスの情報を取得し、
各プロセスの一覧を作成し表示します。
あとおまけで、
OSのCPU使用率、物理メモリの使用率、
ディスクの使用率の各傾向を、
グラフでビジュアルに表示します。

全ソースは【続きを読む】をクリック!

この記事を読んで役に立ったと思うあなた、
私にビール1本おごってくださいね。(笑い)


【画面イメージ】

WTM24.gif

関連書籍

Copyright guy@かしらもんじ でぇ〜

注意:
 下記ソースファイルは、本ページの管理者である「guy」が個人的に作成しました。
 このソースは作者に断り無く、個人がコピー、改造することは許可しますが、
 いかなる場合であっても、商用目的に使用することを固く禁じます。
 あと、ホームページでの公開の都合上、各ソースの先頭に全角スペースが入ってます。
 あなたがDelphiでコンパイルする前に、この全角スペースを半角スペースに変換してくださいね。

Delphi Project File: WTM.dpr
program WTM;

uses
 Forms,
 WTMUnit in 'WTMUnit.pas' {frmWTM};

{$R *.res}

begin
 Application.Initialize;
 Application.Title := 'WTM';
 Application.CreateForm(TfrmWTM, frmWTM);
 Application.Run;
end.

Delphi Form File: WTMUnit.dfm
object frmWTM: TfrmWTM
 Left = 0
 Top = 0
 Width = 203
 Height = 80
 Caption = 'WTM'
 Color = clBtnFace
 Font.Charset = SHIFTJIS_CHARSET
 Font.Color = clWindowText
 Font.Height = -12
 Font.Name = #65325#65331' '#65328#12468#12471#12483#12463
 Font.Style = []
 Icon.Data = {
  0000010002002020100000000000E80200002600000010101000000000002801
  00000E0300002800000020000000400000000100040000000000800200000000
  0000000000000000000000000000000000000000800000800000008080008000
  0000800080008080000080808000C0C0C0000000FF0000FF000000FFFF00FF00
  0000FF00FF00FFFF0000FFFFFF00000000000000000000000000000000000000
  0000000000000000000000000000000000000000000000000000000000000000
  0000000000000000000000000000007777777777777777777777777770000F88
  88888888888888888888888887000F88FFFFFFFFFFFFFFFFFFFFFFF887000F87
  00000000000000000000000F87000F8700200200200200200200200F87000F87
  02222222222222222222220F87000F8700200200200200200200200F87000F87
  00200200200200200200200F87000F8702222222222222222222220F87000F87
  0FFF020020020FFF0200200F87000F870020F2002002F020F200200F87000F87
  02222F22222F22222F22220F87000F8700200F00200F00200F00200F87000F87
  002002F020F2002002F0200F87000F870222222FFF222222222FFF0F87000F87
  00200200200200200200200F87000F8700200200200200200200200F87000F87
  02222222222222222222220F87000F8700200200200200200200200F87000F87
  00200200200200200200200F87000F8700000000000000000000000F87000F88
  77777777777777777777777887000F88888888888888888888888888870000FF
  FFFFFFFFFFFFFFFFFFFFFFFFF000000000000000000000000000000000000000
  0000000000000000000000000000000000000000000000000000000000000000
  0000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFC00000078000
  0003000000010000000100000001000000010000000100000001000000010000
  0001000000010000000100000001000000010000000100000001000000010000
  000100000001000000010000000100000001000000010000000180000003C000
  0007FFFFFFFFFFFFFFFFFFFFFFFF280000001000000020000000010004000000
  0000C00000000000000000000000000000000000000000000000000080000080
  00000080800080000000800080008080000080808000C0C0C0000000FF0000FF
  000000FFFF00FF000000FF00FF00FFFF0000FFFFFF0000000000000000000000
  00000000000000888888888888000F000000000000800F020020020020800F02
  2222222220800F0F00200FFF20800F02F020F200F0800F02F222F22220800F02
  0FFF020020800F020020020020800F022222222220800F000000000000800FFF
  FFFFFFFFFF0000000000000000000000000000000000FFFF0000800100000000
  0000000000000000000000000000000000000000000000000000000000000000
  000000000000000000000000000080010000FFFF0000}
 OldCreateOrder = False
 OnCreate = FormCreate
 OnDestroy = FormDestroy
 PixelsPerInch = 96
 TextHeight = 12
 object lvWTM: TListView
  Left = 0
  Top = 0
  Width = 178
  Height = 0
  Align = alClient
  BevelInner = bvNone
  BevelOuter = bvNone
  Columns = <
   item
    AutoSize = True
    Caption = 'Image Name'
   end
   item
    Alignment = taRightJustify
    AutoSize = True
    Caption = 'PID'
   end
   item
    Alignment = taRightJustify
    AutoSize = True
    Caption = 'CPU'
   end
   item
    Alignment = taRightJustify
    AutoSize = True
    Caption = 'CPU Time'
   end
   item
    Alignment = taRightJustify
    AutoSize = True
    Caption = 'Mem Usage'
   end
   item
    Alignment = taRightJustify
    AutoSize = True
    Caption = 'VM Size'
   end
   item
    Alignment = taRightJustify
    AutoSize = True
    Caption = 'Base Priority'
   end
   item
    Alignment = taRightJustify
    AutoSize = True
    Caption = 'Handles'
   end
   item
    Alignment = taRightJustify
    AutoSize = True
    Caption = 'Threads'
   end>
  ReadOnly = True
  RowSelect = True
  TabOrder = 0
  ViewStyle = vsReport
  OnColumnClick = lvWTMColumnClick
  OnCompare = lvWTMCompare
 end
 object pnlWTM: TPanel
  Left = 0
  Top = 0
  Width = 178
  Height = 47
  Align = alBottom
  TabOrder = 1
  object pnlCPU: TPanel
   Left = 1
   Top = 1
   Width = 176
   Height = 15
   Align = alTop
   TabOrder = 0
   object igCPU: TImage
    Left = 143
    Top = 1
    Width = 32
    Height = 13
    Align = alRight
   end
   object stCPU: TStaticText
    Left = 111
    Top = 1
    Width = 32
    Height = 13
    Align = alRight
    Alignment = taRightJustify
    AutoSize = False
    BorderStyle = sbsSunken
    Color = clLime
    Font.Charset = SHIFTJIS_CHARSET
    Font.Color = clBlack
    Font.Height = -12
    Font.Name = #65325#65331' '#65328#12468#12471#12483#12463
    Font.Style = []
    ParentColor = False
    ParentFont = False
    TabOrder = 1
   end
   object pbCPU: TProgressBar
    Left = 1
    Top = 1
    Width = 110
    Height = 13
    Align = alClient
    ParentShowHint = False
    ShowHint = True
    TabOrder = 0
   end
  end
  object pnlMEM: TPanel
   Left = 1
   Top = 16
   Width = 176
   Height = 15
   Align = alBottom
   TabOrder = 1
   object igMEM: TImage
    Left = 143
    Top = 1
    Width = 32
    Height = 13
    Align = alRight
   end
   object pbMEM: TProgressBar
    Left = 1
    Top = 1
    Width = 110
    Height = 13
    Align = alClient
    ParentShowHint = False
    ShowHint = True
    TabOrder = 0
   end
   object stMEM: TStaticText
    Left = 111
    Top = 1
    Width = 32
    Height = 13
    Align = alRight
    Alignment = taRightJustify
    AutoSize = False
    BorderStyle = sbsSunken
    Color = clYellow
    Font.Charset = SHIFTJIS_CHARSET
    Font.Color = clBlack
    Font.Height = -12
    Font.Name = #65325#65331' '#65328#12468#12471#12483#12463
    Font.Style = []
    ParentColor = False
    ParentFont = False
    TabOrder = 1
   end
  end
  object pnlVOL: TPanel
   Left = 1
   Top = 31
   Width = 176
   Height = 15
   Align = alBottom
   TabOrder = 2
   object igVOL: TImage
    Left = 143
    Top = 1
    Width = 32
    Height = 13
    Align = alRight
   end
   object pbVOL: TProgressBar
    Left = 1
    Top = 1
    Width = 110
    Height = 13
    Align = alClient
    ParentShowHint = False
    ShowHint = True
    TabOrder = 0
   end
   object stVOL: TStaticText
    Left = 111
    Top = 1
    Width = 32
    Height = 13
    Align = alRight
    Alignment = taRightJustify
    AutoSize = False
    BorderStyle = sbsSunken
    Color = clFuchsia
    Font.Charset = SHIFTJIS_CHARSET
    Font.Color = clBlack
    Font.Height = -12
    Font.Name = #65325#65331' '#65328#12468#12471#12483#12463
    Font.Style = []
    ParentColor = False
    ParentFont = False
    TabOrder = 1
   end
  end
 end
 object tmrWTM: TTimer
  OnTimer = tmrWTMTimer
  Left = 2
  Top = 2
 end
end

Delphi Source File: WTMUnit.pas
unit WTMUnit;

interface

uses
 Classes,
 ComCtrls,
 Controls,
 Dialogs,
 ExtCtrls,
 Forms,
 Gauges,
 Graphics,
 Math,
 Messages,
 StdCtrls,
 SysUtils,
 Variants,
 Windows,
 //----------------------------------------------------------------------------
 winternl;

const
 //----------------------------------------------------------------------------
 BUF1SIZE = 65536;
 BUF2SIZE = 10240;

type
 //----------------------------------------------------------------------------
 TfrmWTM = class(TForm)
  tmrWTM: TTimer;
  pnlWTM: TPanel;
  pnlCPU: TPanel;
  pnlMEM: TPanel;
  pnlVOL: TPanel;
  pbCPU: TProgressBar;
  pbMEM: TProgressBar;
  pbVOL: TProgressBar;
  stCPU: TStaticText;
  stMEM: TStaticText;
  stVOL: TStaticText;
  igCPU: TImage;
  igMEM: TImage;
  igVOL: TImage;
  lvWTM: TListView;
  procedure FormCreate(Sender: TObject);
  procedure FormDestroy(Sender: TObject);
  procedure tmrWTMTimer(Sender: TObject);
  procedure lvWTMColumnClick(Sender: TObject; Column: TListColumn);
  procedure lvWTMCompare(Sender: TObject; Item1, Item2: TListItem;
   Data: Integer; var Compare: Integer);
 private
  FBuf1: array[0..BUF1SIZE-1] of Byte;
  FBuf2: array[0..BUF2SIZE-1] of Byte;
  FOldIdlTime,
  FOldSysTime,
  FOldAllTime: Int64;
  FOldExeList: TList;
  FOldExeTime: TStringList;
  FSortToggle: Boolean;
  FSortColumn: Integer;
  procedure GetCPUUsage;
  procedure GetMEMUsage;
  procedure GetVOLUsage;
  procedure UpdateModuleView;
  procedure UpdateUsageGraph(pImage: TImage; pColor: TColor; pUsage: Integer);
 public
 end;

var
 frmWTM: TfrmWTM;

implementation

{$R *.dfm}

//------------------------------------------------------------------------------
procedure TfrmWTM.GetCPUUsage;
var
 lTime: Double;
 lInfo1: TSYSTEM_BASIC_INFORMATION;
 lInfo2: TSYSTEM_PERFORMANCE_INFORMATION;
 lInfo3: TSYSTEM_TIME_INFORMATION;
begin
 if
  (NtQuerySystemInformation(
   SystemBasicInformation, @lInfo1, Sizeof(lInfo1), Nil) <> 0) or
  (NtQuerySystemInformation(
   SystemPerformanceInformation, @lInfo2, Sizeof(lInfo2), Nil) <> 0) or
  (NtQuerySystemInformation(
   SystemTimeOfDayInformation, @lInfo3, Sizeof(lInfo3), Nil) <> 0) then
  Exit;
 if (FOldIdlTime <> 0) then
 begin
  lTime := lInfo3.liKeSystemTime.QuadPart - FOldSysTime;
  if (lTime <> 0) then
  begin
   lTime := (lInfo2.liIdleTime.QuadPart - FOldIdlTime) / lTime;
   pbCPU.Position :=
    Round(100.0 - lTime * 100.0 / lInfo1.bKeNumberProcessors);
   if (pbCPU.Position <= 0) then pbCPU.Position := 1;
   pbCPU.Hint := Format('CPU使用率:%d(%%)', [pbCPU.Position]);
   stCPU.Caption := Format('%d %%', [pbCPU.Position]);
   Application.Title := Format('WTM %s', [stCPU.Caption]);
   UpdateUsageGraph(igCPU, stCPU.Color, pbCPU.Position);
  end;
 end;
 FOldIdlTime := lInfo2.liIdleTime.QuadPart;
 FOldSysTime := lInfo3.liKeSystemTime.QuadPart;
end;

procedure TfrmWTM.GetMEMUsage;
var
 lSts: MEMORYSTATUS;
 lTmp: Integer;
begin
 GlobalMemoryStatus(lSts);
 lSts.dwTotalPhys := lSts.dwTotalPhys div 1024;
 lSts.dwAvailPhys := lSts.dwAvailPhys div 1024;
 pbMEM.Max := lSts.dwTotalPhys;
 pbMEM.Position := lSts.dwTotalPhys - lSts.dwAvailPhys;
 pbMEM.Hint := Format('メモリ使用量:%d(KB), 利用可能:%d(KB), 合計:%d(KB)',
  [pbMEM.Position, lSts.dwAvailPhys, lSts.dwTotalPhys]);
 lTmp := pbMEM.Position * 100 div pbMEM.Max;
 stMEM.Caption := Format('%d %%', [lTmp]);
 UpdateUsageGraph(igMEM, stMEM.Color, lTmp);
end;

//------------------------------------------------------------------------------
procedure TfrmWTM.GetVOLUsage;
var
 lSPC,
 lBPS,
 lNFC,
 lTNC: DWORD;
 lVOL: String;
 lTmp: Integer;
begin
 lVol := Copy(GetEnvironmentVariable('WINDIR'), 1, 3);
 if (GetDiskFreeSpace(PChar(lVol), lSPC, lBPS, lNFC, lTNC)) then
 begin
  pbVOL.Max := lTNC;
  pbVOL.Position := lTNC - lNFC;
  pbVOL.Hint := Format('ディスク使用量:%d(KB), 利用可能:%d(KB), 合計:%d(KB)',
   [pbVOL.Position div 1024 * lSPC * lBPS,
    lNFC div 1024 * lSPC * lBPS, lTNC div 1024 * lSPC * lBPS]);
  lTmp := pbVOL.Position * 100 div pbVOL.Max;
  stVOL.Caption := Format('%d %%', [lTmp]);
  UpdateUsageGraph(igVOL, stVOL.Color, lTmp);
 end;
end;

//------------------------------------------------------------------------------
procedure TfrmWTM.UpdateModuleView;
 //----------------------------------------------------------------------------
 function GetStrElaps(pElaps: Int64): String;
 begin
  Result := Format('%d:%.2d:%.2d', [
   pElaps div 3600, (pElaps mod 3600) div 60, pElaps mod 60]);
 end;
 //----------------------------------------------------------------------------
 function GetOldExeTime(pPID: Integer; var pIndex: Integer): Int64;
 var
  lCnt,
  lPos: Integer;
  lTmp: String;
 begin
  Result := 0;
  pIndex := -1;
  for lCnt := 0 to FOldExeTime.Count-1 do
  begin
   lTmp := FOldExeTime[lCnt];
   lPos := Pos(':', lTmp);
   if (StrToInt(Copy(lTmp, 1, lPos-1)) = pPID) then
   begin
    Result := StrToInt64(Copy(lTmp, lPos+1, Length(lTmp)));
    pIndex := lCnt;
    Exit;
   end;
  end;
 end;
 //----------------------------------------------------------------------------
 procedure SetOldExeTime(pIndex, pPID: Integer; pTime: Int64);
 var
  lTmp: String;
 begin
  lTmp := Format('%d:%d', [pPID, pTime]);
  if (pIndex < 0) then
   FOldExeTime.Add(lTmp)
  else
   FOldExeTime[pIndex] := lTmp;
 end;
 //----------------------------------------------------------------------------
 procedure DelOldExeTime(pPID: Integer);
 var
  lCnt: Integer;
 begin
  for lCnt := 0 to FOldExeTime.Count-1 do
  begin
   if
    (StrToInt(
     Copy(FOldExeTime[lCnt], 1,
      Pos(':', FOldExeTime[lCnt]) - 1)) = pPID) then
   begin
    FOldExeTime.Delete(lCnt);
    Exit;
   end;
  end;
 end;
var
 lCnt1,
 lCnt2: Integer;
 lInfo: PSYSTEM_PROCESS_INFORMATION;
 lItem: TListItem;
 lRate,
 lTim1,
 lTim2,
 lTim3,
 lTim4: Int64;
 lTemp: String;
begin
 if
  (NtQuerySystemInformation(
   SystemProcessInformation, @FBuf1, BUF1SIZE, Nil) = 0) then
 begin
  for lCnt1 := 0 to lvWTM.Items.Count-1 do
   FOldExeList.Add(lvWTM.Items[lCnt1]);
  //-----
  lCnt1 := 0;
  lTim1 := 0;
  while (True) do
  begin
   lInfo := @FBuf1[lCnt1];
   Inc(lTim1,
    (lInfo.qUserTime.QuadPart+lInfo.qKernelTime.QuadPart) div 10000);
   if (lInfo.dNext = 0) then Break;
   Inc(lCnt1, lInfo.dNext);
  end;
  lTim2 := lTim1 - FOldAllTime;
  FOldAllTime := lTim1;
  //-----
  lCnt1 := 0;
  while (True) do
  begin
   lInfo := @FBuf1[lCnt1];
   //------------------------------------------------------------------------
   lItem := Nil;
   for lCnt2 := 0 to lvWTM.Items.Count-1 do
   begin
    if
     (StrToInt(lvWTM.Items[lCnt2].SubItems[0]) =
      lInfo.dUniqueProcessId) then
    begin
     lItem := lvWTM.Items[lCnt2];
     FOldExeList.Remove(lItem);
     Break;
    end;
   end;
   if (lItem = Nil) then
   begin
    lItem := lvWTM.Items.Add;
    // Image Name
    UnicodeToUtf8(@FBuf2, lInfo.usName, BUF2SIZE-1);
    lItem.Caption := Utf8ToAnsi(PChar(@FBuf2));
    // PID
    lItem.SubItems.Add(IntToStr(lInfo.dUniqueProcessId));
    for lCnt2 := 1 to 7 do
     lItem.SubItems.Add('');
   end;
   // CPU
   lRate := 0;
   lTim3 := GetOldExeTime(lInfo.dUniqueProcessId, lCnt2);
   lTim4 :=
    (lInfo.qUserTime.QuadPart+lInfo.qKernelTime.QuadPart) div 10000;
   if (lTim3 <> 0) and (lTim2 <> 0) then
    lRate := Round((lTim4-lTim3) * 100.0 / lTim2);
   SetOldExeTime(lCnt2, lInfo.dUniqueProcessId, lTim4);
   lTemp := Format('%.2d', [lRate]);
   if (lItem.SubItems[1] <> lTemp) then
    lItem.SubItems[1] := lTemp;
   // CPU Time
   lTemp := GetStrElaps(lTim4 div 1000);
   if (lItem.SubItems[2] <> lTemp) then
    lItem.SubItems[2] := lTemp;
   // Mem Usage
   lTemp := Format('%d K', [lInfo.WorkingSetSize div 1024]);
   if (lItem.SubItems[3] <> lTemp) then
    lItem.SubItems[3] := lTemp;
   // VM Size
   lTemp := Format('%d K', [lInfo.PagefileUsage div 1024]);
   if (lItem.SubItems[4] <> lTemp) then
    lItem.SubItems[4] := lTemp;
   // Base Priority
   lTemp := IntToStr(lInfo.BasePriority);
   if (lItem.SubItems[5] <> lTemp) then
    lItem.SubItems[5] := lTemp;
   // Handles
   lTemp := IntToStr(lInfo.dHandleCount);
   if (lItem.SubItems[6] <> lTemp) then
    lItem.SubItems[6] := lTemp;
   // Threads
   lTemp := IntToStr(lInfo.dThreadCount);
   if (lItem.SubItems[7] <> lTemp) then
    lItem.SubItems[7] := lTemp;
   //------------------------------------------------------------------------
   if (lInfo.dNext = 0) then Break;
   Inc(lCnt1, lInfo.dNext);
  end;
  while (FOldExeList.Count > 0) do
  begin
   lCnt1 := lvWTM.Items.IndexOf(FOldExeList[0]);
   DelOldExeTime(StrToInt(lvWTM.Items[lCnt1].SubItems[0]));
   lvWTM.Items.Delete(lCnt1);
   FOldExeList.Delete(0);
  end;
  if (FSortColumn > 0) then lvWTM.AlphaSort;
 end;
end;

//------------------------------------------------------------------------------
procedure TfrmWTM.UpdateUsageGraph(
 pImage: TImage; pColor: TColor; pUsage: Integer);
begin
 with pImage do
 begin
  Canvas.CopyMode := cmSrcCopy;
  Canvas.CopyRect(Rect(1,0,Width,Height), Canvas, Rect(2,0,Width,Height));
  Canvas.Pen.Width := 2;
  Canvas.Pen.Color := pColor;
  Canvas.Polyline(
   [Point(Width-2,Height-1),
    Point(Width-2,Height - Height * pUsage div 100)]);
 end;
end;

//------------------------------------------------------------------------------
procedure TfrmWTM.FormCreate(Sender: TObject);
begin
 inherited;

 FOldIdlTime := 0;
 FOldSysTime := 0;
 FOldAllTime := 0;
 FOldExeList := TList.Create;
 FOldExeTime := TStringList.Create;
 FSortToggle := False;
 FSortColumn := -1;

 igCPU.Canvas.Brush.Color := clBlack;
 igCPU.Canvas.Rectangle(Rect(0,0,igCPU.Width,igCPU.Height));
 igMEM.Canvas.Brush.Color := clBlack;
 igMEM.Canvas.Rectangle(Rect(0,0,igMEM.Width,igMEM.Height));
 igVOL.Canvas.Brush.Color := clBlack;
 igVOL.Canvas.Rectangle(Rect(0,0,igVOL.Width,igVOL.Height));

 frmWTM.ClientWidth := pnlWTM.Width;
 frmWTM.ClientHeight := pnlWTM.Height;
end;

//------------------------------------------------------------------------------
procedure TfrmWTM.FormDestroy(Sender: TObject);
begin
 if (FOldExeList <> Nil) then
 begin
  FOldExeList.Free;
  FOldExeList := Nil;
 end;
 if (FOldExeTime <> Nil) then
 begin
  FOldExeTime.Free;
  FOldExeTime := Nil;
 end;

 inherited;
end;

//------------------------------------------------------------------------------
procedure TfrmWTM.tmrWTMTimer(Sender: TObject);
begin
 if (tmrWTM.Tag <> 0) then Exit;
 try
  tmrWTM.Tag := 1;
  //-----
  GetCPUUsage;
  GetMEMUsage;
  GetVOLUsage;
  UpdateModuleView;
 finally
  tmrWTM.Tag := 0;
 end;
end;

//------------------------------------------------------------------------------
procedure TfrmWTM.lvWTMColumnClick(Sender: TObject; Column: TListColumn);
begin
 if (FSortColumn = Column.Index) then
  FSortToggle := not FSortToggle
 else
  FSortToggle := False;
 FSortColumn := Column.Index;
 (Sender as TCustomListView).AlphaSort;
end;

//------------------------------------------------------------------------------
procedure TfrmWTM.lvWTMCompare(Sender: TObject; Item1, Item2: TListItem;
 Data: Integer; var Compare: Integer);
 //----------------------------------------------------------------------------
 function StrToInt1(pString: String): Integer;
 var
  lPos: Integer;
 begin
  lPos := Pos(':', pString);
  Result :=
   StrToInt(Copy(pString, 1, lPos-1)) * 3600 +
    StrToInt(Copy(pString, lPos+1, 2)) * 60 +
     StrToInt(Copy(pString, lPos+4, 2));
 end;
 //----------------------------------------------------------------------------
 function StrToInt2(pString: String): Integer;
 begin
  Result := StrToInt(Copy(pString, 1, Pos(' ', pString)-1));
 end;
var
 lIdx: Integer;
 lTx1,
 lTx2: String;
begin
 if (FSortColumn = 0) then
 begin
  if (FSortToggle) then
   Compare := CompareText(Item2.Caption, Item1.Caption)
  else
   Compare := CompareText(Item1.Caption, Item2.Caption);
 end
 else begin
  lIdx := FSortColumn - 1;
  case lIdx of
   2:
   begin
    lTx1 := Format('%.10d%', [StrToInt1(Item1.SubItems[lIdx])]);
    lTx2 := Format('%.10d%', [StrToInt1(Item2.SubItems[lIdx])]);
   end;
   3,4:
   begin
    lTx1 := Format('%.10d%', [StrToInt2(Item1.SubItems[lIdx])]);
    lTx2 := Format('%.10d%', [StrToInt2(Item2.SubItems[lIdx])]);
   end;
   else
   begin
    lTx1 := Format('%.10d%', [StrToInt(Item1.SubItems[lIdx])]);
    lTx2 := Format('%.10d%', [StrToInt(Item2.SubItems[lIdx])]);
   end;
  end;
  if (FSortToggle) then
   Compare := CompareText(lTx2, lTx1)
  else
   Compare := CompareText(lTx1, lTx2);
 end;
end;

end.

Delphi Source File: winternl.pas
unit winternl;

interface

uses
 Windows;

const
 //----------------------------------------------------------------------------
 ntdll = 'ntdll.dll';
 //----------------------------------------------------------------------------
 SystemBasicInformation = 0;
 SystemPerformanceInformation = 2;
 SystemTimeOfDayInformation = 3;
 SystemProcessInformation = 5;
 SystemProcessorPerformanceInformation = 8;
 SystemInterruptInformation = 23;
 SystemExceptionInformation = 33;
 SystemRegistryQuotaInformation = 37;
 SystemLookasideInformation = 45;

type
 //----------------------------------------------------------------------------
 _SYSTEM_BASIC_INFORMATION = packed record
  dwUnknown1: DWORD;
  uKeMaximumIncrement: ULONG;
  uPageSize: ULONG;
  uMmNumberOfPhysicalPages: ULONG;
  uMmLowestPhysicalPage: ULONG;
  uMmHighestPhysicalPage: ULONG;
  uAllocationGranularity: ULONG;
  pLowestUserAddress: Pointer;
  pMmHighestUserAddress: Pointer;
  uKeActiveProcessors: ULONG;
  bKeNumberProcessors: byte;
  bUnknown2: byte;
  wUnknown3: word;
 end;
 TSYSTEM_BASIC_INFORMATION = _SYSTEM_BASIC_INFORMATION;
 PSYSTEM_BASIC_INFORMATION = ^TSYSTEM_BASIC_INFORMATION;
 //----------------------------------------------------------------------------
 _SYSTEM_PERFORMANCE_INFORMATION = packed record
  liIdleTime: LARGE_INTEGER; {LARGE_INTEGER}
  dwSpare: array[0..75] of DWORD;
 end;
 TSYSTEM_PERFORMANCE_INFORMATION = _SYSTEM_PERFORMANCE_INFORMATION;
 PSYSTEM_PERFORMANCE_INFORMATION = ^TSYSTEM_PERFORMANCE_INFORMATION;
 //----------------------------------------------------------------------------
 _SYSTEM_TIME_INFORMATION = packed record
  liKeBootTime: LARGE_INTEGER;
  liKeSystemTime: LARGE_INTEGER;
  liExpTimeZoneBias: LARGE_INTEGER;
  uCurrentTimeZoneId: ULONG;
  dwReserved: DWORD;
 end;
 TSYSTEM_TIME_INFORMATION = _SYSTEM_TIME_INFORMATION;
 PSYSTEM_TIME_INFORMATION = ^TSYSTEM_TIME_INFORMATION;
 //----------------------------------------------------------------------------
 _SYSTEM_PROCESS_INFORMATION = packed record
  dNext: DWORD;        // relative offset
  dThreadCount: DWORD;
  dReserved01: DWORD;
  dReserved02: DWORD;
  dReserved03: DWORD;
  dReserved04: DWORD;
  dReserved05: DWORD;
  dReserved06: DWORD;
  qCreateTime: LARGE_INTEGER; // relative to 01-01-1601
  qUserTime: LARGE_INTEGER;  // 100 nsec units
  qKernelTime: LARGE_INTEGER; // 100 nsec units
  usLength: WORD;       // UNICODE_STRING
  usMaximumLength: WORD;   // UNICODE_STRING
  usName: Pointer;      // UNICODE_STRING
  BasePriority: DWORD;
  dUniqueProcessId: DWORD;
  dInheritedFromUniqueProcessId: DWORD;
  dHandleCount: DWORD;
  dReserved07: DWORD;
  dReserved08: DWORD;
  PeakVirtualSize: DWORD;
  VirtualSize: DWORD;
  PageFaultCount: DWORD;
  PeakWorkingSetSize: DWORD;
  WorkingSetSize: DWORD;
  QuotaPeakPagedPoolUsage: DWORD;
  QuotaPagedPoolUsage: DWORD;
  QuotaPeakNonPagedPoolUsage: DWORD;
  QuotaNonPagedPoolUsage: DWORD;
  PagefileUsage: DWORD;
  PeakPagefileUsage: DWORD;
  dCommitCharge: DWORD;    // bytes
  // ast: array[0..n] of SYSTEM_THREAD;
 end;
 TSYSTEM_PROCESS_INFORMATION = _SYSTEM_PROCESS_INFORMATION;
 PSYSTEM_PROCESS_INFORMATION = ^TSYSTEM_PROCESS_INFORMATION;
 //----------------------------------------------------------------------------
 _SYSTEM_THREAD_INFORMATION = record
  qKernelTime: LARGE_INTEGER; // 100 nsec units
  qUserTime: LARGE_INTEGER;  // 100 nsec units
  qCreateTime: LARGE_INTEGER; // relative to 01-01-1601
  d18: DWORD;
  pStartAddress: Pointer;
  UniqueProcess: INTEGER;
  UniqueThread: INTEGER;
  dPriority: DWORD;
  dBasePriority: DWORD;
  dContextSwitches: DWORD;
  dThreadState: DWORD;    // 2=running, 5=waiting
  WaitReason: DWORD;
  dReserved01: DWORD;
 end;
 TSYSTEM_THREAD_INFORMATION = _SYSTEM_THREAD_INFORMATION;
 PSYSTEM_THREAD_INFORMATION = ^TSYSTEM_THREAD_INFORMATION;
 //----------------------------------------------------------------------------
 function NtQuerySystemInformation(
  pSystemInformationClass: Integer; // IN SYSTEM_INFORMATION_CLASS SystemInformationClass
  pSystemInformation: Pointer;    // OUT PVOID SystemInformation
  pSystemInformationLength: Integer; // IN ULONG SystemInformationLength
  pReturnLength: Pointer       // OUT PULONG ReturnLength OPTIONAL
 ): Integer; stdcall;

implementation

function NtQuerySystemInformation;
 external ntdll name 'NtQuerySystemInformation';

end.

posted by guy at 07:52 | 運用管理編
×

この広告は1年以上新しい記事の投稿がないブログに表示されております。