mlabel.pas

立体的改良版 TLabel 构件

{======================================================================}
{=   MultiLabel - 3DLabel with Blinking capabilities                  =}
{=                                                                    =}
{=   CopyRight by Alfonso R. L髉ez Rivero                             =}
{=   [e-mail]                                        =}
{======================================================================}

unit Mlabel;

interface

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


type
  TLabelStatus = (lsOff, lsOn, lsBlink);

  TLabelOnColors = (lcSilver, lcRed, lcLime, lcYellow, lcBlue, lcFuchsia, lcAqua, lcWhite);

  TLabelOffColors = (lcBlack, lcMaroon, lcGreen, lcOlive, lcNavy, lcPurple, lcTeal, lcGray);

  TActualColors = array[0..7] of TColor;

  TTextStyle = (tsNone, TsRaised, tsRecessed);

const
  ActualOnColors: TActualColors = (clSilver, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite);

  ActualOffColors: TActualColors = (clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray);

type
  TMLabel = class(TLabel)
  private
    FTextStyle: TTextStyle;
    FLabelTimer: TTimer;
    FLabelIsOn: Boolean;
    FAutoSelectColor: Boolean;
    FLabelOnColor: TLabelOnColors;
    FLabelOffColor: TLabelOffColors;
    FBlinkRate: Word;
    FLabelStatus: TLabelStatus;

    procedure DoDrawText(var Rect: TRect; Flags: Word);

    procedure SetLabelOnColor(value: TLabelOnColors);
    procedure SetLabelOffColor(value: TLabelOffColors);
    procedure SetLabelStatus(value: TLabelStatus);
    procedure SetBlinkRate(value: Word);

  protected
    procedure Paint; override;
    procedure SetTextStyle(Value: TTextStyle);
    procedure BlinkTimeLimit(Sender: TObject);

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

  published
    property TextStyle: TTextStyle read FTextStyle write SetTextStyle default tsRecessed;
    property AutoSelectColor: Boolean read FAutoSelectColor write FAutoSelectColor default True;
    property LabelOnColor: TLabelOnColors read FLabelOnColor write SetLabelOnColor default lcRed;
    property LabelOffColor: TLabelOffColors read FLabelOffColor write SetLabelOffColor default lcMaroon;
    property BlinkRate: word read FBlinkRate write SetBlinkRate default 500;
    property LabelStatus: TLabelStatus read FLabelStatus write SetLabelStatus default lsOff;

  end;

procedure Register;

implementation

constructor TMLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  {Set defaults}
  FTextStyle:=tsRecessed;
  FAutoSelectColor:=True;
  FBlinkRate:=500;
  FLabelOnColor:=lcRed;
  FLabelOffColor:=lcMaroon;
  FLabelStatus:= lsOff;
  FLabelIsOn:=False;
end;

destructor TMLabel.Destroy;
begin
  if assigned(FLabelTimer) then FLabelTimer.Free;
  inherited Destroy;
end;

procedure TMLabel.SetTextStyle(value: TTextStyle);
begin
  if value<> FtextStyle then
  begin
    FTextStyle:=value;
    Invalidate;
  end;
end;

procedure TMLabel.DoDrawText(var Rect: TRect; Flags: Word);
var
  Text: array[0..255] of Char;
  TmpRect: TRect;
  UpperColor: TColor;
  LowerColor: TColor;
begin
  GetTextBuf(Text, SizeOf(Text));
  if (Flags and DT_CALCRECT<>0) and
     ((Text[0]=#0) or ShowAccelChar and
      (Text[0]='&') and
      (Text[1]=#0)) then StrCopy(Text,' ');

  if not ShowAccelChar then Flags:=Flags or DT_NOPREFIX;

  Canvas.Font:=Font;
  UpperColor:=ActualOnColors[ord(FLabelOnColor)];
  LowerColor:=ActualOffColors[ord(FLabelOffColor)];

  if FTextStyle= tsRecessed then
  begin
    UpperColor:=ActualOffColors[ord(FLabelOffColor)];
    LowerColor:=ActualOnColors[ord(FLabelOnColor)];
  end;

  if FTextStyle in [tsRecessed, tsRaised] then
  begin
    TmpRect:=Rect;
    OffSetRect(TmpRect, 1, 1);
    Canvas.Font.Color:=LowerColor;
    DrawText(Canvas.Handle, Text, StrLen(Text), TmpRect, Flags);
  end;

  if FLabelIsOn then
  begin
    Canvas.Font.Color:=ActualOnColors[ord(FLabelOnColor)];
  end
  else
  begin
    Canvas.Font.Color:=ActualOffColors[ord(FLabelOffColor)];
  end;

  if not Enabled then Canvas.Font.Color:=clGrayText;
  DrawText(Canvas.Handle, Text, StrLen(Text), Rect, Flags);
end;

procedure TMLabel.Paint;
const
  Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
  Rect: TRect;
begin
  with Canvas do
  begin
    if not Transparent then
    begin
      Brush.Color:=Self.Color;
      Brush.Style:=bsSolid;
      FillRect(ClientRect);
    end;
    Brush.Style:=bsClear;
    Rect:=ClientRect;
    if FLabelIsOn then
    begin
      Font.Color:=ActualOnColors[ord(FLabelOnColor)];
    end
    else
    begin
      Font.Color:=ActualOffColors[ord(FLabelOffColor)];
    end;
    DoDrawText(Rect, (DT_EXPANDTABS or DT_WORDBREAK) or Alignments[Alignment]);
  end;
end;

procedure TMLabel.SetLabelOffColor(value: TLabelOffColors);
begin
  FLabelOffColor:=value;
  if AutoSelectColor then FLabelOnColor:=TLabelOnColors(FLabelOffColor);
  Invalidate;
end;

procedure TMLabel.SetLabelOnColor(value: TLabelOnColors);
begin
  FLabelOnColor:=value;
  if AutoSelectColor then FLabelOffColor:=TLabelOffColors(FLabelOnColor);
  Invalidate;
end;

procedure TMLabel.SetLabelStatus(value: TLabelStatus);
begin
  if (value<>FLabelStatus) then
  begin
    if assigned(FLabelTimer) then
    begin
      FLabelTimer.Free;
      FLabelTimer:=nil;
    end;
    FLabelStatus:=value;
    case FLabelStatus of
      lsOff:
      begin
        FLabelIsOn:=False;
      end;
      lsOn:
      begin
        FLabelIsOn:=True;
      end;
      lsBlink:
      begin
        FLabelTimer:=TTimer.Create(Self);
        FLabelTimer.Interval:=FBlinkRate;
        FLabelTimer.OnTimer:=BlinkTimeLimit;
      end;
    end;
    Invalidate
  end;
end;

procedure TMLabel.BlinkTimeLimit(Sender: TObject);
const
  Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
  Rect: TRect;
begin
  FLabelIsOn:= not FLabelIsOn;
  with Self.Canvas do
  begin
    Rect:=ClientRect;
    DoDrawText(Rect, (DT_EXPANDTABS or DT_WORDBREAK) or Alignments[Alignment]);
  end;
end;

procedure TMLabel.SetBlinkRate(value: word);
begin
  if value <> FBlinkRate then
  begin
    FBlinkRate:=value;
    if assigned(FLabelTimer) then FLabelTimer.Interval:=FBlinkRate;
  end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TMlabel]);
end;

end.