procedure TForm1.Timer1Timer(Sender: TObject);

begin

 with StatusBar1 do

 begin

  if GetKeyState(VK_CAPITAL) <> 0 then

  panels[0].text := ' CAP'

  else

  panels[0].text := '';

  if GetKeyState(VK_NUMLOCK) <> 0 then

  panels[1].text := ' NUM'

  else

  panels[1].text := '';

  if GetKeyState(VK_SCROLL) <> 0 then

  panels[2].text := ' SCRL'

  else

  panels[2].text := '';

  panels[3].text := ' ' + DateTimeToStr(now);

 end;

end;

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;

  {Установите все в True, чтобы все это отразилось на 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;

 {Заставляем строку состояния выровняться по нижнему краю}

 Align := alBottom;

 Height := 19;

 BevelInner := bvNone;

 BevelOuter := bvRaised;

 {Если UpdateWidth равен TRUE, StatusBar пересчитывает только ширину панелей}

 UpdateWidth := True;

 Locked := True;

 TabOrder := 0;

 ;

 TabStop := False;

 Font.Name := 'Arial';

 Font.Size := 8;

 {Создаем панель, которая будет отображать дату и время}

 DateTimePanel := TPanel.Create(Self);

 DateTimePanel.Parent := Self;

 SetupPanel(DateTimePanel, ' 00/00/00 00:00:00 дп ');

 {СОздаем панель, которая будет содержать графику ресурсов}

 ResPanel := TPanel.Create(Self);

 ResPanel.Parent := Self;

 SetupPanel(ResPanel, ' ');

 {Создаем 2 Gauges, которые размещаем на Resource Panel}

 ResGauge := TGauge.Create(Self);

 ResGauge.Parent := ResPanel;

 ResGauge.Align := alClient;

 ResGauge.ParentFont := True;

 ResGauge.BackColor := Color;

 ResGauge.ForeColor := clLime;

 ResGauge.BorderStyle := bsNone;

 {Создаем панель, которая будет отображать состояние CapsLock}

 CapPanel := TPanel.Create(Self);

 CapPanel.Parent := Self;

 SetupPanel(CapPanel, ' Cap ');

 {Создаем панель, которая будет отображать состояние NumLock}

 NumPanel := TPanel.Create(Self);

 NumPanel.Parent := Self;

 SetupPanel(NumPanel, ' Num ');

 {Создаем панель, которая будет отображать состояние Insert/Overwrite}

 InsPanel := TPanel.Create(Self);

 InsPanel.Parent := Self;

 SetupPanel(InsPanel, ' Ins ');

 {Создаем панель, которая будет отображать текст состояния}

 HelpPanel := TPanel.Create(Self);

 HelpPanel.Parent := Self;

 SetupPanelFields(HelpPanel);

 {Имеем вспомогательную панель, занимающую все остальное пространство}

 HelpPanel.Align := alClient;

 HelpPanel.Alignment := taLeftJustify;

 {Это таймер, который регулярно обновляет строку состояния}

 FTimer := TTimer.Create(Self);

 if FTimer <> nil then

 begin

  FTimer.OnTimer := UpdateStatusBar;

  {Обновление происходит дважды в секунду}

  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;

{Если мы получаем или устанавливаем заголовок TStatus, то вместо этого задаем

заголовок HelpPanel}

procedure TStatus.SetCaption(A: string);

begin

 HelpPanel.Caption := ' ' + A;

end;

function TStatus.GetCaption: string;

begin

 GetCaption := HelpPanel.Caption;

end;

{Данная процедура устанавливает соответствующие заголовки}

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;

{Позволяем изменять шрифты, используемые панелями для вывода текста}

procedure TStatus.CMFontChanged(var Message: TMessage);

begin

 inherited;

 UpdateWidth := True;

end;

end.

interface

implementation

end.