内存泄露检测方法

Delphi 2007 下面,在主窗口的 FormCreate 加一条 
ReportMemoryLeaksOnShutdown:=true; 
有内存泄漏,会弹出一个对话框. 
CheckMem检测程序的内存泄漏 ,使用方法很简单,把 CHECKMem.pas 加到工程代码的第一行,重新编译程序. 
再运行exe文件 . 有内存泄漏在本目录下 生成 CheckMemory.Log文件. 
CheckMem.pas 
unit CheckMem; //Add it to the first line of project uses 
interface 
procedure SnapCurrMemStatToFile(Filename: string); 
implementation 
uses 
Windows, SysUtils, TypInfo; 
const 
MaxCount = High(Word); 
var 
OldMemMgr: TMemoryManager; 
ObjList: array[0..MaxCount] of Pointer; 
FreeInList: Integer = 0; 
GetMemCount: Integer = 0; 
FreeMemCount: Integer = 0; 
ReallocMemCount: Integer = 0; 
procedure AddToList(P: Pointer); 
begin 
if FreeInList > High(ObjList) then 
begin 
MessageBox(0, '内存管理监视器指针列表溢出，请增大列表项数！', '内存管理监视器', mb_ok); 
Exit; 
end; 
ObjList[FreeInList] := P; 
Inc(FreeInList); 
end; 
procedure RemoveFromList(P: Pointer); 
var 
I: Integer; 
begin 
for I := 0 to FreeInList - 1 do 
if ObjList[I] = P then 
begin 
Dec(FreeInList); 
Move(ObjList[I + 1], ObjList[I], (FreeInList - I) * SizeOf(Pointer)); 
Exit; 
end; 
end; 
procedure SnapCurrMemStatToFile(Filename: string); 
const 
FIELD_WIDTH = 20; 
var 
OutFile: TextFile; 
I, CurrFree, BlockSize: Integer; 
HeapStatus: THeapStatus; 
Item: TObject; 
ptd: PTypeData; 
ppi: PPropInfo; 
procedure Output(Text: string; Value: integer); 
begin 
Writeln(OutFile, Text: FIELD_WIDTH, Value div 1024, ' KB(', Value, ' Byte)'); 
end; 
begin 
AssignFile(OutFile, Filename); 
try 
if FileExists(Filename) then 
begin 
Append(OutFile); 
Writeln(OutFile); 
end 
else 
Rewrite(OutFile); 
CurrFree := FreeInList; 
HeapStatus := GetHeapStatus; { 局部堆状态 } 
with HeapStatus do 
begin 
Writeln(OutFile, '===== ', ExtractFileName(ParamStr(0)), ',', DateTimeToStr(Now), ' ====='); 
Writeln(OutFile); 
Output('可用地址空间 : ', TotalAddrSpace); 
Output('未提交部分 : ', TotalUncommitted); 
Output('已提交部分 : ', TotalCommitted); 
Output('空闲部分 : ', TotalFree); 
Output('已分配部分 : ', TotalAllocated); 
Output('全部小空闲内存块 : ', FreeSmall); 
Output('全部大空闲内存块 : ', FreeBig); 
Output('其它未用内存块 : ', Unused); 
Output('内存管理器消耗 : ', Overhead); 
Writeln(OutFile, '地址空间载入 : ': FIELD_WIDTH, TotalAllocated div (TotalAddrSpace div 100), '%'); 
end; 
Writeln(OutFile); 
Writeln(OutFile, Format('当前出现 %d 处内存漏洞 :', [GetMemCount - FreeMemCount])); 
for I := 0 to CurrFree - 1 do 
begin 
Write(OutFile, I: 4, ') ', IntToHex(Cardinal(ObjList[I]), 16), ' - '); 
BlockSize := PDWORD(DWORD(ObjList[I]) - 4)^; 
Write(OutFile, BlockSize: 4, '($' + IntToHex(BlockSize, 4) + ')字节', ' - '); 
try 
Item := TObject(ObjList[I]); 
if PTypeInfo(Item.ClassInfo).Kind <> tkClass then { type info technique } 
write(OutFile, '不是对象') 
else 
begin 
ptd := GetTypeData(PTypeInfo(Item.ClassInfo)); 
ppi := GetPropInfo(PTypeInfo(Item.ClassInfo), 'Name'); { 如果是TComponent } 
if ppi <> nil then 
begin 
write(OutFile, GetStrProp(Item, ppi)); 
write(OutFile, ' : '); 
end 
else 
write(OutFile, '(未命名): '); 
Write(OutFile, Item.ClassName, ' (', ptd.ClassType.InstanceSize, 
' 字节) - In ', ptd.UnitName, '.pas'); 
end 
except 
on Exception do 
write(OutFile, '不是对象'); 
end; 
writeln(OutFile); 
end; 
finally 
CloseFile(OutFile); 
end; 
end; 
function NewGetMem(Size: Integer): Pointer; 
begin 
Inc(GetMemCount); 
Result := OldMemMgr.GetMem(Size); 
AddToList(Result); 
end; 
function NewFreeMem(P: Pointer): Integer; 
begin 
Inc(FreeMemCount); 
Result := OldMemMgr.FreeMem(P); 
RemoveFromList(P); 
end; 
function NewReallocMem(P: Pointer; Size: Integer): Pointer; 
begin 
Inc(ReallocMemCount); 
Result := OldMemMgr.ReallocMem(P, Size); 
RemoveFromList(P); 
AddToList(Result); 
end; 
const 
NewMemMgr: TMemoryManager = ( 
GetMem: NewGetMem; 
FreeMem: NewFreeMem; 
ReallocMem: NewReallocMem); 
initialization 
GetMemoryManager(OldMemMgr); 
SetMemoryManager(NewMemMgr); 
finalization 
SetMemoryManager(OldMemMgr); 
if (GetMemCount - FreeMemCount) <> 0 then 
SnapCurrMemStatToFile(ExtractFileDir(ParamStr(0)) + 'CheckMemory.Log'); 
end.