procedure TForm1.Fort1Position(Sender: TObject; Position, Rest: Double; 
  Value, Percent: string); 
begin 
  Label1.caption := Floattostr(Position); 
  Label2.caption := Floattostr(Fort1.Position); 
end;



// Ein weiters Beispiel:
// Bei einem Mittelwert (50%) soll der Balken grün sein,
// bei zu hohem Wert gegen Rot gehen und bei niedrigen Werten zu Blau tendieren:

procedure TForm1.Fort1Position(Sender: TObject; Position, Rest: Double; 
  Value, Percent: string); 
var 
  r, g, b: byte; 
  m, v: integer; 
begin 
  m := Fort1.max - Fort1.min; 
  v := round(m / 2 + Fort1.min); 
  b := round((Fort1.max - position) * 255 / m); 
  r := 255 - b; 
  if position > v then g := b * 2 
  else g := r * 2; 
  Fort1.progresscolor := rgb(r, g, b); 
end;

unit Fort; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Graphics, Controls, Messages, Extctrls; 
 
type 
  TA = (tfoCenter, tfoLeft, tfoRight, tfoProgressCenter, tfoProgressleft, 
    tfoProgressright, tfoProgressMiddle); 
  TView = (tfoPercent, tfoNone, tfoPosition, tfoText); 
  TBack = (tfoNormal, tfoFlat, tfoBeam); 
  TRah = (tfoNoFrame, tfo3D, tfoXP); 
  Tpp = array[0..2] of Byte; 
  TMM = -1000000..1000000; 
  TIn = 0..100; 
  TOnPosition = procedure(Sender: TObject; Position, Rest: Double; 
    Value, Percent: string) of object; 
  TFort = class(TCustomControl) 
  private 
    FFlash, FRotate, FLight, FWaag, FFlat, FDown, FM, FD: Boolean; 
    FBer, FLang, FZ, FZ2, FSize: Integer; 
    FBmp, FBm2, FBh1, FBh2: TBitmap; 
    FRH, FGH, FBH, FR, FG, FB: byte; 
    FFarbe, FC, FLT, FHC: TColor; 
    FTimer, FTimer2: TTimer; 
    FChange: TOnPosition; 
    FProz, FPosi: string; 
    FPos, FMerk: Double; 
    FPuls, FIntens: TIn; 
    FMax, FMin: TMM; 
    FBack: TBack; 
    FView: TView; 
    FRa: TRah; 
    FA: TA; 
  protected 
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; 
    procedure MouseDown(Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); override; 
    procedure MouseUp(Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); override; 
    procedure setenabled(Value: Boolean); override; 
    procedure setWaagSenk(b: boolean); 
    procedure setFontSize(i: integer); 
    procedure buildpos(x, y: integer); 
    procedure Timer2(Sender: TObject); 
    procedure Timer(Sender: TObject); 
    procedure setRotate(b: boolean); 
    procedure setLight(b: boolean); 
    procedure setFlash(b: boolean); 
    procedure setFarbe(c: TColor); 
    procedure setDamp(b: boolean); 
    procedure setFlat(b: boolean); 
    procedure setRahmen(r: TRah); 
    procedure makePos(s: Double); 
    procedure setPos(s: Double); 
    procedure setBack(b: TBack); 
    procedure setIntens(i: TIn); 
    procedure setFC(c: TColor); 
    procedure setAnz(v: TView); 
    procedure paint; override; 
    procedure setMax(i: TMM); 
    procedure setMin(i: TMM); 
    procedure FarbeZeigen; 
    procedure setA(a: TA); 
    procedure setBereich; 
    procedure einfaerben; 
    procedure makefont; 
  public 
    procedure CMCOLOR(var M: TMessage); message CM_COLORCHANGED; 
    procedure WMText(var M: TMessage); message WM_SetText; 
    constructor Create(Owner: TComponent); override; 
    destructor Destroy; override; 
    procedure Resize; override; 
  published 
    property FontHorizontal: boolean read FRotate write setRotate; 
    property OnPosition: TOnPosition read FChange write FChange; 
    property Horizontal: boolean read FWaag write setWaagSenk; 
    property ProgressColor: TColor read FFarbe write setFarbe; 
    property FontSize: Integer read FSize write setFontSize; 
    property TextViewStyle: TView read FView write setAnz; 
    property LightTop: boolean read FLight write setLight; 
    property Flashing: boolean read FFlash write setFlash; 
    property Intensity: TIn read FIntens write setIntens; 
    property Background: TBack read FBack write setBack; 
    property Position: Double read FMerk write setPos; 
    property MouseReaction: boolean read FM write FM; 
    property Flat: boolean read FFlat write setFlat; 
    property FontColor: TColor read FC write setFC; 
    property Frame: TRah read FRa write setRahmen; 
    property TextAlignment: TA read FA write setA; 
    property Delay: boolean read FD write setDamp; 
    property Max: TMM read FMax write setMax; 
    property Min: TMM read FMin write setMin; 
    property ParentShowHint; 
    property OnMouseMove; 
    property OnMouseDown; 
    property OnMouseUp; 
    property ShowHint; 
    property Enabled; 
    property Visible; 
    property Cursor; 
    property Color; 
    property Text; 
    property Hint; 
  end; 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TFort]); 
