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:
221:
222:
223:
224:
225:
226:
227:

unit LEDBox;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Math;

type
  TLEDBoxType = (btLED,btCheckbox); // Modus: LED oder Checkbox

  TLEDBox = class(TCustomControl)
  private
    FChecked : Boolean;           // Status der LEDBox
    FonColorFrom : TColor;        // äußere Farbe für Status AN
    FOnColorTo : TColor;          // innere Farbe für Status AN
    FOffColorFrom : TColor;       // äußere Farbe für Status AUS
    FOffColorTo : TColor;         // innere Farbe für Status AUS
    FType : TLEDBoxType;          // Komponententyp: LED oder Checkbox

    procedure SetChecked(newState : Boolean);
    procedure SetOnColorFrom(newColor : TColor);
    procedure SetOnColorTo(newColor : TColor);
    procedure SetOffColorFrom(newColor: TColor);
    procedure SetOffColorTo(newColor : TColor);
    procedure SetType(newType : TLEDBoxType);

  protected
    {Zeichnen der Komponente}
    procedure Paint; override;
    {Klick auf die Komponente}
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);override;

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

  published
    property Checked:Boolean read FChecked write SetChecked;
    property OnColorFrom:TColor read FOnColorFrom write SetOnColorFrom;
    property OnColorTo:TColor read FOnColorTo write SetOnColorTo;
    property OffColorFrom:TColor read FOffColorFrom write SetOffColorFrom;
    property OffColorTo:TColor read FOffColorTo write SetOffColorTo;
    property LEDType:TLEDBoxType read FType write SetType;
    property Visible;
    property OnClick;
    property OnDblClick;
    property ShowHint;
    property ParentShowHint;
    property Enabled;

  end;

procedure Register;

implementation

constructor TLEDBox.Create(AOwner : TComponent);
{Konstruktor}
begin
     inherited;
     Height := 15;
     Width := 15;
     FOnColorTo := clLime;
     FOnColorFrom := clGreen;
     FOffColorTo := clRed;
     FOffColorFrom := clMaroon;
     FType := btLED;
end;

destructor TLEDBox.Destroy;
{Destruktor}
begin
     Inherited;
end;

procedure TLEDBox.SetChecked(newState : Boolean);
{Status der LED}
begin
     If (FChecked <> newState) then
     begin
          FChecked := newState;
          Invalidate;
     end;
end;

procedure TLEDBox.SetOnColorFrom(newColor : TColor);
{Status On, Farbverlauf äußere Farbe}
begin
     If (FOnColorFrom <> newColor) then
     begin
          FOnColorFrom := newColor;
          Invalidate;
     end;
end;

procedure TLEDBox.SetOnColorTo(newColor : TColor);
{Status On, Farbverlauf innere Farbe}
begin
     If (FOnColorTo <> newColor) then
     begin
          FOnColorTo := newColor;
          Invalidate;
     end;
end;

procedure TLEDBox.SetOffColorFrom(newColor : TColor);
{Status Off, Farbverlauf äußere Farbe}
begin
     If (FOffColorFrom <> newColor) then
     begin
          FOffColorFrom := newColor;
          Invalidate;
     end;
end;

procedure TLEDBox.SetOffColorTo(newColor : TColor);
{Status Off, Farbverlauf innere Farbe}
begin
     If (FOffColorTo <> newColor) then
     begin
          FOffColorTo := newColor;
          Invalidate;
     end;
end;

procedure TLEDBox.SetType(newType : TLEDBoxType);
{Modus: LED oder Checkbox}
begin
     If (FType <> newType) then
     begin
          FType := newType;
     end;
end;

procedure TLEDBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
{Linke Maustaste gedrückt}
begin
     If (ssLeft in Shift) then
     begin
          If (FType = btCheckbox) then
          begin
               If FChecked then
                  SetChecked(FALSE)
               Else
                   SetChecked(TRUE);
               Invalidate;
          end;
     end;
end;

procedure TLEDBox.Paint;
{Zeichnen der Komponente}
var
   PRect : TRect;
   i : Integer;
   maxLength : Integer;
   paintColor : array[0..2] of Byte;
   deltaColor : array[0..2] of Single;
   ColorTo : TColor;
   ColorFrom : TColor;
begin
     PRect.Top := 0;
     PRect.Left := 0;
     PRect.Bottom := Height;
     PRect.Right := Width;

     {Maximalwert Breite-Höhe}
     maxLength := max(Width,Height)div 2;

     with Canvas do
     begin
          If FChecked then
          {Status On -> Farbe OnColor}
          begin
             ColorFrom := ColorToRGB(FOnColorFrom);
             ColorTo := ColorToRGB(FOnColorTo);
          end
          Else
          begin
          {Status Off -> Farbe OffColor}
               ColorFrom := ColorToRGB(FOffColorFrom);
               ColorTo := ColorToRGB(FOffColorTo);
          end;

          Brush.Color := ColorFrom;
          Brush.Style := bsSolid;
          FillRect(PRect);

          {Inkrement für Farbverlauf}
          deltaColor[0] := (GetRValue(ColorFrom) - GetRValue(ColorTo));
          deltaColor[1] := (GetGValue(ColorFrom) - GetGValue(ColorTo));
          deltaColor[2] := (GetBValue(ColorFrom) - GetBValue(ColorTo));

          for i := maxLength downto 1 do
          {RGB-Farbverlauf}
          begin
               paintColor[0] := GetRValue(ColorTo) + Trunc(deltaColor[0]*sqr(i/maxLength));
               paintColor[1] := GetGValue(ColorTo) + Trunc(deltaColor[1]*sqr(i/maxLength));
               paintColor[2] := GetBValue(ColorTo) + Trunc(deltaColor[2]*sqr(i/maxLength));
               Brush.Color := RGB(paintColor[0],paintColor[1],paintColor[2]);
               Pen.Color := RGB(paintColor[0],paintColor[1],paintColor[2]);
               Ellipse(Width div 2 -i, Height div 2 -i, Width div 2 +i, Height div 2 +i);
          end;

          for i := 1 to 2 do
          begin
               {Rahmen}
               Pen.Color := cl3DDkShadow;
               MoveTo(PRect.Left,PRect.Bottom);
               LineTo(PRect.Left,PRect.Top);
               LineTo(PRect.Right,PRect.Top);
               Pen.Color := clBtnHighlight;
               LineTo(PRect.Right,PRect.Bottom);
               LineTo(PRect.Left,PRect.Bottom);

               InflateRect(PRect,-1,-1);
          end;
     end;
end;

procedure Register;
{Komponente registrieren}
begin
  RegisterComponents('Zusätzlich', [TLEDBox]);
end;

end.                    

1:
2:
3:
4:
5:
6:

procedure TLEDBox.Paint;
{Komponente zeichnen}
begin
     Inherited;
     BitBlt(Canvas.Handle,Left,Top,Width,Height,FDrawBuffer.Canvas.Handle,0,0,SRCCOPY);
end;                    

1:

LEDBox.PaintTo(Bitmap.Canvas,..); // ich kann mich nicht erinnern aber da kommen noch die Koordinaten zu den Parametern