DBR Delphi-Ecke

// Simples Zeigerinstrument mit quadratischen Abmaßen und einem
// Farbband als Skala. Ist die Komponente disabled, können
// Value, Min, Max, OK und High nicht verändert werden.
// Erläuterung der Eigenschaften und ein Beispiel
// finden Sie am Ende des Codes.
// Siehe aber auch ein einfaches Zeiger-Instrument erstellen

// überarbeitet 24.04.2012

// Getestet mit D4 unter XP

unit BA; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; 
 
type 
  TBAChange = procedure(Sender: TObject; 
    Min_, Max_, Value_, OK_, High_: Double; Wich: Byte) of object; 
  TBAThreshold = procedure(Sender: TObject; Threshold: Byte) of object; 
  TBAError = procedure(Sender: TObject; Difference: Double) of object; 
  TBADisp = (baNull, baTwo, baThree, baFive, baAll); 
  TBAShape = (baCircle, baRoundRect, baSquare); 
  TBA = class(TGraphicControl) 
  private 
    FPen, FBound, FZeiger, FClow, FChigh, FCok, FFc, FNe: TColor; 
    FMin, FMax, FValue, FMerk, FOK, FHigh, Fbreit: double; 
    FMw, FBr, FBr2, FMitte, FAbst, FFsa, FFsv: integer; 
    Fstr, FNum, FShow, FStart: boolean; 
    FThreshold: TBAThreshold; 
    FChange: TBAChange; 
    FError: TBAError; 
    FSkala, FM: byte; 
    FDisp: TBADisp; 
    FSp: TBAShape; 
    FTeil: single; 
    FBM: TBitmap; 
  protected 
    function x(w, b: double): integer; 
    function y(w, h: double): integer; 
    procedure setshow(b: boolean); 
    procedure setdisp(d: TBADisp); 
    procedure setchigh(c: TColor); 
    procedure setvalue(d: double); 
    procedure setbound(c: TColor); 
    procedure sethigh(d: double); 
    procedure setstr(b: boolean); 
    procedure setnum(b: boolean); 
    procedure setclow(c: TColor); 
    procedure setFcol(c: TColor); 
    procedure setskala(s: byte); 
    procedure setpen(c: TColor); 
    procedure setcok(c: TColor); 
    procedure setmin(d: double); 
    procedure setmax(d: double); 
    procedure Zeiger(c: TColor); 
    procedure setNE(c: TColor); 
    procedure kreis(c: TColor); 
    procedure setok(d: double); 
    procedure sp(s: TBAShape); 
    procedure ground; 
    procedure zahlen; 
    procedure skala; 
    procedure zarc; 
    procedure cnfg; 
    procedure rech; 
  public 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
    procedure loaded; override; 
    procedure Resize; override; 
    procedure Paint; override; 
  published 
    property OK: double read FOK write setok; 
    property Shape: TBAShape read FSp write sp; 
    property Min: double read FMin write setmin; 
    property Max: double read FMax write setmax; 
    property ColorNE: TColor read FNe write setne; 
    property High: double read FHigh write sethigh; 
    property Stripe: boolean read FStr write setstr; 
    property ColorOK: TColor read FCok write setcok; 
    property FontColor: TColor read FFc write setFcol; 
    property Value: double read FValue write setvalue; 
    property Periphery: TColor read FPen write setpen; 
    property Numbers: TBADisp read FDisp write setdisp; 
    property ColorLow: TColor read FCLow write setclow; 
    property Graduation: byte read FSkala write setskala; 
    property Boundary: TColor read FBound write setbound; 
    property Indicator: TColor read FZeiger write zeiger; 
    property ShowValue: boolean read FShow write setshow; 
    property ColorHigh: TColor read FChigh write setcHigh; 
    property OnExceeded: TBAError read FError write FError; 
    property OnChange: TBAChange read FChange write FChange; 
    property OnThreshold: TBAThreshold read FThreshold write FThreshold; 
    property OnMouseMove; 
    property OnMouseDown; 
    property OnMouseUp; 
    property ShowHint; 
    property Enabled; 
    property Visible; 
    property Color; 
    property ParentShowHint; 
  end; 
 
procedure Register; 
 
implementation 
 
