home *** CD-ROM | disk | FTP | other *** search
- unit Srclock;
-
- { TSRClock (C)opyright 2001 Version 1.40
- Autor : Simon Reinhardt
- eMail : reinhardt@picsoft.de
- Internet : http://www.picsoft.de
-
- Die SRClock-Komponente stellt eine analoge oder digitale Uhr in verschiedenen
- Designs dar und verfⁿgt ⁿber einen Timer, der in einem eigenen Thread lΣuft.
- Die Uhr kann auch als Stopuhr verwendet werden.
-
- Diese Komponenten sind Public Domain, das Urheberrecht liegt aber beim Autor. }
-
- interface
-
- {$I SRDefine.inc}
-
- uses {$IFDEF SR_Win32} Windows, {$ELSE} WinTypes, WinProcs, Menus, {$ENDIF}
- Classes, Controls, Messages, Forms, Graphics, StdCtrls, Grids, SysUtils;
-
- type
- TClockStyle = (csClassic, csDigital, csMovingPoints, csPieSlice);
- TClockKind = (ckRealTime, ckStopWatch);
- TContrast = 0..9;
- TNumbers = (snAll, snNone, snQuarters);
- TTime = TDateTime;
-
- TThreadTimer = class;
-
- TTimerThread = class(TThread)
- OwnerTimer: TThreadTimer;
- procedure Execute; override;
- end;
-
- TThreadTimer = class(TComponent)
- private
- FEnabled : boolean;
- FInterval : word;
- FOnTimer : TNotifyEvent;
- FTimerThread : TTimerThread;
- FThreadPriority : TThreadPriority;
-
- procedure SetEnabled(Value: Boolean);
- procedure SetInterval(Value: word);
- procedure SetThreadPriority(Value: TThreadPriority);
- procedure Timer; dynamic;
-
- protected
- procedure UpdateTimer;
-
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- property TimerThread: TTimerThread read FTimerThread write FTimerThread;
-
- published
- property Enabled: boolean read FEnabled write SetEnabled default True;
- property Interval: word read FInterval write SetInterval default 250;
- property Priority: TThreadPriority read FThreadPriority write SetThreadPriority default tpNormal;
- property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
- end;
-
- TSRClock = class(TGraphicControl)
- private
- FAutoUpdate : boolean;
- FBorderWidth : integer;
- FColorBackground,
- FColorBorder,
- FColorHands,
- FColorNumbers,
- FColorSegments : TColor;
- FDigit : array [0..9] of TBitmap;
- FFadingColor : boolean;
- FHour,FMinute,FSecond : word;
- FKind : TClockKind;
- FLEDContrast : TContrast;
- FLineWidth : integer;
- FPriority : TThreadPriority;
- FOldWidth,FOldHeight : integer;
- FRunning : boolean;
- FSegCl : array [0..9, 1..7] of TColor;
- FShowNumbers : TNumbers;
- FShowSeconds,
- FShowTicks,
- FSummertime : boolean;
- FStyle : TClockStyle;
- FTime : TTime;
- FTimeOffset : double;
- FUpdateInterval : word;
-
- FOnMouseEnter,
- FOnMouseExit,
- FOnTimer : TNotifyEvent;
-
- Timer : TThreadTimer;
- Buffer : TBitmap;
-
- function GetPriority: TThreadPriority;
- procedure SetAutoUpdate(Value: boolean);
- procedure SetBorderWidth(Value: integer);
- procedure SetColorBackground(Value: TColor);
- procedure SetColorBorder(Value: TColor);
- procedure SetColorNumbers(Value: TColor);
- procedure SetColorHands(Value: TColor);
- procedure SetFadingColor(Value: boolean);
- procedure SetKind(Value: TClockKind);
- procedure SetLEDContrast(Value : TContrast);
- procedure SetLineWidth (Value: integer);
- procedure SetPriority(Value: TThreadPriority);
- procedure SetShowNumbers(Value: TNumbers);
- procedure SetShowSeconds(Value: boolean);
- procedure SetShowTicks(Value: boolean);
- procedure SetStyle(Value: TClockStyle);
- procedure SetTime(Value: TTime);
- procedure SetUpdateInterval(Value: word);
-
- procedure AssignColors (seg: integer; s1,s2,s3,s4,s5,s6,s7: Boolean);
- procedure GenerateBitMaps(AWidth, AHeight: integer);
-
- protected
- procedure Paint; override;
- procedure Loaded; override;
- procedure AutoUpdateClock(Sender: TObject);
- procedure CmEnabledChanged(var Message: TWmNoParams); message CM_ENABLEDCHANGED;
- procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
- procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
- procedure CmVisibleChanged(var Message: TWmNoParams); message CM_VISIBLECHANGED;
-
- public
- property Hour: word read FHour;
- property Minute: word read FMinute;
- property Second: word read FSecond;
- property Time: TTime read FTime write SetTime;
- property Summertime: boolean read FSummertime;
-
- procedure Reset;
- procedure Start;
- procedure Stop;
-
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
-
- published
- property Align;
- {$IFDEF SR_Delphi5_Up}
- property Anchors;
- {$ENDIF}
- property AutoUpdate: boolean read FAutoUpdate write SetAutoUpdate;
- property BorderWidth: integer read FBorderWidth write SetBorderWidth;
- property ColorBackground: TColor read FColorBackground write SetColorBackground;
- property ColorBorder: TColor read FColorBorder write SetColorBorder;
- property ColorNumbers: TColor read FColorNumbers write SetColorNumbers;
- property ColorHands: TColor read FColorHands write SetColorHands;
- property DigitLineWidth: integer read FLineWidth write setLineWidth;
- property Enabled;
- property FadingColor: boolean read FFadingColor write SetFadingColor;
- property Font;
- property Kind: TClockKind read FKind write SetKind;
- property LEDContrast: TContrast read FLEDContrast write SetLEDContrast;
- property Priority: TThreadPriority read GetPriority write SetPriority default tpNormal;
- property ShowNumbers: TNumbers read FShowNumbers write SetShowNumbers;
- property ShowSeconds: boolean read FShowSeconds write SetShowSeconds;
- property ShowTicks: boolean read FShowTicks write SetShowTicks;
- property Style: TClockStyle read FStyle write SetStyle;
- property UpdateInterval: word read FUpdateInterval write SetUpdateInterval;
- property Visible;
- property OnClick;
- property OnDblClick;
- property OnDragDrop;
- property OnDragOver;
- property OnEndDrag;
- property OnMouseDown;
- property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
- property OnMouseExit: TNotifyEvent read FOnMouseExit write FOnMouseExit;
- property OnMouseMove;
- property OnMouseUp;
- property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
- property OnStartDrag;
- end;
-
- procedure Register;
-
- implementation
-
- uses SRUtils, rrColors;
-
- function XKoord(XMittel,XRadius,Grad:word):word;
- begin
- Result:=round(XMittel-(sin(Grad*Pi/180)*XRadius));
- end; {XKoord}
-
- function YKoord(YMittel,YRadius,Grad:word):word;
- begin
- Result:=round(YMittel-(cos(Grad*Pi/180)*YRadius));
- end; {YKoord}
-
- function CalcShadowedColors(AColor:TColor;AContrast:integer):TColor;
- var Dummy : TColor;
- begin
- Get3DColors(AColor,Dummy,REsult,(10-AContrast)/10,(10-AContrast)/10);
- end;
-
- { Klasse TThreadTimer }
- procedure TTimerThread.Execute;
- begin
- Priority := OwnerTimer.Priority;
- repeat
- SleepEx(OwnerTimer.Interval, False);
- Synchronize(OwnerTimer.Timer);
- until Terminated;
- end;
-
- procedure TThreadTimer.UpdateTimer;
- begin
- if not TimerThread.Suspended then
- TimerThread.Suspend;
- if (FInterval <> 0) and FEnabled then
- if TimerThread.Suspended then
- TimerThread.Resume;
- end;
-
- procedure TThreadTimer.SetEnabled(Value: boolean);
- begin
- if Value<>FEnabled then begin
- FEnabled:=Value;
- UpdateTimer;
- end;
- end;
-
- procedure TThreadTimer.SetInterval(Value: Word);
- begin
- if Value<>FInterval then begin
- FInterval:=Value;
- UpdateTimer;
- end;
- end;
-
- procedure TThreadTimer.SetThreadPriority(Value: TThreadPriority);
- begin
- if Value<>FThreadPriority then begin
- FThreadPriority:=Value;
- UpdateTimer;
- end;
- end;
-
- procedure TThreadTimer.Timer;
- begin
- if Assigned(FOntimer) then
- FOnTimer(Self);
- end;
-
- constructor TThreadTimer.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FEnabled := True;
- FInterval := 250;
- FThreadPriority := tpNormal;
- FTimerThread := TTimerThread.Create(False);
- FTimerThread.OwnerTimer := Self;
- end;
-
- destructor TThreadTimer.Destroy;
- begin
- FEnabled := False;
- UpdateTimer;
- FTimerThread.Free;
- inherited Destroy;
- end;
-
- { Komponente TSRClock }
-
- procedure TSRClock.AssignColors (seg: integer; s1,s2,s3,s4,s5,s6,s7: Boolean);
- begin
- if s1 then
- FSegCl[seg, 1] := FColorNumbers
- else
- FSegCl[seg, 1] := FColorSegments;
- if s2 then
- FSegCl[seg, 2] := FColorNumbers
- else
- FSegCl[seg, 2] := FColorSegments;
- if s3 then
- FSegCl[seg, 3] := FColorNumbers
- else
- FSegCl[seg, 3] := FColorSegments;
- if s4 then
- FSegCl[seg, 4] := FColorNumbers
- else
- FSegCl[seg, 4] := FColorSegments;
- if s5 then
- FSegCl[seg, 5] := FColorNumbers
- else
- FSegCl[seg, 5] := FColorSegments;
- if s6 then
- FSegCl[seg, 6] := FColorNumbers
- else
- FSegCl[seg, 6] := FColorSegments;
- if s7 then
- FSegCl[seg, 7] := FColorNumbers
- else
- FSegCl[seg, 7] := FColorSegments;
- end;
-
- procedure TSRClock.GenerateBitMaps(AWidth, AHeight: integer);
- var
- TL, TR, TBL, TBR,
- ML, MTL, MTR, MR,
- MBL, MBR, BL, BTL,
- BTR, BR : TPoint;
- c, wAlt, LineW,
- DigitW : integer;
- begin
- LineW:=FLineWidth+2;
- DigitW:=round((AWidth-12)/8);
- wAlt := AHeight-4;
- { Polygonpunkte zuweisen }
- TL.x := 0;
- TL.y := 0;
- TR.x := DigitW-1;
- TR.y := 0;
- TBL.x := LineW - 1;
- TBL.y := LineW -1;
- TBR.x := DigitW - LineW;
- TBR.y := TBL.y;
- ML.x := 0;
- ML.y := wAlt div 2;
- MTL.x := TBL.x;
- MTL.y := ML.y - (LineW div 2);
- MTR.x := TBR.x;
- MTR.y := MTL.y;
- MR.x := TR.x;
- MR.y := ML.y;
- MBL.x := TBL.x;
- MBL.y := ML.y + (LineW div 2);
- MBR.x := MTR.x; MBR.y := MBL.y;
- BL.x := 0;
- BL.y := wAlt - 1;
- BR.x := TR.x;
- BR.y := BL.y;
- BTL.x := TBL.x;
- BTL.y := wAlt - LineW;
- BTR.x := TBR.x;
- BTR.y := BTL.y;
-
- { Segmentfarben zuweisen }
- AssignColors (0,true,true,true,false,true,true,true);
- AssignColors (1,false,false,true,false,false,true,false);
- AssignColors (2,true,false,true,true,true,false,true);
- AssignColors (3,true,false,true,true,false,true,true);
- AssignColors (4,false,true,true,true,false,true,false);
- AssignColors (5,true,true,false,true,false,true,true);
- AssignColors (6,false,true,false,true,true,true,true);
- AssignColors (7,true,false,true,false,false,true,false);
- AssignColors (8,true,true,true,true,true,true,true);
- AssignColors (9,true,true,true,true,false,true,true);
-
- { Bitmap erstellen }
- for c := 0 to 9 do begin
- FDigit[c].free;
- FDigit[c] := TBitmap.create;
- FDigit[c].width := DigitW;
- FDigit[c].height := wAlt;
- with FDigit[c].canvas do begin
- Pen.Color := ColorBorder;
- Brush.Color := FColorBackGround;
- Brush.style := bsSolid;
- Pen.Width := 1;
- Rectangle (TL.x, TL.y, BR.x+1, BR.y+1);
- { Segment 1 }
- Brush.Color := FSegCl[c, 1];
- Polygon ([TL, TR, TBR, TBL]);
- { Segment 2 }
- Brush.Color := FSegCl[c, 2];
- Polygon ([TL, TBL, MTL, ML]);
- { Segment 3 }
- Brush.Color := FSegCl[c, 3];
- Polygon ([TR, MR, MTR, TBR]);
- { Segment 4 }
- Brush.Color := FSegCl[c, 4];
- Polygon ([ML, MTL, MTR, MR, MBR, MBL]);
- { Segment 5 }
- Brush.Color := FSegCl[c, 5];
- Polygon ([ML, MBL, BTL, BL]);
- { Segment 6 }
- Brush.Color := FSegCl[c, 6];
- Polygon ([MR, BR, BTR, MBR]);
- { Segment 7 }
- Brush.Color := FSegCl[c, 7];
- Polygon ([BL, BTL, BTR, BR]);
- end;
- end;
- end;
-
- constructor TSRClock.Create(AOwner: TComponent);
- var msec : word;
- begin
- inherited Create(AOwner);
- { defaults }
- Buffer := TBitmap.Create;
-
- FUpdateInterval:=1000;
- Timer := TThreadTimer.Create(self);
- Timer.Interval := FUpdateInterval;
- Timer.OnTimer := AutoUpdateClock;
-
- FTime:=Now;
- try
- DecodeTime(FTime,FHour,FMinute,FSecond,msec);
- except
- end;
-
- FAutoUpdate:=false;
- FBorderWidth:=2;
- FColorBackGround:=clWindow;
- FColorBorder:=clWindowFrame;
- FColorNumbers:=clBlue;
- FLEDContrast:=6;
- FColorSegments:=CalcShadowedColors(FColorNumbers, FLEDContrast);
- FColorHands:=clNavy;
- FLineWidth:= 3;
- FPriority := tpNormal;
- FRunning:=false;
- FShowNumbers:=snQuarters;
- FShowSeconds:=true;
- FShowTicks:=true;
- FSummertime:=IsSummertime(Now);
- FStyle:=csClassic;
-
- SetBounds(0,0,80,80);
-
- FOldWidth:=Self.Width;
- FOldHeight:=Self.Height;
- if FStyle=csDigital then
- GenerateBitMaps(Self.Width, Self.Height);
- end;
-
- destructor TSRClock.Destroy;
- begin
- Buffer.Free;
- Timer.Free;
- inherited Destroy;
- end;
-
- procedure TSRClock.Loaded;
- begin
- inherited Loaded;
- Buffer.Width := Self.ClientWidth;
- Buffer.Height := Self.ClientHeight;
- Buffer.Canvas.Brush.Color := Color;
- end;
-
- procedure TSRClock.CmEnabledChanged(var Message: TWmNoParams);
- begin
- inherited;
- Timer.Enabled := Self.Enabled;
- Invalidate;
- end;
-
- procedure TSRClock.CMMouseEnter(var Message: TMessage);
- begin
- inherited;
- if Assigned(FOnMouseEnter) then
- FOnMouseEnter(Self);
- end;
-
- procedure TSRClock.CMMouseLeave(var Message: TMessage);
- begin
- inherited;
- if Assigned(FOnMouseExit) then
- FOnMouseExit(Self);
- end;
-
- procedure TSRClock.CmVisibleChanged(var Message: TWmNoParams);
- begin
- inherited;
- Invalidate;
- end;
-
- function TSRClock.GetPriority: TThreadPriority;
- begin
- Result := Timer.Priority;
- end;
-
- procedure TSRClock.SetAutoUpdate(Value: boolean);
- begin
- if (FAutoUpdate<>Value) and (FKind=ckRealTime) then begin
- FAutoUpdate:=Value;
- Timer.Enabled := FAutoUpdate;
- end;
- end;
-
- procedure TSRClock.SetBorderWidth(Value: integer);
- begin
- if Value<>FBorderWidth then begin
- FBorderWidth:=Value;
- if FStyle=csDigital then
- GenerateBitMaps(Self.Width, Self.Height);
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetColorBackground(Value: TColor);
- begin
- if Value<>FColorBackground then begin
- FColorBackground:=Value;
- if FStyle=csDigital then
- GenerateBitMaps(Self.Width, Self.Height);
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetColorBorder(Value: TColor);
- begin
- if Value<>FColorBorder then begin
- FColorBorder:=Value;
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetColorNumbers(Value: TColor);
- begin
- if Value<>FColorNumbers then begin
- FColorNumbers:=Value;
- FColorSegments:=CalcShadowedColors(FColorNumbers, FLEDContrast);
- if FStyle=csDigital then
- GenerateBitMaps(Self.Width, Self.Height);
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetColorHands(Value: TColor);
- begin
- if Value<>FColorHands then begin
- FColorHands:=Value;
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetFadingColor(Value: boolean);
- begin
- if Value<>FFadingColor then begin
- FFadingColor:=Value;
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetKind(Value: TClockKind);
- begin
- if Value<>FKind then begin
- FKind:=Value;
- if FKind=ckRealTime then
- FTime:=Now
- else begin
- FRunning:=false;
- FTimeOffset:=Now;
- FTime:=0;
- end;
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetLEDContrast(Value: TContrast);
- begin
- if (FLEDContrast<>Value) and (Value>=0) and (Value<10) then begin
- FLEDContrast:=Value;
- FColorSegments:=CalcShadowedColors(FColorNumbers, FLEDContrast);
- if FStyle=csDigital then
- GenerateBitMaps(Self.Width, Self.Height);
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetLineWidth (Value: integer);
- begin
- if FLineWidth<>Value then begin
- FLineWidth:=Value;
- if FStyle=csDigital then
- GenerateBitMaps(Self.Width, Self.Height);
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetPriority(Value: TThreadPriority);
- begin
- if Value<>FPriority then begin
- FPriority:=Value;
- Timer.Priority := FPriority;
- end;
- end;
-
- procedure TSRClock.SetShowNumbers(Value: TNumbers);
- begin
- if Value<>FShowNumbers then begin
- FShowNumbers:=Value;
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetShowSeconds(Value: boolean);
- begin
- if Value<>FShowSeconds then begin
- FShowSeconds:=Value;
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetShowTicks(Value: boolean);
- begin
- if Value<>FShowTicks then begin
- FShowTicks:=Value;
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetStyle(Value: TClockStyle);
- begin
- if Value<>FStyle then begin
- FStyle:=Value;
- if FStyle=csDigital then
- GenerateBitMaps(Self.Width, Self.Height);
- Invalidate;
- end;
- end;
-
- procedure TSRClock.SetTime(Value: TTime);
- var msec : word;
- begin
- if Value<>FTime then begin
- FTime:=Value;
- try
- DecodeTime(FTime,FHour,FMinute,FSecond,msec);
- except
- FHour:=0;
- FMinute:=0;
- FSecond:=0;
- end;
- Paint;
- end;
- end;
-
- procedure TSRClock.SetUpdateInterval(Value: word);
- begin
- if Value<>FUpdateInterval then begin
- FUpdateInterval:=Value;
- Timer.Interval:=FUpdateInterval;
- Invalidate;
- end;
- end;
-
- procedure TSRClock.AutoUpdateClock(Sender: TObject);
- begin
- if ((Kind=ckRealTime) and FAutoUpdate) or ((Kind=ckStopWatch) and FRunning) then begin
- if Kind=ckStopWatch then
- SetTime(Now-FTimeOffset)
- else
- SetTime(Now);
- if Assigned(FOnTimer) then
- FOnTimer(Self);
- end;
- end;
-
- procedure TSRClock.Reset;
- begin
- FTimeOffset:=Now;
- FTime:=0;
- Invalidate;
- end;
-
- procedure TSRClock.Start;
- begin
- FTimeOffset:=Now-FTime;
- FRunning:=true;
- end;
-
- procedure TSRClock.Stop;
- begin
- FRunning:=false;
- end;
-
- procedure TSRClock.Paint;
- var ARect : TRect;
- Center,
- ElCenter : TPoint;
- i : byte;
- XRadius,
- YRadius,
- ElXRadius,
- ElYRadius,
- Grad : word;
- anchoPosi,
- posiLeft,
- PosiTop, c,
- SepPosition : integer;
- outText : string;
- ElXAbstand,
- ElYAbstand : double;
-
- procedure AlTextOut(X,Y:integer;Text:string;HAlign,VAlign:TAlignment);
- var LeftOut,TopOut : integer;
- begin
- with Buffer.Canvas do begin
- LeftOut:=X;
- if HAlign=taRightJustify then
- LeftOut:=X-TextWidth(Text);
- if HAlign=taCenter then
- LeftOut:=X-(TextWidth(Text) div 2);
- TopOut:=Y;
- if VAlign=taRightJustify then
- TopOut:=Y-TextHeight(Text);
- if VAlign=taCenter then
- TopOut:=Y-(TextHeight(Text) div 2);
- TextOut(LeftOut,TopOut,Text);
- end;
- end; { AlTextOut }
-
- begin
- Buffer.Width := Self.Width;
- Buffer.Height := Self.Height;
- ARect:=GetClientRect;
- Center.X:=(ARect.Right-ARect.Left) div 2;
- Center.Y:=(ARect.Bottom-ARect.Top) div 2;
- with Buffer.Canvas do begin
- Font.Assign(Self.Font);
- Brush.Color := Self.Color;
- Brush.Style := bsSolid;
- Pen.Color := Self.Color;
- Rectangle(0, 0, Width, Height);
-
- if Style=csDigital then begin
- if (FOldWidth<>Self.Width) or (FOldHeight<>Self.Height) then
- GenerateBitmaps(Self.Width, Self.Height);
- Brush.Color := ColorBackground;
- Pen.Color := ColorBorder;
- Rectangle(0, 0, Width, Height);
- try
- outText:=FormatDateTime('hh:mm:ss', FTime);
- except
- outText:='';
- end;
- anchoPosi := round((Self.Width-4)/8);
- PosiTop := (Self.Height - (Self.Height-4)) div 2;
- posiLeft := ((anchoPosi - round((Self.Width)/8)) div 2)+3;
- Brush.Color := FColorNumbers;
- Pen.Color := FColorNumbers;
- { Bitmaps und DecSeperator zeichnen }
- for c := 1 to 8 do begin
- { nachfolgende Nullen mⁿssen gezeichnet werden! }
- if outText[c]=':' then begin
- Pen.Width:=1;
- Ellipse(posiLeft+round((Width-12)/16), posiTop+((Height-4) div 3)-2,
- posiLeft+FLineWidth+round((Width-12)/16), posiTop+((Height-4) div 3)-2+FLineWidth);
- Ellipse(posiLeft+round((Width-12)/16), posiTop+((Height-4)*2 div 3)-2,
- posiLeft+FLineWidth+round((Width-12)/16), posiTop+((Height-4)*2 div 3)-2+FLineWidth);
- end
- else
- Draw (posiLeft, posiTop, FDigit[strToInt(outText[c])]);
- inc (posiLeft, anchoPosi);
- end;
- end
- else begin
- { Rahmen und Hintergrund: }
- Pen.Width:=FBorderWidth;
- Pen.Color:=FColorBorder;
- Brush.Color:=FColorBackground;
- Brush.Style:=bsSolid;
- InflateRect(ARect, -FBorderWidth div 2, -FBorderWidth div 2);
- Ellipse(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
- Pen.Width:=1;
- end;
- XRadius:=(ARect.Right-ARect.Left) div 2;
- YRadius:=(ARect.Bottom-ARect.Top) div 2;
- if Style=csClassic then begin
- { Markierungen: }
- if FShowTicks then begin
- for i:=1 to 12 do begin
- MoveTo(XKoord(Center.X-1, XRadius-1, 360-(i*30)),
- YKoord(Center.Y-1, YRadius-1, 360-(i*30)));
- LineTo(XKoord(Center.X-1, XRadius-5, 360-(i*30)),
- YKoord(Center.Y-1, YRadius-5, 360-(i*30)));
- end;
- end;
-
- { Ziffern: }
- if FShowNumbers<>snNone then begin
- Brush.Style:=bsClear;
- Font.Color:=FColorNumbers;
- for i:=1 to 12 do
- if (FShowNumbers=snAll) or ((FShowNumbers=snQuarters) and ((i mod 3)=0)) then
- AlTextOut(XKoord(Center.X, XRadius-TextWidth('3')-2, 360-(i*30)),
- YKoord(Center.Y, YRadius-(TextHeight('1') div 2)-4, 360-(i*30)),
- IntToStr(i), taCenter, taCenter);
- end;
-
- { Zeiger: }
- Pen.Color:=FColorBorder;
- Brush.Color:=FColorBorder;
- Brush.Style:=bsSolid;
- Ellipse(Center.X-(XRadius div 10), Center.Y-(YRadius div 10),
- Center.X+(XRadius div 10), Center.Y+(YRadius div 10));
- Pen.Color:=FColorHands;
- { Stunden }
- Pen.Width:=4;
- Grad:=360-((FHour mod 12)*30);
- Grad:=Grad-round(30*(FMinute/60));
- MoveTo(Center.X, Center.Y);
- LineTo(XKoord(Center.X,XRadius div 2,Grad),
- YKoord(Center.Y,YRadius div 2,Grad));
- { Minuten }
- Pen.Width:=2;
- MoveTo(Center.X, Center.Y);
- LineTo(XKoord(Center.X,XRadius-4,360-(FMinute*6)),
- YKoord(Center.Y,YRadius-4,360-(FMinute*6)));
- { Sekunden }
- if FShowSeconds then begin
- Pen.Width:=1;
- Pen.Color:=FColorNumbers;
- MoveTo(XKoord(Center.X,5,180-(FSecond*6)),
- YKoord(Center.Y,5,180-(FSecond*6)));
- LineTo(XKoord(Center.X,XRadius-4,360-(FSecond*6)),
- YKoord(Center.Y,YRadius-4,360-(FSecond*6)));
- end;
- end;
- if Style=csMovingPoints then begin
- Brush.Color:=FColorBorder;
- Brush.Style:=bsSolid;
- ElXRadius:=((XRadius-(XRadius div 5)) div 2)-2;
- ElYRadius:=((YRadius-(YRadius div 5)) div 2)-2;
- Ellipse(Center.X-ElXRadius, Center.Y-ElYRadius,
- Center.X+ElXRadius, Center.Y+ElYRadius);
- { Stunden und Minuten }
- if (FMinute=0) or not FFadingColor then
- Brush.Color:=FColorHands
- else
- Brush.Color:=CalcShadowedColors(FColorHands, round(7-(7/(60-FMinute))));
- Pen.Color:=Brush.Color;
- Grad:=360-((FHour mod 12)*30);
- Grad:=Grad-round(30*(FMinute/60));
- ElXRadius:=XRadius div 5;
- ElYRadius:=YRadius div 5;
- ElXAbstand:=(XRadius-ElXRadius)/120;
- ElYAbstand:=(YRadius-ElYRadius)/120;
- if FMinute=0 then begin
- ElCenter.X:=XKoord(Center.X, XRadius-2, Grad);
- ElCenter.Y:=YKoord(Center.Y, YRadius-2, Grad);
- end
- else begin
- ElCenter.X:=XKoord(Center.X, XRadius-2-round((60-FMinute)*ElXAbstand), Grad);
- ElCenter.Y:=YKoord(Center.Y, YRadius-2-round((60-FMinute)*ElYAbstand), Grad);
- end;
- Pie(ElCenter.X-ElXRadius, ElCenter.Y-ElYRadius,
- ElCenter.X+ElXRadius, ElCenter.Y+ElYRadius,
- XKoord(ElCenter.X, ElXRadius, Grad+135), YKoord(ElCenter.Y, ElYRadius, Grad+135),
- XKoord(ElCenter.X, ElXRadius, Grad-135), YKoord(ElCenter.Y, ElYRadius, Grad-135));
- { Sekunden }
- if FShowSeconds then begin
- Brush.Color:=FColorNumbers;
- Pen.Color:=Brush.Color;
- ElXRadius:=ElXRadius div 3;
- ElYRadius:=ElYRadius div 3;
- ElCenter.X:=XKoord(Center.X, (XRadius div 3), 360-(FSecond*6));
- ElCenter.Y:=YKoord(Center.Y, (YRadius div 3), 360-(FSecond*6));
- Ellipse(ElCenter.X-ElXRadius, ElCenter.Y-ElYRadius,
- ElCenter.X+ElXRadius, ElCenter.Y+ElYRadius);
- end;
- end;
- if Style=csPieSlice then begin
- if (FMinute=0) or not FFadingColor then
- Brush.Color:=FColorHands
- else
- Brush.Color:=CalcShadowedColors(FColorHands, round(7-(7/(60-FMinute))));
- Pen.Color:=Brush.Color;
- { Stunden und Minuten }
- ElXAbstand:=(XRadius-(XRadius div 3)-4)/60;
- ElYAbstand:=(YRadius-(YRadius div 3)-4)/60;
- if FMinute=0 then begin
- ElXRadius:=(XRadius div 3)+round(ElXAbstand*60);
- ElYRadius:=(YRadius div 3)+round(ElYAbstand*60);
- end
- else begin
- ElXRadius:=(XRadius div 3)+round(ElXAbstand*FMinute);
- ElYRadius:=(YRadius div 3)+round(ElYAbstand*FMinute);
- end;
- Grad:=360-((FHour mod 12)*30);
- Grad:=Grad-round(30*(FMinute/60));
- Pie(Center.X-ElXRadius, Center.Y-ElYRadius,
- Center.X+ElXRadius, Center.Y+ElYRadius,
- XKoord(Center.X, ElXRadius, Grad), YKoord(Center.Y, ElYRadius, Grad),
- XKoord(Center.X, ElXRadius, 0), YKoord(Center.Y, ElYRadius, 0));
- Brush.Color:=FColorBorder;
- Brush.Style:=bsSolid;
- Pen.Color:=Brush.Color;
- Ellipse(Center.X-(XRadius div 3), Center.Y-(YRadius div 3),
- Center.X+(XRadius div 3), Center.Y+(YRadius div 3));
- { Sekunden }
- if FShowSeconds then begin
- Brush.Color:=FColorNumbers;
- Pen.Color:=Brush.Color;
- ElXRadius:=XRadius div 10;
- ElYRadius:=YRadius div 10;
- ElCenter.X:=XKoord(Center.X, (XRadius div 3), 360-(FSecond*6));
- ElCenter.Y:=YKoord(Center.Y, (YRadius div 3), 360-(FSecond*6));
- Ellipse(ElCenter.X-ElXRadius, ElCenter.Y-ElYRadius,
- ElCenter.X+ElXRadius, ElCenter.Y+ElYRadius);
- end;
- end;
- if (FOldWidth<>Self.Width) or (FOldHeight<>Self.Height) then begin
- FOldWidth:=Self.Width;
- FOldHeight:=Self.Height;
- end;
- end;
- Canvas.Draw(0,0,Buffer);
- end;
-
- procedure Register;
- begin
- RegisterComponents('Simon', [TSRClock]);
- end;
-
- end.
-