unit roundlist;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, math;
type
Troundlist =
class(TCustomControl)
private
{ Private-Deklarationen }
selfcolor: TColor;
selfshowwidth: Extended;
selfY: integer;
selfmousepoint: Boolean;
selflist: TStrings;
selffont: TFont;
procedure RedrawEvent(Sender: TObject);
protected
{ Protected-Deklarationen }
procedure Paint;
override;
procedure MouseMove(Shift: TShiftState; X,Y: Integer);
override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
public
{ Public-Deklarationen }
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure setcolor(Color: TColor);
virtual;
procedure setshowwidth(Showwidth: Extended);
virtual;
procedure SetList(list: TStrings);
virtual;
procedure SetFont(Font: TFont);
virtual;
published
{ Published-Deklarationen }
property OnClick;
Property OnMouseDown;
property OnMouseMove;
Property OnMouseUp;
property OnEnter;
Property OnExit;
property OnKeyPress;
property OnKeyDown;
Property OnKeyUp;
Property color: Tcolor
read selfColor
write SetColor;
Property Showwidth: extended
read selfShowwidth
write setshowwidth;
property List: TStringlist
read SelfList
write SetList;
property Font: TFont
read SelfFont
write SetFont;
end;
procedure Register;
implementation
procedure Troundlist.Paint;
var
Steigung, Xpos, YPos: extended;
Uber: integer;
begin
canvas.Pen.Color := selfcolor;
Canvas.Brush.Color := selfColor;
steigung := height / (width * selfshowwidth);
Uber := round(((height / 2) / sqrt(((height / 2) * (height / 2)) - ((Width * selfshowwidth / 2 - Width) * Steigung * (Width * selfshowwidth / 2 - Width) * Steigung)) * (height / 2)) - (height / 2));
Canvas.Ellipse(round(width - (width * selfshowwidth)),-Uber,width, height + Uber);
if (((SelfY) - (height / 2)) / (uber - 6 + (height / 2)) >= -1)
and (((SelfY) - (height / 2)) / (uber - 6 + (height / 2)) <= 1)
then
Xpos := cos(arcsin(((SelfY) - (height / 2)) / (uber - 6 + (height / 2)))) * (width * selfshowwidth / 2 + 6) - ((Width * selfshowwidth / 2) - Width) - 12
else XPos := 0;
if Xpos < (width * 0.05)
then
begin
Xpos := Width * 0.05;
YPos := sin(arccos((XPos + (width * selfshowwidth / 2 - width)) / (Width * selfshowwidth / 2))) * (uber + height / 2 - 6) + Height / 2;
if selfY < Height / 2
then SelfY := round(height - YPos)
else SelfY := round(YPos);
end;
canvas.Pen.Color :=
rgb(255, 255, 0);
Canvas.Rectangle(round(Xpos - 4), selfY - 4, round(Xpos + 4), selfY + 4);
canvas.Pen.Color :=
rgb(255, 243, 0);
Canvas.Rectangle(round(Xpos - 3), selfY - 3, round(Xpos + 3), selfY + 3);
canvas.Pen.Color :=
rgb(255, 231, 0);
Canvas.Rectangle(round(Xpos - 2), selfY - 2, round(Xpos + 2), selfY + 2);
canvas.Pen.Color :=
rgb(255, 219, 0);
Canvas.Rectangle(round(Xpos - 1), selfY - 1, round(Xpos + 1), selfY + 1);
if selflist.Count > 0
then
begin
Canvas.Font.Assign(SelfFont);
canvas.TextOut(0, round(height / 2 - canvas.TextHeight(selflist[0]) / 2), selflist[0]);
end;
end;
constructor Troundlist.Create(AOWner: TComponent);
begin
inherited Create(AOwner);
selfcolor := clWhite;
selfshowwidth := 2;
SelfY := 0;
setBounds(0,0,100,200);
selflist := TStringlist.Create;
TStringlist(SelfList).OnChange := RedrawEvent;
selffont := TFont.Create;
SelfFont.OnChange := RedrawEvent;
end;
destructor TRoundList.Destroy;
begin
SelfFont.Free;
SelfList.Free;
inherited;
end;
procedure TRoundlist.SetFont(AFont: TFont);
begin
SelfFont.Assign(AFont);
end;
procedure TRoundlist.SetList(AList: TStrings);
begin
SelfList.Assign(AList);
end;
procedure TRoundlist.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
SelfMousePoint := False;
end;
procedure TRoundlist.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
XPos: Extended;
uber: integer;
begin
inherited MouseDown(Button, Shift, X, Y);
if (((Y) - (height / 2)) / (uber - 6 + (height / 2)) >= -1)
and (((Y) - (height / 2)) / (uber - 6 + (height / 2)) <= 1)
then
Xpos := cos(arcsin(((SelfY) - (height / 2)) / (uber - 6 + (height / 2)))) * (width * selfshowwidth / 2 + 6) - ((Width * selfshowwidth / 2) - Width) - 12
else XPos := 0;
if (X >= XPos - 6)
and (X <= XPos + 6)
then
begin
SelfMousePoint := true;
selfY := Y;
end;
paint;
end;
procedure TRoundlist.MouseMove(Shift: TShiftState; X,Y: Integer);
begin
inherited MouseMove (Shift, X, Y);
if selfMousepoint
then
SelfY := Y;
Paint;
end;
procedure TRoundlist.setshowwidth(showwidth: Extended);
begin
if not SameValue(selfshowwidth, showwidth, 1000)
then
begin
selfshowwidth := showwidth;
if not ( csLoading
in ComponentState )
then
Invalidate;
end;
end;
procedure TRoundlist.setcolor(color: TColor);
begin
if AColor <> SelfColor
then
begin
SelfColor := AColor;
if not ( csLoading
in ComponentState )
then
Invalidate;
end;
end;
procedure TRoundList.RedrawEvent(Sender: TObject);
begin
if not ( csLoading
in ComponentState )
then
Invalidate;
end;
procedure Register;
begin
RegisterComponents('
Beispiele', [Troundlist]);
end;
end.