procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Slider1.Parent.DoubleBuffered := true; 
end; 

// Um Werte anzuzeigen, setzt man ein Label auf die Form:

procedure TForm1.Slider1Position(Sender: TObject); 
begin 
  Label1.caption := IntToStr(Slider1.Position); 
end;

// oder auch:

procedure TForm1.Slider1Position(Sender: TObject); 
begin 
  Label1.caption := FormatFloat('#,##0.0', Slider1.Position / 10); 
end; 

// oder Ähnliches.

// Man kann den Schieber mit der Maus anfassen und verschieben, oder auf eine
// bestimmte Stelle klicken und der Schieber springt an die Mausposition.

// Um den Schieber darzustellen, müssen Sie hier slid.zip downloaden und
// in das Verzeichnis der Komponente (Lib) kopieren. 

        

// Getestet mit D4 unter XP

unit Slider; 
 
interface 
 
uses            
  Windows, Classes, Graphics, Controls; 
 
type 
  TSLDA = array[0..26] of byte; 
  TSlider = class(TGraphicControl) 
  private 
    FChange: TNotifyEvent; 
    bmw, bms: TBitmap; 
    wg, down, a: boolean; 
    posi, mi, ma, stelle, diff, merk, au, ao: integer; 
    bc, sf, fh, fd, hig: TColor; 
    procedure setstelle; 
    procedure seta(b: boolean); 
    procedure setbc(c: TColor); 
    procedure setmi(i: integer); 
    procedure setma(i: integer); 
    procedure setpo(i: integer); 
    procedure setau(i: integer); 
    procedure setao(i: integer); 
    procedure schieben(x, y: integer); 
    procedure setwaagsenk(b: boolean); 
    procedure setFarbe(c: TColor); 
    procedure setbFarbe(c: TColor); 
    procedure laden; 
    procedure ev(b: boolean); 
    procedure faerben; 
  protected 
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; 
      x, y: integer); override; 
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; 
      x, y: integer); override; 
    procedure MouseMove(Shift: TShiftState; x, y: integer); override; 
    procedure paint; override; 
    procedure Resize; override; 
    procedure loaded; override; 
  public 
    destructor Destroy; override; 
    constructor Create(Owner: TComponent); override; 
  published 
    property Waagerecht: boolean read wg write setwaagsenk; 
    property Position: integer read posi write setpo; 
    property Min: integer read mi write setmi; 
    property Max: integer read ma write setma; 
    property OnPosition: TNotifyEvent read FChange write FChange; 
    property Schieberfarbe: TColor read sf write setbFarbe; 
    property Randfarbe: TColor read bc write setbc; 
    property Farbe: TColor read hig write setfarbe; 
    property Aktiv: boolean read a write seta; 
    property UntererAnschlag: integer read au write setau; 
    property ObererAnschlag: integer read ao write setao; 
    property ShowHint; 
    property Visible; 
    property OnMouseDown; 
    property OnMouseUp; 
    property OnMouseMove; 
    property Enabled; 
  end; 
 
{$R slid.res} 
 
procedure Register; 
 
implementation 
 
function hell(a: integer): integer; 
asm 
  add eax, $32 
  cmp eax, $FF 
  jle @fertig 
  mov eax, $FF 
 @fertig: 
end; 
 
function dunkel(a: integer): integer; 
asm 
  sub eax, $24 
  cmp eax, 0 
  jge @fertig 
  xor eax, eax 
 @fertig: 
end; 
 
function Aufhellen(fb: TColor): TColor; 
begin 
  fb := ColorToRGB(fb); 
  Result := RGB(hell(GetRValue(fb)), 
    hell(GetGValue(fb)), 
    hell(GetBValue(fb))); 
end; 
 
function Abdunkeln(fb: TColor): TColor; 
begin 
  fb := ColorToRGB(fb); 
  Result := RGB(dunkel(GetRValue(fb)), 
    dunkel(GetGValue(fb)), 
    dunkel(GetBValue(fb))); 
end; 
 
constructor TSlider.Create(Owner: TComponent); 
begin 
  inherited Create(Owner); 
  a := true; 
  ma := 100; 
  ao := maxint; 
  au := -maxint; 
  wg := true; 
  width := 113; 
  stelle := 2; 
  down := false; 
  bmw := TBitmap.create; 
  bms := TBitmap.create; 
  laden; 
  sf := clwhite; 
  bc := $666666; 
  setfarbe($EFEFEF); 
