Показ даты, времени и состояния клавиш в строке состояния

=== Показ даты, времени и состояния клавиш в строке состояния ===
Предположим, у вас есть StatusBar с 4-мя панелями, плюс таймер. Тогда вы можете сделать:
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;
О том, как можно изменить формат вывода даты, доходчиво и с примерами изложено в электронной справке, в разделе, посвященный датам (Date). Обратите внимание на то, что свойство Text имеет тип строки, поэтому вы не можете написать panels[0].text := DateTime(now), т.к. дата/время имеет тип Double.
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.
Source: Взято с http://delphiworld.narod.ru
ID: 00517