constructor TBA.Create(AOwner: TComponent); 
begin 
  FStart := false; 
  inherited Create(AOwner); 
  canvas.Font.name := 'Arial'; 
  width := 135; 
  height := width; 
  FMw := width; 
  FShow := true; 
  FPen := $A7A7A7; 
  Color := clwhite; 
  FNe := clSilver; 
  FBound := clBlack; 
  FCok := $33FF33; 
  FClow := $FF7070; 
  FCHigh := $6666FF; 
  FStr := true; 
  FMin := 0; 
  FMax := 100; 
  FValue := 0; 
  FMerk := 100; 
  FOK := FMin - 1; 
  FHigh := FMax + 1; 
  FM := 1; 
  rech; 
  FDisp := baAll; 
  FBM := TBitmap.create; 
  FBM.transparent := true; 
  FZeiger := clred; 
  setskala(10); 
end; 
 
destructor TBA.Destroy; 
begin 
  FBM.free; 
  inherited Destroy; 
end; 
 
function TBA.x(w, b: double): integer; 
begin 
  result := trunc(cos((pi / 180) * w - pi / 2) * (b / 2) + FMitte); 
end; 
 
function TBA.y(w, h: double): integer; 
begin 
  result := trunc(sin((pi / 180) * w - pi / 2) * (h / 2) + FMitte); 
end; 
 
procedure TBA.setpen(c: TColor); 
begin 
  if FPen <> c then begin 
    FPen := c; 
    invalidate; 
  end; 
end; 
 
procedure TBA.setbound(c: TColor); 
begin 
  if FBound <> c then begin 
    FBound := c; 
    invalidate; 
  end; 
end; 
 
procedure TBA.cnfg; 
const 
  minimal = 100; 
begin 
  if width < minimal then width := minimal; 
  if height < minimal then height := minimal; 
  if (width < height) and (width < FMw) or 
    (width > height) and (width > FMw) then height := width 
  else width := height; 
  FMw := width; 
  FFsv := round(width / 17); 
  FFsa := round(width / 22); 
  rech; 
end; 
 
procedure TBA.kreis(c: TColor); 
var 
  breit, dm: integer; 
begin 
  breit := 1 + round(sqrt(width / 1.3)); 
  if (c <> FBM.canvas.brush.color) or 
    (FBM.width <> breit) then begin 
    FBM.width := breit; 
    FBM.height := breit; 
    with FBM.canvas do begin 
      brush.color := clwhite; 
      fillrect(cliprect); 
      brush.color := c; 
      pen.color := c; 
      ellipse(0, 0, breit, breit); 
    end; 
  end; 
  dm := round((width - FBM.width) * 0.5); 
  canvas.draw(dm, dm, FBM); 
end; 
 
procedure TBA.loaded; 
begin 
  cnfg; 
  inherited; 
end; 
 
procedure TBA.Resize; 
begin 
  inherited; 
  cnfg; 
end; 
 
procedure TBA.ground; 
var 
  m: integer; 
begin 
  canvas.pen.width := 2; 
  canvas.pen.color := FPen; 
  m := round(width * 0.333); 
  if enabled then 
    canvas.brush.color := color else 
    canvas.brush.color := FNe; 
  case Fsp of 
    baCircle: canvas.ellipse(0, 0, width, height); 
    baroundrect: canvas.roundrect(1, 1, width, height, m, m); 
  else canvas.rectangle(1, 1, width, height); 
  end; 
end; 
 
procedure TBA.zarc; 
var 
  m, z, a, f: integer; 
  c: TColor; 
begin 
  if FValue >= FHigh then begin 
    c := FCHigh; 
    FM := 3; 
  end else 
    if FValue >= FOk then begin 
      c := FCok; 
      FM := 2; 
    end else begin 
      c := FClow; 
      FM := 1; 
    end; 
  if FSkala < 1 then exit; 
  if FStr then begin 
    a := FAbst + FBr; 
    m := width - FAbst; 
    f := succ(FAbst); 
    z := m - FBr; 
    with canvas do begin 
      pen.color := FBound; 
      pen.width := 1; 
      brush.color := c; 
      pie(f, f, m - 1, m, m, m, FAbst, m); 
      if enabled then 
        brush.color := color else 
        brush.color := FNe; 
      pen.color := brush.color; 
      ellipse(a, a, z, z); 
      pen.color := FBound; 
      arc(a - 1, a - 1, z + 1, z + 1, z, z, a, z); 
    end; 
  end; 
  if FSkala > 1 then skala; 
