Как модернизировать внешний вид кнопок TJvCaptionPanel?

Я использую TJvCaptionPanel в Delphi 10.4 для отображения панели с заголовком и кнопками:

(TJvCaptionPanel является частью OpenSource JEDI Visual Component Library доступно в GetIt)

Это объектный код JvCaptionPanel1 экземпляр объекта, чтобы вы могли вставить его в конструктор форм:

object JvCaptionPanel1: TJvCaptionPanel
  Left = 560
  Top = 79
  Width = 210
  Height = 306
  Align = alRight
  Buttons = [capClose, capHelp]
  Caption = 'My Test Caption'
  CaptionPosition = dpTop
  CaptionFont.Charset = DEFAULT_CHARSET
  CaptionFont.Color = clWhite
  CaptionFont.Height = -13
  CaptionFont.Name = 'Tahoma'
  CaptionFont.Style = [fsBold]
  FlatButtons = True
  Icon.Data = {
    0000010001001010000001002000680400001600000028000000100000002000
    0000010020000000000040040000000000000000000000000000000000000000
    00000000000000000000777777A4777777E07777773177777763777777887777
    7788777777617777772D777777DF777777A80000000000000000000000000000
    00000000000000000000777777C5787878FE7F7F7FFDA9A9A9FDC0C0C0FDBFBF
    BFFDA8A8A8FD7F7F7FFD787878FE777777C90000000000000000000000000000
    0000000000007676760E777777CBABABABFDF4F4F4FDFDFDFDFDFDFDFDFDFDFD
    FDFDFDFDFDFDF4F4F4FDA9A9A9FD777777C77777770C00000000000000000000
    000000000000777777A8B0B0B0FDFCFCFCFDFDFDFDFDFDFDFDFDFDFDFDFDFDFD
    FDFDFDFDFDFDEADCCEFCF2EAE2FCAEAEAEFD777777A300000000000000000000
    000076767635898989FDF9F9F9FDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFD
    FDFDDDC4ACFCCDA782FCFCFCFCFCF8F8F8FD888888FD77777730000000000000
    00007777778EBEBEBEFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFCFCFCFCD5B5
    96FCBE8D5CFCF9F6F3FCFDFDFDFDFDFDFDFDBCBCBCFD77777789000000000000
    0000777777BDDBDBDBFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDD7B99BFCB883
    4DFCF3EBE3FCFDFDFDFDFDFDFDFDFDFDFDFDD9D9D9FD777777B7000000000000
    0000777777C6E0E0E0FDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDC59A6FFCDEC7
    AFFCFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDDEDEDEFD777777C1000000000000
    0000777777AACFCFCFFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDCAA37BFCE4D0
    BDFCFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDCCCCCCFD777777A4000000000000
    000077777766A4A4A4FDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDD1AF8DFCE8D8
    C8FCFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDFDA2A2A2FD77777761000000000000
    00007372710C797979E7DFDFDFFDFDFDFDFDFDFDFDFDFDFDFDFDDBC2A8FCF0E7
    DEFCFDFDFDFDFDFDFDFDFDFDFDFDDDDDDDFD787878E378767509000000000000
    0000A47547088376694C848484FBE5E5E5FCFDFDFDFCFDFDFDFCF1E8E0FCFBFA
    F9FCFDFDFDFCFDFDFDFCE4E4E4FC838383FA80766C47A2764A08000000000000
    0000B1773C9FA7764445827568557B7B7BF1B6B6B6FCE8E8E8FCFCFCFCFCFCFC
    FCFCE7E7E7FCB5B5B5FC7B7B7BF07E756B51A476483DB1773CA8000000000000
    0000B1773CB7B1773CF5AB77425F8F765C1D7B76718F777676DD7A7A7AFC7A7A
    7AFC767676DC7A76728D8C755F1BA8764457B1773DF2B1773CCA000000000000
    0000B1763B3CB1773CF5B2783DFEB1773DC2A9774357000000005D5D5D065D5D
    5D0600000000A8774552B0773DBCB2783DFEB2783DFCB1773C56000000000000
    000000000000B1773B2FB1773CBAB1773CE6B1773C6F00000000000000000000
    000000000000B1773C68B1773CEFB1773CD1B1763B470000000000000000E007
    0000E0070000C0030000C0030000800100008001000080010000800100008001
    0000800100008001000080010000800100008001000082410000C3C30000}
  OutlookLook = False
  Resizable = False
  TabOrder = 2
  OnButtonClick = JvCaptionPanel1ButtonClick
end

Хотя JvCaptionPanel1.FlatButtons = TrueКак вы можете видеть на скриншоте выше, кнопки имеют старомодный пиксельный вид "каменного века" и "Atari":

Это контрастирует с современным видом моего приложения.

Можно ли "модернизировать" внешний вид кнопок, чтобы они казались более "современными"? Как это можно было сделать?

Источник

1 ответ

На вашем месте я бы создал настраиваемый элемент управления:

unit PanelCaption;

interface

uses
  Windows, Messages, SysUtils, Types, UITypes, Classes, Graphics, Controls,
  StdCtrls, Forms;

