unit Zaehler; 
 
interface 
 
uses 
  Windows, Extctrls, Classes, Graphics, Controls; 
 
type 
  TBType = 2..16; 
  TWtype = -2..15; 
  TZaehler = class(TCustomPanel) 
  private 
    FUeb, FChg: TNotifyEvent; 
    FCNE, FFarbe: TColor; 
    FNach: TZaehler; 
    FBasis: TBType; 
    FEin: boolean; 
    FWert: TWtype; 
  protected 
    procedure zeichen; 
    procedure ausgang; 
    function getrand: byte; 
    function getcol: TColor; 
    function getfontsize: byte; 
    procedure setrand(b: byte); 
    procedure setcol(c: TColor); 
    function getsunken: boolean; 
    procedure setcNE(c: TColor); 
    procedure setein(b: boolean); 
    procedure setwert(w: TWtype); 
    procedure setbasis(b: TBType); 
    procedure setfarbe(c: TColor); 
    procedure setnach(z: TZaehler); 
    procedure setfontsize(b: byte); 
    procedure setsunken(b: boolean); 
  public 
    procedure resize; override; 
    destructor Destroy; override; 
    procedure SetEnabled(Value: boolean); override; 
    constructor Create(AOwner: TComponent); override; 
  published 
    property FontSize: byte read getfontsize write setfontsize; 
    property Versunken: boolean read getsunken write setsunken; 
    property OnUebertrag: TNotifyEvent read FUeb write FUeb; 
    property Nachfolger: TZaehler read FNach write setnach; 
    property OnChange: TNotifyEvent read Fchg write Fchg; 
    property FontColor: TColor read getcol write setcol; 
    property Basis: TBType read FBasis write setbasis; 
    property Farbe: TColor read FFarbe write setfarbe; 
    property Eingang: boolean read FEin write setein; 
    property FarbeNE: TColor read FCNE write setcNE; 
    property Wert: TWtype read FWert write setwert; 
    property Rand: Byte read getrand write setrand; 
    property ParentShowHint; 
    property ShowHint; 
    property Visible; 
    property Enabled; 
  end; 
 
procedure Register; 
 
implementation 
 
constructor TZaehler.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  FNach := nil; 
  autosize := false; 
  FBasis := 10; 
  bevelouter := bvLowered; 
  bevelwidth := 3; 
  FWert := 0; 
  zeichen; 
  color := clBlack; 
  FFarbe := color; 
  FCNE := clGray; 
  Font.Name := 'Arial'; 
  Font.Color := clwhite; 
  Font.Style := [fsBold]; 
  Font.Size := 24; 
  resize; 
end; 
 
destructor TZaehler.Destroy; 
begin 
  inherited Destroy; 
end; 
 
procedure TZaehler.setrand(b: byte); 
var 
  w: integer; 
begin 
  if width > height then w := height 
  else w := width; 
  if b > w div 2 - 1 then b := w div 2 - 1; 
  if b = BevelWidth then exit; 
  Bevelwidth := b; 
  resize; 
end; 
 
procedure TZaehler.setsunken(b: boolean); 
begin 
  if b then bevelouter := bvLowered 
  else bevelouter := bvRaised; 
end; 
 
function TZaehler.getsunken: boolean; 
begin 
  result := bevelouter <> bvRaised; 
end; 
 
function TZaehler.getrand: byte; 
begin 
  result := bevelwidth; 
end; 
 
procedure TZaehler.resize; 
begin 
  width := round(bevelwidth * 2 + Font.Size); 
  height := round(bevelwidth * 2 + Font.Size * 1.3); 
end; 
 
function TZaehler.getfontsize: byte; 
begin 
  result := Font.Size; 
end; 
 
procedure TZaehler.setfontsize(b: byte); 
begin 
  if b = Font.Size then exit; 
  Font.Size := b; 
  resize; 
end; 
 
procedure TZaehler.setbasis(b: TBType); 
begin 
  if b = FBasis then exit; 
  FBasis := b; 
  FWert := 0; 
  zeichen; 
end; 
 
procedure TZaehler.zeichen; 
begin 
  case FWert of 
    -1: caption := '.'; 
    -2: caption := ':'; 
    0..9: caption := chr(FWert + 48); 
    10..15: caption := chr(FWert + 55); 
  end; 
end; 
 
procedure TZaehler.setwert(w: TWtype); 
begin 
  if (w = FWert) or not enabled then exit; 
  if w >= FBasis then FWert := 0 else 
    FWert := w; 
  zeichen; 
  if assigned(FChg) then FChg(self); 
end; 
 
procedure TZaehler.setcol(c: TColor); 
begin 
  if c = Font.color then exit; 
  Font.color := c; 
end; 
 
function TZaehler.getcol: TColor; 
begin 
  result := Font.color; 
end; 
 
procedure TZaehler.SetEnabled(Value: boolean); 
begin 
  inherited; 
  if not enabled then 
    color := FCNE else 
    color := FFarbe; 
end; 
 
procedure TZaehler.setcNE(c: TColor); 
begin 
  if FCNE = c then exit; 
  FCNE := c; 
  if not enabled then invalidate; 
end; 
 
procedure TZaehler.ausgang; 
begin 
  if FNach <> nil then FNach.eingang := true; 
  if assigned(FUeb) then FUeb(self); 
end; 
 
procedure TZaehler.setein(b: boolean); 
begin 
  if (b = FEin) or not b or not enabled then exit; 
  FEin := true; 
  if FWert >= 0 then begin 
    inc(FWert); 
    if FWert = FBasis then begin 
      FWert := 0; 
      ausgang; 
    end; 
    zeichen; 
  end else ausgang; 
  FEin := false; 
  if assigned(FChg) then FChg(self); 
end; 
 
procedure TZaehler.setfarbe(c: TColor); 
begin 
  if c = FFarbe then exit; 
  FFarbe := c; 
  if enabled then 
    color := c; 
end; 
 
procedure TZaehler.setnach(z: TZaehler); 
begin 
  if (z = self) or not (z is TZaehler) 
    then FNach := nil 
  else FNach := z; 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TZaehler]); 
end; 
 
end. 

*********************************************************************

Beispiel "Dualanzeige"

uses Zaehler; 
 
var 
  zarr: array[0..2] of TZaehler; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  x: integer; 
begin 
  for x := 0 to high(zarr) do begin 
    zarr[x] := TZaehler.create(self); 
    with zarr[x] do begin 
      basis := 2; 
      if x > 0 then nachfolger := zarr[x - 1]; 
      rand := 0; 
      farbe := clblue; 
      fontcolor := clyellow; 
      top := 10; 
      left := 10 + width * x; 
      zarr[x].parent := self; 
    end; 
  end; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  x: integer; 
begin 
  for x := 0 to high(zarr) do 
    zarr[x].free; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  zarr[high(zarr)].eingang := true; 
end; 

//--------------------------------------------------------------------------