bmpclock.pas

一个漂亮的时钟源码

    if FMinuteHandEnabled then begin
      DrawHand(MinuteHand.Radius, MinuteHand.BackRadius, MinuteHand.Width, MinuteHand.Color, FCurAngle);
    end;

      {---------画出秒针-----------}
    FCurAngle := 2 * Pi * S / 60;
    if FSecondHandEnabled then begin
      DrawHand(SecondHand.Radius, SecondHand.BackRadius, SecondHand.Width, SecondHand.Color, FCurAngle);
    end;

      {---------画中心点-----------}
    if FCenterPoint then begin
      Drawponit(CenterMark.FPointSize, CenterMark.FPenSize, CenterMark.FFillColor, CenterMark.FPenColor);
    end;

  end; {with}
  Self.Canvas.Draw(0, 0, WorkImage); //将结果画到前台

  if (FoldWidth <> Width) or (FoldHeight <> Height) then begin //大小改变时，重画形状;
    FoldWidth := Width;
    FoldHeight := Height;
    StyleChanged;
  end;
end;

{===================自定义背景位图======================}

procedure TBmpClock.SetPicture(Value: TPicture);
begin
  if not (Value.Graphic.Empty) then begin
    FPicture.Assign(value);
    Width := FPicture.Width;
    Height := FPicture.Height;
    Repaint;
  end;
end;

{====================设置背景透明=======================}

procedure TBmpClock.SetTransParent(Value: Boolean);
begin
  if Value <> FTransparent then begin
    FTransparent := Value;
    Repaint;
  end;
end;

{====================设置背景透明的颜色=================}

procedure TBmpClock.SetTransParentColor(Value: TColor);
begin
  if Value <> FTransParentColor then begin
    FTransParentColor := Value;
    Repaint;
  end;
end;

{=====================设置时钟计时周期==================}

procedure TBmpClock.SetInterval(Value: Word);
begin
  if Value <> FInterval then begin
    FInterval := Value;
    FStepTime.Interval := FInterval;
    Repaint;
  end;
end;

{======================启动时钟计时=====================}

procedure TBmpClock.SetActive(Value: Boolean);
begin
  if Value <> Active then begin
    FInterActive := Value;
    FStepTime.Enabled := FInterActive;
    Repaint;
  end;
end;

{======================更改启用属性=====================}

procedure TBmpClock.CmEnabledChanged(var message: TWMNoParams);
begin
  inherited;
  FStepTime.Enabled := Self.Enabled;
  FInterActive := Self.Enabled;
  Repaint;
end;

{=======================版本信息（唯读属性）============}

procedure TBmpClock.VersionMark(Value: string);
var
  s: string;
begin
  s := 'BmpClock V3.0 版权所有(C) 2003-2005 小帆工作室';
  if Value <> FVerInfo then begin
    MessageBox(HANDLE, PChar(s),
      '关于 BmpClock V3.0', MB_OK + MB_ICONINFORMATION);
    FVerInfo := s;
  end;
end;

{===================设置自动中心========================}

procedure TBmpClock.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 TBmpClock.SetBgStyle(Value: TBgStyle);
begin
  if Value <> FColorOrBmp then begin
    FColorOrBmp := Value;
    Repaint;
  end;
end;

{=====================设置背景颜色======================}

procedure TBmpClock.SetBgColor(Value: TColor);
begin
  if Value <> FBgUseColor then begin
    FBgUseColor := Value;
    Repaint;
  end;
end;

{======================设置中心点=======================}

procedure TBmpClock.SetCenterPoint(Value: Boolean);
begin
  if Value <> FCenterPoint then begin
    FCenterPoint := Value;
    Repaint;
  end;
end;

{================指针算法 （核心代码 I )================}

procedure TBmpClock.DrawHand(Radius, BackRadius, HandWidth: Integer; HandColor: TColor; Angle: Real);
var
  X, Y, Xh, Yh, Xb, Yb, FXCenter, FYCenter: Integer;
begin
  {---------定义中心-----------}
  if FAutoCenter then begin
    FXCenter := Width div 2;
    FYCenter := Height div 2
  end
  else begin
    FXCenter := FCenter.FX;
    FYCenter := FCenter.FY;
  end;

  with WorkImage.Canvas do begin
    Pen.Width := HandWidth;
    Pen.Color := HandColor;

    Angle := FCurAngle; //取得当前指针角度

    Y := Round(FYCenter - Radius * cos(Angle));
    X := Round(FXCenter + Radius * sin(Angle));
    Yb := Round(FYCenter + BackRadius * cos(Angle));
    Xb := Round(FXCenter - BackRadius * sin(Angle));
    Yh := Round(FYCenter - BackRadius * cos(Angle));
    Xh := Round(FXCenter + BackRadius * sin(Angle));

    if FHoleRound then begin
      MoveTo(Xh, Yh);
      LineTo(X, Y);
    end
    else begin
      MoveTo(Xb, Yb);
      LineTo(X, Y); //画时钟指针;
    end;
  end;
end;

procedure TBmpClock.SetHoleRound(Value: Boolean);
begin
  if Value <> FHoleRound then
  begin
    FHoleRound := Value;
    Repaint;
  end;
end;