type
  TPanelCaption = class(TCustomControl)
  private
    FTextColor: TColor;
    FCloseBtnHot: Boolean;
    FCloseBtnDown: Boolean;
    FCloseBtnClicked: TNotifyEvent;
    procedure SetTextColor(const Value: TColor);
    function CloseBtnRect: TRect;
    procedure DoCloseBtnClicked;
  protected
    procedure Paint; override;
    procedure Resize; override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Align;
    property Anchors;
    property BiDiMode;
    property Caption;
    property Color;
    property TextColor: TColor read FTextColor write SetTextColor;
    property Constraints;
    property Ctl3D;
    property DockSite;
    property DoubleBuffered;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property Padding;
    property ParentBackground;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentDoubleBuffered;
    property ParentFont default True;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Touch;
    property Visible;
    property StyleElements;
    property OnAlignInsertBefore;
    property OnAlignPosition;
    property OnClick;
    property OnCloseBtnClick: TNotifyEvent read FCloseBtnClicked write FCloseBtnClicked;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDockDrop;
    property OnDockOver;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGesture;
    property OnGetSiteInfo;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
  end;

procedure Register;

implementation

uses
  Math;

function Scale(X: Integer): Integer;
begin
  Result := MulDiv(X, Screen.PixelsPerInch, 96);
end;

{ TPanelCaption }

function TPanelCaption.CloseBtnRect: TRect;
begin
  Result := Rect(ClientWidth - ClientHeight, 0, ClientWidth, ClientHeight);
end;

procedure TPanelCaption.CMMouseLeave(var Message: TMessage);
begin
  if FCloseBtnHot or FCloseBtnDown then
  begin
    FCloseBtnHot := False;
    FCloseBtnDown := False;
    InvalidateRect(Handle, CloseBtnRect, False);
  end;
end;

procedure TPanelCaption.CMTextChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

constructor TPanelCaption.Create(AOwner: TComponent);
begin
  inherited;
  Color := clActiveCaption;
  FTextColor := clCaptionText;
end;

procedure TPanelCaption.DoCloseBtnClicked;
begin
  if Assigned(FCloseBtnClicked) then
    FCloseBtnClicked(Self);
end;

procedure TPanelCaption.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if Button = mbLeft then
  begin
    FCloseBtnDown := CloseBtnRect.Contains(Point(X, Y));
    if FCloseBtnDown then
      InvalidateRect(Handle, CloseBtnRect, False);
  end;
end;

procedure TPanelCaption.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  LCloseButtonHot: Boolean;
begin
  LCloseButtonHot := CloseBtnRect.Contains(Point(X, Y));
  if LCloseButtonHot <> FCloseBtnHot then
  begin
    FCloseBtnHot := LCloseButtonHot;
    InvalidateRect(Handle, CloseBtnRect, False);
  end;
end;

procedure TPanelCaption.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if FCloseBtnDown then
  begin
    FCloseBtnDown := False;
    InvalidateRect(Handle, CloseBtnRect, False);
    if CloseBtnRect.Contains(Point(X, Y)) then
      DoCloseBtnClicked;
  end;
end;

procedure GetActualTextHeight(DC: HDC; out H: Integer);
var
  m: TTextMetric;
begin
  if GetTextMetrics(DC, m) then
    H := m.tmHeight - m.tmDescent - m.tmExternalLeading - m.tmInternalLeading
  else
    H := Scale(20);
end;

procedure TPanelCaption.Paint;
var
  R: TRect;
  S: string;
  XHeight: Integer;
  SizeReduction: Integer;
begin
  inherited;

  Canvas.Brush.Color := Color;
  Canvas.Font.Assign(Font);
  Canvas.Font.Color := FTextColor;

  R := ClientRect;
  Dec(R.Right, ClientHeight);
  Canvas.FillRect(R);

  S := #32 + Caption;
  Canvas.TextRect(R, S, [tfSingleLine, tfLeft, tfVerticalCenter, tfEndEllipsis]);

  R := CloseBtnRect;
  Canvas.Brush.Color := IfThen(FCloseBtnHot, IfThen(FCloseBtnDown, clBlack, clWhite), Color);
  Canvas.FillRect(R);
  GetActualTextHeight(Canvas.Handle, XHeight);
  SizeReduction := R.Height - XHeight;
  if SizeReduction > 0 then
    R.Inflate(-SizeReduction div 2, -SizeReduction div 2);
  Canvas.Pen.Color := IfThen(FCloseBtnHot, IfThen(FCloseBtnDown, clWhite, clBlack), Font.Color);
  Canvas.Pen.Width := Scale(2);
  Canvas.MoveTo(R.Left, R.Top);
  Canvas.LineTo(R.Right, R.Bottom);
  Canvas.MoveTo(R.Right, R.Top);
  Canvas.LineTo(R.Left, R.Bottom);

end;

procedure TPanelCaption.Resize;
begin
  inherited;
  Invalidate;
end;

procedure TPanelCaption.SetTextColor(const Value: TColor);
begin
  if FTextColor <> Value then
  begin
    FTextColor := Value;
    Invalidate;
  end;
end;

procedure Register;
begin
  RegisterComponents('Rejbrand 2020', [TPanelCaption]);
end;

end.

Здесь я решил реализовать кнопку закрытия вручную в коде. Было бы не труднее использоватьTSpeedButtonвместо этого. На самом деле это было бы проще, но тогда вы не получили бы полного контроля над его внешним видом и поведением.

Источник
Другие вопросы по тегам