unit Anzeige; 
 
interface 
 
uses 
  Windows, Classes, Graphics, Forms, Extctrls; 
 
type 
  TAnzeige = class(TCustomPanel) 
  private 
    FBm: TBitmap; 
    FBreit, FHoch: Word; 
    FRauf, FRunter: Boolean; 
    FCFrei, FCTief, FCMitte, FCHoch, FNE: TColor; 
    FWert, FMerk, FMin, FMax, FSpanne, FST1, FST2, FStep: Integer; 
    FRandLR, FRandO, FRandU, FAnzahl, FWMass, FSMass, FAbstand, FDmpfg: Byte; 
  protected 
    procedure setcmitte(c: TColor); 
    procedure setcfrei(c: TColor); 
    procedure setctief(c: TColor); 
    procedure setchoch(c: TColor); 
    procedure setabstand(b: byte); 
    procedure setwert(i: integer); 
    procedure setanzahl(b: byte); 
    procedure setst1(i: integer); 
    procedure setst2(i: integer); 
    procedure setmin(i: integer); 
    procedure setmax(i: integer); 
    procedure setRandLR(b: byte); 
    procedure setbreite(b: byte); 
    procedure runter(w: integer); 
    procedure setcne(c: TColor); 
    procedure setRandO(b: byte); 
    procedure setRandU(b: byte); 
    procedure sethoehe(b: byte); 
    procedure setDmpfg(b: byte); 
    procedure rauf(w: integer); 
    procedure rechStep; 
    procedure Balken; 
    procedure zeigen; 
    procedure build; 
  public 
    procedure paint; override; 
    procedure resize; override; 
    destructor Destroy; override; 
    procedure SetEnabled(Value: Boolean); override; 
    constructor Create(Owner: TComponent); override; 
  published 
    property BalkenAbstand: byte read FAbstand write setabstand; 
    property ColorMitte: TColor read FcMitte write setcMitte; 
    property BalkenBreite: byte read FWMass write setbreite; 
    property Balkenzahl: byte read FAnzahl write setanzahl; 
    property ColorFrei: TColor read FcFrei write setcfrei; 
    property ColorTief: TColor read FcTief write setctief; 
    property BalkenHoehe: byte read FSMass write sethoehe; 
    property ColorHoch: TColor read FcHoch write setchoch; 
    property Daempfung: byte read FDmpfg write setDmpfg; 
    property RandLR: byte read FRandLR write setRandLR; 
    property RandO: byte read FRandO write setRandO; 
    property RandU: byte read FRandU write setRandU; 
    property StufeU: integer read FSt1 write setst1; 
    property StufeO: integer read FSt2 write setst2; 
    property Value: integer read FWert write setwert; 
    property ColorNE: TColor read FNE write setcne; 
    property Min: integer read FMin write setmin; 
    property Max: integer read FMax write setmax; 
    property ParentShowHint; 
    property OnMouseMove; 
    property OnMouseDown; 
    property OnMouseUp; 
    property Showhint; 
    property Enabled; 
    property Visible; 
    property Color; 
  end; 
 
procedure Register; 
 
implementation 
 
constructor TAnzeige.Create(Owner: TComponent); 
begin 
  inherited Create(Owner); 
  FBm := TBitmap.create; 
  Color := clBlack; 
  FMin := 0; 
  FWert := FMin; 
  FMerk := FMin; 
  FMax := 100; 
  FSpanne := FMax; 
  FRandO := 2; 
  FRandU := FRandO; 
  FRandLR := FRandO; 
  FSt1 := 30; 
  FSt2 := 70; 
  FSMass := 4; 
  FWMass := 8; 
  FAnzahl := 10; 
  FAbstand := 1; 
  FcMitte := clyellow; 
  FcFrei := $505050; 
  FcTief := cllime; 
  color := clBlack; 
  FNE := clSilver; 
  FcHoch := clred; 
  FDmpfg := 0; 
  FStep := 10; 
  build; 
end; 
 
destructor TAnzeige.Destroy; 
begin 
  FBm.free; 
  inherited Destroy; 
end; 
 
procedure TAnzeige.zeigen; 
begin 
  canvas.draw(0, 0, FBm); 
end; 
 
procedure TAnzeige.balken; 
var 
  x, y, p1, p2, p3, w: integer; 
begin 
  if enabled then w := FWert else w := FMin; 
  p2 := FAnzahl - round((FAnzahl * (FST2 - FMin)) / FSpanne) - 1; 
  p1 := FAnzahl - round((FAnzahl * (FST1 - FMin)) / FSpanne) - 1; 
  p3 := FAnzahl - round((FAnzahl * (w - FMin)) / FSpanne) - 1; 
  with FBm.canvas do begin 
    for x := 0 to FAnzahl - 1 do begin 
      if x <= p3 then brush.color := FcFrei 
      else begin 
        if x <= p2 then brush.color := FcHoch else 
          if x <= p1 then brush.color := FcMitte else 
            brush.color := FcTief; 
      end; 
      y := x * (FSMass + FAbstand) + FRandO; 
      FillRect(rect(FRandLR, y, FBreit - FRandLR, y + FSMass)); 
    end; 
  end; 
end; 
 
procedure TAnzeige.build; 
begin 
  FBreit := FWMass + FRandLR + FRandLR; 
  FHoch := FAnzahl * (FSMass + FAbstand) + FRandU + FRando - FAbstand; 
  FBm.width := FBreit; 
  FBm.height := FHoch; 
  with FBm.canvas do begin 
    if enabled then brush.color := Color 
    else brush.color := FNE; 
    fillrect(cliprect); 
  end; 
  balken; 
  resize; 
end; 
 
procedure TAnzeige.paint; 
begin 
  build; 
  zeigen; 
