Beispiel für 3 bewegte Gauges (siehe Bild):

procedure TForm1.FormCreate(Sender: TObject); 
begin 
  doublebuffered := true; 
  TransGauge1.Tag := 1; 
  TransGauge1.Progress := 100; 
  TransGauge2.Progress := 50; 
  TransGauge3.Progress := 75; 
  Timer1.Interval := 80; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
  procedure doit(tg: TTransGauge); 
  begin 
    if tg.tag = 0 then begin 
      tg.progress := tg.progress - 5; 
      if tg.progress = 50 then tg.tag := 1; 
    end else begin 
      tg.progress := tg.progress + 5; 
      if tg.progress = 100 then tg.tag := 0; 
    end; 
  end; 
begin 
  doit(TransGauge1); 
  doit(TransGauge2); 
  doit(TransGauge3); 
end; 

unit TransGauge; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls; 
 
type 
  TFontKind = (tgHorizontal, tgVertical); 
  TGaugeKind = (tgHorizontalBar, tgVerticalBar, tgPie); 
  TGaugeText = (tgCaption, tgProgress, tgPercent, tgNone); 
  TIntens = 0..5; 
  TTransGauge = class(TControl) 
  private 
    FR, FG, FB, FFF, FRD, FGD, FBD, FXR, FXG, FXB, FTR, FTG, FTB: Byte; 
    FStelle, FBer, FMin, FMax, FPos, FLang: integer; 
    FFore, FFrameCl, F2Cl, FDisCl, FDisF: TColor; 
    FFrame, Ftrans, FFlat, FShadow: boolean; 
    FNotify: TNotifyEvent; 
    FBmp, FHlp: TBitmap; 
    FDrctn: TFontKind; 
    FKind: TGaugeKind; 
    FText: TGaugeText; 
    FCanvas: TCanvas; 
    FProz: single; 
    FF: TIntens; 
  protected 
    procedure CMFontChanged(var aMsg: TMessage); message CM_FONTCHANGED; 
    procedure CMCOLOR(var M: TMessage); message CM_COLORCHANGED; 
    procedure WMPaint(var aMsg: TWMPaint); message WM_PAINT; 
    procedure setpix(i, d: integer; var p1, p2, p3: byte); 
    procedure setEnabled(Value: Boolean); override; 
    function setbyte(b, m, d: integer): byte; 
    procedure setText(t: TGaugeText); 
    procedure setDrctn(d: TFontKind); 
    procedure setKind(k: TGaugeKind); 
    procedure setFrameCl(c: TColor); 
    procedure setShadow(b: boolean); 
    procedure setFrame(b: boolean); 
    procedure setTrans(b: boolean); 
    procedure setFlat(b: boolean); 
    procedure setDisCl(c: TColor); 
    procedure setPos(i: integer); 
    procedure setMin(i: integer); 
    procedure setMax(i: integer); 
    procedure setFore(c: TColor); 
    procedure setF2Cl(c: TColor); 
    procedure setDisF(c: TColor); 
    procedure setFF(t: TIntens); 
    procedure settranscol; 
    procedure FontSwitch; 
    procedure setBitmap; 
    procedure setBereich; 
    procedure makefont; 
    procedure setrgb; 
    procedure sichtw; 
    procedure sichts; 
    procedure sichtk; 
  public 
    procedure WMText(var M: TMessage); message WM_SetText; 
    constructor Create(AOwner: TComponent); override; 
    property Canvas: TCanvas read FCanvas; 
    destructor Destroy; override; 
    procedure Resize; override; 
    procedure Loaded; override; 
  published 
    property ProgressDisabledColor: TColor read FDisCl write setDisCl; 
    property OnProgress: TNotifyEvent read FNotify write FNotify; 
    property FontDirection: TFontKind read FDrctn write setDrctn; 
    property FrameColor: TColor read FFrameCl write setFrameCl; 
    property FontShadow: boolean read FShadow write setShadow; 
    property FontShadowColor: TColor read F2Cl write setF2Cl; 
    property FontDisabledColor: TColor read FDisF write setDisF; 
    property Transparent: boolean read FTrans write setTrans; 
    property ProgressColor: TColor read FFore write setFore; 
    property TextMode: TGaugeText read FText write setText; 
    property Frame: boolean read FFrame write setframe; 
    property Kind: TGaugeKind read FKind write setKind; 
    property Progress: integer read FPos write setPos; 
    property Intensity: TIntens read FF write setFF; 
    property FLat: boolean read FFlat write setFlat; 
    property Min: integer read FMin write setMin; 
    property Max: integer read FMax write setMax; 
    property ParentShowHint; 
    property ParentColor; 
    property OnMouseDown; 
    property ParentFont; 
    property OnMouseUp; 
    property ShowHint; 
    property Enabled; 
    property Visible; 
    property Caption; 
    property Color; 
    property Font; 
  end; 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TTransGauge]); 