end; 
 
destructor TSlider.Destroy; 
begin 
  bmw.free; 
  bms.free; 
  inherited Destroy; 
end; 
 
procedure TSlider.loaded; 
begin 
  ev(true); 
end; 
 
procedure TSlider.laden; 
begin 
  bmw.LoadFromResourceName(HInstance, 'waag'); 
  bmw.pixelformat := pf24bit; 
  bms.LoadFromResourceName(HInstance, 'senk'); 
  bms.pixelformat := pf24bit; 
end; 
 
procedure TSlider.seta(b: boolean); 
begin 
  if a = b then exit; 
  a := b; 
  repaint; 
end; 
 
procedure TSlider.setfarbe(c: TColor); 
begin 
  if c = hig then exit; 
  hig := c; 
  faerben; 
  repaint; 
end; 
 
procedure TSlider.setbfarbe(c: TColor); 
var x, y: integer; 
  r, g, b: byte; 
  p: ^TSLDA; 
  procedure go; 
  begin 
    p[x] := trunc(p[x] * b / 255); 
    p[x + 1] := trunc(p[x + 1] * g / 255); 
    p[x + 2] := trunc(p[x + 2] * r / 255); 
    inc(x, 3); 
  end; 
begin 
  if c = sf then exit; 
  laden; 
  sf := colortorgb(c); 
  r := getrvalue(sf); 
  g := getgvalue(sf); 
  b := getbvalue(sf); 
  for y := 0 to 9 do begin 
    p := bmw.scanline[y]; 
    x := 0; 
    while x < 27 do go; 
  end; 
  for y := 0 to 8 do begin 
    p := bms.scanline[y]; 
    x := 0; 
    while x < 30 do go; 
  end; 
  repaint; 
end; 
 
procedure TSlider.Resize; 
begin 
  if wg then begin 
    height := 10; 
    if width < 15 then width := 15; 
  end else begin 
    width := 10; 
    if height < 15 then height := 15; 
  end; 
  setstelle; 
  repaint; 
end; 
 
procedure TSlider.ev(b: boolean); 
begin 
  if (merk <> posi) or b then begin 
    if assigned(fchange) then fchange(self); 
    merk := posi; 
  end; 
end; 
 
procedure TSlider.schieben(x, y: integer); 
var i, m: integer; 
begin 
  m := posi; 
  if wg then begin 
    i := width; 
    stelle := x - diff; 
  end else begin 
    i := height; 
    stelle := y - diff; 
  end; 
  if stelle < 2 then begin 
    stelle := 2; 
    diff := 4; 
  end else begin 
    if stelle > i - 11 then begin 
      stelle := i - 11; 
      diff := 4; 
    end; 
  end; 
  posi := Round(mi + (stelle - 2) * (ma - mi) / (i - 13)); 
  if posi < au then begin 
    posi := au; 
    setstelle; 
  end else 
    if posi > ao then begin 
      posi := ao; 
      setstelle; 
    end; 
  if posi <> m then ev(false); 
  repaint; 
end; 
 
procedure TSlider.MouseDown(Button: TMouseButton; Shift: TShiftState; 
  x, y: integer); 
begin 
  if not enabled or not a then exit; 
  down := true; 
  if wg then begin 
    if (x < stelle) or (x > stelle + 9) then 
      diff := 4 else diff := x - stelle; 
  end else begin 
    if (y < stelle) or (y > stelle + 9) then 
      diff := 4 else diff := y - stelle; 
  end; 
  schieben(x, y); 
  inherited; 
end; 
 
procedure TSlider.MouseUp(Button: TMouseButton; Shift: TShiftState; x, y: 
  integer); 
begin 
  down := false; 
  inherited; 
end; 
 
procedure TSlider.MouseMove(Shift: TShiftState; x, y: integer); 
begin 
  if down then schieben(x, y); 
end; 
 
procedure TSlider.setmi(i: integer); 
begin 
  if (i = mi) or not (enabled or (csDesigning in componentstate)) then exit; 
  if not (csReading in componentstate) then if i >= ma then i := ma - 1; 
  mi := i; 
  if mi > posi then setpo(mi) else setstelle; 
  repaint; 
end; 
 
