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 MEMICON

Project Structure


MEMICON.DPR

program MemIcon;

uses
  RunFirst in 'RunFirst.pas',
  Forms, Windows,
  Resform in 'RESFORM.PAS' {MemForm};

{$R *.RES}

begin
  Application.ShowMainForm := False;
  IsLibrary := False;
  Application.CreateForm(TMemForm, MemForm);
  Application.Run;
end.

RUNFIRST.PAS

unit RunFirst;

interface

implementation

initialization
  IsLibrary := True;
end.

RESFORM.PAS

unit Resform;

interface

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

const
  wm_IconMessage = wm_User;

type
  TMemForm = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    RamGauge: TGauge;
    VirtualGauge: TGauge;
    Timer1: TTimer;
    PopupMenu1: TPopupMenu;
    Details1: TMenuItem;
    Close1: TMenuItem;
    N1: TMenuItem;
    About1: TMenuItem;
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Details1Click(Sender: TObject);
    procedure About1Click(Sender: TObject);
    procedure Close1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  public
    procedure IconTray (var Msg: TMessage);
      message wm_IconMessage;
  private
    nid: TNotifyIconData;
  end;

var
  MemForm: TMemForm;

implementation

{$R *.DFM}
{$R RYG.RES}

function FmtMem (N: Integer): string;
begin
  if N > 1024*1024 then
    FmtMem := Format ('%.1f MB', [n / (1024*1024)])
  else
    FmtMem := Format ('%.1f KB', [n / 1024])
end;

procedure TMemForm.Timer1Timer(Sender: TObject);
var
  MemInfo : TMemoryStatus;
begin
  MemInfo.dwLength := Sizeof (MemInfo);
  GlobalMemoryStatus (MemInfo);
  RamGauge.Progress := MemInfo.dwAvailPhys div
    (MemInfo.dwTotalPhys div 100);
  VirtualGauge.Progress := MemInfo.dwAvailPageFile div
    (MemInfo.dwTotalPageFile div 100);

  Caption := Format ('Memory: = %d - %d',
    [RamGauge.Progress, VirtualGauge.Progress]);

  Label1.Caption := Format ('RAM:'#13'%s'#13'(%s)'    ,
    [FmtMem (MemInfo.dwAvailPhys),
    FmtMem (MemInfo.dwTotalPhys)]);
  Label2.Caption := Format ('Swap:'#13'%s'#13'(%s)'    ,
    [FmtMem (MemInfo.dwAvailPageFile),
    FmtMem (MemInfo.dwTotalPageFile)]);

  // set icon color
  if RamGauge.Progress > 5 then
    Icon.Handle :=
      LoadIcon (HInstance, 'GREEN')
  else if VirtualGauge.Progress > 20 then
    Icon.Handle :=
      LoadIcon (HInstance, 'YELLOW')
  else
    Icon.Handle :=
      LoadIcon (HInstance, 'RED');

  // update the NotifyIcon structure
  nid.hIcon := Icon.Handle;
  strcopy (nid.szTip, PChar(Caption));
  nid.uFlags := nif_Icon or nif_Tip;
  Shell_NotifyIcon (NIM_MODIFY, @nid);
end;

procedure TMemForm.IconTray (var Msg: TMessage);
var
  Pt: TPoint;
begin
  if Msg.lParam = wm_rbuttondown then
  begin
    GetCursorPos (Pt);
//    SetForegroundWindow (Handle);
    PopupMenu1.Popup (Pt.x, Pt.y);
  end;
  if Msg.lParam = wm_lbuttondblclk then
    Details1Click (Self);
end;

procedure TMemForm.FormCreate(Sender: TObject);
begin
  // load the initial icon
  Icon.Handle :=
    LoadIcon (HInstance, 'GREEN');

  // fill the NotifyIcon data structure
  nid.cbSize := sizeof (nid);
  nid.wnd := Handle;
  nid.uID := 1; // icon ID
  nid.uCallBAckMessage := wm_IconMessage;
  nid.hIcon := Icon.Handle;
  nid.szTip := 'Free memory';
  nid.uFlags := nif_Message or
    nif_Icon or nif_Tip;
  Shell_NotifyIcon (NIM_ADD, @nid);

  // update the output ASAP
  Timer1Timer (Self);
end;

procedure TMemForm.FormDestroy(Sender: TObject);
begin
  nid.uFlags := 0;
  Shell_NotifyIcon (NIM_DELETE, @nid);
end;

procedure TMemForm.Details1Click(Sender: TObject);
begin
  ShowWindow (Handle, sw_ShowNormal);
  SetForegroundWindow (Handle);
  Show; // enables the creation of window controls
end;

procedure TMemForm.About1Click(Sender: TObject);
begin
  MessageDlg ('Windows Memory Meter'#13 +
    'Copyright Marco Cantý 1996-99'#13 +
    'Source code in Mastering Delphi',
    mtInformation, [mbOk], 0);
end;

procedure TMemForm.Close1Click(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TMemForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caNone;
  ShowWindow (Handle, sw_Hide);
end;

end.

RESFORM.DFM

object MemForm: TMemForm
  Left = 205
  Top = 108
  BorderIcons = [biSystemMenu, biMinimize]
  BorderStyle = bsSingle
  Caption = 'Memory'
  ClientHeight = 148
  ClientWidth = 205
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clBlack
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnClose = FormClose
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 8
    Top = 88
    Width = 89
    Height = 57
    Alignment = taCenter
    AutoSize = False
    Caption = 'RAM'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -15
    Font.Name = 'Arial'
    Font.Style = [fsBold]
    ParentFont = False
  end
  object Label2: TLabel
    Left = 104
    Top = 88
    Width = 89
    Height = 57
    Alignment = taCenter
    AutoSize = False
    Caption = 'Swap'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -15
    Font.Name = 'Arial'
    Font.Style = [fsBold]
    ParentFont = False
  end
  object RamGauge: TGauge
    Left = 16
    Top = 8
    Width = 73
    Height = 73
    BackColor = clYellow
    BorderStyle = bsNone
    ForeColor = clLime
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clBlack
    Font.Height = -15
    Font.Name = 'Arial'
    Font.Style = [fsBold]
    Kind = gkPie
    ParentFont = False
    Progress = 0
  end
  object VirtualGauge: TGauge
    Left = 112
    Top = 8
    Width = 73
    Height = 73
    BackColor = clRed
    BorderStyle = bsNone
    ForeColor = clLime
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clBlack
    Font.Height = -15
    Font.Name = 'Arial'
    Font.Style = [fsBold]
    Kind = gkPie
    ParentFont = False
    Progress = 0
  end
  object Timer1: TTimer
    OnTimer = Timer1Timer
  end
  object PopupMenu1: TPopupMenu
    AutoPopup = False
    Left = 128
    Top = 8
    object Details1: TMenuItem
      Caption = 'Details...'
      Default = True
      OnClick = Details1Click
    end
    object Close1: TMenuItem
      Caption = 'Close'
      OnClick = Close1Click
    end
    object N1: TMenuItem
      Caption = '-'
    end
    object About1: TMenuItem
      Caption = 'About...'
      OnClick = About1Click
    end
  end
end