unit GraphicClock;

interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  ExtCtrls;

type
  TClockStyle = (scAnalog, scDigital);

  TGraphicClock = class(TGraphicControl)
  private
    Ticker: TTimer;

    FBitmap, FBGBitmap: TBitmap;
    FOnSecond, FOnMinute, FOnHour: TNotifyEvent;

    CenterPoint: TPoint;
    Radius: integer;
    LapStepW: integer;
    PrevTime: TDateTime;
    ShowSecondArrow: boolean;
    FHourArrowColor,FMinArrowColor, FSecArrowColor: TColor;
    FFaceColor: TColor;
    CHourDiff, CMinDiff: integer;
    FClockStyle:TClockStyle;
    FDateFormat: String;
    FFont: TFont;
    procedure SetStyleStyle(Value: TClockStyle);
    procedure SetBGBitmap(Value: TBitmap);
    procedure SetFaceColor(Value: TColor);
    procedure SetHourArrowColor(Value: TColor);
    procedure SetMinuteArrowColor(Value: TColor);
    procedure SetSecArrowColor(Value: TColor);
    procedure SetShowSecondArrow(Value: boolean);
    procedure SetHourDiff(Value: integer);
    procedure SetMinDiff(Value: integer);
    function MinuteAngle(Min: word): real;
    function HourAngle(Hou, Min: word): real;
    procedure CalcClockSettings;
    procedure DrawClockBkg;
    procedure DrawArrows;
    procedure TimeDiff(GTime, DTime: TDateTime; var dHour, dMin: integer);
    procedure DecodeCTime(CTime: TDateTime; var H, M, S: word);
    procedure SetFDateFormat(const Value: String);
    procedure SetFont(const Value: TFont);
  protected
    procedure Paint; override;
    procedure TickerCall(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ClkTime( var H, M, S: word);
    procedure SetClkTime( CTime: TDateTime);
  published
    property Align;
    property Enabled;
    property ParentShowHint;
    property ShowHint;
    property Visible;
    property BGBitmap: TBitmap read FBGBitmap write SetBGBitmap;
    property DateFormat: String read FDateFormat write SetFDateFormat;
    property Font: TFont read FFont write SetFont;
    property ColorHourArrow: TColor read FHourArrowColor write SetHourArrowColor;
    property ColorMinuteArrow: TColor read FMinArrowColor write SetMinuteArrowColor;
    property ColorSecondArrow: TColor read FSecArrowColor write SetSecArrowColor;
    property ClockFaceColor: TColor read FFaceColor write SetFaceColor;
    property DifHour: integer read CHourDiff write SetHourDiff default 0;
    property DifMinute: integer read CMinDiff write SetMinDiff default 0;
    property SecArrow: boolean read ShowSecondArrow write SetShowSecondArrow;
    property OnSecond: TNotifyEvent read FOnSecond write FOnSecond;
    property OnMinute: TNotifyEvent read FOnMinute write FOnMinute;
    property OnHour: TNotifyEvent read FOnHour write FOnHour;
    property ClockStyle: TClockStyle read FClockStyle write SetStyleStyle default scAnalog;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents( 'Samples', [TGraphicClock]);
end;

constructor TGraphicClock.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);

 Width := 50;
 Height := 50;
 ShowSecondArrow := true;
 PrevTime := 0;
 CHourDiff := 0;
 CMinDiff := 0;

 FBGBitmap:= TBitmap.Create;
 FFont:=TFont.Create;;
 FBitmap:= TBitmap.Create;
 FBitmap.Width := Width;
 FBitmap.Height := Height;
 DateFormat:='tt';

 Ticker := TTimer.Create( Self);
 Ticker.Interval := 1000;
 Ticker.OnTimer := TickerCall;
 Ticker.Enabled := true;

 FFaceColor := clBtnFace;
 FHourArrowColor := clActiveCaption;
 FMinArrowColor := clActiveCaption;
 FSecArrowColor := clActiveCaption;
end;

procedure TGraphicClock.SetFaceColor( Value : TColor);
begin
 FFaceColor := Value;
 invalidate;
end;

procedure TGraphicClock.SetBGBitmap(Value: TBitmap);
begin
 FBGBitmap.Assign(Value);
 invalidate;
end;

procedure TGraphicClock.SetHourArrowColor( Value : TColor);
begin
 FHourArrowColor := Value;
 invalidate;
