amclock.pas

Delphi basic program. Basic programing guide for delphi language. Several samples are giving.

{ TAMClock  for Delphi 7
  这是一个模拟时钟的小组件，主要通过它演示把组件打包的过程和代码
  下面使部分属性的说明

  TAMClock properties
    AutoCenter       : 缺省为default，把时钟自动至于画布中间
    Center           : 位置
    Interval         : Update interval (and interval of OnTimer-event)
    Interactive      : 缺省为false，为true的时候可以在运行时点击使之移动到中间
    Picture          : 设定时钟的图片
    Priority         : 设定时钟线程的优先级

  TAMClocl events
    OnTimer       : 每 X 微秒触发一次,就像 Delphi中的TTimer
}

unit AMClock;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;

type
  TCmMouseEnter = record
    Msg    : Cardinal;
    Unused : Integer;
    Sender : TControl;             
    Result : LongInt;
  end;
  TCmMouseLeave = TCmMouseEnter;

  TMouseEnterLeave = procedure (Sender: TObject) of object;

  THour   = procedure (Sender: TObject; Hour: word) of object;
  TMinute = procedure (Sender: TObject; Minute: word) of object;
  TSecond = procedure (Sender: TObject; Second: word) of object;

  TAMClock = class;
  TThrdTimer = class;

  TTimerThread = class(TThread)
    OwnerTimer: TThrdTimer;
    procedure Execute; override;
  end;

  TThrdTimer = 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;

  TCenter = class(TPersistent)
  private
    FX: integer;
    FY: integer;
    FParent: TAMClock;

    procedure SetCenter(Index, Value: integer);
  protected
    procedure UpdateParent;
  public
    constructor Create;
    property Parent: TAMClock read FParent write FParent;
  published
    property X: integer index 0 read FX write SetCenter default 50;
    property Y: integer index 1 read FY write SetCenter default 50;
  end;

  THand = class(TPersistent)
  private
    FBackRadius: integer;
    FColor: TColor;
    FParent: TAMClock;
    FRadius: integer;
    FWidth: integer;

    procedure SetBackRadius(Value: integer);
    procedure SetColor(Value: TColor);
    procedure SetRadius(Value: integer);
    procedure SetWidth(Value: integer);
  protected
    procedure UpdateParent;  
  public
    constructor Create;
    property Parent: TAMClock read FParent write FParent;
  published
    property BackRadius: integer read FBackRadius write SetBackRadius default 10;
    property Color: TColor read FColor write SetColor default clRed;
    property Radius: integer read FRadius write SetRadius default 90;
    property Width: integer read FWidth write SetWidth default 2;
  end;

  TAMClock = class(TCustomControl)
  private
    FAutoCenter: boolean;
    FCenter: TCenter;
    FHoursHand: THand;
    FInteractive: boolean;
    FInterval: word;
    FMinutesHand: THand;
    FSecondsHand: THand;
//    FPicture: TPicture;
    FPriority: TThreadPriority;
    FTransparent: boolean;
    FTransparentColor: TColor;

    FHour: THour;
    FMinute: TMinute;
    FSecond: TSecond;
    FOnTimer: TNotifyEvent;
    FMouseEnter : TMouseEnterLeave;
    FMouseLeave : TMouseEnterLeave;

    Timer: TThrdTimer;
    Buffer: TBitmap;
    h,m,s: word;
    OldHour, OldMinute, OldSecond: word;

    procedure SetAutoCenter(Value: boolean);
    procedure SetInterval(Value: word);
    procedure SetPicture(Value: TPicture);
    function  GetPriority: TThreadPriority;
    procedure SetPriority(Value: TThreadPriority);
    procedure SetTransparent(Value: boolean);
    procedure SetTransparentColor(Value: TColor);
  protected
    procedure UpdateClock(Sender: TObject);
    procedure DrawHand(XCenter, YCenter, Radius, BackRadius, HandWidth: integer; HandColor: TColor; Angle: Real);
    procedure CmEnabledChanged(var Message: TWmNoParams); message CM_ENABLEDCHANGED;
    procedure CmMouseEnter(var Message: TCmMouseEnter); message CM_MOUSEENTER;
    procedure CmMouseLeave(var Message: TCmMouseLeave); message CM_MOUSELEAVE;
    procedure CmVisibleChanged(var Message: TWmNoParams); message CM_VISIBLECHANGED;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Loaded; override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas;
  published
    property AutoCenter: boolean read FAutoCenter write SetAutoCenter default True;
    property Center: TCenter read FCenter write FCenter;
    property Color;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Hint;
    property HoursHand: THand read FHoursHand write FHoursHand;
    property Interval: word read FInterval write SetInterval default 250;
    property Interactive: boolean read FInteractive write FInteractive default False;
    property MinutesHand: THand read FMinutesHand write FMinutesHand;
    property ParentColor;
    property ParentShowHint;
