hemispherebutton.pas

机房管理系统 是用VB设计的简单的管理系统

unit HemisphereButton;

{*
** 球形按钮
** 作者：Chirstian Schnell
** 修改：午秋
** 更新：新增了一个 Action 属性
** THemisphereButton implementation
** Copyright (c) 1997 Christian Schnell
**
** Author: Christian Schnell
**         [e-mail]
**         http://www.cs.tu-berlin.de/~lulli
** 
** History:
**
** .p00 [19970627cs] first release
** .p01 [19970801cs] [sub-release]
**                   removed MATH-usage, added functions ceil() and floor().
** .p02 [19970814cs] [sub-release]
**                   added user-bitmap UserBitmap, lower left pixel is
**                     reserved for transparent color.
** .p03 [19970815cs] renamed UserBitmap to Glyph, added NumGlyphs,
**                     GlyphIndex
**                   stripped CalcImages, fixed: mouse events, default size
**                   added shaded glyphs
**      [19970821cs] added GlyphMapped, AttenControl
**                   added arctan2
**                   changed illumination model
**                     removed fColorBright, redDt, greenDt, blueDt
**                   renamed Pressed to Down
**                   added ParentShowHint, ShowHint
** .p04 [19970823cs] [sub-release]
**      [19970825cs] added FaceShaded
**                   bmIn and bmOut now calculated in one step
**                   bug-fix: Glyph painting on odd width or height
**                   problem: ParentFont seems not possible, TControl.Font is
**                            protected (cannot access Parent.Font!)
**                   added FaceTransparent, GlyphTransparent
** .p05 [19970826cs] [sub-release]
** .p06 [19970831cs] added bmMask, background-clip-mask is now persistent
**                   calling Paint indirectly now (Invalidate), except SetDown
**                   right mouse click ignored now
**                   made changes for Delphi1
**                   [sub-release]
** .p07 [19971006cs] 2nd release (as 2.0)
**                   OK for Delphi1, Delphi2 and Delphi3
** .p08 [19971030cs] 3rd release (as 2.1)
**                   Bug-fix:
**                     - added fFont.Free in destructor
**                     - fixed Delphi1\HemiBtn.dcr (was bad in release 2.0)
**                   Changed:
**                     - New glyph for component-palette, note that if you
**                       are upgrading from release 2.0, you must reinstall
**                       the component to see the new image in your IDE.
*}

interface

uses
  {$IFDEF VER80}
  WinProcs, WinTypes, Menus,
  {$ELSE}
  Windows,
  {$ENDIF}
  SysUtils, Forms, Classes, Controls, Graphics;

const
  cDefaultColor = clGray;   { default face color                          }
  cDefaultWidth = 25;       { default dimensions                          }
  cDefaultHeight = 25;
  cLightX = -0.5773502692;  { vector to light-source,                     }
  cLightY = -0.5773502692;  { left-handed coordinate system               }
  cLightZ =  0.5773502692;  { (points to upper-left corner, Windows-std.) }

