delphi - 如何在选中的复选框而不是选中的标记中显示“X”？

CheckBox组件在选中时显示一个选中标记。

我想显示一个“ X”来代替。

最佳答案

您可以执行以下操作：

unit CheckboxEx;

interface

uses
  SysUtils, Windows, Messages, Graphics, Classes, Controls, UxTheme;

type
  TCrossType = (ctChar, ctGDI);
  TCheckboxEx = class(TCustomControl)
  private type
    THoverState = (hsNormal = 1, hsHover = 2, hsPushed = 3);
  private const
    DEFAULT_PADDING = 3;
    DEFAULT_CHECK_CHAR = '✘';
    CHECK_LINE_PADDING = 4;
  private
    { Private declarations }
    FCaption: TCaption;
    FChecked: boolean;
    FPadding: integer;
    FCheckWidth, FCheckHeight: integer;
    FCheckRect, FTextRect: TRect;
    theme: HTHEME;
    FHoverState: THoverState;
    FCheckFont: TFont;
    FCheckChar: Char;
    FMouseHover: boolean;
    FCrossType: TCrossType;
    procedure SetCaption(const Caption: TCaption);
    procedure SetChecked(Checked: boolean);
    procedure SetPadding(Padding: integer);
    procedure UpdateMetrics;
    procedure CheckFontChange(Sender: TObject);
    procedure SetCheckChar(const CheckChar: char);
    procedure DetermineState;
    procedure SetCrossType(CrossType: TCrossType);
  protected
    procedure Paint; override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure WndProc(var Message: TMessage); override;
    procedure Click; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    { Protected declarations }
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    { Public declarations }
  published
    { Published declarations }
    property ParentColor;
    property ParentFont;
    property Color;
    property Visible;
    property Enabled;
    property TabStop default true;
    property TabOrder;
    property OnDblClick;
    property OnEnter;
    property OnExit;
    property OnKeyUp;
    property OnKeyPress;
    property OnKeyDown;
    property OnMouseActivate;
    property OnMouseLeave;
    property OnMouseEnter;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseDown;
    property OnClick;
    property Font;
    property CheckFont: TFont read FCheckFont write FCheckFont;
    property Caption: TCaption read FCaption write SetCaption;
    property Checked: boolean read FChecked write SetChecked default false;
    property Padding: integer read FPadding write SetPadding default DEFAULT_PADDING;
    property CheckChar: Char read FCheckChar write SetCheckChar default DEFAULT_CHECK_CHAR;
    property CrossType: TCrossType read FCrossType write SetCrossType default ctGDI;
  end;

procedure Register;

implementation

uses Math;

procedure Register;
begin
  RegisterComponents('Rejbrand 2009', [TCheckboxEx]);
end;

var
  Hit: boolean;

