unit MemMan;

interface

var
  GetMemCount, FreeMemCount,
    ReallocMemCount: Integer;

implementation

uses
  Windows, SysUtils;

var
  OldMemMgr: TMemoryManager;

function NewGetMem(Size: Integer): Pointer;
begin
  Inc(GetMemCount);
  Result := OldMemMgr.GetMem(Size);
end;

function NewFreeMem(P: Pointer): Integer;
begin
  Inc(FreeMemCount);
  Result := OldMemMgr.FreeMem(P);
end;

function NewReallocMem(P: Pointer; Size: Integer): Pointer;
begin
  Inc(ReallocMemCount);
  Result := OldMemMgr.ReallocMem(P, Size);
end;

const
  NewMemMgr: TMemoryManager = (
    GetMem: NewGetMem;
    FreeMem: NewFreeMem;
    ReallocMem: NewReallocMem);

initialization
  GetMemoryManager(OldMemMgr);
  SetMemoryManager(NewMemMgr);

finalization
  SetMemoryManager(OldMemMgr);
  if (GetMemCount - FreeMemCount) <> 0 then
    MessageBox(0, pChar(
      'Objects left: ' + IntToStr(GetMemCount - FreeMemCount)),
      'MemManager', mb_ok);
end.

unit MemForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    BtnRefresh1: TButton;
    BtnCreateNil: TButton;
    BtnCreateOwner: TButton;
    BtnGetMem: TButton;
    LblResult: TLabel;
    Btn100Strings: TButton;
    Bevel1: TBevel;
    BtnRefresh2: TButton;
    procedure BtnRefresh1Click(Sender: TObject);
    procedure BtnCreateNilClick(Sender: TObject);
    procedure BtnCreateOwnerClick(Sender: TObject);
    procedure BtnGetMemClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Btn100StringsClick(Sender: TObject);
    procedure BtnRefresh2Click(Sender: TObject);
  public
    procedure Refresh;
    procedure Refresh2;
  end;

var
  Form1: TForm1;

implementation

uses MemMan;

{$R *.DFM}

procedure TForm1.Refresh;
begin
  LblResult.Caption :=
    'Allocated: ' + IntToStr(GetMemCount) + #13 +
    'Free: ' + IntToStr(FreeMemCount) + #13 +
    'Existing: ' +
    IntToStr(GetMemCount - FreeMemCount) + #13 +
    'Re-allocated: ' + IntToStr(ReallocMemCount);
end;

procedure TForm1.Refresh2;
begin
  LblResult.Caption := Format(
    'Allocated: %d'#13'Free: %d'#13'Existing: %d'#13'Re-allocated %d'      ,
    [GetMemCount, FreeMemCount,
    GetMemCount - FreeMemCount, ReallocMemCount]);
end;

procedure TForm1.BtnRefresh1Click(Sender: TObject);
begin
  Refresh;
end;

procedure TForm1.BtnCreateNilClick(Sender: TObject);
begin
  TButton.Create(nil);
  Refresh;
end;

procedure TForm1.BtnCreateOwnerClick(Sender: TObject);
begin
  TButton.Create(self);
  Refresh;
end;

procedure TForm1.BtnGetMemClick(Sender: TObject);
var
  P: Pointer;
begin
  GetMem(P, 100);
  Integer(P^) := 0;
  Refresh;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Refresh;
end;

procedure TForm1.Btn100StringsClick(Sender: TObject);
var
  s1, s2: string;
  I: Integer;
begin
  s1 := 'hi';
  s2 := Btn100Strings.Caption;
  for I := 1 to 100 do
    s1 := s1 + ': hello world';
  Btn100Strings.Caption := s1;
  s1 := s2;
  Btn100Strings.Caption := s1;
  Refresh;
end;

procedure TForm1.BtnRefresh2Click(Sender: TObject);
begin
  Refresh2;
end;

end.