end; 
 
var 
  FBytesm: array[0..29] of byte = ( 
    $85, $93, $A2, $AF, $BE, $CB, $DA, $E7, $EC, $F3, 
    $F9, $FE, $F9, $F3, $EE, $E8, $E2, $D8, $D0, $C6, 
    $BD, $B3, $AA, $A1, $97, $8F, $85, $7C, $72, $6A); 
  FBytesU: array[0..29] of byte = ( 
    $C4, $C6, $C9, $CB, $CD, $CF, $D1, $D3, $D5, $D7, 
    $D9, $DB, $DD, $E0, $E2, $E4, $E6, $E8, $E9, $EB, 
    $ED, $EF, $F1, $F3, $F5, $F6, $F8, $FA, $FC, $FE); 
  FBytes: array[0..29] of byte = ( 
    $B7, $C1, $CC, $D6, $E1, $EB, $F7, $FE, $FB, $F2, 
    $EA, $E1, $D8, $CF, $C7, $BE, $B6, $AC, $A4, $9B, 
    $93, $8B, $84, $7C, $74, $6D, $65, $5E, $56, $4F); 
 
procedure TFort.paint; 
var 
  w, h, y, i, j, hmfz, hmmfl, fzpfl: Integer; 
  sz: TSize; 
  s: string; 
  procedure Rahmen; 
  begin 
    with Canvas do begin 
      if FRa = tfoXP then 
        pen.color := $B6A592 else 
        pen.color := $666666; 
      moveto(0, pred(h)); 
      LineTo(0, 0); 
      LineTo(w, 0); 
      if FRa = tfo3D then pen.color := clWhite; 
      LineTo(w, h); 
      LineTo(-1, h); 
    end; 
  end; 
  procedure testen; 
  begin 
    if y < i then y := i else 
      if y > j then y := j; 
  end; 
  procedure schriftw; 
  begin 
    i := 2 + FZ; 
    j := width - FZ - sz.cx - 2; 
    case FA of 
      tfoLeft: y := i; 
      tfoRight: y := j; 
      tfoProgressCenter: y := FLang - sz.cx shr 1; 
      tfoProgressleft: y := FLang - sz.cx; 
      tfoProgressright: y := FLang + 2; 
      tfoProgressMiddle: y := (FLang - sz.cx) div 2; 
    else y := (width - sz.cx) shr 1; 
    end; 
    testen; 
    canvas.Textout(y, (height - sz.cy) shr 1, s); 
  end; 
  procedure schrifts; 
  begin 
    i := 2 + FZ + sz.cx; 
    j := height - 2 - FZ; 
    case FA of 
      tfoLeft: y := j; 
      tfoRight: y := i; 
      tfoProgressCenter: y := hmmfl + sz.cx shr 1; 
      tfoProgressleft: y := hmmfl + sz.cx; 
      tfoProgressright: y := hmmfl - 2; 
      tfoProgressMiddle: y := hmfz - (FLang - sz.cx) div 2; 
    else y := height - (height - sz.cx) shr 1; 
    end; 
    testen; 
    canvas.TextOut((width - sz.cy) shr 1, y, s); 
  end; 
  procedure schrifts2; 
  begin 
    i := 2 + FZ; 
    j := height - 2 - FZ - sz.cy; 
    case FA of 
      tfoLeft: y := j; 
      tfoRight: y := i; 
      tfoProgressCenter: y := hmmfl - sz.cy shr 1; 
      tfoProgressleft: y := hmmfl; 
      tfoProgressright: y := hmmfl - sz.cy; 
      tfoProgressMiddle: y := hmfz - (FLang + sz.cy) div 2; 
    else y := (height - sz.cy) shr 1; 
    end; 
    testen; 
    Canvas.TextOut((width - sz.cx) shr 1, y, s); 
  end; 
  procedure schriftw2; 
  begin 
    i := FZ + sz.cy + 1; 
    j := width - 1 - FZ; 
    case FA of 
      tfoLeft: y := i; 
      tfoRight: y := j; 
      tfoProgressCenter: y := fzpfl + sz.cy shr 1; 
      tfoProgressleft: y := fzpfl; 
      tfoProgressright: y := fzpfl + sz.cy; 
      tfoProgressMiddle: y := (FLang + sz.cy) div 2 + FZ; 
    else y := (width + sz.cy) shr 1; 
    end; 
    testen; 
    canvas.TextOut(y, (height - sz.cx) shr 1, s); 
  end; 
