unit Stufe; 
 
interface 
 
uses 
  Windows, 
  Classes, 
  SysUtils, 
  StdCtrls, 
  Graphics; 
 
type 
  TChange = 
    procedure(Sender: TObject; Position, Rest: Word; Zustand: Shortint) of object; 
  TStufe = class(TCustomLabel) 
  private 
    FChange: TChange; 
    FMinColor, FNormalColor, FMaxColor, FUntergrund, FNotEnabled: TColor; 
    FMax, FPosition, FNormal, FOben: Word; 
    FNormal1, FOben1, FPosition1: Integer; 
    FSunken, FVerlauf, FCtl3D, FProzent: Boolean; 
    FRahmen, FBalkenbreite: Byte; 
  protected 
    procedure Resize; override; 
    procedure Paint; override; 
    procedure Farbverlauf(Rect: TRect; c: array of TColor); 
    procedure setNotEnabledColor(c: TColor); 
    procedure setNormalColor(c: TColor); 
    procedure setUntergrund(c: TColor); 
    procedure setBalkenbreite(b: byte); 
    procedure setMinColor(c: TColor); 
    procedure setMaxColor(c: TColor); 
    procedure setProzent(b: boolean); 
    procedure setVerlauf(b: boolean); 
    procedure setSunken(b: boolean); 
    procedure setPosition(w: word); 
    procedure setRahmen(b: byte); 
    procedure setNormal(w: word); 
    procedure set3D(b: boolean); 
    procedure setOben(w: word); 
    procedure setMax(w: word); 
    procedure berechnen; 
    procedure border; 
    procedure Change; 
    procedure hoehe; 
  public 
    constructor Create(Owner: TComponent); override; 
  published 
    property Balkenbreite: byte read FBalkenbreite write setBalkenbreite; 
    property FarbeMax: TColor read FMaxColor write setMaxcolor; 
    property FarbeMin: TColor read FMinColor write setMincolor; 
    property FarbeNormal: TColor read FNormalColor write setNormalcolor; 
    property FarbeNotEnabled: TColor read FNotenabled write setNotEnabledColor; 
    property Untergrund: TColor read FUntergrund write setUntergrund; 
    property Max: word read FMax write setMax; 
    property Normal: word read FNormal write setNormal; 
    property Position: word read FPosition write setPosition; 
    property Rahmenbreite: byte read FRahmen write setRahmen; 
    property Verlauf: boolean read FVerlauf write setVerlauf; 
    property Vertieft: boolean read FSunken write setSunken; 
    property ZuHoch: word read FOben write setOben; 
    property OnPosition: TChange read FChange write FChange; 
    property Ctl3D: boolean read FCtl3D write set3D; 
    property Prozent: boolean read FProzent write setProzent; 
    property Transparent; 
    property Enabled; 
    property Visible; 
    property Caption; 
    property Font; 
  end; 
 
procedure Register; 
 
implementation 
 
constructor TStufe.Create(Owner: TComponent); 
begin 
  inherited Create(Owner); 
  Autosize := false; 
  FVerlauf := false; 
  FProzent := false; 
  FCtl3D := true; 
  FSunken := true; 
  FBalkenbreite := 15; 
  FPosition := 0; 
  FNormal := 20; 
  FRahmen := 1; 
  width := 102; 
  height := 17; 
  FOben := 80; 
  FMax := 100; 
  FMaxColor := $4080FF; 
  FMincolor := clYellow; 
  FNormalColor := clLime; 
  FUntergrund := clBtnFace; 
  FNotEnabled := cl3DDKShadow; 
  Caption := Name; 
end; 
 
procedure TStufe.Farbverlauf(Rect: TRect; c: array of TColor); 
var 
  x, y, z, stelle, mx, bis, fach, mass: integer; 
  faktor: double; 
  a: array[0..2] of byte; 
  b: array of array[0..2] of byte; 
