ablabel.pas

著名的虚拟仪表控件,包含全部源码, 可以在,delphi2007 下安装运行

unit AbLabel;

{******************************************************************************}
{ Abakus VCL                                                                   }
{               Components TAbLabel                                            }
{                                                                              }
{******************************************************************************}
{        e-Mail: [e-mail] , Web: http://www.abaecker.com            }
{------------------------------------------------------------------------------}
{          (c) Copyright 1998..2000 A.Baecker, All rights Reserved             }
{******************************************************************************}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  _AbProc, _GClass;

type

  TAbLabel = class(TAbGraphicControl)
  private
    { Private-Deklarationen }
    FDigitText: string;
    FDigit: Integer;
    FDefaultText: string;
    FTextPosH: TPosH;
    FTextPosV: TPosV;
    FSpacing: Integer;
    TextArray: array[0..31] of string;
    bkCreated: Boolean;
    BmpBackground: TBitmap;
    procedure Draw;
    procedure SetDefaultText(Value: string);
    procedure SetTextPosH(Value: TPosH);
    procedure SetTextPosV(Value: TPosV);
    procedure SetDigit(Value: Integer);
    procedure SetDigitText(Value: string);
    procedure SetSpacing(Value: Integer);
    procedure Parse;
  protected
    { Protected-Deklarationen }
  public
    { Public-Deklarationen }
    procedure Paint; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published-Deklarationen }
    property DigitText: string read FDigitText write SetDigitText;
    property Digit: Integer read FDigit write SetDigit default 0;
    property Spacing: Integer read FSpacing write SetSpacing default 3;
    property TextPosH: TPosH read FTextPosH write SetTextPosH default phCenter;
    property TextPosV: TPosV read FTextPosV write SetTextPosV default pvCenter;
    property DefaultText: string read FDefaultText write SetDefaultText;
    property Width default 60;
    property Height default 20;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnStartDrag;
    property OnMouseDown;
    property OnMouseUp;
    property Align;
    property Visible;
    property Font;
  end;

implementation

procedure TAbLabel.SetSpacing(Value: Integer);
begin
  if FSpacing <> Value then
  begin
    FSpacing := Value;
    Draw;
  end;
end;

procedure TAbLabel.SetTextPosH(Value: TPosH);
begin
  if FTextPosH <> Value then
  begin
    FTextPosH := Value;
    Draw;
  end;
end;

procedure TAbLabel.SetTextPosV(Value: TPosV);
begin
  if FTextPosV <> Value then
  begin
    FTextPosV := Value;
    Draw;
  end;
end;

procedure TAbLabel.SetDigit(Value: Integer);
begin
  if FDigit <> Value then
  begin
    FDigit := Value;
    Draw;
  end;
end;

procedure TAbLabel.SetDefaultText(Value: string);
begin
  if FDefaultText <> Value then
  begin
    FDefaultText := Value;
  end;
end;

procedure TAbLabel.Parse;
var
  n                 : Integer;
  Text, token       : string;
begin
  Text := FDigitText;
  for n := 0 to 31 do
  begin
    token := AbStrToken(Text, ';');
    TextArray[n] := token;
  end;
  Draw;
end;

procedure TAbLabel.Paint;
begin
  if Visible or (csDesigning in Componentstate) then
  begin
    BmpBackground.Width := Width;       // save Background
    BmpBackground.Height := Height;
    BmpBackground.Canvas.CopyRect(ClientRect, Canvas, ClientRect);
    bkCreated := true;
    Draw;
  end;
end;

procedure TAbLabel.Draw;
var
  Bmp               : TBitmap;
  TextPos, cp       : TPoint;
  w, h              : Integer;
  txt               : string;
begin
  if not bkCreated or
    (not Visible and not (csDesigning in Componentstate)) then Exit;

  if (FDigit >= 0) and (FDigit < 32) then
  begin
    txt := TextArray[FDigit];
  end
  else
  begin
    txt := FDefaultText;
  end;
  if txt = '' then txt := FDefaultText;

  Bmp := TBitmap.Create;
  Bmp.Assign(BmpBackground);

  Bmp.Canvas.Font := Font;
  h := Bmp.Canvas.Textheight('X');
  w := Bmp.Canvas.TextWidth(txt);

  cp := AbCenterPoint(Rect(0, 0, Width, Height));

  case FTextPosV of
    pvTop: TextPos.y := FSpacing - Round(h * 0.25);
    pvCenter: TextPos.y := cp.y - h div 2;
    pvBottom: TextPos.y := Height - Round(0.8 * h) - 1 - FSpacing;
  end;

  case FTextPosH of
    phLeft: TextPos.x := FSpacing;
    phCenter: TextPos.x := cp.x - w div 2;
    phRight: TextPos.x := Width - w - FSpacing;
  end;

  Bmp.Canvas.Brush.Style := bsClear;
  Bmp.Canvas.textout(TextPos.x, TextPos.y, txt);
  Canvas.Draw(0, 0, Bmp);

  Bmp.Free;
end;


procedure TAbLabel.SetDigitText(Value: string);
begin
  if FDigitText <> Value then
  begin
    FDigitText := Value;
    Parse;
  end;
end;

constructor TAbLabel.Create(AOwner: TComponent);
var
  n                 : Integer;
begin
  inherited Create(AOwner);
  if (AOwner is TWinControl) then Parent := AOwner as TWinControl;
  FTextPosV := pvCenter;
  FTextPosH := phCenter;
  FSpacing := 3;
  SetBounds(Left, Top, 60, 20);
  FDefaultText := 'default';
  for n := 0 to 31 do
  begin
    FDigitText := FDigitText + IntToStr(n) + ';';
  end;
  BmpBackground := TBitmap.Create;
  BmpBackground.Width := Width;
  BmpBackground.Height := Height;

  Parse;
end;

destructor TAbLabel.Destroy;
begin
  BmpBackground.Free;
  inherited Destroy;
end;

end.