begin 
  w := pred(Width); 
  h := pred(Height); 
  hmfz := height - FZ; 
  hmmfl := hmfz - Flang; 
  fzpfl := FZ + FLang; 
  with Canvas do begin 
    Brush.color := Color; 
    case FView of 
      tfoNone: s := ''; 
      tfoPercent: s := FProz; 
      tfoText: s := Text; 
    else 
      s := FPosi; 
    end; 
    sz := textextent(s); 
    if FWaag then begin 
      if FBack = tfoFlat then 
        Fillrect(rect(Flang, FZ, width - FZ, hmfz)) 
      else begin 
        SetstretchBltMode(handle, STRETCH_HALFTONE); 
        StretchBlt(handle, Flang, FZ, width - FZ, height - FZ2, 
          FBh1.canvas.handle, 0, 0, 1, FBh1.height, srcCopy); 
      end; 
      if FFlat then begin 
        brush.color := FLT; 
        fillrect(rect(FZ, FZ, fzpfl, hmfz)); 
      end else begin 
        SetstretchBltMode(handle, STRETCH_HALFTONE); 
        StretchBlt(handle, 0, FZ, fzpfl, height - FZ2, FBmp.canvas.handle, 
          0, 0, 1, FBmp.height, srcCopy); 
      end; 
      SetBKMode(handle, Transparent); 
      if not FRotate then schriftw2 else schriftw; 
    end else begin 
      if FBack = tfoFlat then 
        Fillrect(rect(FZ, FZ, width - FZ, height - FLang)) 
      else begin 
        SetstretchBltMode(handle, STRETCH_HALFTONE); 
        stretchdraw(rect(FZ, FZ, width - FZ, height - FLang), FBh2); 
      end; 
      if FFlat then begin 
        brush.color := FLT; 
        fillrect(rect(FZ, height - FLang - FZ, width - FZ, hmfz)); 
      end else begin 
        SetstretchBltMode(handle, STRETCH_HALFTONE); 
        stretchdraw(rect(FZ, height - FLang - FZ, width - FZ, 
          hmfz), FBm2); 
      end; 
      SetBKMode(handle, Transparent); 
      if not FRotate then schrifts else schrifts2; 
    end; 
    if FRa <> tfoNoFrame then rahmen; 
  end; 
end; 
 
procedure TFort.makefont; 
var 
  LogFont: TLogfont; 
