ClockCtl.pas

unit ClockCtl;

interface

uses
  Windows, SysUtils, Types, UITypes, Classes, Controls, Graphics, Generics.Defaults,
  Generics.Collections, Forms, Messages, Direct2D, D2D1, ExtCtrls;

type
  TClockCtl = class(TCustomControl)
  strict private
    FCanvas: TDirect2DCanvas;
    FTimer: TTimer;
    FOnNewSec: TNotifyEvent;
    FPrevSec: Word;
    function CanvasWidth: Integer;
    function CanvasHeight: Integer;
    function CanvasRect: TRect;
  private
    FShowSeconds: Boolean;
    procedure CreateDeviceResources;
    procedure TimerTimer(Sender: TObject);
    function Vector(const Rho, Phi: Double): TPoint;
    function HourPos(const Rho, Hour: Double): TPoint;
    procedure SetShowSeconds(const Value: Boolean);
  protected
    procedure Paint; override;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure CreateWnd; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure ChangeScale(M: Integer; D: Integer; isDpiChange: Boolean); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TDirect2DCanvas read FCanvas;
  published
    property Align;
    property AlignWithMargins;
    property Anchors;
    property Cursor;
    property Font;
    property Hint;
    property PopupMenu;
    property ShowSeconds: Boolean read FShowSeconds write SetShowSeconds default True;
    property TabOrder;
    property TabStop default True;
    property OnNewSec: TNotifyEvent read FOnNewSec write FOnNewSec;
  end;

procedure Register;

implementation

uses
  Math, DateUtils, Rux;

procedure Register;
begin
  RegisterComponents('Rejbrand 2024', [TClockCtl]);
end;     

{ TClockCtl }
     
constructor TClockCtl.Create(AOwner: TComponent);
begin
  inherited;
  FShowSeconds := True;
  FTimer := TTimer.Create(Self);
  FTimer.Interval := 100;
  FTimer.OnTimer := TimerTimer;
end;

procedure TClockCtl.CreateDeviceResources;
begin
  FreeAndNil(FCanvas);
  FCanvas := TDirect2DCanvas.Create(Handle);
  ID2D1HwndRenderTarget(FCanvas.RenderTarget).SetDpi(PixelsPerInch, PixelsPerInch);
end;

procedure TClockCtl.CreateWnd;
begin
  inherited;
  CreateDeviceResources;
end;

destructor TClockCtl.Destroy;
begin
  FreeAndNil(FCanvas);
  inherited;
end;

function TClockCtl.HourPos(const Rho, Hour: Double): TPoint;
begin
  Result := Vector(Rho, Hour / 12.0);
end;

procedure TClockCtl.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if CanFocus then
    SetFocus;
end;

procedure TClockCtl.Paint;
begin

  Canvas.RenderTarget.Clear(D2D1ColorF(clWhite));

  const C = CanvasRect.CenterPoint;
  const R = Round(0.8 * Min(CanvasWidth, CanvasHeight) / 2);

  Canvas.Pen.Width := EnsureRange(Round(2 * R / 120), 1, 20);
  Canvas.Pen.Color := TUx.ThemeData.ActiveCaptionColor;
  Canvas.Brush.Color := TUx.ThemeData.InactiveCaptionColor;

  begin
    const TL = C - Point(r, r);
    const BR = C + Point(r, r);
    Canvas.Ellipse(TRect.Create(TL, BR));
  end;

  for var h := 1 to 12 do
  begin
    const P1 = HourPos(0.90 * R, h);
    const P2 = HourPos(0.99 * R, h);
    with P1 do Canvas.MoveTo(X, Y);
    with P2 do Canvas.LineTo(X, Y);
  end;

  var LNow: TDateTime := Time;

  begin
    const P1 = Vector(0.7 * R, 2 * LNow);
    Canvas.Pen.Width := EnsureRange(Round(5 * R / 120), 1, 20);
    Canvas.Pen.Color := TUx.ThemeData.InactiveCaptionTextColor;
    Canvas.MoveTo(C.X, C.Y);
    Canvas.LineTo(P1.X, P1.Y);
  end;

  begin
    const P1 = Vector(0.9 * R, 24 * LNow);
    Canvas.Pen.Width := EnsureRange(Round(3 * R / 120), 1, 20);
    Canvas.Pen.Color := TUx.ThemeData.InactiveCaptionTextColor;
    Canvas.MoveTo(C.X, C.Y);
    Canvas.LineTo(P1.X, P1.Y);
  end;

  if FShowSeconds then
  begin
    const P1 = Vector(0.9 * R, 24 * 60 * LNow);
    Canvas.Pen.Width := EnsureRange(Round(1 * R / 120), 1, 20);
    Canvas.Pen.Color := TUx.ThemeData.InactiveCaptionTextColor;
    Canvas.MoveTo(C.X, C.Y);
    Canvas.LineTo(P1.X, P1.Y);
  end;

end;

procedure TClockCtl.SetShowSeconds(const Value: Boolean);
begin
  if FShowSeconds <> Value then
  begin
    FShowSeconds := Value;
    Invalidate;
    if Assigned(FOnNewSec) then
      FOnNewSec(Self);
  end;
end;

procedure TClockCtl.TimerTimer(Sender: TObject);
begin
  Invalidate;
  if Assigned(FOnNewSec) then
  begin
    const LNewSec = SecondOf(Now);
    if LNewSec <> FPrevSec then
    begin
      FOnNewSec(Self);
      FPrevSec := LNewSec;
    end;
  end;
end;

function TClockCtl.Vector(const Rho, Phi: Double): TPoint;
begin
  var S, C: Double;
  SinCos(Pi/2 - 2*Pi*Phi, S, C);
  Result := CanvasRect.CenterPoint + Point(Round(Rho * C), -Round(Rho * S));
end;

function TClockCtl.CanvasHeight: Integer;
begin
  Result := MulDiv(ClientHeight, 96, Self.PixelsPerInch);
end;

function TClockCtl.CanvasRect: TRect;
begin
  Result := TRect.Create(0, 0, CanvasWidth, CanvasHeight);
end;

function TClockCtl.CanvasWidth: Integer;
begin
  Result := MulDiv(ClientWidth, 96, Self.PixelsPerInch);
end;

procedure TClockCtl.ChangeScale(M, D: Integer; isDpiChange: Boolean);
begin
  inherited;
  if Assigned(FCanvas) then
  begin
    ID2D1HwndRenderTarget(FCanvas.RenderTarget).SetDpi(PixelsPerInch, PixelsPerInch);
    Invalidate;
  end;
end;

procedure TClockCtl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TClockCtl.WMPaint(var Message: TWMPaint);
var
  PaintStruct: TPaintStruct;
  res: HRESULT;
begin
  BeginPaint(Handle, PaintStruct);
  try
    if Assigned(FCanvas) then
    begin
      FCanvas.BeginDraw;
      try
        Paint;
      finally
        res := FCanvas.RenderTarget.EndDraw;
        if res = D2DERR_RECREATE_TARGET then
          CreateDeviceResources;
      end;
    end;
  finally
    EndPaint(Handle, PaintStruct);
  end;
end;

procedure TClockCtl.WMSize(var Message: TWMSize);
begin
  if Assigned(FCanvas) then
  begin
    var S := D2D1SizeU(ClientWidth, ClientHeight);
    ID2D1HwndRenderTarget(FCanvas.RenderTarget).Resize(S);
  end;
  Invalidate;
  inherited;
end;

end.