How to create a status bar that displays the system's time, date and keyboard status

Problem/Question/Abstract:

How to create a status bar that displays the system's time, date and keyboard status

Answer:

unit Status;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, Menus, Gauges;

type
  TStatus = class(TCustomPanel)
  private
    FDate: Boolean;
    FKeys: Boolean;
    FTime: Boolean;
    FResources: Boolean;
    DateTimePanel: TPanel;
    ResPanel: TPanel;
    ResGauge: TGauge;
    CapPanel: TPanel;
    NumPanel: TPanel;
    InsPanel: TPanel;
    HelpPanel: TPanel;
    UpdateWidth: Boolean;
    FTimer: TTimer;
    procedure SetDate(A: Boolean);
    procedure SetKeys(A: Boolean);
    procedure SetTime(A: Boolean);
    procedure SetResources(A: Boolean);
    procedure SetCaption(A: string);
    function GetCaption: string;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetupPanelFields(ThePanel: TPanel);
    procedure SetupPanel(ThePanel: TPanel; WidthMask: string);
    procedure UpdateStatusBar(Sender: TObject);
  published
    property ShowDate: Boolean read FDate write SetDate default True;
    property ShowKeys: Boolean read FKeys write SetKeys default True;
    property ShowTime: Boolean read FTime write SetTime default True;
    property ShowResources: Boolean read FResources write SetResources default True;
    property BevelInner;
    property BevelOuter;
    property BevelWidth;
    property BorderStyle;
    property BorderWidth;
    property Caption: string read GetCaption write SetCaption;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentCtl3d;
    property ParentFont;
    property ParentShowHint;
    property PopUpMenu;
    property ShowHint;
    property Visible;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Additional', [TStatus]);
end;

procedure TStatus.SetupPanelFields(ThePanel: TPanel);
begin
  with ThePanel do
  begin
    Alignment := taCenter;
    Caption := '';
    BevelInner := bvLowered;
    BevelOuter := bvNone;
    {Set all these true so they reflect the settings of the TStatus}
    ParentColor := True;
    ParentFont := True;
    ParentCtl3D := True;
  end;
end;

procedure TStatus.SetupPanel(ThePanel: TPanel; WidthMask: string);
begin
  SetupPanelFields(ThePanel);
  with ThePanel do
  begin
    Width := Canvas.TextWidth(WidthMask);
    Align := alRight;
  end;
end;

constructor TStatus.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Parent := TWinControl(AOwner);
  FTime := True;
  FDate := True;
  FKeys := True;
  FResources := True;
  {Force the status bar to be aligned bottom}
  Align := alBottom;
  Height := 19;
  BevelInner := bvNone;
  BevelOuter := bvRaised;
  {When UpdateWidth is set TRUE, status bar will recalculate panel widths once}
  UpdateWidth := True;
  Locked := True;
  TabOrder := 0;
  ;
  TabStop := False;
  Font.Name := 'Arial';
  Font.Size := 8;
  {Create the panel that will hold the date and time}
  DateTimePanel := TPanel.Create(Self);
  DateTimePanel.Parent := Self;
  SetupPanel(DateTimePanel, '  00/00/00 00:00:00 am  ');
  {Create the panel that will hold the resources graph}
  ResPanel := TPanel.Create(Self);
  ResPanel.Parent := Self;
  SetupPanel(ResPanel, '                    ');
  {Create the 2 Gauges that will reside within the Resource Panel}
  ResGauge := TGauge.Create(Self);
  ResGauge.Parent := ResPanel;
  ResGauge.Align := alClient;
  ResGauge.ParentFont := True;
  ResGauge.BackColor := Color;
  ResGauge.ForeColor := clLime;
  ResGauge.BorderStyle := bsNone;
  {Create the panel that will hold the CapsLock state}
  CapPanel := TPanel.Create(Self);
  CapPanel.Parent := Self;
  SetupPanel(CapPanel, '  Cap  ');
  {Create the panel that will hold the NumLock state}
  NumPanel := TPanel.Create(Self);
  NumPanel.Parent := Self;
  SetupPanel(NumPanel, '  Num  ');
  {Create the panel that will hold the Insert/Overwrite state}
  InsPanel := TPanel.Create(Self);
  InsPanel.Parent := Self;
  SetupPanel(InsPanel, '  Ins  ');
  {Create the panel that will hold the status text}
  HelpPanel := TPanel.Create(Self);
  HelpPanel.Parent := Self;
  SetupPanelFields(HelpPanel);
  {Have the help panel consume all remaining space}
  HelpPanel.Align := alClient;
  HelpPanel.Alignment := taLeftJustify;
  {This is the timer that will update the status bar at regular intervals}
  FTimer := TTimer.Create(Self);
  if FTimer <> nil then
  begin
    FTimer.OnTimer := UpdateStatusBar;
    {Updates will occur twice a second}
    FTimer.Interval := 500;
    FTimer.Enabled := True;
  end;