end; 
 
procedure TBA.skala; 
var 
  s, o, u: single; 
  procedure makesk(g: single); 
  begin 
    canvas.moveto(x(g, width - o), y(g, width - o)); 
    canvas.lineto(x(g, width - u), y(g, width - u)); 
  end; 
begin 
  canvas.pen.color := FBound; 
  canvas.pen.width := 1; 
  s := -135 + FTeil; 
  o := (FAbst + FBr) * 1.9; 
  u := FAbst * 2.1; 
  if not FStr then begin 
    makesk(-135); 
    makesk(135); 
  end; 
  while s < 135 do begin 
    makesk(s); 
    s := s + FTeil; 
  end; 
end; 
 
procedure TBA.paint; 
begin 
  ground; 
  zarc; 
  zahlen; 
  zeiger(FZeiger); 
  FStart := true; 
end; 
 
procedure TBA.sp(s: TBAShape); 
begin 
  if s <> FSp then begin 
    Fsp := s; 
    invalidate; 
  end; 
end; 
 
procedure TBA.setskala(s: byte); 
begin 
  if s = FSkala then exit; 
  FSkala := s; 
  if s > 0 then 
    FTeil := 270 / s; 
  invalidate; 
end; 
 
procedure TBA.setstr(b: boolean); 
begin 
  if FStr = b then exit; 
  FStr := b; 
  invalidate; 
end; 
 
procedure TBA.setvalue(d: double); 
var 
  b: byte; 
begin 
  if (d = FValue) or not enabled then exit; 
  b := 0; 
  if d < FMin then begin 
    if assigned(FError) then 
      FError(self, d - FMin); 
    d := FMin; 
    b := b or 1; 
  end else 
    if d > FMax then begin 
      if assigned(FError) then 
        FError(self, d - FMax); 
      d := FMax; 
      b := b or 2; 
    end; 
  FValue := d; 
  b := b or 4; 
  zeiger(FZeiger); 
  if FStart and 
    assigned(FChange) then FChange(self, FMin, FMax, FValue, FOK, FHigh, b); 
end; 
 
procedure TBA.Zeiger(c: TColor); 
var 
  r: TRect; 
  a, i: integer; 
  st: double; 
  s: string; 
  b: boolean; 
  cl: TColor; 
  procedure build(v: double; f: TColor; w: integer); 
  begin 
    st := ((v - FMin) * 270) / FBreit - 135; 
    with canvas do begin 
      pen.color := f; 
      pen.width := w + ord(width > 200) * 2; 
      moveto(x(st, FBM.width), y(st, FBM.height)); 
      lineto(x(st, width - a), y(st, width - a)); 
    end; 
  end; 
begin 
  if (FValue >= FHigh) and (FM <> 3) or (FValue < FOK) and (FM <> 1) 
    or (FM <> 2) and (FValue < FHigh) and (FValue >= FOK) 
    then begin 
    zarc; 
    b := true; 
  end else b := false; 
  if enabled then 
    cl := color else 
    cl := FNe; 
  if FShow then begin 
    if enabled then 
      canvas.brush.color := color else 
      canvas.brush.color := FNe; 
    canvas.Font.color := c; 
    if FDisp = baNull then 
      r := rect((Fabst + FBr) * 2, height - FBr2 - FBr, 
        width - (FAbst + FBr) * 2, height - FBr) else 
      r := rect(FAbst + FBr2, height - FBr2 - FBr, width - FAbst - FBr2, 
        height - FBr); 
    canvas.FillRect(r); 
    canvas.font.size := FFsv; 
    s := formatfloat('0.0', FValue); 
    i := canvas.textwidth(s); 
    canvas.textout((width - i) div 2, height - height div 4, s); 
  end; 
  FZeiger := c; 
  a := round((FAbst + FBr + 2) * (2.1 + ord(Fdisp = baNull) * 0.05)); 
  build(FMerk, cl, 5); 
  kreis(FZeiger); 
  build(FValue, c, 3); 
  FMerk := FValue; 
  if b and assigned(FThreshold) then FThreshold(self, FM); 
end; 
 
procedure TBA.setmin(d: double); 
var 
  b: byte; 