type
  THemisphereBevel = (hbNone, hbLowered, hbRaised);

  THemiBtn = class(TGraphicControl)
  protected
    faceRed, faceGreen, faceBlue : TColor;
    bmUnpressed, bmPressed, bmMask, bmGlpyh: TBitmap;
    oldWidth, oldHeight, fBevelWidth, fGroupIndex,
    fNumGlyphs, fGlyphIndex: Integer;
    GlyphValid, InMousePress, oldDown,
    fDown, fAllowAllUp, fFaceShaded, fGlyphShaded,
    fGlyphMapped, fGlyphTransparent, fFaceTransparent: Boolean;
    fBorderColor, fFaceColor: TColor;
    fOnClick, fOnDblClick: TNotifyEvent;
    fBevelOuter, fBevelInner: THemisphereBevel;
    fOnMouseDown, fOnMouseUp: TMouseEvent;
    fOnMouseMove: TMouseMoveEvent;
    fBorderStyle: TBorderStyle;
    fAttenControl: Double;
    fCaption: String;
    fFont: TFont;
    procedure CalcImages;
    procedure DefineProperties(Filer: TFiler); override;
    function  InsideEllipse(X,Y: Integer): Boolean;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
    procedure ReadGlyphValid(Reader: TReader);
    procedure ReadImageGlyph(Stream: TStream);
    procedure ReadImageIn(Stream: TStream);
    procedure ReadImageMask(Stream: TStream);
    procedure ReadImageOut(Stream: TStream);
    procedure RenderBorder(aCanvas: TCanvas; X0,Y0,X1,Y1, bevWidth: Integer; Raised: Boolean);
    procedure RenderButtonFaces(nBorder: Integer; mskBorder, canvUp, canvDown: TCanvas);
    procedure SetAllowAllUp(Value: Boolean);
    procedure SetAttenControl(Value: Double);
    procedure SetBevelInner(Value: THemisphereBevel);
    procedure SetBevelOuter(Value: THemisphereBevel);
    procedure SetBevelWidth(Value: Integer);
    procedure SetBorderColor(Value: TColor);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetBounds(aLeft, aTop, aWidth, aHeight: Integer); override;
    procedure SetCaption(Value: String);
    procedure SetDown(Value: Boolean);
    procedure SetFaceColor(Value: TColor);
    procedure SetFaceShaded(Value: Boolean);
    procedure SetFaceTransparent(Value: Boolean);
    procedure SetFont(Value: TFont);
    procedure SetGlyph(Value: TBitmap);
    procedure SetGlyphIndex(Value: Integer);
    procedure SetGlyphMapped(Value: Boolean);
    procedure SetGlyphShaded(Value: Boolean);
    procedure SetGlyphTransparent(Value: Boolean);
    procedure SetNumGlyphs(Value: Integer);
    procedure WriteGlyphValid(Writer: TWriter);
    procedure WriteImageGlyph(Stream: TStream);
    procedure WriteImageIn(Stream: TStream);
    procedure WriteImageMask(Stream: TStream);
    procedure WriteImageOut(Stream: TStream);
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Action;
    property Align;
    property AllowAllUp: Boolean read fAllowAllUp write SetAllowAllUp;
    property AttenControl: Double read fAttenControl write SetAttenControl;
    property BevelInner: THemisphereBevel read fBevelInner write SetBevelInner;
    property BevelOuter: THemisphereBevel read fBevelOuter write SetBevelOuter;
    property BevelWidth: Integer read fBevelWidth write SetBevelWidth;
    property BorderColor: TColor read fBorderColor write SetBorderColor;
    property BorderStyle: TBorderStyle read fBorderStyle write SetBorderStyle;
    property Caption: String read fCaption write SetCaption;
    property Down: Boolean read fDown write SetDown;
    property Enabled;
    property FaceColor: TColor read fFaceColor write SetFaceColor;
    property FaceShaded: Boolean read fFaceShaded write SetFaceShaded;
    property FaceTransparent: Boolean read fFaceTransparent write SetFaceTransparent;
    property Font: TFont read fFont write SetFont;
    property Glyph: TBitmap read bmGlpyh write SetGlyph stored False; { We store it, TBitmap is buggy }
    property GlyphIndex: Integer read fGlyphIndex write SetGlyphIndex;
    property GlyphShaded: Boolean read fGlyphShaded write SetGlyphShaded;
    property GlyphMapped: Boolean read fGlyphMapped write SetGlyphMapped;
    property GlyphTransparent: Boolean read fGlyphTransparent write SetGlyphTransparent;
    property GroupIndex: Integer read fGroupIndex write fGroupIndex;
    property Hint;
    property NumGlyphs: Integer read fNumGlyphs write SetNumGlyphs;
    property OnClick: TNotifyEvent read fOnClick write fOnClick;
    property OnDblClick: TNotifyEvent read fOnDblClick write fOnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    {$IFNDEF VER80}
    property OnStartDrag;
    {$ENDIF}
    property OnMouseDown: TMouseEvent read fOnMouseDown write fOnMouseDown;
    property OnMouseMove: TMouseMoveEvent read fOnMouseMove write fOnMouseMove;
    property OnMouseUp: TMouseEvent read fOnMouseUp write fOnMouseUp;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
  end;

  procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Wuqiu', [THemiBtn]);
end;