begin 
  mx := high(c); 
  mass := rect.right - rect.left; 
  setlength(b, mx + 1); 
  for x := 0 to mx do begin 
    c[x] := colortorgb(c[x]); 
    b[x][0] := getrvalue(c[x]); 
    b[x][1] := getgvalue(c[x]); 
    b[x][2] := getbvalue(c[x]); 
  end; 
  fach := round(mass / mx); 
  for y := 0 to mx - 1 do begin 
    if y = mx - 1 then bis := mass - y * fach - 1 
    else bis := fach; 
    for x := 0 to bis do begin 
      stelle := x + y * fach; 
      if bis = 0 then faktor := 1 else 
        faktor := x / bis; 
      for z := 0 to 2 do 
        a[z] := trunc(b[y][z] + ((b[y + 1][z] - b[y][z]) * faktor)); 
      canvas.Pen.Color := RGB(a[0], a[1], a[2]); 
      canvas.MoveTo(rect.left + stelle, Rect.Top); 
      canvas.LineTo(rect.left + stelle, Rect.Bottom); 
    end; 
  end; 
  b := nil; 
end; 
 
procedure TStufe.hoehe; 
var 
  x: integer; 
begin 
  x := FBalkenbreite + FRahmen shl 1; 
  height := x; 
  if width < x then width := x; 
end; 
 
procedure TStufe.Resize; 
begin 
  inherited; 
  hoehe; 
end; 
 
procedure TStufe.berechnen; 
  function rech(i: integer): integer; 
  begin 
    result := Round(i * (width - FRahmen shl 1) / FMax); 
  end; 
begin 
  FPosition1 := rech(FPosition) + FRahmen; 
  FNormal1 := rech(FNormal) + FRahmen; 
  FOben1 := rech(FOben) + FRahmen; 
end; 
 
procedure TStufe.border; 
var 
  x, y: integer; 
begin 
  with canvas do begin 
    for x := 0 to pred(FRahmen) do begin 
      y := succ(x); 
      if not FCtl3D then pen.color := cl3DDKShadow else 
        if FSunken then pen.color := clBtnShadow else 
          pen.color := clBtnHighlight; 
      moveto(x, height - y); 
      lineto(x, x); 
      lineto(width - x, x); 
      if not FCtl3D then pen.color := cl3DDKShadow else 
        if FSunken then pen.color := clBtnHighlight else 
          pen.color := clBtnShadow; 
      moveto(y, height - y); 
      lineto(width - y, height - y); 
      lineto(width - y, x); 
    end; 
  end; 
end; 
 
procedure TStufe.Paint; 
var 
  Punkt1, Punkt2, hmr, wmr: integer; 
  Farbe1, Farbe2: TColor; 
  rec: TRect; 
  procedure zeichneMin; 
  begin 
    if enabled then begin 
      Farbe1 := FMinColor; 
      Farbe2 := FNormalColor; 
    end else begin 
      Farbe1 := FNotEnabled; 
      Farbe2 := FNotEnabled; 
    end; 
    with canvas do begin 
      brush.color := Farbe1; 
      rec := rect(FRahmen, FRahmen, Punkt1, hmr); 
      if FVerlauf then 
        Farbverlauf(rec, [Farbe1, Farbe2]) 
      else fillrect(rec); 
    end; 
  end; 
  procedure zeichneNormal; 
  begin 
    if enabled then begin 
      Farbe1 := FNormalColor; 
      Farbe2 := FMaxColor; 
    end else begin 
      Farbe1 := FNotEnabled; 
      Farbe2 := FNotEnabled; 
    end; 
    with canvas do begin 
      brush.color := Farbe1; 
      rec := rect(Punkt1, FRahmen, Punkt2, hmr); 
      if FVerlauf then 
        Farbverlauf(rec, [Farbe1, Farbe2]) 
      else fillrect(rec); 
    end; 
  end; 
  procedure zeichneMax; 
  begin 
    with canvas do begin 
      if enabled then 
        brush.color := FMaxColor else 
        brush.color := FNotEnabled; 
      fillrect(rect(Punkt2, FRahmen, FPosition1, hmr)); 
    end; 
  end; 
  procedure zeichneUntergrund; 
  begin 
    if transparent then exit; 
    with canvas do begin 
      brush.color := FUntergrund; 
      fillrect(rect(FPosition1, FRahmen, wmr, hmr)); 
    end; 
  end; 
