vrbuttons.pas

来自「作工控的好控件」· PAS 代码 · 共 1,220 行 · 第 1/3 页

        BorderHighlight, BorderShadow, 1)
    else
      DrawFrame3D(BitmapCanvas, PaintRect,
        BorderShadow, BorderHighlight, 1)
  end else InflateRect(PaintRect, -1, -1);

  if FPressed then
  begin
    OffsetRect(FImageRect, 1, 1);
    OffsetRect(FTextBounds, 1, 1);
  end;

  if not FGlyph.Empty then
  begin
    BitmapCanvas.Brush.Style := bsClear;
    BitmapCanvas.BrushCopy(FImageRect, FGlyph, BitmapRect(FGlyph),
      FGlyph.TransparentColor);
  end;

  if not Enabled then
    BitmapCanvas.Font.Color := DisabledText;
  BitmapCanvas.Brush.Style := bsClear;
  DrawText(BitmapCanvas.Handle, PChar(Caption), -1, FTextBounds,
    DT_SINGLELINE + DT_VCENTER + DT_CENTER);

  inherited Paint;
end;

procedure TVrHyperButton.CalcPaintParams;
var
  Rect: TRect;
  ImagePos: TPoint;
begin
  Rect := ClientRect;
  InflateRect(Rect, -1, -1); //fix borderwidth
  FSize.X := FGlyph.Width;
  FSize.Y := FGlyph.Height;
  BitmapCanvas.Font.Assign(Self.Font);
  CalcImageTextLayout(BitmapCanvas, Rect, Point(1, 1), Caption, FLayout,
    FMargin, FSpacing, Point(FSize.X, FSize.Y), ImagePos, FTextBounds);
  if FGlyph.Empty then OffsetRect(FTextBounds, 0, -1);
  FImageRect := Bounds(ImagePos.X, ImagePos.Y, FSize.X, FSize.Y);
end;

procedure TVrHyperButton.CMFontChanged(var Message: TMessage);
begin
  inherited;
  BitmapCanvas.Font.Assign(Self.Font);
  UpdateControlCanvas;
end;

procedure TVrHyperButton.CMEnabledChanged(var Message: TMessage);
begin
  UpdateControlCanvas;
end;

procedure TVrHyperButton.GlyphChanged(Sender: TObject);
begin
  UpdateControlCanvas;
end;

procedure TVrHyperButton.SetLayout(Value: TVrImageTextLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrHyperButton.SetMargin(Value: Integer);
begin
  if FMargin <> Value then
  begin
    FMargin := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrHyperButton.SetSpacing(Value: Integer);
begin
  if FSpacing <> Value then
  begin
    FSpacing := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrHyperButton.SetBorderColor(Value: TColor);
begin
  if FBorderColor <> Value then
  begin
    FBorderColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrHyperButton.SetBorderHighlight(Value: TColor);
begin
  if FBorderHighlight <> Value then
  begin
    FBorderHighlight := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrHyperButton.SetBorderShadow(Value: TColor);
begin
  if FBorderShadow <> Value then
  begin
    FBorderShadow := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrHyperButton.SetColorEnter(Value: TColor);
begin
  if FColorEnter <> Value then
  begin
    FColorEnter := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrHyperButton.SetColorLeave(Value: TColor);
begin
  if FColorLeave <> Value then
  begin
    FColorLeave := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrHyperButton.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
end;

procedure TVrHyperButton.Click;
begin
end;

procedure TVrHyperButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if (Button = mbLeft) then
  begin
    FDown := True;
    FPressed := True;
    UpdateControlCanvas;
  end;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TVrHyperButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  DoClick: Boolean;
begin
  FDown := false;
  DoClick := false;
  if FPressed then
  begin
    FPressed := false;
    UpdateControlCanvas;
    DoClick := True;
  end;
  inherited MouseUp(Button, Shift, X, Y);
  if DoClick then
    inherited Click;
end;

procedure TVrHyperButton.MouseEnter;
begin
  FHasMouse := True;
  if FDown then FPressed := True;
  UpdateControlCanvas;
  inherited;
end;

procedure TVrHyperButton.MouseLeave;
begin
  FHasMouse := false;
  if FDown then FPressed := false;
  UpdateControlCanvas;
  inherited;
end;

{ TVrShadowBrush }
constructor TVrShadowBrush.Create;
begin
  inherited Create;
  Color := clBlack;
end;

{ TVrShadowPen }
constructor TVrShadowPen.Create;
begin
  inherited Create;
  Color := clLime;
end;

{TVrShadowButton}

constructor TVrShadowButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque] - [csDoubleClicks];
  Width := 110;
  Height := 30;
  Font.Color := clWhite;
  ParentColor := true;
  ParentFont := false;
  FDepth := 4;
  FShadowColor := clBtnShadow;
  FShadowOutline := clBtnShadow;
  FBrush := TVrShadowBrush.Create;
  FBrush.OnChange := StyleChanged;
  FPen := TVrShadowPen.Create;
  FPen.OnChange := StyleChanged;
  FStyle := ssRoundRect;
  FDirection := sdBottomRight;
  FTextAlign := vtaCenter;
