Советы по Delphi


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


Предположим, у вас есть 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
.

[001600]




Начало  Назад  Вперед



Книжный магазин