Home: Code Repository: Mastering Delphi 5

Project VCLMEM

Project Structure

VCLMEM.DPR
MAINFORM.PAS
MEMFORM.PAS
MAINFORM.DFM
MEMFORM.DFM

program VclMem;

uses
  Forms,
  MainForm in 'MainForm.pas' {FormMain},
  MemForm in 'MemForm.pas' {FormMemStatus};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TFormMain, FormMain);
  Application.Run;
end.

unit MainForm;

interface

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

type
  TFormMain = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FormMain: TFormMain;

implementation

uses MemForm;

{$R *.DFM}

procedure TFormMain.Button1Click(Sender: TObject);
begin
  if not Assigned (FormMemStatus) then
    FormMemStatus := TFormMemStatus.Create (nil);
  FormMemStatus.Show;
end;

end.

unit MemForm;

interface

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

type
  TFormMemStatus = class(TForm)
    StringGrid2: TStringGrid;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormMemStatusClose(Sender: TObject;
      var Action: TCloseAction);
  private
    procedure UpdateStatus;
  public
    s: string;
    sl: TStringList;
    f: TForm;
  end;

var
  FormMemStatus: TFormMemStatus;

implementation

{$R *.DFM}

procedure TFormMemStatus.UpdateStatus;
var
  HeapStatus: THeapStatus;
begin
  HeapStatus := GetHeapStatus;
  with HeapStatus do
  begin
    StringGrid2.Cells [1, 0] := FloatToStrF (
      TotalAddrSpace div 1024,
      ffNumber, 20, 0) + ' Kbytes';
    StringGrid2.Cells [1, 1] := FloatToStrF (
      TotalUncommitted div 1024,
      ffNumber, 20, 0) + ' Kbytes';
    StringGrid2.Cells [1, 2] := FloatToStrF (
      TotalCommitted div 1024,
      ffNumber, 20, 0) + ' Kbytes';
    StringGrid2.Cells [1, 3] := FloatToStrF (
      TotalFree div 1024,
      ffNumber, 20, 0) + ' Kbytes';
    StringGrid2.Cells [1, 4] := FloatToStrF (
      TotalAllocated div 1024,
      ffNumber, 20, 0) + ' Kbytes';
    StringGrid2.Cells [1, 5] := IntToStr (
       TotalAllocated div (TotalAddrSpace div 100)) + '%';
    StringGrid2.Cells [1, 6] := FloatToStrF (
      FreeSmall div 1024,
      ffNumber, 20, 0) + ' Kbytes';
    StringGrid2.Cells [1, 7] := FloatToStrF (
      FreeBig div 1024,
      ffNumber, 20, 0) + ' Kbytes';
    StringGrid2.Cells [1, 8] := FloatToStrF (
      Unused div 1024,
      ffNumber, 20, 0) + ' Kbytes';
    StringGrid2.Cells [1, 9] := FloatToStrF (
      Overhead div 1024,
      ffNumber, 20, 0) + ' Kbytes';
  end;
end;

procedure TFormMemStatus.FormCreate(Sender: TObject);
begin
  StringGrid2.Cells [0, 0] := 'Available address space ';
  StringGrid2.Cells [0, 1] := 'Uncommitted portion';
  StringGrid2.Cells [0, 2] := 'Committed portion';
  StringGrid2.Cells [0, 3] := 'Free portion';
  StringGrid2.Cells [0, 4] := 'Allocated portion';
  StringGrid2.Cells [0, 5] := 'Address space load';
  StringGrid2.Cells [0, 6] := 'Total small free blocks';
  StringGrid2.Cells [0, 7] := 'Total big free blocks';
  StringGrid2.Cells [0, 8] := 'Other unused blocks';
  StringGrid2.Cells [0, 9] := 'Total overhead';

  UpdateStatus;
end;

procedure TFormMemStatus.Timer1Timer(Sender: TObject);
begin
  UpdateStatus;
end;

procedure TFormMemStatus.FormMemStatusClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Action := caFree;
  FormMemStatus := nil;
end;

end.

object FormMain: TFormMain
  Left = 229
  Top = 249
  Width = 287
  Height = 181
  Caption = 'VclMem'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Button1: TButton
    Left = 96
    Top = 56
    Width = 75
    Height = 25
    Caption = 'About...'
    TabOrder = 0
    OnClick = Button1Click
  end
end

object FormMemStatus: TFormMemStatus
  Left = 259
  Top = 160
  Width = 348
  Height = 281
  Caption = 'Memory Status'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnClose = FormMemStatusClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object StringGrid2: TStringGrid
    Left = 0
    Top = 0
    Width = 340
    Height = 254
    Align = alClient
    ColCount = 2
    DefaultColWidth = 166
    RowCount = 10
    FixedRows = 0
    TabOrder = 0
    RowHeights = (
      24
      24
      24
      24
      24
      24
      24
      24
      24
      24)
  end
  object Timer1: TTimer
    OnTimer = Timer1Timer
    Left = 40
    Top = 32
  end
end