unit Meter; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Graphics, Controls, Extctrls, Messages; 
 
type 
  TMeterZahlen = (mAlle, mKeine, mZwei); 
  TZeigerLaenge = (mKurz, mLang, mMittel); 
 
  TMeter = class(TCustomPanel) 
  private 
    FBereich1, FBereich2, FBereich3, FChange: TNotifyEvent; 
    FBereiche, FTeilung, Radius1, Strichgr, Strichkl, FStellen, ib: byte; 
    x1, y1, x2, y2, Wert1, Teilung, Winkel1, Winkel2, Winkel3, FFaktor: single; 
    Wert2, mini, maxi, Radius2, Strich, Bereich, Wert3, fs: integer; 
    FUntergrund, FFarbe1, FFarbe2, FFarbe3, FZeigerfarbe: TColor; 
    FMeterZahlen: TMeterZahlen; 
    s1, s2, FValue: double; 
    FWertAnzeige: boolean; 
    Strichzahl, anz: word; 
    Flang: TZeigerlaenge; 
    s, nk: string; 
    FScala: smallint; 
    sz: TSize; 
  protected 
    procedure MFont(var Msg: TWMSETFONT); message WM_SETFONT; 
    procedure setMeterZahlen(m: TMeterZahlen); 
    procedure setWertAnzeige(b: boolean); 
    procedure setlang(z: TZeigerlaenge); 
    procedure setZeigerfarbe(f: Tcolor); 
    procedure setUntergrund(f: Tcolor); 
    procedure setKommastellen(b: byte); 
    procedure setFaktor(s: single); 
    procedure makeEvent(d: double); 
    procedure setbereiche(b: byte); 
    procedure setFarbe1(f: Tcolor); 
    procedure setFarbe2(f: Tcolor); 
    procedure setFarbe3(f: Tcolor); 
    procedure setTeilung(b: byte); 
    procedure setValue(d: double); 
    procedure setmini(i: integer); 
    procedure setmaxi(i: integer); 
    procedure sets1(d: double); 
    procedure sets2(d: double); 
    procedure setscala(s: smallint); 
    procedure rechnestriche; 
    procedure makeTeilung; 
    procedure makewert; 
    function Punktx(x: Single): Integer; 
    function Punkty(y: Single): Integer; 
  public 
    procedure Paint; override; 
    procedure setEnabled(Value: boolean); override; 
    constructor Create(Owner: TComponent); override; 
  published 
    property Font; 
    property Enabled; 
    property Visible; 
    property BorderStyle; 
    property Stufe1: double read s1 write sets1; 
    property Stufe2: double read s2 write sets2; 
    property Value: double read FValue write setValue; 
    property MinValue: integer read mini write setmini; 
    property MaxValue: integer read maxi write setmaxi; 
    property Farbe1: TColor read FFarbe1 write setFarbe1; 
    property Farbe2: TColor read FFarbe2 write setFarbe2; 
    property Farbe3: TColor read FFarbe3 write setFarbe3; 
    property SkalaStelle: smallint read FScala write setscala; 
    property FontFaktor: single read FFaktor write setFaktor; 
    property Bereiche: byte read FBereiche write setbereiche; 
    property Unterteilung: byte read FTeilung write setTeilung; 
    property ZeigerLaenge: TZeigerlaenge read FLang write setLang; 
    property Kommastellen: byte read FStellen write setKommastellen; 
    property Untergrund: TColor read FUntergrund write setUntergrund; 
    property ZeigerFarbe: TColor read FZeigerfarbe write setZeigerfarbe; 
    property Zahlen: TMeterZahlen read FMeterZahlen write setMeterZahlen; 
    property WertAnzeige: boolean read FWertAnzeige write setWertAnzeige; 
    property OnBereich1: TNotifyEvent read Fbereich1 write FBereich1; 
    property OnBereich2: TNotifyEvent read Fbereich2 write FBereich2; 
    property OnBereich3: TNotifyEvent read Fbereich3 write FBereich3; 
    property OnValueChange: TNotifyEvent read FChange write FChange; 
    property OnMouseDown; 
    property OnMouseMove; 
    property OnDblClick; 
    property OnMouseUp; 
    property OnClick; 
  end; 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TMeter]); 
end; 
 