end;

destructor TVrShadowButton.Destroy;
begin
  FBrush.Free;
  FPen.Free;
  inherited Destroy;
end;

procedure TVrshadowButton.Click;
begin
end;

procedure TVrShadowButton.SetBrush(Value: TVrShadowBrush);
begin
  FBrush.Assign(Value);
end;

procedure TVrShadowButton.SetPen(Value: TVrShadowPen);
begin
  FPen.Assign(Value);
end;

procedure TVrShadowButton.SetDepth(Value: Integer);
begin
  if (FDepth <> Value) and (Value > 2) then
  begin
    FDepth := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrShadowButton.SetShadowColor(Value: TColor);
begin
  if FShadowColor <> Value then
  begin
    FShadowColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrShadowButton.SetShadowOutline(Value: TColor);
begin
  if FShadowOutline <> Value then
  begin
    FShadowOutline := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrShadowButton.SetStyle(Value: TVrShadowButtonStyle);
begin
  if FStyle <> Value then
  begin
    FStyle := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrShadowButton.SetDirection(Value: TVrShadowDirection);
begin
  if FDirection <> Value then
  begin
    FDirection := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrShadowButton.SetTextAlign(Value: TVrTextAlignment);
begin
  if FTextAlign <> Value then
  begin
    FTextAlign := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrShadowButton.StyleChanged(Sender: TObject);
begin
  UpdateControlCanvas;
end;

procedure TVrShadowButton.AdjustBtnRect(var Rect: TRect; Offset: Integer);
begin
  case FDirection of
    sdBottomRight: OffsetRect(Rect, Offset, Offset);
    sdBottomLeft: OffsetRect(Rect, -Offset, Offset);
    sdTopLeft: OffsetRect(Rect, -Offset, -Offset);
    sdTopRight: OffsetRect(Rect, Offset, -Offset);
  end;
end;

procedure TVrShadowButton.DrawButton;
const
  ShapeStyles: array[TVrShadowButtonStyle] of TVrShapeType =
    (stRectangle, stRoundRect);
var
  ImageRect, ShadowRect: TRect;
begin
  ImageRect := ClientRect;

  with BitmapImage do
  begin
    InflateRect(ImageRect, -FPen.Width, -FPen.Width);

    case FDirection of
      sdBottomRight:
        begin
          Dec(ImageRect.Right, FDepth);
          Dec(ImageRect.Bottom, FDepth);
        end;
      sdBottomLeft:
        begin
          Inc(ImageRect.Left, FDepth);
          Dec(ImageRect.Bottom, FDepth);
        end;
      sdTopLeft:
        begin
          Inc(ImageRect.Top, FDepth);
          Inc(ImageRect.Left, FDepth);
        end;
      sdTopRight:
        begin
          Inc(ImageRect.Top, FDepth);
          Dec(ImageRect.Right, FDepth);
        end;
    end;

    with Canvas do
    begin
      Pen.Width := 1;
      Pen.Color := FShadowOutline;
      Pen.Mode := pmCopy;
      Pen.Style := psSolid;
      Brush.Style := bsSolid;
      Brush.Color := FShadowColor;
    end;

    ShadowRect := ImageRect;
    AdjustBtnRect(ShadowRect, FDepth);
    if Down then
      AdjustBtnRect(ShadowRect, -1);

    DrawShape(Canvas, ShapeStyles[FStyle], ShadowRect.Left, ShadowRect.Top,
        ShadowRect.Right - ShadowRect.Left, ShadowRect.Bottom - ShadowRect.Top);

    if Down then AdjustBtnRect(ImageRect, 2);

    Canvas.Brush.Assign(FBrush);
    Canvas.Pen.Assign(FPen);
    Canvas.Font.Assign(Self.Font);
    if not Enabled then Canvas.Font.Color := clInActiveCaption;

    DrawShape(Canvas, ShapeStyles[FStyle], ImageRect.Left, ImageRect.Top,
      ImageRect.Right - ImageRect.Left, ImageRect.Bottom - ImageRect.Top);

    InflateRect(ImageRect, -Pen.Width, -Pen.Width);
    Canvas.Brush.Style := bsClear;
    DrawText(Canvas.Handle, PChar(Caption), -1, ImageRect,
      DT_SINGLELINE + VrTextAlign[TextAlign]);

    CurrentRect := ImageRect;
  end;
end;

procedure TVrShadowButton.Paint;
begin
  ClearBitmapCanvas;
  DrawButton;
  inherited Paint;
end;

procedure TVrShadowButton.CMTextChanged(var Message: TMessage);
begin
  inherited;
  UpdateControlCanvas;
end;

procedure TVrShadowButton.CMFontChanged(var Message: TMessage);
begin
  inherited;
  BitmapCanvas.Font.Assign(Self.Font);
  UpdateControlCanvas;
end;