cmptimedisplay.pas

Delphi的另一款钢琴软件

unit cmpTimeDisplay;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls;

type
  TTimeDisplay = class(TCustomControl)
  private
    fTime : Integer;
    fHours, fMins, fSecs, fCs : Integer;

    fBevelInner : TPanelBevel;
    fBevelOuter : TPanelBevel;
    fBorderStyle : TBorderStyle;
    fAlignment : TAlignment;

    r : TRect;

    procedure SetTime (value : Integer);
    procedure SetBevelInner (value : TPanelBevel);
    procedure SetBevelOuter (value : TPanelBevel);
    procedure SetBorderStyle (value : TBorderStyle);
    procedure SetAlignment (value : TAlignment);

    procedure UpdateDisplay;

    { Private declarations }
  protected
    procedure Paint; override;
    procedure CreateWnd; override;

  public
    constructor Create (AOwner : TComponent); override;
    { Public declarations }
  published
    property Time : Integer read fTime write SetTime;
    property Hours : Integer read fHours;
    property Mins : Integer read fMins;
    property Secs : Integer read fSecs;
    property CS : Integer read fCs;

    property BevelInner : TPanelBevel read fBevelInner write SetBevelInner;
    property BevelOuter : TPanelBevel read fBevelOuter write SetBevelOuter;
    property BorderStyle : TBorderStyle read fBorderStyle write SetBorderStyle;
    property Alignment : TAlignment read fAlignment write SetAlignment;

    property Font;
    property Color;
    property Align;
    property Ctl3D;

    property ParentColor;
    property ParentFont;
    property TabOrder;
  end;

implementation

constructor TTimeDisplay.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  Width := 100;
  Height := 20;
end;

procedure TTimeDisplay.SetTime (value : Integer);
begin
  if value <> fTime then
  begin
    fTime := value;
    fCs := fTime mod 1000 div 10;
    fSecs := fTime div 1000;
    fMins := fSecs div 60;
    fSecs := fSecs mod 60;
    fHours := fMins div 60;
    fMins := fMins mod 60;
    UpdateDisplay
  end
end;

procedure TTimeDisplay.SetBevelInner (value : TPanelBevel);
begin
  if fBevelInner <> value then
  begin
    fBevelInner := value;
    Refresh
  end
end;

procedure TTimeDisplay.SetBevelOuter (value : TPanelBevel);
begin
  if fBevelOuter <> value then
  begin
    fBevelOuter := value;
    Refresh
  end
end;

procedure TTimeDisplay.SetBorderStyle (value : TBorderStyle);
begin
  if fBorderStyle <> value then
  begin
    fBorderStyle := value;
    Refresh
  end
end;

procedure TTimeDisplay.SetAlignment (value : TAlignment);
begin
  if value <> fAlignment then
  begin
    fAlignment := value;
    Refresh
  end
end;

procedure TTimeDisplay.UpdateDisplay;
var
  st : string;
  x, w : Integer;
begin
  st := Format ('%02d:%02.2d:%02.2d.%02.2d', [fHours, fMins, fSecs, fCS]);
  if Alignment = taLeftJustify then
    x := r.left + 1
  else
  begin
    w := Canvas.TextWidth (st);
    if Alignment = taRightJustify then
      x := r.right - w - 1
    else
      x := r.left + (r.right - r.left - w) div 2
  end;
  Canvas.FillRect (r);
  Canvas.TextOut (x, 1, st);
//  Canvas.TdextRect (r, x, 1, st);
end;

procedure TTimeDisplay.Paint;
var
  BevelWidth : Integer;

  procedure DrawBevel (x, y, w, h : Integer; tp : TPanelBevel);
  begin
    case tp of
      bvRaised :
        with Canvas do
        begin
          Pen.Color := clBtnHighlight;
          MoveTo (x, y + h);
          LineTo (x, y);
          LineTo (x + w + 1, y);

          Pen.Color := clBtnShadow;
          MoveTo (x + w, y + 1);
          LineTo (x + w, y + h);
          LineTo (x, y + h);
        end;
      bvLowered :
        with Canvas do
        begin
          Pen.Color := clBtnShadow;
          MoveTo (x, y + h);
          LineTo (x, y);
          LineTo (x + w + 1, y);

          Pen.Color := clBtnHighlight;
          MoveTo (x + w, y + 1);
          LineTo (x + w, y + h);
          LineTo (x, y + h);
        end;
    end;
  end;

begin
  Canvas.Pen.Width := 1;
  Canvas.Font := Font;
  Canvas.Brush.Color := Color;
  if BevelInner <> bvNone then
    BevelWidth := 2
  else
    if BevelOuter <> bvNone then
      BevelWidth := 1
    else
      BevelWidth := 0;

  DrawBevel (0, 0, ClientWidth - 1, ClientHeight - 1, BevelOuter);
  DrawBevel (1, 1, ClientWidth - 3, ClientHeight - 3, BevelInner);

  with r do
  begin
    left := BevelWidth;
    top := BevelWidth;
    right := ClientWidth - bevelWidth * 2;
    bottom := ClientHeight - bevelWidth * 2
  end;

  UpdateDisplay
end;

procedure TTimeDisplay.CreateWnd;
begin
  inherited;
end;

end.