end; 
 
procedure TAnzeige.resize; 
begin 
  inherited; 
  width := FBreit; 
  height := FHoch; 
end; 
 
procedure TAnzeige.sethoehe(b: byte); 
begin 
  if b = FSMass then exit 
  else if b = 0 then b := 1; 
  FSMass := b; 
  build; 
end; 
 
procedure TAnzeige.setbreite(b: byte); 
begin 
  if b = FWMass then exit 
  else if b = 0 then b := 1; 
  FWMass := b; 
  build; 
end; 
 
procedure TAnzeige.setabstand(b: byte); 
begin 
  if b = FAbstand then exit; 
  FAbstand := b; 
  build; 
end; 
 
procedure TAnzeige.setRandLR(b: byte); 
begin 
  if b = FRandLR then exit; 
  FRandLR := b; 
  build; 
end; 
 
procedure TAnzeige.setRandO(b: byte); 
begin 
  if b = FRandO then exit; 
  FRandO := b; 
  build; 
end; 
 
procedure TAnzeige.setRandU(b: byte); 
begin 
  if b = FRandU then exit; 
  FRandU := b; 
  build; 
end; 
 
procedure TAnzeige.setmin(i: integer); 
begin 
  if i = FMin then exit; 
  FMin := i; 
  if FMax <= FMin then FMax := FMin + 1; 
  if FWert < FMin then FWert := FMin 
  else if FWert > FMax then FWert := FMax; 
  FSpanne := abs(FMax - FMin); 
  rechStep; 
  balken; 
  zeigen; 
end; 
 
procedure TAnzeige.setmax(i: integer); 
begin 
  if i = FMax then exit; 
  FMax := i; 
  if FMin >= FMax then FMin := FMax - 1; 
  if FWert > FMax then FWert := FMax 
  else if FWert < FMin then FWert := FMin; 
  FSpanne := abs(FMax - FMin); 
  rechStep; 
  balken; 
  zeigen; 
end; 
 
procedure TAnzeige.setst1(i: integer); 
begin 
  if i = FSt1 then exit; 
  FSt1 := i; 
  if FSt1 > FSt2 then FST2 := FSt1; 
  balken; 
  zeigen; 
end; 
 
procedure TAnzeige.setst2(i: integer); 
begin 
  if i = FSt2 then exit; 
  FSt2 := i; 
  if FSt2 < FSt1 then FST1 := FSt2; 
  balken; 
  zeigen; 
end; 
 
procedure TAnzeige.rauf(w: integer); 
var 
  zeit: Cardinal; 
begin 
  FRauf := true; 
  repeat 
    application.processmessages; 
    FWert := FWert + FStep; 
    if FWert > w then FWert := w; 
    balken; 
    zeigen; 
    zeit := gettickcount + FDmpfg; 
    repeat 
      application.processmessages; 
    until not FRauf or (gettickcount >= zeit) or application.terminated; 
  until not FRauf or (FWert = w) or application.terminated; 
  FRauf := false; 
end; 
 
procedure TAnzeige.runter(w: integer); 
var 
  zeit: Cardinal; 
begin 
  FRunter := true; 
  repeat 
    application.processmessages; 
    FWert := FWert - FStep; 
    if FWert < w then FWert := w; 
    balken; 
    zeigen; 
    zeit := gettickcount + FDmpfg; 
    repeat 
      application.processmessages; 
    until not FRunter or (gettickcount >= zeit) or application.terminated; 
  until not FRunter or (FWert = w) or application.terminated; 
  FRunter := false; 
end; 
 
procedure TAnzeige.rechStep; 
begin 
  FStep := round(FSpanne / FAnzahl); 
  inc(FStep, ord(FStep = 0)); 
end; 
 
procedure TAnzeige.setwert(i: integer); 
begin 
  if i < FMin then i := Fmin 
  else if i > FMax then i := FMax; 
  FMerk := i; 
  if i = FWert then exit; 
  if not enabled or (FDmpfg = 0) then begin 
    FWert := i; 
    balken; 
    zeigen; 
  end else begin 
    if i > FWert then begin 
      FRunter := false; 
      rauf(i); 
    end else begin 
      FRauf := false; 
      runter(i); 
    end; 
  end; 
end; 
 
procedure TAnzeige.setanzahl(b: byte); 
begin 
  if b < 2 then b := 2; 
  if b = FAnzahl then exit; 
  FAnzahl := b; 
  rechStep; 
  build; 
end; 
 
procedure TAnzeige.setcne(c: TColor); 
begin 
  if c = FNE then exit; 
  FNE := c; 
  build; 
end; 
 
procedure TAnzeige.setcfrei(c: TColor); 
begin 
  if c = FcFrei then exit; 
  FcFrei := c; 
  balken; 
  zeigen; 
end; 
 
procedure TAnzeige.setctief(c: TColor); 
begin 
  if c = FcTief then exit; 
  FcTief := c; 
  balken; 
  zeigen; 
end; 
 
procedure TAnzeige.setcmitte(c: TColor); 
begin 
  if c = FcMitte then exit; 
  FcMitte := c; 
  balken; 
  zeigen; 
end; 
 
procedure TAnzeige.setchoch(c: TColor); 
begin 
  if c = FcHoch then exit; 
  FcHoch := c; 
  balken; 
  zeigen; 
end; 
 
procedure TAnzeige.setDmpfg(b: byte); 
begin 
  FDmpfg := b; 
end; 
 
procedure TAnzeige.SetEnabled(Value: Boolean); 
begin 
  inherited; 
  if not Value then 
  begin 
    FRunter := false; 
    FRauf := false; 
    FWert := FMerk; 
  end; 
  invalidate; 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TAnzeige]); 
end; 
 
end.