unit1.pas

在delphi中实现windows核心编程.原书光盘代码核心编程.原书光盘代码

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,TLHelp32, ComCtrls;
type
 TForm1 = class(TForm)
    Button1: TButton;
    ComboBox1: TComboBox;
    ListView1: TListView;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    IsBreak:boolean;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function GetProcessID(var List:TStringList;FileName:string=''):TProcessEntry32;
var
     Ret : BOOL;
     s:string;
     FProcessEntry32:TProcessEntry32;
     FSnapshotHandle:THandle;
begin
    FSnapshotHandle:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);
    FProcessEntry32.dwSize:=Sizeof(FProcessEntry32);
    Ret:=Process32First(FSnapshotHandle,FProcessEntry32);
    while Ret do
    begin
      s:=ExtractFileName(FProcessEntry32.szExeFile);
      if (FileName='') then
      begin
         List.Add(Pchar(s));
      end
      else if (AnsicompareText(Trim(s),Trim(FileName))=0)and(FileName<>'')then
      begin
         List.Add(Pchar(s));
         result:=FProcessEntry32;
         break;
      end;
      Ret:=Process32Next(FSnapshotHandle,FProcessEntry32);
    end;
    CloseHandle(FSnapshotHandle);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  List:TStringList;
  i:integer;
begin
  Combobox1.clear;
  List:=TStringList.Create;
  GetProcessID(List);
  for i:=0 to List.Count-1 do
    Combobox1.items.add(Trim(List.strings[i]));
  List.Free;
  Combobox1.itemindex:=0;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
 FProcessEntry32:TProcessEntry32;
 PID : integer;
 List:TStringList;
 HeapListHandle:Thandle;
 HeapStruct:THeapEntry32;
 HeapList:THeapList32;
 IsHeapFinish,IsListFinish:boolean;
 ListItem:TListItem;
 flagStr:string;
begin
    Isbreak:=false;
    ListView1.Items.clear;
    if Combobox1.itemindex=-1 then exit;
    List:=TStringList.Create;
    FProcessEntry32:=GetProcessID(List,Combobox1.text);
    if FProcessEntry32.th32ProcessID=0 then exit;
    PID:=FProcessEntry32.th32ProcessID;
    HeapListHandle:=CreateToolhelp32Snapshot(TH32CS_SNAPHeaplist,PID);
    HeapList.dwSize:=sizeof(THeapList32);
    IsListFinish:=Heap32ListFirst(HeapListhandle,HeapList);
    while IsListFinish do
    begin
      Application.ProcessMessages;
      if IsBreak then break;
      HeapStruct.dwSize:=SizeOf(THEAPENTRY32);
      IsHeapFinish:=Heap32First(HeapStruct,PID,HeapList.th32HeapID);
      while IsHeapFinish do
      begin
         Application.ProcessMessages;
         if IsBreak then break;
         try
             ListView1.Items.BeginUpdate;
             ListItem:=ListView1.Items.add;
             ListItem.Caption:=IntTostr(HeapList.th32HeapId);
             Listitem.SubItems.Add(format('$%p',[Pointer(HeapStruct.dwAddress)]));
             ListItem.SubItems.add(format('%d字节',[HeapStruct.dwBlockSize]));
             case HeapStruct.dwFlags of
               LF32_FIXED:
                  flagStr:='固定块';
               LF32_FREE:
                  flagstr:='空闲块';
               LF32_MOVEABLE:
                  flagstr:='可移动块';
             end;
             ListItem.SubItems.add(flagstr);
          finally
             Listview1.Items.EndUpdate;
          end;
         IsHeapFinish:=Heap32Next(HeapStruct);
        end;
       IsListFinish:=Heap32ListNext(HeapListHandle,HeapList);
    end;
    closehandle(HeapListHandle);
    List.Free;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  IsBreak:=true;
end;

end.