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: TStringlist;
selffont: TFont;
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;
procedure setcolor(Color: TColor);
virtual;
procedure setshowwidth(Showwidth: Extended);
virtual;
procedure setlist(list: TStringlist);
virtual;
procedure setfont(Font: TFont);
virtual;
function getlist: TStringlist;
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 getlist
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 canvas.TextOut(0, round(height / 2 - canvas.TextHeight(selflist[0]) / 2), selflist[0]);
end;
constructor Troundlist.create(AOWner: TComponent);
begin
inherited create (AOwner);
selfcolor := clWhite;
selfshowwidth := 2;
SelfY := 0;
setBounds(0,0,100,200);
selflist := TStringlist.Create;
selffont := TFont.Create;
end;
function TRoundlist.getlist: TStringlist;
begin
result := selflist;
end;
procedure TRoundlist.setfont(font: TFont);
begin
selffont := Font;
end;
procedure TRoundlist.setlist(list: TStringlist);
begin
selflist := list;
end;
procedure TRoundlist.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
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
selfshowwidth := showwidth;
rEPAINT;
end;
procedure TRoundlist.setcolor(color: TColor);
begin
selfcolor := Color;
Repaint;
end;
procedure Register;
begin
RegisterComponents('
Beispiele', [Troundlist]);
end;
end.