procedure TSlider.setau(i: integer); 
begin 
  if i = au then exit; 
  if not (csReading in componentstate) then begin 
    if i >= ma then i := ma - 1; 
    if i >= ao then i := ao - 1; 
  end; 
  au := i; 
  if au > posi then setpo(au); 
  repaint; 
end; 
 
procedure TSlider.setao(i: integer); 
begin 
  if i = ao then exit; 
  if not (csReading in componentstate) then begin 
    if i <= mi then i := mi + 1; 
    if i <= au then i := au + 1; 
  end; 
  ao := i; 
  if posi > ao then setpo(ao); 
  repaint; 
end; 
 
procedure TSlider.setma(i: integer); 
begin 
  if (i = ma) or not (enabled or (csDesigning in componentstate)) then exit; 
  if not (csReading in componentstate) then if i <= mi then i := mi + 1; 
  ma := i; 
  if ma < posi then setpo(ma) else setstelle; 
  repaint; 
end; 
 
procedure TSlider.setstelle; 
var x: integer; 
begin 
  if wg then x := width else x := height; 
  if ma - mi <> 0 then 
    stelle := round((posi - mi) * (x - 13) / (ma - mi) + 2); 
end; 
 
procedure TSlider.faerben; 
begin 
  fh := aufhellen(hig); 
  fd := abdunkeln(hig); 
end; 
 
procedure TSlider.setpo(i: integer); 
begin 
  if (i <> posi) and (a or enabled or (csDesigning in componentstate)) then 
  begin 
    if i < au then i := au; 
    if i > ao then i := ao; 
    posi := i; 
    if not (csReading in componentstate) 
      then begin 
      if posi > ma then posi := ma else 
        if posi < mi then posi := mi; 
    end; 
    setstelle; 
    ev(false); 
    repaint; 
  end; 
end; 
 
procedure TSlider.paint; 
begin 
if csDesigning in componentstate then setstelle; 
  with canvas do begin 
    brush.color := hig; 
    pen.color := bc; 
    if wg then begin 
      height := 10; 
      RoundRect(0, 1, width, height - 1, 5, 5); 
      pen.color := fh; 
      moveto(2, 2); 
      lineto(width - 2, 2); 
      moveto(1, 3); 
      lineto(width - 1, 3); 
      pen.color := fd; 
      moveto(2, height - 3); 
      lineto(width - 2, height - 3); 
      moveto(1, height - 4); 
      lineto(width - 1, height - 4); 
      if enabled and a then begin 
        bmw.canvas.pixels[0, 0] := pixels[stelle, 0]; 
        bmw.canvas.pixels[0, 9] := pixels[stelle, 9]; 
        bmw.canvas.pixels[8, 0] := pixels[stelle + 8, 0]; 
        bmw.canvas.pixels[8, 9] := pixels[stelle + 8, 9]; 
        draw(stelle, 0, bmw); 
      end; 
    end else begin 
      width := 10; 
      RoundRect(1, 0, width - 1, height, 5, 5); 
      pen.color := fh; 
      moveto(2, 2); 
      lineto(2, height - 2); 
      moveto(3, 1); 
      lineto(3, height - 1); 
      pen.color := fd; 
      moveto(width - 3, 2); 
      lineto(width - 3, height - 2); 
      moveto(width - 4, 1); 
      lineto(width - 4, height - 1); 
      if enabled and a then begin 
        bms.canvas.pixels[0, 0] := pixels[0, stelle]; 
        bms.canvas.pixels[0, 8] := pixels[0, stelle + 8]; 
        bms.canvas.pixels[9, 0] := pixels[9, stelle]; 
        bms.canvas.pixels[9, 8] := pixels[9, stelle + 8]; 
        draw(0, stelle, bms); 
      end; 
    end; 
  end; 
end; 
 
procedure TSlider.setwaagsenk(b: boolean); 
begin 
  if (b <> wg) and a then begin 
    wg := b; 
    if not (csReading in componentstate) 
      then begin 
      if wg then begin 
        width := height; 
        height := 10; 
      end else begin 
        height := width; 
        width := 10; 
      end; 
    end; 
    repaint; 
  end; 
end; 
 
procedure TSlider.setbc(c: TColor); 
begin 
  if c = bc then exit; 
  bc := c; 
  repaint; 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TSlider]); 
end; 
 
end.