begin 
  with Canvas do begin 
    GetObject(Font.Handle, sizeof(Logfont), @Logfont); 
    Logfont.lfEscapement := ord(not FRotate) * 900 
      * (ord(not FWaag) * 2 - 1); 
    Font.Handle := CreateFontIndirect(Logfont); 
  end; 
end; 
 
constructor TFort.Create(Owner: TComponent); 
begin 
  inherited Create(Owner); 
  ControlStyle := ControlStyle + [csOpaque]; 
  FTimer := TTimer.create(self); 
  FTimer.enabled := false; 
  FTimer.interval := 167; 
  FTimer.OnTimer := Timer; 
  FTimer2 := TTimer.create(self); 
  FTimer2.enabled := false; 
  FTimer2.interval := 12; 
  FTimer2.OnTimer := Timer2; 
  FIntens := 50; 
  FM := True; 
  FWaag := True; 
  FDown := False; 
  FFlat := False; 
  FFlash := False; 
  FLight := False; 
  FRotate := True; 
  FBack := tfoNormal; 
  Canvas.Font.Name := 'Arial'; 
  FBmp := TBitmap.create; 
  FBmp.pixelformat := pf24bit; 
  FBmp.width := 1; 
  FBmp.height := 30; 
  FBm2 := TBitmap.create; 
  FBm2.pixelformat := pf24bit; 
  FBm2.width := FBmp.height; 
  FBm2.height := FBmp.width; 
  FBh1 := TBitmap.create; 
  FBh1.pixelformat := pf24bit; 
  FBh1.width := FBmp.width; 
  FBh1.height := FBmp.height; 
  FBh2 := TBitmap.create; 
  FBh2.pixelformat := pf24bit; 
  FBh2.width := FBmp.height; 
  FBh2.height := FBmp.width; 
  FMerk := 0.0; 
  FPos := 0.0; 
  FMax := 100; 
  FPuls := 0; 
  FLang := 0; 
  FMin := 0; 
  width := 150; 
  height := 17; 
  Color := $EFEFEF; 
  SetFontSize(8); 
  setRahmen(tfo3D); 
  setFarbe($FF9999); 
  setFC(clBlack); 
  setBereich; 
  FD := False; 
end; 
 
destructor TFort.Destroy; 
begin 
  FTimer2.free; 
  FTimer.free; 
  FBh2.free; 
  FBh1.free; 
  FBm2.free; 
  FBmp.free; 
  inherited Destroy; 
end; 
 
procedure TFort.makePos(s: Double); 
begin 
  FPos := s; 
  setBereich; 
  if assigned(FChange) then 
    FChange(self, FPos, FMax - FPos, FPosi, FProz); 
end; 
 
procedure TFort.setPos(s: Double); 
begin 
  if s < FMin then s := FMin; 
  if s > FMax then s := FMax; 
  if not enabled then exit; 
  FMerk := s; 
  if FD and (FMerk <> FPos) and not FDown then 
    FTimer2.enabled := true 
  else makepos(s); 
end; 
 
procedure TFort.setBereich; 
var 
  m: integer; 
  s: string; 
  procedure rechnen(i: integer); 
  begin 
    FLang := round(m * (i - FZ2) / FBer); 
  end; 
begin 
  FBer := FMax - FMin; 
  m := round(Fpos - FMin); 
  if FWaag then rechnen(width) 
  else rechnen(height); 
  if frac(Fpos) <> 0 then s := '.00' 
  else s := ''; 
  FPosi := FormatFloat('#,#0' + s, FPos); 
  FProz := FormatFloat('0.0', m * 100 / FBer) + '%'; 
  invalidate; 
end; 
 
procedure TFort.setMax(i: TMM); 
var m: boolean; 
begin 
  if i > 1000000 then i := 1000000; 
  if (FMax = i) or (i <= FMin) then exit; 
  m := FD; 
  FD := false; 
  FMax := i; 
  if Fpos > i then setpos(i); 
  setBereich; 
  FD := m; 
end; 
 
procedure TFort.setMin(i: TMM); 
var m: boolean; 
begin 
  if i < -1000000 then i := -1000000; 
  if (FMin = i) or (i >= FMax) then exit; 
  m := FD; 
  FD := false; 
  FMin := i; 
  if FPos < i then setpos(i); 
  setbereich; 
  FD := m; 