begin 
  berechnen; 
  border; 
  hmr := height - FRahmen; 
  wmr := width - FRahmen; 
  if FPosition >= FNormal then begin 
    Punkt1 := pred(FNormal1); 
    zeichneMin; 
    if FPosition >= FOben then begin 
      Punkt2 := pred(FOben1); 
      zeichneNormal; 
      zeichneMax; 
    end else begin 
      Punkt2 := FPosition1; 
      zeichneNormal; 
    end; 
  end else begin 
    Punkt1 := FPosition1; 
    zeichneMin; 
  end; 
  zeichneUntergrund; 
  if FProzent then caption := inttostr(trunc((FPosition * 100) / FMax)) + '%'; 
  rec := rect(FRahmen, FRahmen, width - FRahmen, height - FRahmen); 
  canvas.Font := Font; 
  canvas.brush.style := bsclear; 
  DrawText(canvas.handle, 
    PChar(caption), -1, rec, DT_Center or DT_VCenter or DT_Singleline); 
end; 
 
procedure TStufe.setRahmen(b: byte); 
begin 
  if b = FRahmen then exit; 
  FRahmen := b; 
  hoehe; 
  repaint; 
end; 
 
procedure TStufe.setBalkenbreite(b: byte); 
begin 
  if b = FBalkenbreite then exit; 
  FBalkenbreite := b; 
  hoehe; 
  repaint; 
end; 
 
procedure TStufe.setNotEnabledColor(c: TColor); 
begin 
  if c = FNotEnabled then exit; 
  FNotEnabled := c; 
  repaint; 
end; 
 
procedure TStufe.setMinColor(c: TColor); 
begin 
  if c = FMinColor then exit; 
  FMinColor := c; 
  repaint; 
end; 
 
procedure TStufe.setMaxColor(c: TColor); 
begin 
  if c = FMaxColor then exit; 
  FMaxColor := c; 
  repaint; 
end; 
 
procedure TStufe.setUntergrund(c: TColor); 
begin 
  if c = FUntergrund then exit; 
  FUntergrund := c; 
  repaint; 
end; 
 
procedure TStufe.setNormalColor(c: TColor); 
begin 
  if c = FNormalColor then exit; 
  FNormalColor := c; 
  repaint; 
end; 
 
procedure TStufe.setPosition(w: word); 
begin 
  if enabled then begin 
    if w > FMax then w := FMax; 
    if w = FPosition then exit; 
    FPosition := w; 
    repaint; 
    change; 
  end; 
end; 
 
procedure TStufe.setSunken(b: boolean); 
begin 
  if b = FSunken then exit; 
  FSunken := b; 
  repaint; 
end; 
 
procedure TStufe.setProzent(b: boolean); 
begin 
  if b = FProzent then exit; 
  FProzent := b; 
  if not b then Caption := ''; 
  repaint; 
end; 
 
procedure TStufe.setVerlauf(b: boolean); 
begin 
  if b = FVerlauf then exit; 
  FVerlauf := b; 
  repaint; 
end; 
 
procedure TStufe.set3D(b: boolean); 
begin 
  if b = FCtl3D then exit; 
  FCtl3D := b; 
  repaint; 
end; 
 
procedure TStufe.setMax(w: word); 
begin 
  if (w = FMax) or not enabled then exit; 
  FMax := w; 
  if FPosition > FMax then begin 
    FPosition := FMax; 
    repaint; 
    change; 
  end else repaint; 
end; 
 
procedure TStufe.setNormal(w: word); 
begin 
  if (w = FNormal) or not enabled then exit; 
  FNormal := w; 
  repaint; 
  change; 
end; 
 
procedure TStufe.setOben(w: word); 
begin 
  if (w = FOben) or not enabled then exit; 
  FOben := w; 
  repaint; 
  change; 
end; 
 
procedure TStufe.Change; 
var 
  zustand: shortint; 
  diff: word; 
begin 
  if assigned(FChange) then begin 
    if FPosition < FNormal then zustand := -1 else 
      if FPosition >= FOben then zustand := 1 
      else zustand := 0; 
    diff := FMax - FPosition; 
    FChange(self, FPosition, diff, zustand); 
  end; 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TStufe]); 
end; 
 
end.