begin 
  if (d = FMin) or not enabled then exit; 
  b := 0; 
  if d >= FMax then begin 
    FMax := d + 1; 
    b := b or 2; 
  end; 
  if d > FValue then begin 
    FValue := d; 
    b := b or 4; 
  end; 
  FMin := d; 
  b := b or 1; 
  FBreit := FMax - FMin; 
  invalidate; 
  if FStart and 
    assigned(FChange) then FChange(self, FMin, FMax, FValue, FOK, FHigh, b); 
end; 
 
procedure TBA.setmax(d: double); 
var 
  b: byte; 
begin 
  if (d = FMax) or not enabled then exit; 
  b := 0; 
  if d <= FMin then begin 
    FMin := d - 1; 
    b := b or 1; 
  end; 
  if d < FValue then begin 
    FValue := d; 
    b := b or 4; 
  end; 
  FMax := d; 
  b := b or 2; 
  FBreit := FMax - FMin; 
  invalidate; 
  if FStart and 
    assigned(FChange) then FChange(self, FMin, FMax, FValue, FOK, FHigh, b); 
end; 
 
procedure TBA.setok(d: double); 
begin 
  if (d <> FOK) and enabled then begin 
    FOK := d; 
    invalidate; 
    if FStart and 
      assigned(FChange) then FChange(self, FMin, FMax, FValue, FOK, FHigh, 8); 
  end; 
end; 
 
procedure TBA.sethigh(d: double); 
begin 
  if (d <> FHigh) and enabled then begin 
    FHigh := d; 
    invalidate; 
    if FStart and 
      assigned(FChange) then FChange(self, FMin, FMax, FValue, FOK, FHigh, 16); 
  end; 
end; 
 
procedure TBA.setclow(c: TColor); 
begin 
  if FClow = c then exit; 
  FClow := c; 
  invalidate; 
end; 
 
procedure TBA.setchigh(c: TColor); 
begin 
  if FChigh = c then exit; 
  FChigh := c; 
  invalidate; 
end; 
 
procedure TBA.setcok(c: TColor); 
begin 
  if FCok = c then exit; 
  FCok := c; 
  invalidate; 
end; 
 
procedure TBA.zahlen; 
var 
  k, u, t, w, j: single; 
  i: integer; 
  sz: TSize; 
  procedure go(a: single); 
  var 
    s: string; 
  begin 
    s := formatfloat('0', FMin + w * i); 
    with canvas do begin 
      canvas.brush.style := bsclear; 
      sz := Textextent(s); 
      moveto(x(a, u) - sz.cx div 2 + 1, y(a, u) - sz.cy div 2); 
      textout(penpos.x, penpos.y, s); 
    end; 
  end; 
begin 
  setnum(FDisp = baNull); 
  if FDisp <> baNull then begin 
    i := 0; 
    k := -135; 
    u := width - FAbst * 1.1; 
    case FDisp of 
      baTwo: begin 
          t := 270; 
          j := 1; 
        end; 
      baThree: begin 
          t := 135; 
          j := 2; 
        end; 
      baFive: begin 
          t := 67.5; 
          j := 4; 
        end; 
    else begin 
        if FSkala > 0 then begin 
          j := FSkala; 
          t := 270 / j; 
        end else begin 
          t := 270; 
          j := 1; 
        end; 
      end; 
    end; 
    w := (FBreit / j); 
    canvas.font.size := FFsa; 
    canvas.Font.color := FFc; 
    while k <= 135 do begin 
      go(k); 
      k := k + t; 
      inc(i); 
    end; 
  end; 
end; 
 
procedure TBA.rech; 
begin 
  FBreit := FMax - FMin; 
  FBr := width div 11; 
  FBr2 := FBr + FBr; 
  FMitte := round(width / 2); 
  FAbst := width div (17 - ord(FDisp <> baNull) * 11); 
end; 
 
procedure TBA.setnum(b: boolean); 
begin 
  if b = FNum then exit; 
  FNum := b; 
  rech; 
  invalidate; 
end; 
 
procedure TBA.setdisp(d: TBADisp); 
begin 
  if d = FDisp then exit; 
  FDisp := d; 
  invalidate; 
end; 
 
procedure TBA.setFcol(c: TColor); 
begin 
  if c = FFc then exit; 
  FFc := c; 
  invalidate; 
end; 
 
procedure TBA.setshow(b: boolean); 
begin 
  if b = FShow then exit; 
  FShow := b; 
  invalidate; 
end; 
 
