unit DblSlider; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Graphics, Controls, ExtCtrls, Stdctrls; 
 
type 
  TLftRght = (dblLeft, dblRight); 
  TBvl = (dblFlat, dblLowered, dblRaised); 
  TInd = (dblNone, dblMinMax, dblPos1Pos2); 
  TGivePos = procedure(Sender: TObject; Min, BandLinks, Pos1, BandMitte, Pos2, 
    BandRechts, Max: Integer) of object; 
  TGiveSlide = procedure(Sender: TObject; Wich: TLftRght; Pos1, Pos2: Integer) 
    of object; 
  TDblSlider = class(TCustomPanel) 
  private 
    art: TBvl; 
    p: TPoint; 
    tcl: TLabel; 
    trsp: TColor; 
    indktn: TInd; 
    abst: single; 
    FPosChange: TGivePos; 
    FMouseUp: TGiveSlide; 
    FMouseDown: TGiveSlide; 
    lbl: array[0..1] of TLabel; 
    Schieber: array[0..1] of TImage; 
    isdown, einmal, zeiger, rOK, mOK, nhint, mhint: boolean; 
    diffw, diffs, mini, maxi, poslinks, posrechts, links, breite, 
      schieberbreite, schieberhoehe, f, hoehe, skala, lks, rts, rand, 
      anzeige: integer; 
  protected 
    procedure tw; 
    procedure rfbs; 
    procedure werte; 
    procedure lbltop; 
    procedure feuern; 
    procedure testen; 
    procedure posit1; 
    procedure posit2; 
    procedure malzeiger; 
    procedure makelinks; 
    procedure lblrechts; 
    procedure makerechts; 
    procedure rechnefreq; 
    procedure linksrechts; 
    procedure beidesetzen; 
    procedure setind(i: TInd); 
    procedure setbevel(bv: TBvl); 
    procedure setMin(i: integer); 
    procedure setMax(i: integer); 
    procedure setzen(img: Timage); 
    procedure setAbst(i: integer); 
    procedure setPosL(i: integer); 
    procedure setPosR(i: integer); 
    procedure setnhint(b: boolean); 
    procedure rechnen(img: Timage); 
    procedure setzeiger(b: boolean); 
    procedure festlegen(img: Timage); 
    procedure verschieben(img: Timage); 
    procedure positionieren(img: Timage); 
    procedure zahlzeigen(Sender: TImage); 
    procedure XMouseDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure XMouseUp(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure XMouseMove(Sender: TObject; Shift: TShiftState; 
      X, Y: Integer); 
    procedure paint; override; 
    procedure Resize; override; 
  public 
    constructor Create(Owner: TComponent); override; 
    destructor Destroy; override; 
  published 
    property ShowHint; 
    property Bevel: TBvl read art write setbevel; 
    property Max: integer read maxi write setmax; 
    property Min: integer read mini write setmin; 
    property Frequency: integer read f write setAbst; 
    property Indicator: TInd read indktn write setind; 
    property Scale: boolean read zeiger write setzeiger; 
    property PositionDsp: boolean read nhint write setnhint; 
    property Position1: integer read poslinks write setPosL; 
    property Position2: integer read posrechts write setPosR; 
    property OnSldMouseUp: TGiveSlide read FMouseUp write FMouseUp; 
    property OnPosChange: TGivePos read FPosChange write FPosChange; 
    property OnSldMouseDown: TGiveSlide read FMouseDown write FMouseDown; 
  end; 
 
procedure Register; 
 
implementation 
 
constructor TDblSlider.Create(Owner: TComponent); 
var x, y: integer; 
begin 
  inherited Create(Owner); 
  doublebuffered := true; 
  parentcolor := true; 
  parentfont := false; 
  with canvas do begin 
    Font.Name := 'Arial'; 
    Font.size := 9; 
  end; 
  art := dblRaised; 
  zeiger := true; 
  einmal := true; 
  nhint := true; 
  mhint := true; 
  skala := 7; 
  anzeige := 9; 
  breite := 129; 
  hoehe := 29; 
  rand := 8; 
  schieberbreite := 7; 
  schieberhoehe := 13; 
  mini := 0; 
  maxi := 100; 
  f := 5; 
  abst := 5; 
  height := hoehe; 
  width := breite; 
  for x := 0 to 1 do begin 
    Schieber[x] := TImage.create(self); 
    lbl[x] := TLabel.create(self); 
    lbl[x].parent := self; 
    with Schieber[x] do begin 
      parent := self; 
      autosize := true; 
      with picture.bitmap, canvas do begin 
        cursor := crHandpoint; 
        onMouseDown := XMouseDown; 
        onMouseMove := XMouseMove; 
        onMouseUp := XMouseUp; 
        width := schieberbreite; 
        height := schieberhoehe; 
        brush.color := clGray; 
        rectangle(0, 3, width, height); 
        brush.color := clWhite; 
        fillrect(rect(1, 4, pred(schieberbreite), 6)); 
        brush.color := $404040; 
        fillrect(rect(1, 7, pred(schieberbreite), pred(schieberhoehe))); 
        for y := 0 to 2 do begin 
          moveto(y * 2 + 2, 4); 
          lineto(y * 2 + 2, height); 
        end; 
      end; 
    end; 
  end; 
  trsp := Color; 
  malzeiger; 
  poslinks := 0; 
  posrechts := maxi; 
  lbl[0].left := rand + 1; 
  tcl := TLabel.create(self); 
  tcl.parent := self; 
  tcl.left := -maxint; 
end; 
 
destructor TDblSlider.Destroy; 
var x: integer; 
begin 
  tcl.free; 
  for x := 0 to 1 do begin 
    Schieber[x].free; 
    lbl[x].free; 
  end; 
  inherited Destroy; 
end; 
 
procedure TDblSlider.linksrechts; 
begin 
  lks := rand + schieberbreite - 1; 
  rts := width - lks - 1; 
end; 
 
procedure TDblSlider.werte; 
begin 
  case ord(indktn = dblPos1Pos2) of 
    1: begin 
        lbl[0].caption := inttostr(poslinks); 
        lbl[1].caption := inttostr(posrechts); 
      end; 
  else begin 
      lbl[0].caption := inttostr(mini); 
      lbl[1].caption := inttostr(maxi); 
    end; 
  end; 
end; 
 
procedure TDblSlider.lblrechts; 
begin 
  lbl[1].left := width - 1 - rand - lbl[1].width; 
end; 
 
procedure TDblSlider.tw; 
begin 
  testen; 
  werte; 
end; 
 
procedure TDblSlider.feuern; 
begin 
  tw; 
  lblrechts; 
  if assigned(FPosChange) then begin 
    FPosChange(self, mini, poslinks - mini, poslinks, posrechts - poslinks, 
      posrechts, maxi - posrechts, maxi); 
    einmal := false; 
  end; 
end; 
 
procedure TDblSlider.lbltop; 
var x: integer; 
begin 
  for x := 0 to 1 do 
    if indktn <> dblNone then lbl[x].top := Schieber[0].top + 14 else 
      lbl[x].top := height; 
end; 
 
procedure TDblSlider.setzeiger(b: boolean); 
begin 
  if b = zeiger then exit; 
  zeiger := b; 
  height := hoehe + skala * ord(zeiger) + anzeige * ord(indktn <> dblNone); 
  malzeiger; 
  repaint; 
end; 
 
procedure TDblSlider.malzeiger; 
var x, y: integer; 
begin 
  trsp := Color; 
  for x := 0 to 1 do 
    with Schieber[x].picture, bitmap, canvas do begin 
      brush.color := color; 
      fillrect(rect(0, 0, schieberbreite, 3)); 
      pen.color := color * ord(not zeiger); 
      for y := 0 to 2 do begin 
        if x = 0 then begin 
          moveto(schieberbreite - 3 + y, 2 - y); 
          lineto(schieberbreite - 3 + y, 3); 
        end else begin 
          moveto(y, y); 
          lineto(y, 3); 
        end; 
      end; 
    end; 
end; 
 
procedure TDblSlider.setzen(img: TImage); 
begin 
  img.setbounds(links, img.top, img.width, img.height); 
end; 
 
procedure TDblSlider.testen; 
begin 
  if poslinks < mini then poslinks := mini else 
    if poslinks > maxi then poslinks := maxi; 
  if posrechts < mini then posrechts := mini else 
    if posrechts > maxi then posrechts := maxi; 
end; 
 
procedure TDblSlider.rechnefreq; 
var i: single; 
begin 
  tw; 
  if f = 0 then abst := 0 else begin 
    i := (maxi - mini) / f; 
    if i < 1 then abst := 0 else 
      abst := (rts - lks) / i; 
  end; 
end; 
 
procedure TDblSlider.beidesetzen; 
begin 
  makerechts; 
  setzen(Schieber[1]); 
  makelinks; 
  setzen(Schieber[0]); 
end; 
 
procedure TDblSlider.rfbs; 
begin 
  rechnefreq; 
  beidesetzen; 
end; 
 
procedure TDblSlider.Resize; 
var h: integer; 
begin 
  inherited; 
  h := hoehe + skala * ord(zeiger) + anzeige * ord(indktn <> dblNone); 
  if width < breite then width := breite; 
  if height <> h then height := h; 
  linksrechts; 
  lblrechts; 
  rfbs; 
  repaint; 
  if einmal then feuern; 
end; 
 
procedure TDblSlider.paint; 
var x: integer; 
  d: single; 
begin 
  caption := ''; 
  for x := 0 to 1 do 
    Schieber[x].top := (height - schieberhoehe - ord(indktn <> dblNone) * 
      anzeige + ord(zeiger) * (skala + 2)) div 2 - 1; 
  inherited; 
  lbltop; 
  if trsp <> color then malzeiger; 
  with canvas do begin 
    pen.color := clBlack; 
    if zeiger then begin 
      moveto(lks, 5); 
      lineto(lks, 13); 
      moveto(rts, 5); 
      lineto(rts, 13); 
      if (abst > 0) then begin 
        d := lks + abst; 
        while d < rts do begin 
          x := round(d); 
          moveto(x, 7); 
          lineto(x, 13); 
          d := d + abst; 
        end; 
      end; 
    end; 
    brush.color := clsilver; 
    rectangle(pred(rand), Schieber[0].top + 4, width - pred(rand), 
      Schieber[0].top + 12); 
    brush.color := clWhite; 
    fillrect(rect(rand, Schieber[0].top + 5, width - rand, 
      Schieber[0].top + 7)); 
    brush.color := clgray; 
    fillrect(rect(rand, Schieber[0].top + 9, width - rand, 
      Schieber[0].top + 11)); 
  end; 
end; 
 
procedure TDblSlider.festlegen(img: Timage); 
begin 
  getcursorpos(p); 
  diffw := p.x - img.left; 
  diffs := p.y - img.top; 
  isdown := true; 
end; 
 
procedure TDblSlider.positionieren(img: TImage); 
begin 
  if img = Schieber[0] then begin 
    if links < rand then links := rand else 
      if pred(links) > Schieber[1].left - schieberbreite 
        then links := Schieber[1].left - schieberbreite + 1; 
  end else begin 
    if succ(links) < Schieber[0].left + schieberbreite then 
      links := Schieber[0].left + schieberbreite - 1 else 
      if links + img.width > width - rand then 
        links := width - rand - img.width; 
  end; 
  setzen(img); 
end; 
 
procedure TDblSlider.rechnen(img: TImage); 
begin 
  if img = Schieber[0] then 
    poslinks := Round(mini + (links - rand) * (maxi - mini) / (width - pred(2 * 
      (rand + schieberbreite)))) 
  else 
    posrechts := Round(mini + (links - rand - schieberbreite + 1) * 
      (maxi - mini) / (width - pred(2 * (rand + schieberbreite)))); 
end; 
 
procedure TDblSlider.verschieben(img: TImage); 
begin 
  getcursorpos(p); 
  links := p.x - diffw; 
  positionieren(img); 
  rechnen(img); 
  feuern; 
end; 
 
procedure TDblSlider.zahlzeigen(Sender: TImage); 
begin 
  if sender = Schieber[0] then 
    tcl.caption := #32#32 + inttostr(poslinks) + #32#32 else 
    tcl.caption := #32#32 + inttostr(posrechts) + #32#32; 
  tcl.left := (width - tcl.width) div 2; 
  if zeiger then 
    tcl.top := 2 else tcl.top := lbl[0].top; 
end; 
 
procedure TDblSlider.XMouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  festlegen(Timage(sender)); 
  if nhint then zahlzeigen(Timage(sender)); 
  if assigned(FMouseDown) then 
    FMouseDown(self, TLftRght(ord(sender = Schieber[1])), poslinks, posrechts); 
end; 
 
procedure TDblSlider.posit1; 
begin 
  makelinks; 
  positionieren(Schieber[0]); 
end; 
 
procedure TDblSlider.posit2; 
begin 
  makerechts; 
  positionieren(Schieber[1]); 
end; 
 
procedure TDblSlider.XMouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  isdown := false; 
  tcl.left := -maxint; 
  if sender = Schieber[0] then posit1 
  else posit2; 
  if assigned(FMouseUp) then 
    FMouseUp(self, TLftRght(ord(sender = Schieber[1])), poslinks, posrechts); 
end; 
 
procedure TDblSlider.XMouseMove(Sender: TObject; Shift: TShiftState; 
  X, Y: Integer); 
begin 
  if not isdown then exit; 
  verschieben(TImage(sender)); 
  if nhint then zahlzeigen(Timage(sender)); 
end; 
 
procedure TDblSlider.makelinks; 
begin 
  links := round((poslinks - mini) * (width - pred(2 * 
    (rand + schieberbreite))) / (maxi - mini) + rand); 
end; 
 
procedure TDblSlider.makerechts; 
begin 
  links := round((posrechts - mini) * (width - pred(2 * (rand + 
    schieberbreite))) / (maxi - mini) + rand + schieberbreite - 1); 
end; 
 
procedure TDblSlider.SetPosR(i: integer); 
begin 
  posrechts := i; 
  testen; 
  if posrechts < poslinks then posrechts := poslinks; 
  werte; 
  posit2; 
  feuern; 
  rOK := true; 
end; 
 
procedure TDblSlider.SetMin(i: integer); 
begin 
  mini := i; 
  testen; 
  if mOK then 
    if maxi <= mini then maxi := mini + 1; 
  rfbs; 
  repaint; 
  if mOK then feuern; 
end; 
 
procedure TDblSlider.SetPosL(i: integer); 
begin 
  poslinks := i; 
  testen; 
  if rOK then 
    if poslinks > posrechts then poslinks := posrechts; 
  werte; 
  posit1; 
  if rOK then feuern; 
end; 
 
procedure TDblSlider.SetMax(i: integer); 
begin 
  maxi := i; 
  if mini >= maxi then mini := maxi - 1; 
  linksrechts; 
  rfbs; 
  repaint; 
  feuern; 
  mOK := true; 
end; 
 
procedure TDblSlider.setbevel(bv: TBvl); 
begin 
  if bv = art then exit; 
  art := bv; 
  BevelOuter := TBevelCut(ord(art)); 
end; 
 
procedure TDblSlider.SetAbst(i: integer); 
begin 
  f := abs(i); 
  rechnefreq; 
  repaint; 
end; 
 
procedure TDblSlider.setnhint(b: boolean); 
begin 
  if (b = nhint) or (indktn = dblPos1Pos2) then exit; 
  nhint := b; 
  mhint := b; 
end; 
 
procedure TDblSlider.setind(i: TInd); 
begin 
  if i = indktn then exit; 
  if i = dblPos1Pos2 then nhint := false 
  else nhint := mhint; 
  indktn := i; 
  height := hoehe + skala * ord(zeiger) + anzeige * ord(i <> dblNone); 
  werte; 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TDblSlider]); 
