Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 5

Project VCLMEM

Project Structure


VCLMEM.DPR

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.

MAINFORM.PAS

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.

MEMFORM.PAS

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.

MAINFORM.DFM

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

MEMFORM.DFM

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