end;

destructor TStatus.Destroy;
begin
  FTimer.Free;
  HelpPanel.Free;
  InsPanel.Free;
  NumPanel.Free;
  CapPanel.Free;
  ResGauge.Free;
  ResPanel.Free;
  DateTimePanel.Free;
  inherited Destroy;
end;

procedure TStatus.SetDate(A: Boolean);
begin
  FDate := A;
  UpdateWidth := True;
end;

procedure TStatus.SetKeys(A: Boolean);
begin
  FKeys := A;
  UpdateWidth := True;
end;

procedure TStatus.SetTime(A: Boolean);
begin
  FTime := A;
  UpdateWidth := True;
end;

procedure TStatus.SetResources(A: Boolean);
begin
  FResources := A;
  UpdateWidth := True;
end;

{When we set or get the TStatus caption, it is affecting the HelpPanel caption instead}

procedure TStatus.SetCaption(A: string);
begin
  HelpPanel.Caption := ' ' + A;
end;

function TStatus.GetCaption: string;
begin
  GetCaption := HelpPanel.Caption;
end;

{This procedure sets the captions appropriately}

procedure TStatus.UpdateStatusBar(Sender: TObject);
begin
  if ShowDate and ShowTime then
    DateTimePanel.Caption := DateTimeToStr(Now)
  else if ShowDate and not ShowTime then
    DateTimePanel.Caption := DateToStr(Date)
  else if not ShowDate and ShowTime then
    DateTimePanel.Caption := TimeToStr(Time)
  else
    DateTimePanel.Caption := '';
  if UpdateWidth then
    with DateTimePanel do
      if ShowDate or ShowTime then
        Width := Canvas.TextWidth('  ' + Caption + '  ')
      else
        Width := 0;
  if ShowResources then
  begin
    ResGauge.Progress := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);
    if ResGauge.Progress < 20 then
      ResGauge.ForeColor := clRed
    else
      ResGauge.ForeColor := clLime;
  end;
  if UpdateWidth then
    if ShowResources then
      ResPanel.Width := Canvas.TextWidth('                    ')
    else
      ResPanel.Width := 0;
  if ShowKeys then
  begin
    if (GetKeyState(vk_NumLock) and $01) <> 0 then
      NumPanel.Caption := '  Num  '
    else
      NumPanel.Caption := '';
    if (GetKeyState(vk_Capital) and $01) <> 0 then
      CapPanel.Caption := '  Cap  '
    else
      CapPanel.Caption := '';
    if (GetKeyState(vk_Insert) and $01) <> 0 then
      InsPanel.Caption := '  Ins  '
    else
      InsPanel.Caption := '';
  end;
  if UpdateWidth then
    if ShowKeys then
    begin
      NumPanel.Width := Canvas.TextWidth(' Num ');
      InsPanel.Width := Canvas.TextWidth(' Ins ');
      CapPanel.Width := Canvas.TextWidth(' Cap ');
    end
    else
    begin
      NumPanel.Width := 0;
      InsPanel.Width := 0;
      CapPanel.Width := 0;
    end;
  UpdateWidth := False;
end;

{This allows font changes to be detected so the panels will be adjusted}

procedure TStatus.CMFontChanged(var Message: TMessage);
begin
  inherited;
  UpdateWidth := True;
end;

end.

interface

implementation

end.