{====================画中心点过程=======================}

procedure TBmpClock.DrawPonit(PointSize, PenSize: Integer; FillColor, PenColor: TColor);
var
  FXCenter, FYCenter: Integer;
begin
  if FAutoCenter then begin
    FXCenter := Width div 2;
    FYCenter := Height div 2
  end
  else begin
    FXCenter := FCenter.FX;
    FYCenter := FCenter.FY;
  end;
  with WorkImage.Canvas do begin
    Pen.Width := PenSize;
    Pen.Color := PenColor;
    Brush.Color := FillColor;
    RoundRect((FXCenter) - PointSize, (FYCenter) - PointSize, (FXCenter) + PointSize, (FYCenter) + PointSize, Width, Height);
  end;
end;

{====================是否启用时针=======================}

procedure TBmpClock.SetHourHandEnabled(Value: Boolean);
begin
  if Value <> FHourHandEnabled then begin
    FHourHandEnabled := Value;
    Repaint;
  end;
end;

{=====================是否启用分针======================}

procedure TBmpClock.SetMinuteHandEnabled(Value: Boolean);
begin
  if Value <> FMinuteHandEnabled then begin
    FMinuteHandEnabled := Value;
    Repaint;
  end;
end;

{====================是否启用秒针=======================}

procedure TBmpClock.SetSecondHandEnabled(Value: Boolean);
begin
  if Value <> FSecondHandEnabled then begin
    FSecondHandEnabled := Value;
    Repaint;
  end;
end;

{====================设置背景图效果=====================}

procedure TBmpClock.SetPictureStyle(Value: TPictureStyle);
begin
  if Value <> FPictureStyle then begin
    FPictureStyle := Value;
    Repaint;
  end;
end;

{====================设置控件外形=======================}

procedure TBmpClock.SetThemeStyle(Value: TThemeStyle);
begin
  if value <> FThemeStyle then
  begin
    FThemeStyle := Value;
    StyleChanged;
  end;
end;

{=================设置圆角 X============================}

procedure TBmpClock.SetRoundX(Value: Integer);
begin
  if Value <> FRoundX then
  begin
    FRoundX := Value;
    StyleChanged;
  end;
end;

{===================设置圆角 Y==========================}

procedure TBmpClock.SetRoundY(Value: Integer);
begin
  if Value <> FRoundY then
  begin
    FRoundY := Value;
    StyleChanged;
  end;
end;

{=================设置形状过程==========================}

procedure TBmpClock.StyleChanged;
var
  HT: THandle;
begin
  HT := CreateRectRgn(0, 0, Width, Height);
  case FThemeStyle of
    tsNone:
      begin
        HT := CreateRectRgn(0, 0, Width, Height);
      end;
    tsCircle:
      begin
        HT := CreateEllipticRgn(0, 0, Width, Height);
      end;
    tsRoundRect:
      begin
        HT := CreateRoundRectRgn(0, 0, Width, Height, FRoundX, FRoundY);
      end;
  end;
  SetWindowRgn(Handle, HT, True);
  Repaint;
end;

//***********************************开始 TCenter*******************************
{=======================构造 中心=======================}

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

{===================设置中心的 X 坐标===================}

procedure TCenter.SetX(Value: Integer);
begin
  if Value <> FX then
  begin
    FX := Value;
    UpdateParent;
  end;
end;

{===================设置中心的 Y 坐标===================}

procedure TCenter.SetY(Value: Integer);
begin
  if Value <> FY then
  begin
    FY := Value;
    UpdateParent;
  end;
end;

{======================刷新父控件=======================}

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

//*******************************开始 THand ************************************

{======================建立指针==========================}

constructor THand.Create;
begin
  inherited Create;
end;

{====================更改属性后，刷新父控件==============}

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

{===================设置指针正向长度=====================}

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

{===================设置指针反向长度=====================}

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

{===================设置指针宽度=========================}

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

{===================设置指针颜色=========================}

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

//*****************************开始 TCenterPoint *******************************
{======================建立中心点========================}

constructor TCenterPoint.Create;
begin
  inherited Create;
  FPointSize := 4;
  FPenSize := 1;
  FFillColor := clBlack;
  FPenColor := clWhite;
end;

{========================中心点大小======================}

procedure TCenterPoint.SetPonitSize(Value: Integer);
begin
  if Value <> FPointSize then
  begin
    FPointSize := Value;
    UpdateParent;
  end;
end;

{=======================边缘圆圈大小=====================}

procedure TCenterPoint.SetPenSize(Value: Integer);
begin
  if Value <> FPenSize then
  begin
    FPenSize := Value;
    UpdateParent;
  end;
end;

{=====================设置边缘圆圈颜色===================}

procedure TCenterPoint.SetPenColor(Value: TColor);
begin
  if Value <> FPenColor then
  begin
    FPenColor := Value;
    UpdateParent;
  end;
end;

{=======================设置填充颜色=====================}

procedure TCenterPoint.SetFillColor(Value: TColor);
begin
  if Value <> FFillColor then
  begin
    FFillColor := Value;
    UpdateParent;
  end;
end;

{==================设置中心属性后刷新父控件==============}

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

{=====================注册组件===========================}

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

end.