Home: Code Repository: Mastering Delphi 5

Project MEMICON

Project Structure

MEMICON.DPR
RUNFIRST.PAS
RESFORM.PAS
RESFORM.DFM

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.

unit RunFirst;

interface

implementation

initialization
  IsLibrary := True;
end.

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.

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