hemispherebutton.pas

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

  if fAttenControl <> Value then begin
    fAttenControl := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetBevelWidth(Value: Integer);
begin
  if (fBevelWidth <> Value) and (Value >= 1) then begin
    fBevelWidth := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetBevelInner(Value: THemisphereBevel);
begin
  if fBevelInner <> Value then begin
    fBevelInner := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetBevelOuter(Value: THemisphereBevel);
begin
  if fBevelOuter <> Value then begin
    fBevelOuter := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetBorderColor(Value: TColor);
begin
  if fBorderColor <> Value then begin
    fBorderColor := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetBorderStyle(Value: TBorderStyle);
begin
  if fBorderStyle <> Value then begin
    fBorderStyle := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetBounds(aLeft, aTop, aWidth, aHeight: Integer);
begin
  inherited SetBounds(aLeft, aTop, aWidth, aHeight);
  if (aWidth <> oldWidth) or (aHeight <> oldHeight) then begin
    if not (csLoading in ComponentState) then begin
      CalcImages;
      Invalidate;
    end;
    oldWidth := aWidth;
    oldHeight := aHeight;
  end;
end;

procedure THemiBtn.SetCaption(Value: String);
begin
  if fCaption <> Value then begin
    fCaption := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetDown(Value: Boolean);
begin
  if fDown <> Value then begin
    fDown := Value;
    Paint; {Invalidate;}
  end;
end;

procedure THemiBtn.SetFaceColor(Value: TColor);
begin
  if fFaceColor <> Value then begin
    faceBlue := (Value shr 16) and $ff;
    faceGreen := (Value shr 8) and $ff;
    faceRed := Value and $ff;
    fFaceColor := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetFaceShaded(Value: Boolean);
begin
  if fFaceShaded <> Value then begin
    fFaceShaded := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetFaceTransparent(Value: Boolean);
begin
  if fFaceTransparent <> Value then begin
    fFaceTransparent := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetFont(Value: TFont);
begin
  fFont.Assign(Value);
  CalcImages;
  Invalidate;
end;

procedure THemiBtn.SetGlyph(Value: TBitmap);
var
  r: TRect;
begin
  if bmGlpyh <> Value then begin
    if Value = nil then
      GlyphValid := False
    else begin
      GlyphValid := True;
      bmGlpyh.Width := Value.Width;
      bmGlpyh.Height := Value.Height;
      r := Rect(0, 0, Value.Width, Value.Height);
      bmGlpyh.Canvas.CopyRect(r, Value.Canvas, r);
      if (bmGlpyh.Height<>0) and (bmGlpyh.Width mod bmGlpyh.Height=0) then
        fNumGlyphs := bmGlpyh.Width div bmGlpyh.Height
      else
        fNumGlyphs := 1;
      fGlyphIndex := 1;
    end;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetGlyphIndex(Value: Integer);
begin
  if (fGlyphIndex <> Value) and (Value > 0) and
     ((csLoading in ComponentState) or (Value <= fNumGlyphs)) then begin
    fGlyphIndex := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetGlyphMapped(Value: Boolean);
begin
  if fGlyphMapped <> Value then begin
    fGlyphMapped := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetGlyphShaded(Value: Boolean);
begin
  if fGlyphShaded <> Value then begin
    fGlyphShaded := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetGlyphTransparent(Value: Boolean);
begin
  if fGlyphTransparent <> Value then begin
    fGlyphTransparent := Value;
    CalcImages;
    Invalidate;
  end;
end;

procedure THemiBtn.SetNumGlyphs(Value: Integer);
begin
  if fNumGlyphs <> Value then begin
    fNumGlyphs := Value;
    CalcImages;
    Invalidate;
  end;
end;

function THemiBtn.InsideEllipse(X,Y: Integer): Boolean;
var
  borderSz: Integer;
  w2, h2: Double;
begin
  w2 := Width/2;
  h2 := Height/2;
  borderSz := 0;
  if fBevelOuter <> hbNone then inc(borderSz, fBevelWidth);
  if fBevelInner <> hbNone then inc(borderSz, fBevelWidth);
  Result := sqr((X-w2)/(w2-borderSz)) + sqr((Y-h2)/(h2-borderSz)) <= 1.0;
end;