function _EnumFontsProcBool(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; stdcall;
begin
  hit := SameStr(LogFont.lfFaceName, Pstring(Data)^);
  result := IfThen(hit, 0, 1);
end;

function FontInstalled(const FontName: TFontName): boolean;
var
  LF: TLogFont;
  fn: string;
begin
  hit := false;
  FillChar(LF, sizeOf(LF), 0);
  LF.lfCharSet := DEFAULT_CHARSET;
  fn := FontName;
  EnumFontFamiliesEx(GetDC(0), LF, @_EnumFontsProcBool, cardinal(@fn), 0);
  result := hit;
end;

function IsKeyDown(const VK: integer): boolean;
begin
  IsKeyDown := GetKeyState(VK) and $8000 <> 0;
end;

{ TCheckboxEx }

procedure TCheckboxEx.CheckFontChange(Sender: TObject);
begin
  Invalidate;
end;

procedure TCheckboxEx.Click;
begin
  inherited;
  if Enabled then
  begin
    SetChecked(not FChecked);
    SetFocus;
  end;
end;

constructor TCheckboxEx.Create(AOwner: TComponent);
begin
  inherited;
  TabStop := true;
  FMouseHover := false;
  FChecked := false;
  FPadding := DEFAULT_PADDING;
  FCheckChar := DEFAULT_CHECK_CHAR;
  FCrossType := ctGDI;
  theme := 0;
  FHoverState := hsNormal;
  FCheckFont := TFont.Create;
  FCheckFont.Assign(Font);
  if FontInstalled('Arial Unicode MS') then
    FCheckFont.Name := 'Arial Unicode MS';
  FCheckFont.OnChange := CheckFontChange;
end;

destructor TCheckboxEx.Destroy;
begin
  FCheckFont.Free;
  if theme <> 0 then
    CloseThemeData(theme);
  inherited;
end;

procedure TCheckboxEx.DetermineState;
var
  OldState: THoverState;
begin
  inherited;
  OldState := FHoverState;
  FHoverState := hsNormal;
  if FMouseHover then
    FHoverState := hsHover;
  if (csLButtonDown in ControlState) or (IsKeyDown(VK_SPACE) and Focused) then
    FHoverState := hsPushed;
  if (FHoverState <> OldState) and UseThemes then
    Invalidate;
end;

procedure TCheckboxEx.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  if Key = VK_SPACE then
    DetermineState;
end;

procedure TCheckboxEx.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited;
  if Key = VK_SPACE then
  begin
    Click;
    DetermineState;
  end;
end;

procedure TCheckboxEx.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  DetermineState;
end;

procedure TCheckboxEx.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  FMouseHover := true;
  DetermineState;
end;

procedure TCheckboxEx.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  DetermineState;
end;

procedure TCheckboxEx.Paint;
var
  ext: TSize;
  frect: TRect;
begin
  inherited;
  Canvas.Brush.Color := Self.Color;
  Canvas.FillRect(ClientRect);
  if UseThemes then
  begin
    if theme = 0 then
    begin
      theme := OpenThemeData(Handle, 'BUTTON');
      UpdateMetrics;
    end;
    if Enabled then
      DrawThemeBackground(theme,
        Canvas.Handle,
        BP_CHECKBOX,
        ord(FHoverState),
        FCheckRect,
        nil)
    else
      DrawThemeBackground(theme,
        Canvas.Handle,
        BP_CHECKBOX,
        CBS_UNCHECKEDDISABLED,
        FCheckRect,
        nil);
  end
  else
    if Enabled then
      DrawFrameControl(Canvas.Handle,
        FCheckRect,
        DFC_BUTTON,
        DFCS_BUTTONCHECK)
    else
      DrawFrameControl(Canvas.Handle,
        FCheckRect,
        DFC_BUTTON,
        DFCS_BUTTONCHECK or DFCS_INACTIVE);
  Canvas.TextFlags := TRANSPARENT;
  Canvas.Brush.Style := bsClear;
  Canvas.Font.Assign(Font);
  DrawText(Canvas.Handle,
    PChar(FCaption),
    length(FCaption),
    FTextRect,
    DT_SINGLELINE or DT_VCENTER or DT_LEFT);
  if Focused then
  begin
    ext := Canvas.TextExtent(FCaption);
    frect := Rect(FTextRect.Left,
      (ClientHeight - ext.cy) div 2,
      FTextRect.Left + ext.cx,
      (ClientHeight + ext.cy) div 2);
    Canvas.DrawFocusRect(frect);
  end;
  if FChecked then
    case FCrossType of
      ctChar:
        begin
          Canvas.Font.Assign(FCheckFont);
          DrawText(Canvas.Handle,
            CheckChar,
            1,
            FCheckRect,
            DT_SINGLELINE or DT_VCENTER or DT_CENTER);
        end;
      ctGDI:
        begin
          Canvas.Pen.Width := 2;
          Canvas.Pen.Color := clBlack;
          Canvas.Pen.Mode := pmCopy;
          Canvas.MoveTo(FCheckRect.Left + CHECK_LINE_PADDING, FCheckRect.Top + CHECK_LINE_PADDING);
          Canvas.LineTo(FCheckRect.Right - CHECK_LINE_PADDING, FCheckRect.Bottom - CHECK_LINE_PADDING);
          Canvas.MoveTo(FCheckRect.Right - CHECK_LINE_PADDING, FCheckRect.Top + CHECK_LINE_PADDING);
          Canvas.LineTo(FCheckRect.Left + CHECK_LINE_PADDING, FCheckRect.Bottom - CHECK_LINE_PADDING);
        end;
    end;
end;

procedure TCheckboxEx.SetCaption(const Caption: TCaption);
begin
  if not SameStr(FCaption, Caption) then
  begin
    FCaption := Caption;
    Invalidate;
  end;
end;

procedure TCheckboxEx.SetCheckChar(const CheckChar: char);
begin
  if FCheckChar <> CheckChar then
  begin
    FCheckChar := CheckChar;
    if FChecked then Invalidate;
  end;
end;

procedure TCheckboxEx.SetChecked(Checked: boolean);
begin
  if FChecked <> Checked then
  begin
    FChecked := Checked;
    Invalidate;
  end;
end;

procedure TCheckboxEx.SetCrossType(CrossType: TCrossType);
begin
  if FCrossType <> CrossType then
  begin
    FCrossType := CrossType;
    if FChecked then Invalidate;
  end;
end;

procedure TCheckboxEx.SetPadding(Padding: integer);
begin
  if FPadding <> Padding then
  begin
    FPadding := Padding;
    UpdateMetrics;
    Invalidate;
  end;
end;

procedure TCheckboxEx.UpdateMetrics;
var
  size: TSize;
begin
  FCheckWidth := GetSystemMetrics(SM_CXMENUCHECK);
  FCheckHeight := GetSystemMetrics(SM_CYMENUCHECK);
  if UseThemes then
  begin
    UxTheme.GetThemePartSize(theme, Canvas.Handle, BP_CHECKBOX, CBS_UNCHECKEDNORMAL, nil, TS_DRAW, size);
    FCheckWidth := size.cx;
    FCheckHeight := size.cy;
  end;
  FCheckRect := Rect(0,
                  (ClientHeight - FCheckHeight) div 2,
                  FCheckWidth,
                  (ClientHeight + FCheckHeight) div 2);
  FTextRect := Rect(FCheckWidth + FPadding,
                 0,
                 ClientWidth,
                 ClientHeight);
end;

procedure TCheckboxEx.WndProc(var Message: TMessage);
begin
  inherited;
  case Message.Msg of
    CM_MOUSELEAVE:
      begin
        FMouseHover := false;
        DetermineState;
      end;
    WM_SIZE:
      begin
        UpdateMetrics;
        Invalidate;
      end;
    WM_SETFOCUS, WM_KILLFOCUS:
      Invalidate;
  end;
end;

end.

现在（将CrossType设置为ctChar），您可以使用任何Unicode字符作为复选标记，默认选择是✘（U + 2718：HEAVY BALLOT X）。下图说明了该控件在有和没有视觉主题的情况下都可以工作：




下图说明您可以选择任何字符作为选中标记：



此字符为✿（U + 273F：BLACK FLORETTE）。

如果将CrossType设置为ctGDI而不是ctChar，则控件将手动绘制十字而不是字符：



这次我没有使用双缓冲，因为启用主题没有明显的闪烁。但是，如果没有主题，就会闪烁。要解决此问题，只需使用FBuffer: TBitmap并绘制FBuffer.Canvas而不是Self.Canvas，然后在BitBlt的末尾绘制Paint，就像我在此处其他控件中所做的那样。

关于delphi - 如何在选中的复选框而不是选中的标记中显示“X”？，我们在Stack Overflow上找到一个类似的问题：https://stackoverflow.com/questions/5500166/