1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:

unit Slider;

interface

uses
  Windows, SysUtils, Messages, Classes, Graphics, Controls,
  StdCtrls, ExtCtrls, Forms, Menus;

type
    TSlider = class(TGraphicControl)

    private
           FMax : Single;                {obere Grenze für Position}
           FMin : Single;                {untere Grenze für Position}
           FPosition : Single;           {Position des Sliders}

           DrawBuffer : TBitmap;         {Zeichenpuffer}

           procedure SetPosition(newPosition : Single);
           procedure SetMax(newValue : Single);
           procedure SetMin(newValue : Single);

    protected
             procedure Paint; override;
             procedure MouseMove(Shift: TShiftState; X, Y: Integer);override;
             procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);override;

    public
          constructor Create(AOwner : TComponent); override;
          destructor Destroy; override;

    published
             property Max:Single read FMax write SetMax;
             property Min:Single read FMin write SetMin;
             property Position:Single read FPosition write SetPosition;
end;

procedure Register;

implementation

constructor TSlider.Create(AOwner : TComponent);
begin
     inherited Create(AOwner);
     
     Height := 200;
     Width := 50;
     FMax := 100;
     FMin := 0;
     FPosition := 0;

     DrawBuffer := TBitmap.Create;
end;

destructor TSlider.Destroy;
begin
     inherited Destroy;
     DrawBuffer.Free;
end;

procedure TSlider.Paint;
{Zeichnen der TrackBar in den Zeichenpuffer}
var
   CRect : TRect;                   {Zeichenbereich für die Trackbar}
   SliderRect : TRect;              {Zeichenbereich für den Slider}
   LEDRect : TRect;                 {Zeichenbereich für die LED}
   i,j : Integer;                   {Laufvariablen}
   SliderPosition : Integer;        {Position des Sliders als Y-Koordinate}

begin

      Inherited;

     {Bereichsüberprüfung für Max, Min und Position}
     If FPosition > FMax then FPosition := FMax;
     If FPosition < FMin then FPosition := FMin;
     If FMax <= FMin then FMax := FMin+1;

     CRect.Top    := 0;
     CRect.Left   := 0;
     CRect.Bottom := Height;
     CRect.Right  := Width;

     with DrawBuffer.Canvas do
     begin
          {Rahmen zeichnen}
          for i := 1 to 3 do
            begin
                for j := CRect.Left to CRect.Right do
                begin
                    Pixels[j,CRect.Top] := Pixels[j,CRect.Top] - $00505050;
                    If Pixels[j,CRect.Top] < clBlack then Pixels[j,CRect.Top] := clBlack;
                    Pixels[j,CRect.Bottom] := Pixels[j,CRect.Bottom] + $00505050;
                    If Pixels[j,CRect.Bottom] > clWhite then Pixels[j,CRect.Bottom] := clWhite;
                end;
                for j := CRect.Top to CRect.Bottom do
                begin
                    Pixels[CRect.Left,j] := Pixels[CRect.Left,j] - $00505050;
                    If Pixels[CRect.Left,j] < clBlack then Pixels[CRect.Left,j] := clBlack;
                    Pixels[CRect.Right,j] := Pixels[CRect.Right,j] + $00505050;
                    If Pixels[CRect.Right,j] > clWhite then Pixels[CRect.Right,j] := clWhite;
                end;
                InflateRect(CRect,-1,-1);
            end;

          {Hintergrund zeichnen}
             Brush.Style := bsClear;
             FillRect(CRect);

          {Slider zeichnen}
          {Y-Koordinate des Sliders bestimmen}
          SliderPosition := Round(Height - (FPosition-FMin)/(FMax-FMin)*(Height-20) - 10);

          SliderRect.Top := SliderPosition - 7;
          SliderRect.Bottom := SliderPosition + 6;
          SliderRect.Left := 6;
          SliderRect.Right := Width - 6;


          {Rahmen des Sliders zeichnen}
          for i := 1 to 2 do
          begin
               Pen.Color := clBtnHighlight;
               MoveTo(SliderRect.Left,SliderRect.Top);
               LineTo(SliderRect.Right,SliderRect.Top);
               MoveTo(SliderRect.Left,SliderRect.Top);
               LineTo(SliderRect.Left,SliderRect.Bottom);
               Pen.Color := clBtnShadow;
               MoveTo(SliderRect.Right,SliderRect.Bottom);
               LineTo(SliderRect.Left,SliderRect.Bottom);
               MoveTo(SliderRect.Right,SliderRect.Bottom);
               LineTo(SliderRect.Right,SliderRect.Top);
               InflateRect(SliderRect,-1,-1);
          end;
          Brush.Style := bsSolid;
          Brush.Color := clSilver;
          FillRect(SliderRect);


          {LED zeichnen}
          LEDRect.Top := SliderRect.Top+2;
          LEDRect.Left := Round(SliderRect.Right-(SliderRect.Right-SliderRect.Left)/3);
          LEDRect.Bottom := SliderRect.Bottom-2;
          LEDRect.Right := SliderRect.Right-1;

          {Rahmen der LED zeichnen}
          Pen.Color := clBlack;
          Pen.Width := 1;
          MoveTo(LEDRect.Left,LEDRect.Top);
          LineTo(LEDRect.Right,LEDRect.Top);
          MoveTo(LEDRect.Left,LEDRect.Top);
          LineTo(LEDRect.Left,LEDRect.Bottom);
          MoveTo(LEDRect.Right,LEDRect.Bottom);
          LineTo(LEDRect.Left,LEDRect.Bottom);
          MoveTo(LEDRect.Right,LEDRect.Bottom);
          LineTo(LEDRect.Right,LEDRect.Top);
          InflateRect(LEDRect,-1,-1);

          Brush.Color := clRed;
          FillRect(LEDRect);
     end;

     {DrawBuffer zeichnen}
     Canvas.Draw(0,0,DrawBuffer);

end;


procedure TSlider.SetPosition(newPosition : Single);
{Position ändern}
begin
    If FPosition <> newPosition then
        FPosition := newPosition;
    Invalidate;
end;

procedure TSlider.SetMax(newValue : Single);
{Maximalwert ändern}
begin
    If FMax <> newValue then
        FMax := newValue;
    Invalidate;
end;

procedure TSlider.SetMin(newValue : Single);
{Minimalwert ändern}
begin
    If FMin <> newValue then
        FMin := newValue;
    Invalidate;
end;

procedure TSlider.MouseMove(Shift: TShiftState; X, Y: Integer);
{Slider bewegen}
begin
     Inherited;
     If (ssLeft in Shift) then
     begin
        SetPosition(Round(FMax - Y/(Height-20)*(FMax-FMin)));
          Invalidate;
     end;
end;

procedure TSlider.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
{Linksklick in die Trackbar}
begin
     Inherited;
     If (ssLeft in Shift) then
     begin
        SetPosition(Round(FMax - Y/(Height-20)*(FMax-FMin)));
          Invalidate;
     end;
end;

procedure Register;
begin
  RegisterComponents('Beispiele', [TSlider]);
end;

end.