end; 
 
end.

//--------------- Ein paar Aufruf-Beispiele ------------------------------- 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  DblSlider1.Indicator := dblPos1Pos2; 
end; 

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

procedure TForm1.Button3Click(Sender: TObject); 
begin 
  DblSlider1.scale := not DblSlider1.scale; 
end; 

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

procedure TForm1.DblSlider1PosChange(Sender: TObject; Min, BandLinks, Pos1, 
  BandMitte, Pos2, BandRechts, Max: Integer); 
begin 
  label1.caption := inttostr(Min); 
  label2.caption := inttostr(BandLinks); 
  label3.caption := inttostr(Pos1); 
  label4.caption := inttostr(BandMitte); 
  label5.caption := inttostr(Pos2); 
  label6.caption := inttostr(BandRechts); 
  label7.caption := inttostr(Max); 
end; 

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

var 
  merklinks, merkrechts: integer; 
 
procedure TForm1.DblSlider1SldMouseDown(Sender: TObject; Wich: TLftRght; Pos1, 
  Pos2: Integer); 
begin 
  if wich = dblLeft then merklinks := Pos1 
  else merkrechts := Pos2; 
end; 
 
procedure TForm1.DblSlider1SldMouseUp(Sender: TObject; Wich: TLftRght; Pos1, 
  Pos2: Integer); 
var 
  i: integer; 
  s, z: string; 
begin 
  if wich = dblLeft then begin 
    i := abs(Pos1 - merklinks); 
    if i = 1 then z := '' else z := 'en'; 
    if Pos1 > merklinks then s := 'rechts' 
    else s := 'links'; 
    showmessage('Der linke Schieber wurde um ' + 
      inttostr(i) + ' Position' + z + ' nach ' + s + ' verschoben.'); 
  end else begin 
    i := abs(Pos2 - merkrechts); 
    if i = 1 then z := '' else z := 'en'; 
    if Pos2 > merkrechts then s := 'rechts' 
    else s := 'links'; 
    showmessage('Der rechte Schieber wurde um ' + 
      inttostr(i) + ' Position' + z + ' nach ' + s + ' verschoben.'); 
  end; 
end; 

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

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  with DblSlider1 do 
    Frequency := (Max - Min) div 2; 
end; 

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