procedure THemiBtn.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Enabled and InsideEllipse(X,Y) then begin
    if Assigned(fOnMouseDown) then
      fOnMouseDown(Self, Button, Shift, X, Y);
    if (Button = mbLeft) then begin
      InMousePress := True;
      oldDown := Down;
      Down := True;
      if (ssDouble in Shift) and Assigned(fOnDblClick) then
        fOnDblClick(Self);
    end;
  end;
end;

procedure THemiBtn.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if InMousePress and not oldDown then
    Down := InsideEllipse(X,Y);
  if Assigned(fOnMouseMove) then
    fOnMouseMove(Self, Shift, X, Y);
end;

procedure THemiBtn.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  i: Integer;
  aHb: THemiBtn;
begin
  if InMousePress then begin
    InMousePress := False;
    if InsideEllipse(X,Y) then begin
      if Assigned(fOnClick) then
        fOnClick(Self);
      if GroupIndex = 0 then
        Down := False
      else begin
        if not (not fAllowAllUp and oldDown) then begin
          for i:=0 to Owner.ComponentCount-1 do
            if (Owner.Components[i] is THemiBtn) and
               (Owner.Components[i] <> Self) then begin
              aHb := THemiBtn(Owner.Components[i]);
              if aHb.GroupIndex = GroupIndex then
                aHb.Down := False;
            end;
          Down := not oldDown;
        end;
      end;
    end;
  end;
  if Assigned(fOnMouseUp) then
    fOnMouseUp(Self, Button, Shift, X, Y);
end;

procedure THemiBtn.RenderBorder(aCanvas: TCanvas; X0,Y0,X1,Y1, bevWidth: Integer; Raised: Boolean);
var
  cX, cY, Len2d, Len3d, dirX, dirY, dirZ: Double;
  aGreyVal, nWayDelta: Longint;

  procedure SetPixel(X,Y: Integer; normX, normY, normZ: Double);
  begin
    aGreyVal := 128 + Round(128*(cLightX*normX + cLightY*normY + cLightZ*normZ));
    if aGreyVal > 255 then aGreyVal := 255
    else if aGreyVal < 0 then aGreyVal := 0;
    aCanvas.Pixels[x,y] := (aGreyVal shl 16) or (aGreyVal shl 8) or aGreyVal;
  end;

  procedure SetPixel4Way(X, Y: Integer);
  begin
    if (X=0) and (Y=0) then begin
      SetPixel(0,0,0,0,1);
      exit;
    end;
    Len2d := sqrt(sqr(X)+sqr(Y));
    Len3d := sqrt(sqr(X)+sqr(Y)+sqr(Len2d));
    dirX := -X/Len3d;
    dirY := Y/Len3d;
    dirZ := Len2d/Len3d;
    if not Raised then begin
      dirX := -dirX;
      dirY := -dirY;
    end;
    SetPixel(Ceil(cX+X),  Ceil(cY-Y),  -dirX, -dirY, dirZ);  { Right-Top    }
    SetPixel(Ceil(cX+X),  Floor(cY+Y), -dirX,  dirY, dirZ);  { Right-Bottom }
    SetPixel(Floor(cX-X), Floor(cY+Y),  dirX,  dirY, dirZ);  { Left-Bottom  }
    SetPixel(Floor(cX-X), Ceil(cY-Y),   dirX, -dirY, dirZ);  { Left-Top     }
  end;

  procedure SetPixelNWay(X,Y: Integer);
  var
    i, j: Integer;
  begin
    for i := Y-nWayDelta to Y+nWayDelta do
      for j := X-nWayDelta to X+nWayDelta do
        SetPixel4Way(j, i);
  end;

var
  a, b, x, y, a2, b2, d1, d2: Double;
begin
  nWayDelta := 1 + Ceil(bevWidth/2);
  a := (X1-X0-1) / 2;
  b := (Y1-Y0-1) / 2;
  cX := X0 + a;
  cY := Y0 + b;
  x := 0;
  y := b;
  a2 := sqr(a);
  b2 := sqr(b);
  d1 := b2 - a2*b + a2/4;
  SetPixelNWay(Round(x), Round(y));
  while (a2*(y-0.5) > b2*(x+1)) do begin
    if d1 < 0 then begin
      d1 := d1 + b2*(2*x+3);
      x := x + 1;
    end else begin
      d1 := d1 + b2*(2*x+3)+a2*(-2*y+2);
      x := x + 1;
      y := y - 1;
    end;
    SetPixelNWay(Round(x), Round(y));
  end;
  d2 := b2*sqr(x+0.5)+a2*sqr(y-1)-a2*b2;
  while y > 0 do begin
    if d2 < 0 then begin