end; 
 
constructor TTransGauge.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  FCanvas := TCanvas.Create; 
  FKind := tgHorizontalBar; 
  FDrctn := tgHorizontal; 
  FFrame := true; 
  FTrans := true; 
  FF := 4; 
  FFF := 1; 
  FG := 255; 
  FR := 0; 
  FB := FR; 
  FFore := RGB(FR, FG, FB); 
  FGD := 180; 
  FRD := FGD; 
  FBD := FGD; 
  FDisCl := RGB(FRD, FGD, FBD); 
  FMax := 100; 
  width := 100; 
  height := 100; 
  FFrameCl := $4000; 
  FBmp := TBitmap.create; 
  Fbmp.pixelformat := pf24bit; 
  FHlp := TBitmap.create; 
  FHlp.pixelformat := pf24bit; 
  Font.Color := clBlack; 
  Font.Name := 'Arial'; 
  Font.Size := 8; 
  F2Cl := clwhite; 
  FDisF := F2Cl; 
  setBitmap; 
  setrgb; 
  settranscol; 
  FBmp.transparent := true; 
end; 
 
destructor TTransGauge.Destroy; 
begin 
  FHlp.free; 
  FBmp.free; 
  FCanvas.Free; 
  inherited Destroy; 
end; 
 
procedure TTransGauge.WMPaint(var aMsg: TWMPaint); 
var 
  s: string; 
  sz: TSize; 
  rct: TRect; 
  w, h: integer; 
  procedure horzText(f: TColor); 
  begin 
    with FBmp.Canvas do begin 
      if enabled then Font.Color := f 
      else Font.Color := FDisF; 
      drawtext(FBmp.Canvas.handle, pchar(s), -1, rct, dt_singleline 
        or dt_center or dt_vcenter); 
    end; 
  end; 
  procedure vertText(f: TColor; x, y: integer); 
  begin 
    with FBmp.Canvas do begin 
      if enabled then Font.Color := f 
      else Font.Color := FDisF; 
      textrect(rct, x, y, s); 
    end; 
  end; 
begin 
  FCanvas.Handle := aMsg.DC; 
  rct := rect(3, 2, width - 2, height - 2); 
  FProz := FStelle * 100 / FBer; 
  with FBmp, Canvas do begin 
    copyrect(FBmp.Canvas.cliprect, FCanvas, FCanvas.cliprect); 
    case FText of 
      tgPercent: s := FormatFloat('0.0', FProz) + '%'; 
      tgProgress: s := FormatFloat('#,#0', FPos); 
      tgCaption: s := caption; 
    else s := ''; 
    end; 
    if Ftrans then 
      brush.style := bsClear 
    else brush.color := color; 
    if FFrame then Pen.color := FFrameCl 
    else Pen.color := Transparentcolor; 
    if FKind = tgPie then begin 
      pen.style := psclear; 
      Ellipse(0, 0, width, height); 
    end else 
      RoundRect(0, 0, width, height, 6, 6); 
    if FKind = tgHorizontalBar then sichtw 
    else if FKind = tgPie then sichtk 
    else sichts; 
    brush.style := bsClear; 
    if s <> '' then begin 
      makefont; 
      sz := TextExtent(s); 
      if FDrctn = tgVertical then begin 
        w := (width - sz.cy) div 2; 
        h := height - (height - sz.cx) div 2; 
        if FShadow and enabled then vertText(F2Cl, w + 1, h - 1); 
        vertText(self.Font.color, w, h); 
      end else begin 
        if FShadow and enabled then horzText(F2Cl); 
        offsetrect(rct, -1, -1); 
        horzText(self.Font.color); 
      end; 
    end; 
  end; 
  FCanvas.draw(0, 0, FBmp); 
