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:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:

unit DiscoLight;
{
 +-----------------------------------------------------------------------------+
 |Autor: Marco Dahms                                                           |
 |E-Mail: md1289@gmx.de                                                        |
 |Datum: XX.07.2006                                                            |
 |Dankeschön an: Lannes, der beim Zeichen des Kreisbogens half                 |
 |Lizenz: Ihr dürft damit machen was ihr wollt, solange ihr diese Mitteilung   |
 |        nicht entfernt ;)                                                    |
 |Changelog: 16.07.2006 - Version 1.0 erscheint                                |
 +-----------------------------------------------------------------------------+
 |Was kann diese Komponente?                                                   |
 |Die Frage nach dem Sinn dieser Komponente ist berechtigt. Der Anlass war     |
 |Regan aus dem Delphi-Forum (www.delphi-forum.de). Er brauchte genau so eine  |
 |Komponente. Da ich mich in letzter Zeit in die Objektorientierte             |
 |Programmierung eingearbeitet habe, wollte ich mich mal ausprobieren,         |
 |und bot ihm an, diese Komponente zu entwickeln. Einerseits wollte ich ihm    |
 |helfen, andererseits hatte ich vor, mir Kenntnisse hinsichtlich der          |
 |Komponentenentwicklung anzueignen.                                           |
 |Diese Komponente heißt TDiscoLight, weil sie einen Lichtkegel simuliert.     |
 |Es besteht die Möglichkeit, diesen stufenlos transparent zu machen und die   |
 |Lichtfarbe zu bestimmen.                                                     |
 +-----------------------------------------------------------------------------+
 |Feedback bitte an md1289@gmx.de oder in den passenden Thread im Forum.       |
 +-----------------------------------------------------------------------------+
}
interface

uses
  Windows, SysUtils, Classes, Controls, Graphics, Forms, ExtCtrls, dialogs;

type
  TDiscoLight = class(TCustomControl)
  private
    FColor: TColor;
    FAlphaBlendValue: integer; //1-100
    FAlphaBlend: boolean;
    FDrehung: integer; // 0-360
    FPointed : integer;
    Folor: TColor; //2-4
    function MixColor(Color1, Color2 : TColor; AlphaBlendValue : integer) : TColor;
    function GetWidth: integer;
    function GetHeight: integer;
    procedure SetHeight(const Value: integer);
    procedure SetAlphaBlendValue(Value: integer);
    procedure SetPointed(Value: integer);
    procedure SetAlphaBlend(Value: boolean);
    procedure SetColor(const Value: TColor);
    procedure SetWidth(const Value: integer);
    function HexToColor(Hex: string) : TColor;
    procedure SwapSubStrings(var s : string; index1, index2, count : integer);

 public

    constructor Create(AOwner : TComponent); override;
    procedure Paint; override;
    procedure SetNewColor(AColor: TColor); overload;
    procedure SetNewColor(Red,Green,Blue: Byte); overload;
    procedure SetNewColor(Hex: string); overload;


  published

    property Height: integer read GetHeight write SetHeight;
    property Width: integer Read GetWidth write SetWidth;
    property Color: TColor read Folor write SetColor;
    property Pointed: integer read FPointed write SetPointed;
    property AlphaBlendValue: integer read FAlphaBlendValue write SetAlphaBlendValue;
    property AlphaBlend: boolean read FAlphaBlend write SetAlphaBlend;
  
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Win32', [TDiscoLight]);
end;


procedure TDiscoLight.SwapSubStrings(var s : string; index1, index2, count : integer);
var temp:string;
begin
  if (index1+count-1<=index2) and (index2<Length(s)) then
  begin
    temp:=Copy(s,index1,count);
    Delete(s,index1,count);
    Insert(Copy(s,index2-count,count),s,index1);
    Delete(s,index2,count);
    Insert(temp,s,index2+1);
  end;
end;

function TDiscoLight.HexToColor(Hex: string) : TColor;
var temp:string;
begin
  if Length(Hex)=7 then
  begin
    Delete(Hex,1,1);
    temp:=Copy(Hex,1,2);
    SwapSubstrings(Hex,1,5,2);
    result:=strtoint('$00'+Hex);
  end
  else result:=clBlack;
end;