end; 
 
procedure TFort.einfaerben; 
var 
  z, d, dh, f, t, bt, b3, rv, gv, bv, rh, gh, bh: integer; 
  pv, ph: PByte; 
  p2: ^Tpp; 
  procedure wgr(bp: TBitmap; r, g, b, k: integer; p1: PByte); 
  var 
    y: integer; 
  begin 
    for y := 0 to bp.height - 1 do begin 
      p2 := bp.scanline[y]; 
      bt := p1^ * k; 
      p2[0] := (b + bt) shr 8; 
      p2[1] := (g + bt) shr 8; 
      p2[2] := (r + bt) shr 8; 
      inc(p1); 
    end; 
  end; 
  procedure snk(bp: TBitmap; r, g, b, k: integer; p1: PByte); 
  var 
    y: integer; 
  begin 
    p2 := bp.scanline[0]; 
    b3 := bp.width * 3; 
    y := 0; 
    while y < b3 do begin 
      bt := p1^ * k; 
      p2[y] := (b + bt) shr 8; 
      p2[y + 1] := (g + bt) shr 8; 
      p2[y + 2] := (r + bt) shr 8; 
      inc(p1); 
      inc(y, 3); 
    end; 
  end; 
begin 
  z := 200; 
  if FFlash and enabled then d := FPuls + 50 
  else d := FIntens + 50; 
  dh := 50; 
  f := 255 - d; 
  t := z * f; 
  if FLight then 
    pv := @FBytes 
  else pv := @FBytesm; 
  if FBack = tfoBeam then 
    ph := pv else ph := @FBytesU; 
  rv := FR * d; 
  gv := FG * d; 
  bv := FB * d; 
  rh := FRH * dh; 
  gh := FGH * dh; 
  bh := FBH * dh; 
  FLT := RGB((rv + t) shr 8, (gv + t) shr 8, (bv + t) shr 8); 
  wgr(FBmp, rv, gv, bv, f, pv); 
  wgr(FBh1, rh, gh, bh, z, ph); 
  snk(FBm2, rv, gv, bv, f, pv); 
  snk(FBh2, rh, gh, bh, z, ph); 
end; 
 
procedure TFort.setFarbe(c: TColor); 
begin 
  c := ColorToRGB(c); 
  if c = FFarbe then exit; 
  FFarbe := c; 
  FR := getRvalue(FFarbe); 
  FG := getGvalue(FFarbe); 
  FB := getBvalue(FFarbe); 
  FarbeZeigen; 
end; 
 
procedure TFort.FarbeZeigen; 
begin 
  einfaerben; 
  invalidate; 
end; 
 
procedure TFort.setFc(c: TColor); 
begin 
  c := ColorToRGB(c); 
  if c = FC then exit; 
  FC := c; 
  Canvas.Font.Color := c; 
  invalidate; 
end; 
 
procedure TFort.setRahmen(r: TRah); 
begin 
  if r = FRa then exit; 
  FRa := r; 
  FZ := ord(r <> tfoNoFrame); 
  FZ2 := FZ + FZ; 
  invalidate; 
end; 
 
procedure TFort.setAnz(v: TView); 
begin 
  if v = FView then exit; 
  FView := v; 
  invalidate; 
end; 
 
procedure TFort.Resize; 
var 
  i1, i2: integer; 
begin 
  inherited; 
  if FWaag then begin 
    i1 := 25; 
    i2 := 10; 
  end else begin 
    i1 := 10; 
    i2 := 25; 
  end; 
  if width < i1 then width := i1 
  else if width > 1000 then width := 1000; 
  if height < i2 then height := i2 
  else if height > 1000 then height := 1000; 
  setbereich; 
end; 
 
procedure TFort.WMText(var M: TMessage); 
begin 
  DefaultHandler(M); 
  invalidate; 
end; 
 