end; 
 
procedure TTransGauge.setrgb; 
begin 
  if enabled then begin 
    FXR := FR; 
    FXG := FG; 
    FXB := FB; 
  end else begin 
    FXR := FRD; 
    FXG := FGD; 
    FXB := FBD; 
  end; 
end; 
 
function TTransGauge.setbyte(b, m, d: integer): byte; 
begin 
  result := (b div succ(FFF)); 
  if not FFLat then 
    result := result * m div d; 
end; 
 
procedure TTransGauge.setpix(i, d: integer; var p1, p2, p3: byte); 
var px1, px2, px3: byte; 
begin 
  if Ftrans then begin 
    px1 := p1; 
    px2 := p2; 
    px3 := p3; 
  end else begin 
    px1 := $99; 
    px2 := px1; 
    px3 := px1; 
  end; 
  p1 := setbyte(FXB + px1 * FFF, i, d); 
  p2 := setbyte(FXG + px2 * FFF, i, d); 
  p3 := setbyte(FXR + px3 * FFF, i, d); 
end; 
 
procedure TTransGauge.sichts; 
var x, y, by, bx, k, fy, bm, h: integer; 
  pm: PBytearray; 
begin 
  bx := pred(width) * 3; 
  by := (bx div 6) * 3; // Farbsicherheit. Nicht "bx div 2" ! 
  fy := height - FLang - 1; 
  h := height - 2; 
  for y := fy to h do begin 
    pm := FBmp.scanline[y]; 
    k := ord((y = fy) or (y = h)) * 3; 
    x := 3 + k; 
    bm := bx - k; 
    while x <= by do begin 
      setpix(x, by, pm[x], pm[x + 1], pm[x + 2]); 
      inc(x, 3); 
    end; 
    x := by + 3; 
    while x < bm do begin 
      setpix(bx - x, by, pm[x], pm[x + 1], pm[x + 2]); 
      inc(x, 3); 
    end; 
  end; 
end; 
 
procedure TTransGauge.sichtw; 
var x, y, b3, hy, hx, k, bm: integer; 
  pm: PBytearray; 
  procedure setk(b: boolean); 
  begin 
    k := ord(b) * 3; 
    bm := b3 - k; 
    x := 3 + k; 
  end; 
begin 
  b3 := FLang * 3; 
  hx := FBmp.height - 2; 
  hy := hx div 2; 
  for y := 1 to hy do begin 
    setk(y = 1); 
    pm := FBmp.scanline[y]; 
    while x <= bm do begin 
      setpix(y, hy, pm[x], pm[x + 1], pm[x + 2]); 
      inc(x, 3); 
    end; 
  end; 
  for y := hy + 1 to hx do begin 
    setk(y = hx); 
    pm := FBmp.scanline[y]; 
    while x <= bm do begin 
      setpix(hx - y, hy, pm[x], pm[x + 1], pm[x + 2]); 
      inc(x, 3); 
    end; 
  end; 
end; 
 
procedure TTransGauge.sichtk; 
var x, y, w, h, stp, b3, f, d: integer; 
  winkel: single; 
  pm, ph: PBytearray; 
  p1, p2, p3, pf1, pf2, pf3: byte; 
  procedure DrawRadial; 
  var 
    i: Integer; 
    Rx, Gx, Bx: byte; 
  begin 
    with FHlp, Canvas do begin 
      for i := 0 to stp do begin 
        Rx := Round((FXR / stp) * i); 
        Gx := Round((FXG / stp) * i); 
        Bx := Round((FXB / stp) * i); 
        Brush.Color := RGB(Rx, Gx, Bx); 
        Pen.Color := Brush.Color; 
        Ellipse(i, i, width - i, height - i); 
      end; 
    end; 
  end; 