function Ceil(X: Double): Longint;
begin
  Result := Trunc(X);
  if Frac(X) > 0 then Inc(Result);
end;

function Floor(X: Double): Longint;
begin
  Result := Trunc(X);
  if Frac(X) < 0 then Dec(Result);
end;

function ArcTan2(Y, X: Double): Double;
assembler;
  asm
    FLD Y
    FLD X
    FPATAN
    FWAIT
end;

constructor THemiBtn.Create(aOwner: TComponent);
begin
  fFont := TFont.Create;
  inherited Create(aOwner);
  bmUnpressed := TBitmap.Create;
  bmPressed := TBitmap.Create;
  bmMask := TBitmap.Create;
  bmGlpyh := TBitmap.Create;
  oldWidth := -1;
  oldHeight := -1;
  fBevelWidth := 2;
  fBevelInner := hbNone;
  fBevelOuter := hbLowered;
  fBorderStyle := bsNone;
  fBorderColor := clGray;
  fNumGlyphs := 1;
  fGlyphIndex := 1;
  fAttenControl := 1.0;
  fFaceShaded := True;
  fGlyphShaded := True;
  fGlyphTransparent := True;
  fFaceColor := cDefaultColor;
  faceRed := cDefaultColor and $ff;
  faceGreen := (cDefaultColor shr 8) and $ff;
  faceBlue := (cDefaultColor shr 16) and $ff;
  inherited SetBounds(Left, Top, cDefaultWidth, cDefaultHeight);
end;

destructor THemiBtn.Destroy;
begin
  fFont.Free;
  bmUnpressed.Free;
  bmPressed.Free;
  bmMask.Free;
  bmGlpyh.Free;
  inherited Destroy;
end;

procedure THemiBtn.ReadImageIn(Stream: TStream);
begin
  bmPressed.LoadFromStream(Stream);
end;

procedure THemiBtn.ReadImageOut(Stream: TStream);
begin
  bmUnpressed.LoadFromStream(Stream);
end;

procedure THemiBtn.ReadImageMask(Stream: TStream);
begin
  bmMask.LoadFromStream(Stream);
end;

procedure THemiBtn.ReadImageGlyph(Stream: TStream);
begin
  bmGlpyh.LoadFromStream(Stream);
end;

procedure THemiBtn.WriteImageIn(Stream: TStream);
begin
  bmPressed.SaveToStream(Stream);
end;

procedure THemiBtn.WriteImageOut(Stream: TStream);
begin
  bmUnpressed.SaveToStream(Stream);
end;

procedure THemiBtn.WriteImageMask(Stream: TStream);
begin
  bmMask.SaveToStream(Stream);
end;

procedure THemiBtn.WriteImageGlyph(Stream: TStream);
begin
  bmGlpyh.SaveToStream(Stream);
end;

procedure THemiBtn.ReadGlyphValid(Reader: TReader);
begin
  GlyphValid := Reader.ReadBoolean;
end;

procedure THemiBtn.WriteGlyphValid(Writer: TWriter);
begin
  Writer.WriteBoolean(GlyphValid);
end;

procedure THemiBtn.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('GlyphValid', ReadGlyphValid, WriteGlyphValid, True);
  Filer.DefineBinaryProperty('ImageOut', ReadImageOut, WriteImageOut, True);
  Filer.DefineBinaryProperty('ImageIn', ReadImageIn, WriteImageIn, True);
  Filer.DefineBinaryProperty('ImageMask', ReadImageMask, WriteImageMask, True);
  Filer.DefineBinaryProperty('ImageGlyph', ReadImageGlyph, WriteImageGlyph, GlyphValid);
end;

procedure THemiBtn.SetAllowAllUp(Value: Boolean);
var
  i: Integer;
begin
  if Value <> fAllowAllUp then begin
    if (csLoading in ComponentState) or (GroupIndex = 0) then
      fAllowAllUp := Value
    else
      for i:=0 to Owner.ComponentCount-1 do
        if Owner.Components[i] is THemiBtn then
          if THemiBtn(Owner.Components[i]).GroupIndex = GroupIndex then
            THemiBtn(Owner.Components[i]).fAllowAllUp := Value;
  end;
end;

procedure THemiBtn.SetAttenControl(Value: Double);
begin