end;

procedure TGraphicClock.SetMinuteArrowColor(Value: TColor);
begin
 FMinArrowColor := Value;
 invalidate;
end;

procedure TGraphicClock.SetSecArrowColor(Value: TColor);
begin
 FSecArrowColor := Value;
 invalidate;
end;

procedure TGraphicClock.SetShowSecondArrow( Value : boolean);
begin
 ShowSecondArrow := Value;
 PrevTime := 0;
 Invalidate;
end;

procedure TGraphicClock.SetHourDiff( Value : integer);
begin
 CHourDiff := Value MOD 12;
 DrawArrows;
end;

procedure TGraphicClock.SetMinDiff( Value : integer);
begin
 CMinDiff := Value MOD 60;
 DrawArrows;
end;


procedure TGraphicClock.Paint;
begin
 CalcClockSettings;
 DrawClockBkg;
 PrevTime := 0;
 DrawArrows;
end;

destructor TGraphicClock.Destroy;
begin
 Ticker.Free;
 FBitmap.Free;
 FBGBitmap.Free;
 inherited Destroy;
end;

procedure TGraphicClock.TimeDiff( GTime, DTime : TDateTime; var dHour, dMin : integer);
var MinDiff : integer; GTMin, DTMin : integer;

  function Time2Min( Tim : TDateTime) : integer;
    var cH, cM, cS, cmS : word;
  begin
   DecodeTime( Tim, cH, cM, cS, cmS);  Result := cH * 60 + cM;
  end;

begin
 GTMin := Time2Min( GTime);
 DTMin := Time2Min( DTime);
 MinDiff :=  GTMin - DTMin;
 dHour := MinDiff DIV 60;
 dMin  := MinDiff MOD 60;
end;

procedure TGraphicClock.DecodeCTime( CTime : TDateTime; var H, M, S : word);
var
 cH, cM, cS, cmS : word;
 SysMinAft0, TotMinDiff, ClkMinAft0 : integer;
begin
 DecodeTime( CTime, cH, cM, cS, cmS);
 SysMinAft0 := cH * 60 + cM;
 TotMinDiff := CHourDiff * 60 + CMinDiff;
 ClkMinAft0 := SysMinAft0 + TotMinDiff;
 if ClkMinAft0 < 0 then ClkMinAft0 := 24 * 60 + ClkMinAft0;
 H := ClkMinAft0 DIV 60;
 M := ClkMinAft0 MOD 60;
 S := cS;
end;

procedure TGraphicClock.ClkTime( var H, M, S : word); { Get clock time}
begin
 DecodeCTime(Time, H, M, S);
end;

procedure TGraphicClock.SetClkTime( CTime : TDateTime);
begin
 TimeDiff(CTime, Time, CHourDiff, CMinDiff);
 invalidate;
end;

function TGraphicClock.MinuteAngle( Min : word) : real;
begin
 MinuteAngle := Min * 2 * Pi / 60;
end;

function TGraphicClock.HourAngle( Hou, Min : word) : real;
begin
 HourAngle := ( Hou MOD 12) * 2 * Pi / 12 + MinuteAngle( Min) / 12;
end;

procedure TGraphicClock.TickerCall(Sender: TObject);
var
 H,M,S,Hp,Mp,Sp: word;
begin
 if csDesigning in ComponentState then exit;

 DecodeCTime( Time, H, M, S);
 DecodeCTime( PrevTime, Hp, Mp, Sp);

 if Assigned( FOnSecond) then FOnSecond(Self);
 if Assigned( FOnMinute) AND (Mp < M) then FOnMinute(Self);
 if Assigned( FOnHour) AND (Hp < H) then FOnHour(Self);
 PrevTime := Time;

 if ( NOT ShowSecondArrow) AND (Sp <= S) then exit;

 DrawArrows;
end;

procedure TGraphicClock.DrawArrows;
var
 H, M, S : word;
 ABitmap : TBitmap;
 Str:String;

  procedure DrawArrow( Angle, Scale : real; AWidth : integer);
  var SR : real;
  begin
   with ABitmap.Canvas do
    begin
     Pen.Width := AWidth;
     MoveTo( CenterPoint.X, CenterPoint.Y);
     SR := Scale *  Radius;
     LineTo(trunc(SR * sin( Angle)) + CenterPoint.X,trunc(-SR * cos( Angle)) + CenterPoint.Y);
    end;
  end;