procedure TBA.setNE(c: TColor); 
begin 
  if c = FNe then exit; 
  FNe := c; 
  if not enabled then invalidate; 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TBA]); 
end; 
 
end.

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

Erläuterung der Eigenschaften:

Boundary: TColor
Legt die Farbe der Umrandung des Farbbandes und der Skalenstriche fest.

Color: TColor
Bestimmt die Farbe der Grundfläche.

ColorHigh, ColorOK, ColorLow: TColor
Bestimmt die Farbe des Farbbandes entsprechend der erreichten Stufe.
Siehe dazu weiter unten OK und High.

ColorNE: TColor
Bestimmt die Farbe der Grundfläche, wenn die Komponente "not Enabled" ist.

FontColor: TColor
Bestimmt die Farbe der Skalenbeschriftung.

Graduation: Byte
Skaleneinteilung. Bei "0" wird kein Farbband angezeigt.

OK, High: Double
Stellen Stufen dar. Ist "Value" unter OK, wird das Farbband in der Farbe
"ColorLow" angezeigt. Ist "Value" größer oder gleich High, wird das Farbband
in der Farbe "ColorHigh" angezeigt. Ansonsten hat das Band die Farbe "ColorOK".

Indicator: TColor
Bestimmt die Farbe des Zeigers und der Anzeige des Wertes unterhalb des Zeigers.

Min, Max: Double
Anfang und Ende der Skala.

Numbers: TBADisp
baNull = Es wird keine Skalenbeschriftung angezeigt.
baTwo = Es wird nur Anfang und Ende der Skala beschriftet.
baThree = Anfang, Mitte und Ende derSkala werden beschriftet.
baFive = Fünf Zahlen werden unabhängig von der Skaleneinteilung angezeigt.
baAll = Alle vorhandenen Skalenstriche werden beschriftet.

Periphery: TColor
Farbe der Umrandung des Instrumentes.

Shape: TBAShape
baCircle = Instrument ist kreisförmig.
baSquare = Instrument wird als Quadrat dargestellt.
baRoundRect = Quadrat mit abgerundeten Ecken.

ShowValue: Boolean
Der Wert von "Value" wird unter dem Zeiger als Zahl dargestellt.

Stripe: Boolean
Blendet das Farbband ein bzw. aus. Siehe aber auch oben "Graduation".

Value: Double
Der anzuzeigende Wert.

OnChange: Event
Wird ausgelöst, wenn sich Min, Max, Value, OK oder High ändern.
Dabei enthält "Wich" den Hinweis, welcher Wert sich geändert hat.
Wich = 1 : Min hat sich geändert
Wich = 2 : Max hat sich geändert
Wich = 4 : Value hat sich geändert
Wich = 8 : OK hat sich geändert
Wich = 16 : High hat sich geändert
Auch Kombinationen sind möglich:
Wich = 6 : Value und Max haben sich geändert usw.

OnExeeded: Event
Wird ausgelöst, wenn "Value" den Wert von "Min" oder "Max" überschreitet.
Ist "Difference" negativ, dann war "Value" zu klein, ansonsten war "Value"
zu groß.

OnThreshold: Event
Wird ausgelöst, wenn "Value" den Wert von "OK" oder "High" überquert.
Dabei zeigt "Threshold" an, in welchem Bereich sich "Value" bewegt.
1: Value ist unterhalb von OK
2: Value ist zwischen OK und High
3: Value ist >= High

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

Beispiel:

procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Ba1.Min := 0; 
  Ba1.Max := 200; 
  Ba1.ok := 50; 
  Ba1.High := 150; 
  Ba1.Value := Ba1.Min; 
  Ba1.Indicator := Ba1.ColorLow; 
  Trackbar1.Min := trunc(Ba1.Min); 
  Trackbar1.Max := round(Ba1.Max); 
  Trackbar1.Position := Trackbar1.Min; 
end; 
 
procedure TForm1.TrackBar1Change(Sender: TObject); 
begin 
  Ba1.value := Trackbar1.position; 
end; 
 
procedure TForm1.BA1Threshold(Sender: TObject; Threshold: Byte); 
begin 
  case Threshold of 
    1: Ba1.Indicator := Ba1.ColorLow; 
    2: Ba1.Indicator := Ba1.ColorOK; 
    3: Ba1.Indicator := Ba1.ColorHigh; 
  end; 
end;