procedure TFort.CMCOLOR(var M: TMessage); 
begin 
  DefaultHandler(M); 
  FHC := ColorToRGB(Color); 
  FRH := getRvalue(FHC); 
  FGH := getGvalue(FHC); 
  FBH := getBvalue(FHC); 
  FarbeZeigen; 
end; 
 
procedure TFort.setWaagSenk(b: boolean); 
var 
  m: integer; 
begin 
  if b = FWaag then exit; 
  FWaag := b; 
  if not (csReading in componentstate) then begin 
    FRotate := FWaag = FRotate xor FWaag; 
    m := width; 
    width := height; 
    height := m; 
  end; 
  makefont; 
  invalidate; 
end; 
 
procedure TFort.setFontSize(i: integer); 
begin 
  if i = FSize then exit; 
  FSize := i; 
  Canvas.Font.Size := i; 
  makefont; 
  invalidate; 
end; 
 
procedure TFort.setA(a: TA); 
begin 
  if a = FA then exit; 
  FA := a; 
  invalidate; 
end; 
 
procedure TFort.setFlat(b: boolean); 
begin 
  if b = FFlat then exit; 
  FFlat := b; 
  invalidate; 
end; 
 
procedure TFort.setBack(b: TBack); 
begin 
  if b = FBack then exit; 
  FBack := b; 
  FarbeZeigen; 
end; 
 
procedure TFort.buildpos(x, y: integer); 
  procedure MPosi(a, b: integer); 
  begin 
    setPos(a * FBer / (b - FZ2) + FMin); 
  end; 
begin 
  if FWaag then MPosi(x, width) else MPosi(height - y, height); 
end; 
 
procedure TFort.MouseDown(Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  inherited; 
  if not FM or (Button <> mbLeft) then exit; 
  FTimer2.enabled := false; 
  FDown := True; 
  buildpos(x, y); 
end; 
 
procedure TFort.MouseUp(Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  inherited; 
  FDown := False; 
end; 
 
procedure TFort.MouseMove(Shift: TShiftState; X, Y: Integer); 
begin 
  inherited; 
  if FDown then buildpos(x, y); 
end; 
 
procedure TFort.setRotate(b: boolean); 
begin 
  if b = FRotate then exit; 
  FRotate := b; 
  makefont; 
  invalidate; 
end; 
 
procedure TFort.setIntens(i: TIn); 
begin 
  if i < 0 then i := 0 
  else if i > 100 then i := 100; 
  FTimer.enabled := False; 
  if (i = FIntens) and not FFlash or not enabled then exit; 
  FFlash := false; 
  FIntens := i; 
  Farbezeigen; 
end; 
 
procedure TFort.setLight(b: boolean); 
begin 
  if b = FLight then exit; 
  FLight := b; 
  Farbezeigen; 
end; 
 
procedure TFort.setFlash(b: boolean); 
begin 
  if b = FFlash then exit; 
  FFlash := b; 
  FTimer.enabled := b; 
  if not b then Farbezeigen; 
end; 
 
procedure TFort.Timer(Sender: TObject); 
begin 
  if FPuls = 0 then FPuls := 100 
  else FPuls := 0; 
  Farbezeigen; 
end; 
 
procedure TFort.Timer2(Sender: TObject); 
var d: double; 
begin 
  d := FMerk; 
  if FPos = FMerk then begin 
    FTimer2.enabled := false; 
  end else begin 
    if FPos < FMerk then begin 
      d := FPos + FBer / 24; 
      if d > FMerk then d := FMerk; 
    end else begin 
      d := FPos - FBer / 24; 
      if d < FMerk then d := FMerk; 
    end; 
  end; 
  makePos(d); 
end; 
 
procedure TFort.setDamp(b: boolean); 
begin 
  if b = FD then exit; 
  FD := b; 
  if not b then begin 
    Ftimer2.enabled := false; 
    setpos(FMerk); 
  end else 
    Ftimer2.enabled := true; 
end; 
 
procedure TFort.setenabled(value: boolean); 
begin 
  FTimer2.enabled := false; 
  FTimer.enabled := FFlash and value; 
  inherited; 
  Farbezeigen; 
end; 
 
end.