begin 
  w := width div 2; 
  h := height div 2; 
  b3 := width * 3; 
  if h > w then stp := w else stp := h; 
  case ff of 
    0: f := 50; 
    1: f := 110; 
    2: f := 150; 
    3: f := 175; 
    4: f := 200 
  else f := 255; 
  end; 
  d := 256 - f; 
  with FHlp.canvas do begin 
    brush.color := FBmp.transparentcolor; 
    fillrect(cliprect); 
    winkel := (FProz / 50) * pi; 
    x := round(W * sin(winkel) + W); 
    y := round(-H * cos(winkel) + H); 
    drawradial; 
    pen.color := FBmp.transparentcolor; 
    brush.color := FBmp.transparentcolor; 
    if FProz = 0 then 
      ellipse(0, 0, width, height) else 
      if FProz < 100 then 
        pie(0, 0, width, height, W, 0, x, y); 
    brush.style := bsclear; 
    ellipse(0, 0, width, height); 
  end; 
  for y := 0 to height - 1 do begin 
    x := 0; 
    pm := FBMp.ScanLine[y]; 
    ph := FHlp.ScanLine[y]; 
    while x < b3 do begin 
      if (ph[x] <> FTB) or (ph[x + 1] <> FTG) or (ph[x + 2] <> FTR) 
        then begin 
 
        if FTrans then begin 
          p1 := pm[x]; 
          p2 := pm[x + 1]; 
          p3 := pm[x + 2]; 
        end else begin 
          p1 := $50; 
          p2 := p1; 
          p3 := p1; 
        end; 
        if not FFLat then begin 
          pf1 := ph[x]; 
          pf2 := ph[x + 1]; 
          pf3 := ph[x + 2]; 
        end else begin 
          pf1 := FXB; 
          pf2 := FXG; 
          pf3 := FXR; 
        end; 
        pm[x] := ((pf1 * f) + p1 * d) shr 8; 
        pm[x + 1] := ((pf2 * f) + p2 * d) shr 8; 
        pm[x + 2] := ((pf3 * f) + p3 * d) shr 8; 
      end; 
      inc(x, 3); 
    end; 
  end; 
  FBmp.Canvas.brush.style := bsClear; 
  if FFrame then begin 
    FBmp.canvas.pen.color := FFrameCl; 
    FBmp.canvas.pen.style := psSolid; 
    FBmp.canvas.ellipse(0, 0, width, height); 
  end; 
end; 
 
procedure TTransGauge.setBitmap; 
begin 
  FBmp.width := width; 
  FBmp.height := height; 
  FHlp.width := width; 
  FHlp.height := height; 
end; 
 
procedure TTransGauge.setTrans(b: boolean); 
begin 
  if b = FTrans then exit; 
  FTrans := b; 
  invalidate; 
end; 
 
procedure TTransGauge.setFrame(b: boolean); 
begin 
  if b = FFrame then exit; 
  FFrame := b; 
  invalidate; 
end; 
 
procedure TTransGauge.setFlat(b: boolean); 
begin 
  if b = FFlat then exit; 
  FFlat := b; 
  invalidate; 
end; 
 
procedure TTransGauge.setShadow(b: boolean); 
begin 
  if b = FShadow then exit; 
  FShadow := b; 
  invalidate; 
end; 
 
procedure TTransGauge.setKind(k: TGaugeKind); 
begin 
  if k = FKind then exit; 
  FKind := k; 
  FontSwitch; 
  resize; 
end; 
 
procedure TTransGauge.setFore(c: TColor); 
begin 
  c := ColorToRGB(c); 
  if c = FFore then exit; 
  FFore := c; 
  FR := GetRValue(c); 
  FG := GetGValue(c); 
  FB := GetBValue(c); 
  setrgb; 
  invalidate; 
end; 
 
procedure TTransGauge.setDisCl(c: TColor); 
begin 
  c := ColorToRGB(c); 
  if c = FDisCl then exit; 
  FDisCl := c; 
  FRD := GetRValue(c); 
  FGD := GetGValue(c); 
  FBD := GetBValue(c); 
  setrgb; 
  if not enabled then invalidate; 
end; 
 
procedure TTransGauge.setFrameCl(c: TColor); 
begin 
  c := ColorToRGB(c); 
  if c = FFrameCl then exit; 
  FFrameCl := c; 
  invalidate; 
end; 
 
procedure TTransGauge.setDisF(c: TColor); 
begin 
  c := ColorToRGB(c); 
  if c = FDisF then exit; 
  FDisF := c; 
  if not enabled then invalidate; 
end; 
 
procedure TTransGauge.setF2Cl(c: TColor); 
begin 
  c := ColorToRGB(c); 
  if c = F2Cl then exit; 
  F2Cl := c; 
  invalidate; 