//    property Picture: TPicture read FPicture write SetPicture;
    property PopupMenu;
    property Priority: TThreadPriority read GetPriority write SetPriority default tpNormal;
    property SecondsHand: THand read FSecondsHand write FSecondsHand;
    property ShowHint;
    property Transparent: boolean read FTransparent write SetTransparent default True;
    property TransparentColor: TColor read FTransparentColor write SetTransparentColor default clOlive;
    property Visible;
    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnHour: THour read FHour write FHour;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMinute: TMinute read FMinute write FMinute;
    property OnMouseDown;
    property OnMouseEnter : TMouseEnterLeave read FMouseEnter write FMouseEnter;
    property OnMouseLeave : TMouseEnterLeave read FMouseLeave write FMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnSecond: TSecond read FSecond write FSecond;
    property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
    property OnStartDrag;
  end;

procedure Register;

implementation

{$R AMClock.res}

procedure TAMClock.UpdateClock(Sender: TObject);
var
  hsec: word;
begin
  DecodeTime(Time,h,m,s,hsec);
  Repaint;
  if s <> OldSecond then
  begin
    if Assigned(FSecond) then FSecond(Self, s);
    OldSecond := s;
  end;
  if m <> OldMinute then
  begin
    if Assigned(FMinute) then FMinute(Self, m);
    OldMinute := m;
  end;
  if h <> OldHour then
  begin
    if Assigned(FHour) then FHour(Self, h);
    OldHour := h;
  end;
  if Assigned(FOnTimer) then FOnTimer(Self);
end;

procedure TAMClock.Paint;
var
  Angle: real;
begin
  Buffer.Width := Self.Width;
  Buffer.Height := Self.Height;
  with Buffer.Canvas do
  begin
    Brush.Color := Self.Color;
    Brush.Style := bsSolid;
    Pen.Color := Self.Color;
    Rectangle(0,0,Width,Height);
    if FTransparent then
//       BrushCopy(ClientRect, FPicture.Bitmap, ClientRect, FTransparentColor)
    else
//       Draw(0,0,FPicture.Graphic);
  end;

  Angle := 2 * PI * (h + m / 60) / 12;
  DrawHand(100,100,HoursHand.Radius,HoursHand.BackRadius,HoursHand.Width,HoursHand.Color,Angle);
  Angle := 2 * PI * m / 60;
  DrawHand(100,100,MinutesHand.Radius,MinutesHand.BackRadius,MinutesHand.Width,MinutesHand.Color,Angle);
  Angle := 2 * PI * s / 60;
  DrawHand(100,100,SecondsHand.Radius,SecondsHand.BackRadius,SecondsHand.Width,SecondsHand.Color,Angle);

  Canvas.Draw(0,0,Buffer);
end;

procedure TAMClock.Loaded;
var
  HSec: word;
begin
  inherited Loaded;
  Buffer.Width := Self.ClientWidth;
  Buffer.Height := Self.ClientHeight;
  Buffer.Canvas.Brush.Color := Color;
  if AutoCenter then
  begin
    with Center do
    begin
      X := Width div 2;
      Y := Height div 2;
    end;
  end;
  DecodeTime(Now, OldHour, OldMinute, OldSecond, HSec);
end;

procedure TAMClock.SetAutoCenter(Value: boolean);
begin
  if Value <> FAutoCenter then
  begin
    if Value then
    begin
      with FCenter do
      begin
        X := Width div 2;
        Y := Height div 2;
      end;
    end;
    FAutoCenter := Value;
    Repaint;
  end;
end;

procedure TAMClock.SetInterval(Value: word);
begin
  if Value <> FInterval then
  begin
    FInterval := Value;
    Timer.Interval := FInterval;
    Repaint;
  end;
end;

procedure TAMClock.SetPicture(Value: TPicture);
begin
  if Transparent and not (Value.Graphic is TBitmap) then Transparent := False;
//  FPicture.Assign(value);
//  Width := FPicture.Width;
  Buffer.Width := Width;