Как отобразить «X» в отмеченном флажке вместо галочки? - PullRequest
Новая
       18

Как отобразить «X» в отмеченном флажке вместо галочки?

2 голосов
/ 31 марта 2011

Компонент CheckBox отображает галочку, если отмечен.

Я хотел бы вместо этого отображать 'X'.

Ответы [ 4 ]

11 голосов
/ 31 марта 2011

Вы можете сделать что-то вроде этого: 

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), вы можете использовать любой символ Юникода в качестве галочки, по умолчанию выбор ✘ (U + 2718: Тяжелый баллот X).Изображения ниже показывают, что элемент управления работает как с визуальными темами, так и без них:

Образец изображения с визуальными темами http://privat.rejbrand.se/checkboxex.png Образец изображения без включенных визуальных тем http://privat.rejbrand.se/checkboxex2.png

Следующее изображениеиллюстрирует, что вы можете выбрать любой символ в качестве своей галочки:

Пример изображения с пользовательским галочкой http://privat.rejbrand.se/checkboxex3.png

Этот символ - is (U + 273F: ЧЕРНАЯ ФЛОРТКА).

Если вы установите CrossType на ctGDI вместо ctChar, элемент управления будет рисовать крест вручную, а не символ:

Образец изображения с GDI ccross http://privat.rejbrand.se/checkboxex5.png

Iна этот раз не использовал двойную буферизацию, потому что нет заметного мерцания с включенными темами.Без тем, однако, есть мерцание.Чтобы исправить это, просто используйте FBuffer: TBitmap и нарисуйте FBuffer.Canvas вместо Self.Canvas, а затем BitBlt в конце Paint, как я делаю в других своих элементах управления здесь в SO.

1 голос
/ 31 марта 2011

В любом случае, я бы пошел противоположным путем, выбрав все элементы по умолчанию и позволив пользователю удалить те, кого следует исключить из списка.

1 голос
/ 31 марта 2011

Вам придется написать собственный элемент управления и нарисовать его самостоятельно.

Если это настоящий флажок, то избегать системного чертежа по умолчанию - плохая идея. Однако, если вы хотите сделать что-то вроде формы для голосования, я могу понять, почему вы можете сделать это.

0 голосов
/ 05 апреля 2016

Имея флажок серьезного ограничения в дизайне, кто хочет остаться в VCL, может использовать BitBtn в качестве проверки, используя свойство «Добрый» для рисования изображений Cancel или Ok, когда пользователь нажимает на него. Также удаляйте после каждого изменения условия свойство Caption, так как BitBtn должен иметь квадратную разметку для имитации проверки. Также используйте ярлык на левой или правой руке, если хотите. 

if lAutoMode = False then
  begin
   lAutoMode := True;
   BitBtn1.Kind := bkOK;
   BitBtn1.Caption := '';
end
else
begin
  lAutoMode := False;
  BitBtn1.Kind := bkAbort;
  BitBtn1.Caption := '';
end;

При создании формы задайте начальное состояние для BitBtn.

...