constructor TMeter.Create(Owner: TComponent); 
begin 
  inherited Create(Owner); 
  Font.Color := clGray; 
  Font.name := 'Arial'; 
  fs := 7; 
  Font.size := fs; 
  bevelouter := bvNone; 
  doublebuffered := true; 
  FStellen := 1; 
  nk := '0'; 
  ib := 0; 
  FFaktor := 1.25; 
  FZeigerfarbe := clFuchsia; 
  FFarbe1 := $33CC33; 
  FFarbe2 := $606060; 
  FFarbe3 := clRed; 
  s1 := 10; 
  s2 := 90; 
  width := 217; 
  height := 135; 
  FUntergrund := clwhite; 
  mini := 0; 
  maxi := 100; 
  Bereich := maxi - mini; 
  FTeilung := 5; 
  FBereiche := 10; ; 
  makeTeilung; 
  rechnestriche; 
  makewert; 
  Strichkl := 5; 
  Strichgr := 8; 
  FMeterZahlen := mAlle; 
  Winkel2 := 1.05; 
  Radius1 := 75; 
  rechnestriche; 
  FLang := mLang; 
  Radius2 := 21; 
  Strich := 62; 
  FScala := 5; 
  FWertAnzeige := true; 
end; 
 
function TMeter.Punktx(x: Single): Integer; 
begin 
  Result := Round(ClientWidth * (x / 100) - 1 + 
    ClientWidth / 2); 
end; 
 
function TMeter.Punkty(y: Single): Integer; 
begin 
  Result := ClientHeight - Round(ClientHeight * 
    ((y - 20) / (FScala + 75))); 
end; 
 
procedure TMeter.setscala(s: smallint); 
begin 
  if s > 70 then s := 70; 
  if FScala = s then exit; 
  FScala := s; 
  repaint; 
end; 
 
procedure TMeter.setlang(z: TZeigerlaenge); 
begin 
  if FLang = z then exit; 
  Flang := z; 
  case z of 
    mLang: Radius2 := 21; 
    mKurz: Radius2 := 11; 
  else Radius2 := 13; 
  end; 
  repaint; 
end; 
 
procedure TMeter.makeTeilung; 
begin 
  Teilung := Bereich / (FBereiche * FTeilung); 
end; 
 
procedure TMeter.setbereiche(b: byte); 
begin 
  if b = FBereiche then exit; 
  FBereiche := b; 
  if FBereiche < 1 then FBereiche := 1; 
  makeTeilung; 
  rechnestriche; 
  repaint; 
end; 
 
procedure TMeter.setTeilung(b: byte); 
begin 
  if b = FTeilung then exit; 
  FTeilung := b; 
  if FTeilung < 1 then FTeilung := 1; 
  makeTeilung; 
  rechnestriche; 
  repaint; 
end; 
 
procedure TMeter.makewert; 
begin 
  Wert2 := round(FValue - mini); 
  if Wert2 > Bereich then Wert2 := Bereich else 
    if Wert2 < 0 then Wert2 := 0; 
end; 
 
procedure TMeter.makeEvent(d: double); 
begin 
  if (d <= s1) and (ib <> 0) then begin 
    ib := 0; 
    if assigned(FBereich1) then FBereich1(self); 
  end else 
    if (d > s1) and (d < s2) and (ib <> 1) then begin 
      ib := 1; 
      if assigned(FBereich2) then FBereich2(self); 
    end else 
      if (d >= s2) and (ib <> 2) then begin 
        ib := 2; 
        if assigned(FBereich3) then FBereich3(self); 
      end; 
end; 
 
procedure TMeter.setValue(d: double); 
begin 
  if (d = FValue) or not enabled then exit; 
  if d < mini then d := mini 
  else if d > maxi then d := maxi; 
  FValue := d; 
  makewert; 
  if assigned(FChange) then FChange(self); 
  makeevent(d); 
  repaint; 
end; 
 
procedure TMeter.setmini(i: integer); 
begin 
  if i = mini then exit; 
  mini := i; 
  Bereich := maxi - mini; 
  if mini > FValue then 
    FValue := mini; 
  makeTeilung; 
  makewert; 
  repaint; 
end; 
 
procedure TMeter.setmaxi(i: integer); 
begin 
  if i = maxi then exit; 
  maxi := i; 
  Bereich := maxi - mini; 
  if maxi < FValue then begin 
    FValue := maxi; 
    makewert; 
  end; 
  makeTeilung; 
  repaint; 
end; 
 
procedure TMeter.setMeterZahlen(m: TMeterZahlen); 
begin 
  if m = FMeterZahlen then exit; 
  FMeterZahlen := m; 
  repaint; 
end; 
 
procedure TMeter.setUntergrund(f: Tcolor); 
begin 
  if f = FUntergrund then exit; 
  FUntergrund := f; 
  repaint; 
end; 
 
procedure TMeter.rechnestriche; 
begin 
  Strichzahl := succ(FTeilung * FBereiche); 
  anz := pred(Strichzahl); 
end; 
 