function TDiscoLight.MixColor(Color1, Color2 : TColor; AlphaBlendValue : integer) : TColor;
var b1,b2,b3,r1,r2,r3,g1,g2,g3:byte;
begin
  b1:=GetBValue(Color1);
  b2:=GetBValue(Color2);
  b3:=round((AlphaBlendValue/100)*b1 + (1-AlphaBlendValue/100)*b2);

  r1:=GetRValue(Color1);
  r2:=GetRValue(Color2);
  r3:=round((AlphaBlendValue/100)*r1 + (1-AlphaBlendValue/100)*r2);

  g1:=GetGValue(Color1);
  g2:=GetGValue(Color2);
  g3:=round((AlphaBlendValue/100)*g1 + (1-AlphaBlendValue/100)*g2);

  result:=RGB(r3,g3,b3);
end;


procedure TDiscoLight.Paint;
var AlphaBlendColor,ParentColor: TColor; r: integer; verschiebung: extended;
begin
  //Paint-Methode der Mutterklasse aurufen
  inherited Paint;
  //die Farbe des Parents auslesen
  if (Parent is TForm) then ParentColor:=(Parent as TForm).Color
  else if (Parent is TPanel) then ParentColor:=(Parent as TPanel).Color
  else ParentColor:=clBlack;
  //wenn AlphaBlend aktiviert, dann die Mischfarbe (MixColor) aus
  //der Lichtfarbe (FColor) und der Farbe des Parents (ParentColor) berechnen 
  if (AlphaBlend) then
    AlphaBlendColor:=MixColor(FColor,ParentColor,FAlphaBlendValue);
    
  with canvas do
  begin
    //Zeichenfäche leeren
    Brush.Color:=ParentColor;
    FillRect(rect(0,0,Width,Height));

    //Neuzeichnen
    //wenn AlphaBlend aktiviert, dann ist die Farbe zum Zeichnen die Mischfarbe (AlphaBlendColor),
    //andernfalls ist die Farbe zum Zeichnen die Lichtfarbe (FColor)
    if (AlphaBlend) then
    begin
      Pen.Color:=AlphaBlendColor;
      Brush.Color:=AlphaBlendColor
    end
    else begin
      Pen.Color:=FColor;
      Brush.Color:=FColor;
    end;
    MoveTo(0,0);
    LineTo(Width div FPointed,Height);
    MoveTo(0,0);
    LineTo(Width,Height div FPointed);
    r := Round(Sqrt(Sqr(Width) + Sqr(Height div FPointed)));
    pie(-r,-r,r,r,Width div FPointed,Height,Width,Height div FPointed);
  end;
end;

constructor TDiscoLight.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FColor:=clSkyBlue;
  FAlphaBlend:=true;
  FAlphaBlendValue:=90;
  FPointed:=4;
  SetBounds(50,50,200,200);
end;




procedure TDiscoLight.SetAlphaBlendValue(Value: integer);
begin
  if  (Value>=1) and (Value<=100) then
  begin
    FAlphaBlendValue := Value;
    if (FAlphaBlend) then
        Paint;
  end;
end;

procedure TDiscoLight.SetPointed(Value: integer);
begin
  if (Value>=2) and (Value<=32) then
  begin
    FPointed:=Value;
    Paint;
  end;
end;

procedure TDiscoLight.SetAlphaBlend(Value: boolean);
begin
  FAlphaBlend := Value;
  Paint;
end;

procedure TDiscoLight.SetColor(const Value: TColor);
begin
  FColor := Value;
  Paint;
end;

function TDiscoLight.GetWidth: integer;
begin
  result:= inherited Width;
end;


procedure TDiscoLight.SetWidth(const Value: integer);
begin
inherited Width:=Value;
inherited Height:=Value;
end;

function TDiscoLight.GetHeight: integer;
begin
result:=inherited Width;
end;

procedure TDiscoLight.SetHeight(const Value: integer);
begin
inherited Width:=Value;
inherited Height:=Value;
end;

procedure TDiscoLight.SetNewColor(AColor: TColor);
begin
  FColor:=AColor;
  Paint;
end;

procedure TDiscoLight.SetNewColor(Red,Green,Blue: Byte);
begin
  FColor:=RGB(Red,Green,Blue);
  Paint;
end;

procedure TDiscoLight.SetNewColor(Hex: string);
begin
  FColor:=HexToColor(Hex);
  Paint;
end;



end.					

1:
2:
3:
4:

function TDiscoLight.GetHeight: integer;   
begin   
result:=inherited Width;   
end;