end; 
 
procedure TTransGauge.Loaded; 
begin 
  inherited; 
  Resize; 
end; 
 
procedure TTransGauge.Resize; 
begin 
  inherited; 
  if width > 1000 then width := 1000 
  else if width < 10 then width := 10; 
  if height > 1000 then height := 1000 
  else if height < 10 then height := 10; 
  if assigned(FBmp) then setBitmap; 
  setbereich; 
end; 
 
procedure TTransGauge.setBereich; 
var i: integer; 
begin 
  FBer := FMax - FMin; 
  FStelle := Fpos - FMin; 
  if FKind = tgHorizontalBar then i := width - 2 
  else i := height - 2; 
  FLang := round(FStelle * i / FBer); 
  repaint; 
end; 
 
procedure TTransGauge.setMax(i: integer); 
begin 
  if i > 1000000 then i := 1000000; 
  if (FMax = i) or (i <= FMin) then exit; 
  FMax := i; 
  if Fpos > i then FPos := i; 
  setBereich; 
end; 
 
procedure TTransGauge.setMin(i: integer); 
begin 
  if i < -1000000 then i := -1000000; 
  if (FMin = i) or (i >= FMax) then exit; 
  FMin := i; 
  if FPos < i then FPos := i; 
  setbereich; 
end; 
 
procedure TTransGauge.setPos(i: Integer); 
begin 
  if i < FMin then i := FMin; 
  if i > FMax then i := FMax; 
  if (FPos = i) or not enabled then exit; 
  FPos := i; 
  setBereich; 
  if assigned(FNotify) then FNotify(self); 
end; 
 
procedure TTransGauge.WMText(var M: TMessage); 
begin 
  DefaultHandler(M); 
  invalidate; 
end; 
 
procedure TTransGauge.setText(t: TGaugeText); 
begin 
  if FText = t then exit; 
  FText := t; 
  invalidate; 
end; 
 
procedure TTransGauge.makefont; 
var 
  LogFont: TLogfont; 
begin 
  GetObject(FBmp.Canvas.Font.Handle, sizeof(Logfont), @Logfont); 
  Logfont.lfEscapement := ord(FDrctn = tgVertical) * 900; 
  FBmp.Canvas.Font.Handle := CreateFontIndirect(Logfont); 
end; 
 
procedure TTransGauge.setFF(t: TIntens); 
var i: integer; 
begin 
  if t > 5 then t := 5 
  else if t < 0 then t := 0; 
  if t = FF then exit; 
  FF := t; 
  i := ord(not FFlat); 
  case FF of 
    0: FFF := 1 + i * 15; 
    1: FFF := 7 - i; 
  else FFF := 6 - FF - i; 
  end; 
  invalidate; 
end; 
 
procedure TTransGauge.setDrctn(d: TFontKind); 
begin 
  if d = FDrctn then exit; 
  FDrctn := d; 
  FontSwitch; 
  invalidate; 
end; 
 
procedure TTransGauge.CMFontChanged(var aMsg: TMessage); 
begin 
  FBmp.Canvas.Font := Font; 
  FontSwitch; 
  invalidate; 
end; 
 
procedure TTransGauge.FontSwitch; 
var tm: TTextMetric; 
begin 
  if FDrctn = tgHorizontal then exit; 
  GetTextMetrics(FBmp.Canvas.Handle, tm); 
  if (tm.tmPitchAndFamily and TMPF_TRUETYPE = 0) 
    then begin 
    Font.Name := 'Arial'; 
    Font.Charset := DEFAULT_CHARSET; 
    FBmp.Canvas.Font := Font; 
  end; 
end; 
 
procedure TTransGauge.setEnabled(Value: Boolean); 
begin 
  inherited; 
  setrgb; 
end; 
 
procedure TTransGauge.settranscol; 
var c: TColor; 
begin 
  c := ColorToRGB(color); 
  if odd(c) then c := c - 1 
  else c := c + 1; 
  FBmp.Transparentcolor := c; 
  FTR := GetRValue(c); 
  FTG := GetGValue(c); 
  FTB := GetBValue(c); 
end; 
 
procedure TTransGauge.CMCOLOR(var M: TMessage); 
begin 
  inherited; 
  settranscol; 
end; 
 
end.