amclock.pas

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

//  Height := FPicture.Height;
  Buffer.Height := Height;
  if AutoCenter then
  begin
    with Center do
    begin
      X := Width div 2;
      Y := Height div 2;
    end;
  end;
  Repaint;
end;

function TAMClock.GetPriority: TThreadPriority;
begin
  Result := Timer.Priority;
end;

procedure TAMClock.SetPriority(Value: TThreadPriority);
begin
  if Value <> FPriority then
  begin
    FPriority := Value;
    Timer.Priority := FPriority;
  end;
end;

procedure TAMClock.SetTransparent(Value: boolean);
begin
//  if FPicture.Graphic is TBitmap then
    if Value <> FTransparent then
    begin
      FTransparent := Value;
//      FTransparentColor := FPicture.Bitmap.Canvas.Pixels[0,FPicture.Bitmap.Height-1];
      Repaint;
    end
  else
    FTransparent := False;
end;

procedure TAMClock.SetTransparentColor(Value: TColor);
begin
  if Value <> FTransparentColor then
  begin
    FTransparentColor := Value;
    if (Value <> clNone) and not Transparent then FTransparent := True;
    Repaint;
  end;
end;

procedure TAMClock.DrawHand(XCenter, YCenter, Radius, BackRadius, HandWidth: integer; HandColor: TColor; Angle: Real);
var
  X,Y: integer;
begin
  with Buffer.Canvas.Pen do
  begin
    Width := HandWidth;
    Color := HandColor;
  end;
  with Buffer.Canvas do
  begin
    Angle := (Angle + 3 * PI / 2);
    X := Center.X - Round(BackRadius * cos(Angle));
    Y := Center.Y - Round(BackRadius * sin(Angle));
    MoveTo(Center.X,Center.Y);
    LineTo(X,Y);
    X := Center.X + Round(Radius * cos(Angle));
    Y := Center.Y + Round(Radius * sin(Angle));
    MoveTo(Center.X,Center.Y);
    LineTo(X,Y);
  end;
end;

procedure TAMClock.CmEnabledChanged(var Message: TWmNoParams);
begin
  inherited;
  Timer.Enabled := Self.Enabled;
  Repaint;
end;

procedure TAMClock.CmMouseEnter(var Message: TCmMouseEnter);
begin
  inherited;
  if Assigned(FMouseEnter) then FMouseEnter(Self);
end;

procedure TAMClock.CmMouseLeave(var Message: TCmMouseLeave);
begin
  inherited;
  if Assigned(FMouseLeave) then FMouseLeave(Self);
end;

procedure TAMClock.CmVisibleChanged(var Message: TWmNoParams);
begin
  inherited;
  Repaint;
end;

procedure TAMClock.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
//  if (Button = mbLeft) and Interactive then
//  begin
//    Center.X := X;//将当前时钟的中心移到X，Y
//    Center.Y := Y;
//  end;
//  inherited MouseDown(Button, Shift, X, Y);
end;

constructor TAMClock.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  SetBounds(0,0,100,100);
  FInterval := 250;
  Timer := TThrdTimer.Create(self);
  Timer.Interval := FInterval;
  Timer.OnTimer := UpdateClock;
  Buffer := TBitmap.Create;
//  FPicture := TPicture.Create;
//  FPicture.Bitmap.Handle := LoadBitmap(hInstance, 'SAMPLECLOCK');
  FPriority := tpNormal;
  FSecondsHand := THand.Create;
  with FSecondsHand do
  begin
    Parent := Self;
    BackRadius := 10;
    Color := clRed;
    Radius := 48;
    Width := 1;
  end;
  FMinutesHand := THand.Create;
  with FMinutesHand do
  begin
    Parent := Self;
    BackRadius := 0;
    Color := clBlack;
    Radius := FSecondsHand.Radius * 90 div 100;
    Width := 2;
  end;
  FHoursHand := THand.Create;
  with FHoursHand do
  begin
    Parent := Self;
    BackRadius := 0;
    Color := clBlack;
    Radius := FSecondsHand.Radius * 70 div 100;
    Width := 2;
  end;
  FCenter := TCenter.Create;
  FCenter.Parent := Self;
  FAutoCenter := True;
  FInteractive := False;
  FTransparent := True;
  FTransparentColor := clOlive;
end;

destructor TAMClock.Destroy;
begin
//  FPicture.Free;
  Buffer.Free;
  Timer.Free;
  inherited Destroy;
end;

// Begin of TThrdTimer-implementation...
procedure TTimerThread.Execute;
begin
  Priority := OwnerTimer.Priority;
  repeat
    SleepEx(OwnerTimer.Interval, False);
    Synchronize(OwnerTimer.Timer);
  until Terminated;
end;

procedure TThrdTimer.UpdateTimer;
begin
  if not TimerThread.Suspended then TimerThread.Suspend;
  if (FInterval <> 0) and FEnabled then
     if TimerThread.Suspended then TimerThread.Resume;
end;

procedure TThrdTimer.SetEnabled(Value: boolean);
begin
  if Value <> FEnabled then
  begin
    FEnabled := Value;
    UpdateTimer;
  end;
end;

procedure TThrdTimer.SetInterval(Value: Word);
begin
  if Value <> FInterval then
  begin
    FInterval := Value;
    UpdateTimer;
  end;
end;

procedure TThrdTimer.SetThreadPriority(Value: TThreadPriority);
begin
  if Value <> FThreadPriority then
  begin
    FThreadPriority := Value;
    UpdateTimer;
  end;
end;

procedure TThrdTimer.Timer;
begin
  if Assigned(FOntimer) then FOnTimer(Self);
end;

constructor TThrdTimer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled := True;
  FInterval := 250;
  FThreadPriority := tpNormal;
  FTimerThread := TTimerThread.Create(true);
  FTimerThread.OwnerTimer := Self;
end;

destructor TThrdTimer.Destroy;
begin
  FEnabled := False;
  UpdateTimer;
  FTimerThread.Free;
  inherited Destroy;
end;

// Begin of THand-implementation...
procedure THand.SetBackRadius(Value: integer);
begin
  if Value <> FBackRadius then
  begin
    FBackRadius := Value;
    UpdateParent;
  end;
end;

procedure THand.SetColor(Value: TColor);
begin
  if Value <> FColor then
  begin
    FColor := Value;
    UpdateParent;
  end;
end;

procedure THand.SetRadius(Value: integer);
begin
  if Value <> FRadius then
  begin
    FRadius := Value;
    UpdateParent;
  end;
end;

procedure THand.SetWidth(Value: integer);
begin
  if Value <> FWidth then
  begin
    FWidth := Value;
    UpdateParent;
  end;
end;

procedure THand.UpdateParent;
begin
  Parent.Repaint;
end;

constructor THand.Create;
begin
  inherited Create;
  FBackRadius := 10;
  FColor := clRed;
  FRadius := 90;
  FWidth := 2;
end;

procedure TCenter.SetCenter(Index, Value: integer);
begin
  case Index of
    0: if Value <> FX then FX := Value;
    1: if Value <> FY then FY := Value;
  end;
  if Parent.AutoCenter then Parent.AutoCenter := False;
  UpdateParent;
end;

procedure TCenter.UpdateParent;
begin
  Parent.Repaint;
end;

constructor TCenter.Create;
begin
  inherited Create;
  FX := 50;
  FY := 50;
end;

{注意，下面代码是用来在组件面板上注册和装载本单元}
procedure Register;
begin
  RegisterComponents('D7Sample', [TAMClock]);
end;

end.