Autor |
Beitrag |
Marco D.
Beiträge: 2750
Windows Vista
Delphi 7, Delphi 2005 PE, PHP 4 + 5 (Notepad++), Java (Eclipse), XML, XML Schema, ABAP, ABAP OO
|
Verfasst: So 16.07.06 22:19
Ich veröffentlich hier meine erste eigene Komponente:
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;
interface
uses Windows, SysUtils, Classes, Controls, Graphics, Forms, ExtCtrls, dialogs;
type TDiscoLight = class(TCustomControl) private FColor: TColor; FAlphaBlendValue: integer; FAlphaBlend: boolean; FDrehung: integer; FPointed : integer; Folor: TColor; 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 inherited Paint; if (Parent is TForm) then ParentColor:=(Parent as TForm).Color else if (Parent is TPanel) then ParentColor:=(Parent as TPanel).Color else ParentColor:=clBlack; if (AlphaBlend) then AlphaBlendColor:=MixColor(FColor,ParentColor,FAlphaBlendValue); with canvas do begin Brush.Color:=ParentColor; FillRect(rect(0,0,Width,Height));
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. |
Ihr fragt euch bestimmt: Toll, und wozu brauche ich das jetzt? Tja, das ist eine gute Frage. Diese Komponente braucht eigentlich Regan, und ich habe die Entwicklung übernommen.
Diese Komponente simuliert einen Lichtkegel in eurer Anwendung. Man kann diesem stufenlos transparent machen und dessen Größe sowie Farbe ändern.
Ich veröffentliche diese Unit hier um:
1. Kritik bezüglich meines Programmierstils entgegenzunehmen, um diesen zu verbessern,
2. Kritik dieser Komponente entsprechend entgegenzunehmen (neue Funktionen, Überarbeitung bestehender Funktionen etc.),
3. und falls jemand diese Komponente doch mal brauchen sollte, dass er sie haben kann.
Ich habe sie problemlos unter Delphi 7 installieren können und sie funktionierte bis auf ein paar bekannte Bugs, die ich nicht alleine zu beheben vermag, bei mir.
Bekannte Bugs:
1.Die Methode Paint liest die Farbe des Parent aus, wenn dieser entweder der Klasse TForm oder Panel angehört.
Adernfalls wird die Property Color auf clBlack gesetzt. Darum kann man zur Entwurfszeit zwar die Farbe auswählen,
aber es wird zur Laufzeit direkt nach dem Programmstart die Farbe zurück auf Schwarz gesetzt, was nicht gewollt ist.
Allerdings kann man zur Laufzeit entweder der Property Color eine neue Farbe zuweisen oder die Methode SetNewColor
benutzen.
2.Um die Komponente transparent zu machen, lese ich die Farbe des Parents aus (siehe 1.) und berechen die Mischfareb
zwischen dieser und der Lichtfarbe. Wenn die Farbe des Formulars (also Parent) clBtnFace ist und man die Komponente
transparent machen will, wird sie annähernd schwarz anstatt Grau.
Weiterhin ist geplant, der Komponente eine Rotations-Funktion einzubauen, aber da komme ich nicht weiter.
Demo im Anhang
Einloggen, um Attachments anzusehen!
_________________ Pascal keeps your hand tied. C gives you enough rope to hang yourself. C++ gives you enough rope to shoot yourself in the foot
Zuletzt bearbeitet von Marco D. am So 16.07.06 22:37, insgesamt 2-mal bearbeitet
|
|
alias5000
Beiträge: 2145
WinXP Prof SP2, Ubuntu 9.04
C/C++(Code::Blocks, VS.NET),A51(Keil),Object Pascal(D2005PE, Turbo Delphi Explorer) C# (VS 2008 Express)
|
Verfasst: So 16.07.06 22:24
Klingt ja schon interessant, doch bevor ich mir den "Stress" mach, die zu installieren und ne Demo für zu schreiben um mir die Features anzuschauen, fände ichs toll, wenn du eine Demonstration hier anhängen könntest, oder zumindest ein paar Screenshots
Gruß alias5000
_________________ Programmers never die, they just GOSUB without RETURN
|
|
Marco D.
Beiträge: 2750
Windows Vista
Delphi 7, Delphi 2005 PE, PHP 4 + 5 (Notepad++), Java (Eclipse), XML, XML Schema, ABAP, ABAP OO
|
Verfasst: So 16.07.06 22:38
Hab eine Demo hochgeladen.
_________________ Pascal keeps your hand tied. C gives you enough rope to hang yourself. C++ gives you enough rope to shoot yourself in the foot
|
|
alias5000
Beiträge: 2145
WinXP Prof SP2, Ubuntu 9.04
C/C++(Code::Blocks, VS.NET),A51(Keil),Object Pascal(D2005PE, Turbo Delphi Explorer) C# (VS 2008 Express)
|
Verfasst: So 16.07.06 22:43
Danke
Also zur Komponente selber kann ich nicht viel sagen, da der Einsatzzeck tatsächlich sehr "speziell" ist.
Was mir auf die Schnelle aufgefallen ist, ist folgendes(ich orientiere mich an der Demo):
-Erzeuge mal eine größeren Kegel als die Standardgröße. Klicke dann auf erzeugen. Vllcht könntest du ja noch in die Komponente einbauen, dass er alte Kegel dann weggelöscht wird, oder sogar mit Transparenz einfach übermalt wird (also der alte noch existiert)
-Das Flackern beim Neuzeichnen könnte man noch versuchen zu vermeiden
Gruß alias5000
_________________ Programmers never die, they just GOSUB without RETURN
|
|
Marco D.
Beiträge: 2750
Windows Vista
Delphi 7, Delphi 2005 PE, PHP 4 + 5 (Notepad++), Java (Eclipse), XML, XML Schema, ABAP, ABAP OO
|
Verfasst: Mo 17.07.06 13:17
alias5000 hat folgendes geschrieben: |
-Erzeuge mal eine größeren Kegel als die Standardgröße. Klicke dann auf erzeugen. Vllcht könntest du ja noch in die Komponente einbauen, dass er alte Kegel dann weggelöscht wird, oder sogar mit Transparenz einfach übermalt wird (also der alte noch existiert) |
Brauch nicht, weil es in einem Programm außerhalb der Demo keinen Button 'Erzeugen' gibt.
alias5000 hat folgendes geschrieben: |
-Das Flackern beim Neuzeichnen könnte man noch versuchen zu vermeiden
|
Ja Nur wie?
_________________ Pascal keeps your hand tied. C gives you enough rope to hang yourself. C++ gives you enough rope to shoot yourself in the foot
|
|
JayEff
Beiträge: 2971
Windows Vista Ultimate
D7 Enterprise
|
Verfasst: Mo 17.07.06 14:10
Ich vermute ja DoubleBuffered:=true; ... geht das denn nicht? Vielleicht im Create...? Oder schon versucht? (Hab den QT nicht angeguckt )
_________________ >+++[>+++[>++++++++<-]<-]<++++[>++++[>>>+++++++<<<-]<-]<<++
[>++[>++[>>++++<<-]<-]<-]>>>>>++++++++++++++++++.+++++++.>++.-.<<.>>--.<+++++..<+.
|
|
Marco D.
Beiträge: 2750
Windows Vista
Delphi 7, Delphi 2005 PE, PHP 4 + 5 (Notepad++), Java (Eclipse), XML, XML Schema, ABAP, ABAP OO
|
Verfasst: Mo 17.07.06 14:16
DoubleBuffered:=true im OnCreate des Hauptformulars hat nichts bewirkt.
_________________ Pascal keeps your hand tied. C gives you enough rope to hang yourself. C++ gives you enough rope to shoot yourself in the foot
|
|
Marco D.
Beiträge: 2750
Windows Vista
Delphi 7, Delphi 2005 PE, PHP 4 + 5 (Notepad++), Java (Eclipse), XML, XML Schema, ABAP, ABAP OO
|
Verfasst: Di 18.07.06 13:08
Zitat: |
Ich veröffentliche diese Unit hier um:
1. Kritik bezüglich meines Programmierstils entgegenzunehmen, um diesen zu verbessern,
|
Oder hat sich bis jetzt niemand den Source angeschaut?
_________________ Pascal keeps your hand tied. C gives you enough rope to hang yourself. C++ gives you enough rope to shoot yourself in the foot
|
|
Marco D.
Beiträge: 2750
Windows Vista
Delphi 7, Delphi 2005 PE, PHP 4 + 5 (Notepad++), Java (Eclipse), XML, XML Schema, ABAP, ABAP OO
|
Verfasst: So 28.01.07 19:11
Marco D. hat folgendes geschrieben: | Zitat: |
Ich veröffentliche diese Unit hier um:
1. Kritik bezüglich meines Programmierstils entgegenzunehmen, um diesen zu verbessern,
|
Oder hat sich bis jetzt niemand den Source angeschaut? |
*Thread wieder ausgrab*
*Spaten wegpack*
_________________ Pascal keeps your hand tied. C gives you enough rope to hang yourself. C++ gives you enough rope to shoot yourself in the foot
|
|
Karlson
Beiträge: 2088
|
Verfasst: So 28.01.07 20:22
Du verhinderst das Flackern indem du das Bild im RAM zeichnest und dann auf die Form kopierst. z.B. BITBLT oder Luckies OffScreenBitmap TuT.
|
|
Marco D.
Beiträge: 2750
Windows Vista
Delphi 7, Delphi 2005 PE, PHP 4 + 5 (Notepad++), Java (Eclipse), XML, XML Schema, ABAP, ABAP OO
|
Verfasst: So 28.01.07 20:24
Karlson hat folgendes geschrieben: | Du verhinderst das Flackern indem du das Bild im RAM zeichnest und dann auf die Form kopierst. z.B. BITBLT oder Luckies OffScreenBitmap TuT. |
Danke für den Hinweis.
_________________ Pascal keeps your hand tied. C gives you enough rope to hang yourself. C++ gives you enough rope to shoot yourself in the foot
|
|
Nightmare_82
Beiträge: 260
|
Verfasst: So 13.05.07 13:19
Hier hast du wohl was verwechselt:
Delphi-Quelltext 1: 2: 3: 4:
| function TDiscoLight.GetHeight: integer; begin result:=inherited Width; end; |
Und ansonsten solltest du alle Paint-Aufrufe beim Ändern von Properties durch Repaint ersetzen, damit das Licht nicht unnötig oft neugezeichnet wird.(wenn du jetzt 5 Eigenschaften hintereinander änderst, wird das Licht auch 5x neugezeichnet, bei Repaint nur einmal).
|
|
|