procedure TMeter.sets1(d: double); 
begin 
  if s1 = d then exit; 
  s1 := d; 
  makeevent(FValue); 
  repaint; 
end; 
 
procedure TMeter.sets2(d: double); 
begin 
  if s2 = d then exit; 
  s2 := d; 
  makeevent(FValue); 
  repaint; 
end; 
 
procedure TMeter.setFarbe1(f: Tcolor); 
begin 
  if FFarbe1 = f then exit; 
  FFarbe1 := f; 
  repaint; 
end; 
 
procedure TMeter.setFarbe2(f: Tcolor); 
begin 
  if FFarbe2 = f then exit; 
  FFarbe2 := f; 
  repaint; 
end; 
 
procedure TMeter.setFarbe3(f: Tcolor); 
begin 
  if FFarbe3 = f then exit; 
  FFarbe3 := f; 
  repaint; 
end; 
 
procedure TMeter.setZeigerfarbe(f: Tcolor); 
begin 
  if FZeigerfarbe = f then exit; 
  FZeigerfarbe := f; 
  repaint; 
end; 
 
procedure TMeter.setWertAnzeige(b: boolean); 
begin 
  if FWertAnzeige = b then exit; 
  FWertAnzeige := b; 
  repaint; 
end; 
 
procedure TMeter.setFaktor(s: single); 
begin 
  if s = FFaktor then exit; 
  FFaktor := s; 
  repaint; 
end; 
 
procedure TMeter.setKommastellen(b: byte); 
begin 
  if b = FStellen then exit; 
  if b > 10 then b := 10; 
  FStellen := b; 
  nk := stringofchar('0', FStellen); 
  repaint; 
end; 
 
procedure TMeter.setEnabled(Value: boolean); 
begin 
  inherited; 
  repaint; 
end; 
 
procedure TMeter.paint; 
var i: integer; 
begin 
  with Canvas do begin 
    brush.color := FUntergrund; 
    FillRect(rect(0, 0, clientwidth, clientheight)); 
    Wert1 := Bereich; 
    Winkel1 := Winkel2; 
    Winkel3 := Winkel2 / anz; 
    for i := 0 to anz do 
    begin 
      x1 := Cos(Winkel1) * Radius1; 
      y1 := Sin(Winkel1) * Radius1; 
      Wert3 := round(Wert1) + mini; 
      if Wert3 >= s2 then pen.color := FFarbe3 
      else if Wert3 <= s1 then pen.color := FFarbe1 
      else pen.color := FFarbe2; 
      if (i mod FTeilung = 0) then begin 
        x2 := x1 + Cos(Winkel1) * Strichgr; 
        y2 := y1 + Sin(Winkel1) * Strichgr; 
        if ((i = 0) or (i = anz)) and (FMeterZahlen <> mKeine) 
          or (FMeterZahlen = mAlle) then begin 
          Canvas.Font.Size := fs; 
          s := inttostr(Wert3); 
          sz := textextent(s); 
          TextOut(Punktx(x2) - pred(sz.cx div 2), Punkty(y2) - sz.cy, s); 
        end; 
      end else begin 
        x2 := x1 + Cos(Winkel1) * Strichkl; 
        y2 := y1 + Sin(Winkel1) * Strichkl; 
      end; 
      Wert1 := Wert1 - Teilung; 
      MoveTo(Punktx(x1), Punkty(y1)); 
      LineTo(Punktx(x2), Punkty(y2)); 
      Winkel1 := Winkel1 + Winkel3; 
    end; 
    if FWertAnzeige then begin 
      Canvas.Font.Size := round(fs * FFaktor); 
      s := formatfloat('#,##0.' + nk, FValue); 
      sz := textextent(s); 
      i := (ClientWidth - sz.cx) div 2; 
      TextOut(i, clientheight - 10 - sz.cy, s); 
    end; 
    if not enabled then exit; 
    Pen.Color := FZeigerfarbe; 
    Winkel1 := Winkel2 + ((Bereich - Wert2) / Bereich) * Winkel2; 
    x1 := Cos(Winkel1) * Radius2; 
    y1 := Sin(Winkel1) * Radius2; 
    x2 := x1 + Cos(Winkel1) * Strich; 
    y2 := y1 + Sin(Winkel1) * Strich; 
    MoveTo(Punktx(x1), Punkty(y1)); 
    LineTo(Punktx(x2), Punkty(y2)); 
  end; 
end; 
 
procedure TMeter.MFont(var Msg: TWMSETFONT); 
begin 
  if not (csReading in componentstate) 
    then begin 
    Canvas.font := Font; 
    fs := Canvas.Font.size; 
    repaint; 
  end; 
end; 
 
end.