begin
 ABitmap := TBitmap.Create;
 try
  ABitmap.Width := Width;
  ABitmap.Height := Height;
  ABitmap.Canvas.Brush.Color := FFaceColor;

  ABitmap.Canvas.CopyMode := cmSrcCopy;
  ABitmap.Canvas.CopyRect(ABitmap.Canvas.ClipRect,FBitmap.Canvas,FBitmap.Canvas.ClipRect);

  DecodeCTime( Time, H, M, S);

  if FClockStyle=scAnalog then
   begin
    ABitmap.Canvas.Pen.Color := FSecArrowColor;
    if ShowSecondArrow then
     DrawArrow( MinuteAngle( S),  1, 1);

    ABitmap.Canvas.Pen.Color := FMinArrowColor;
    DrawArrow( MinuteAngle( M),  0.95, 3);

    ABitmap.Canvas.Pen.Color := FHourArrowColor;
    DrawArrow( HourAngle( H, M), 0.60, 6);
   end
  else
   begin
    ABitmap.Canvas.Brush.Style:=BSClear;
    ABitmap.Canvas.Font.Assign(FFont);
    Str:=FormatDateTime(FDateFormat,Time);
    ABitmap.Canvas.TextOut(round((Width-ABitmap.Canvas.TextWidth(Str))/2),
                           round((Height-ABitmap.Canvas.TextHeight(Str))/2),
                           Str);
   end;

  Canvas.CopyMode := cmSrcCopy;
  Canvas.Draw( 0, 0, ABitmap);
 finally
  ABitmap.Free;
 end;
end;

procedure TGraphicClock.CalcClockSettings;
begin
 FBitmap.Free;
 FBitmap := TBitmap.Create;
 FBitmap.Width := Width;
 FBitmap.Height := Height;
 CenterPoint := Point( Width DIV 2, Height DIV 2 );
 with CenterPoint do
  if X <= Y then Radius := X
  else Radius := Y;

 LapStepW := Radius DIV 8;
 if LapStepW < 6 then
  LapStepW := 6;
 dec( Radius, LapStepW + 2);
end;

procedure TGraphicClock.DrawClockBkg;
  procedure Draw3dRect( ARect : TRect);
   begin
    Frame3D(FBitmap.Canvas, ARect, clBtnHighlight, clBtnShadow, 1);
   end;
  procedure DrawMinSteps;
  var
   OfsX, OfsY : integer;
   MinCou : word;
   CurPt : TPoint;
   TmpRect : TRect;
   SR, Ang : real;
  begin
   OfsX := LapStepW DIV 2; OfsY := OfsX;
   MinCou := 0;
   while MinCou < 56 do
    begin
     SR := Radius + OfsX;
     Ang := MinuteAngle( MinCou);
     CurPt := Point(trunc(  SR * sin( Ang)) + CenterPoint.X,trunc( -SR * cos( Ang)) + CenterPoint.Y);
     if MinCou MOD 15 = 0 then
      TmpRect := Rect( CurPt.X - OfsX, CurPt.Y - OfsY, CurPt.X + OfsX, CurPt.Y + OfsY)
     else TmpRect := Rect( CurPt.X - 2, CurPt.Y - 2, CurPt.X + 2, CurPt.Y + 2);

     Draw3dRect( TmpRect);

     inc( MinCou, 5);
    end;
  end;
begin
 with FBitmap.Canvas do
  begin
   Brush.Style := bsSolid;
   Brush.Color := FFaceColor;
   if FBGBitmap<>nil then
    CopyRect(ClipRect,FBGBitmap.Canvas,FBGBitmap.Canvas.ClipRect)
   else
    FillRect(ClipRect);
  end;
 if FClockStyle=scAnalog then
  DrawMinSteps;
end;

procedure TGraphicClock.SetStyleStyle(Value: TClockStyle);
begin
 if FClockStyle <> Value then
  begin
   FClockStyle := Value;
   Invalidate;
  end;
end;

procedure TGraphicClock.SetFDateFormat(const Value: String);
begin
  FDateFormat := Value;
end;

procedure TGraphicClock.SetFont(const Value: TFont);
begin
 FFont.Assign(Value);
end;

end.

