lazarus-ccr/components/exctrls/source/excheckcombo.pas

unit ExCheckCombo;

{$mode objfpc}{$H+}

interface

uses
  LCLIntf, LCLType, LMessages,
  Classes, SysUtils, Controls, StdCtrls, GroupedEdit, EditBtn, CheckLst, Forms;

type
  { TCheckComboBoxEx }

  TCheckItemChange = procedure(Sender: TObject; AIndex: Integer) of object;
  TCheckComboBoxHintMode = (cbhmDefault, cbhmItems);
                         
  TCheckComboBoxEx = class(TEditButton)
  private
    FAutoDropDown: Boolean;
    FCheckListBox: TCheckListBox;
    FDelimiter: Char;
    FDropDownCount: Integer;
    FDropDownForm: TForm;
    FDroppedDown: Boolean;
    FEscCancels: Boolean;
    FItemIndex: Integer;
    FItemWidth: Integer;
    FHintMode: TCheckComboBoxHintMode;
    FSavedChecks: array of Integer;
    FOnChange: TNotifyEvent;
    FOnCloseUp: TNotifyEvent;
    FOnDropDown: TNotifyEvent;
    FOnItemChange: TCheckItemChange;
    FOnItemClick: TCheckListClicked;
    procedure CloseUpHandler(Sender: TObject);
    function GetAllowGrayed: Boolean;
    function GetChecked(AIndex: Integer): Boolean;
    function GetItemEnabled(AIndex: Integer): Boolean;
    function GetItemIndex: Integer;
    function GetItems: TStrings;
    function GetSorted: Boolean;
    function GetState(AIndex: Integer): TCheckBoxState;
    procedure ItemClickHandler(Sender: TObject; AIndex: Integer);
    procedure SetAllowGrayed(AValue: Boolean);
    procedure SetChecked(AIndex: Integer; const AValue: Boolean);
    procedure SetDelimiter(AValue: Char);
    procedure SetDropDownCount(AValue: Integer);
    procedure SetItemEnabled(AIndex: Integer; const AValue: Boolean);
    procedure SetItemIndex(AValue: Integer);
    procedure SetItems(const AValue: TStrings);
    procedure SetItemWidth(AValue: Integer);
    procedure SetSorted(AValue: Boolean);
    procedure SetState(AIndex: Integer; const AValue: TCheckboxState);
  protected
    procedure ButtonClick; override;
    procedure CloseUp; 
    procedure DoEnter; override;
    procedure DoChange; virtual;
    procedure DoItemChange(AIndex: Integer); virtual;
    procedure DoCloseUp; virtual;
    procedure DoDropDown; virtual;
    procedure DoItemClick(AIndex: Integer); virtual;
    procedure DoOnShowHint(HintInfo: PHintInfo); override;
    procedure EditKeyDown(var Key: Word; Shift: TShiftState); override;
    function GetBuddyClassType: TControlClass; override;
    function GetEditorClassType: TGEEditClass; override;
    procedure RestoreInitialChecks;
    procedure SaveInitialChecks;
    procedure SetBiDiMode(AValue: TBiDiMode); override;
    procedure ShowPopup;
    procedure UpdateCaption;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function AddItem(AText: String; AChecked: Boolean = false; AEnabled: Boolean = true): Integer;
    procedure CheckAll(AState: TCheckBoxState; aAllowGrayed: Boolean = true; aAllowDisabled: Boolean = true);
    procedure Clear;
    procedure Toggle(AIndex: Integer);
    // public properties
    property Checked[AIndex: Integer]: Boolean read GetChecked write SetChecked;
    property DroppedDown: Boolean read FDroppedDown;
    property ItemEnabled[AIndex: Integer]: Boolean read GetItemEnabled write SetItemEnabled;
    property Text;
  published
    property AllowGrayed: Boolean read GetAllowGrayed write SetAllowGrayed default false;
    property AutoDropDown: Boolean read FAutoDropDown write FAutoDropDown default false;
    property Delimiter: char read FDelimiter write SetDelimiter default ';';
    property DropDownCount: Integer read FDropDownCount write SetDropDownCount default 8;
    property EscCancels: Boolean read FEscCancels write FEscCancels default true;
    property HintMode: TCheckComboBoxHintMode read FHintMode write FHintMode default cbhmDefault;
    property ItemIndex: Integer read FItemIndex write SetItemIndex default -1;
    property Items: TStrings read GetItems write SetItems;
    property ItemWidth: Integer read FItemWidth write FItemWidth default 0;
    property Sorted: Boolean read GetSorted write SetSorted default false;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
    property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
    property OnItemChange: TCheckItemChange read FOnItemChange write FOnItemChange;
    property OnItemClick: TCheckListClicked read FOnItemClick write FOnItemClick;
    // inherited properties
    property Align;
    property Anchors;
    property AutoSize;
    property BiDiMode;
    property BorderSpacing;
    property Color;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property Hint;
    property ParentBidiMode;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Spacing default 0;
    property TabOrder;
    property TabStop;
    property TextHint;
    property Visible;  
    // inherited events
    property OnChangeBounds;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

  
implementation

uses
  Buttons, Themes, WSForms;

{ TCCBEdit }     // CCB = CheckComboBox
type
  TCCBEdit = class(TEbEdit)
  protected
    procedure DoOnShowHint(HintInfo: PHintInfo); override;
  end;

procedure TCCBEdit.DoOnShowHint(HintInfo: PHintInfo); 
begin
  (Parent as TCheckComboBoxEx).DoOnShowHint(HintInfo);
end;

  
{ TCCBButton }
type
  TCCBButton = class(TSpeedButton)
  protected
    procedure DoOnShowHint(HintInfo: PHintInfo); override;
    procedure Paint; override;
  end;

procedure TCCBButton.DoOnShowHint(HintInfo: PHintInfo); 
begin
  (Parent as TCheckComboBoxEx).DoOnShowHint(HintInfo);
end;
  
procedure TCCBButton.Paint;
const
  DETAILS: array[TButtonState] of TThemedComboBox = (
    tcDropDownButtonNormal,   // bsUp = button is up
    tcDropDownButtonDisabled, // bsDisabled = button is disabled
    tcDropDownButtonPressed,  // bsPressed = button is down
    tcDropDownButtonPressed,  // (not used)
    tcDropDownButtonHot       // bsHot = mouse is under mouse
  );
var
  detail: TThemedElementDetails;
begin
  inherited Paint;
  detail := ThemeServices.GetElementDetails(DETAILS[FState]);
  ThemeServices.DrawElement(Canvas.Handle, detail, ClientRect);
end;
  
  
{ TCheckComboBoxForm }
type
  TCheckComboBoxForm = class(TForm)
  private
    FCaller: TControl;
    FCheckListBox: TCheckListBox;
    FDropDownCount: Integer;
  protected
    procedure ActivateDoubleBuffered;
    procedure DblClickHandler(Sender: TObject);
    procedure Deactivate; override;
    procedure KeepInView(APopupOrigin: TPoint);    
    procedure KeyDownHandler(Sender: TObject; var Key: Word; Shift: TShiftState); 
    procedure MeasureHeight(out AHeight: Integer);
  public
    constructor CreateNew(AOwner: TComponent; Num: Integer = 0); override;
    procedure Initialize(ADropdownCount: Integer; APosition: TPoint; AWidth: Integer);
  end;

constructor TCheckComboBoxForm.CreateNew(AOwner: TComponent; Num: Integer = 0);
begin
  inherited CreateNew(AOwner, Num);
  BorderStyle := bsNone;
  FCheckListbox := TCheckListbox.Create(self);
  FCheckListbox.Align := alClient;
  FCheckListbox.Parent := self;
  FCheckListbox.OnDblClick := @DblClickHandler;
  FCheckListbox.OnKeyDown := @KeyDownHandler;
  FDropDownCount := 8;
end;
  
procedure TCheckComboBoxForm.ActivateDoubleBuffered;
begin
  DoubleBuffered := TWSCustomFormClass(WidgetSetClass).GetDefaultDoubleBuffered;
end;

procedure TCheckComboBoxForm.Deactivate;
begin
  Close;
end;

procedure TCheckComboboxForm.DblClickHandler(Sender: TObject);
begin
  Close;
end;

procedure TCheckComboBoxForm.Initialize(ADropDownCount: Integer;
  APosition: TPoint; AWidth: Integer);
var
  h: Integer;
begin
  FDropDownCount := ADropDownCount;
  MeasureHeight(h);
  SetBounds(APosition.X, APosition.Y, AWidth, h);
  KeepInView(APosition);
  AutoScroll := FCheckListBox.Items.Count > FDropDownCount;
end;
  
procedure TCheckComboBoxForm.KeepInView(APopupOrigin: TPoint);
var
  R: TRect;
begin
  R := Screen.MonitorFromPoint(APopupOrigin).WorkAreaRect; // take care of taskbar
  
  if APopupOrigin.X + Width > R.Right then
    Left := R.Right - Width
  else if APopupOrigin.X < R.Left then
    Left := R.Left
  else
    Left := APopupOrigin.X;
  
  if APopupOrigin.Y + Height > R.Bottom then
  begin
    if Assigned(FCaller) then
      Top := APopupOrigin.Y - FCaller.Height - Height
    else
      Top := R.Bottom - Height;
  end else if APopupOrigin.Y < R.Top then
    Top := R.Top
  else
    Top := APopupOrigin.Y;
  
  if Left < R.Left then Left := 0;
  if Top < R.Top then Top := 0;
end;
  
procedure TCheckComboBoxForm.KeyDownHandler(Sender: TObject; var Key: Word; 
  Shift: TShiftState); 
begin
  inherited;
  if (Key = VK_ESCAPE) and TCheckComboBoxEx(FCaller).EscCancels then
    TCheckComboBoxEx(FCaller).RestoreInitialChecks;
  if (Key = VK_ESCAPE) or (Key = VK_TAB) or (Key = VK_RETURN) or
     (((Key = VK_UP) or (Key = VK_DOWN)) and (Shift = [ssAlt])) 
  then
    Close;
end;

procedure TCheckComboBoxForm.MeasureHeight(out AHeight: Integer);
var
  i: Integer;
  h: Integer;
begin
  AHeight := 0;
  for i := 0 to FCheckListbox.Items.Count-1 do
    if i < FDropDownCount then
    begin
      FCheckListbox.MeasureItem(i, h);
      inc(AHeight,h);
    end;
  inc(AHeight, 6);
end;
    

{ TCheckComboBoxEx }

constructor TCheckComboBoxEx.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Spacing := 0;
  Button.Flat := true;
  Button.Width := GetSystemMetrics(SM_CXVSCROLL);
  FDelimiter := ';';
  FDropDownCount := 8;
  FDropDownForm := TCheckComboBoxForm.CreateNew(Self);
  with TCheckComboBoxForm(FDropDownForm) do
  begin
    Self.FCheckListbox := FCheckListbox;
    FCaller := self;
    OnHide := @CloseUpHandler;
    FCheckListbox.OnItemClick := @ItemClickHandler;
  end;
  FEscCancels := true;
end;

destructor TCheckComboBoxEx.Destroy;
begin
  inherited Destroy;
end;

function TCheckComboBoxEx.AddItem(AText: String; AChecked: Boolean = false; 
  AEnabled: Boolean = true): Integer;
begin
  with FCheckListBox do
  begin
    Result := Items.Add(AText);
    Checked[Result] := AChecked;
    ItemEnabled[Result] := AEnabled;
  end;
  UpdateCaption;
end;

procedure TCheckComboBoxEx.ButtonClick;
begin
  ShowPopup;
end;

procedure TCheckComboBoxEx.CheckAll(AState: TCheckBoxState;
  AAllowGrayed: Boolean = true; AAllowDisabled: Boolean = true);
begin
  with FCheckListBox do
    CheckAll(AState, AAllowGrayed, AAllowDisabled);
  UpdateCaption;
  DoChange;
end;

procedure TCheckComboBoxEx.Clear;
begin
  FCheckListBox.Clear;
  UpdateCaption;
  DoChange;
end;

procedure TCheckComboBoxEx.CloseUp;
begin
  FDroppedDown := false;
  UpdateCaption;
  DoCloseUp;
end;

procedure TCheckComboBoxEx.CloseUpHandler(Sender: TObject);
begin
  CloseUp;
end;

procedure TCheckComboBoxEx.DoChange;
begin
  if Assigned(FOnChange) then FOnChange(self);
end;

procedure TCheckComboBoxEx.DoCloseUp;
begin
  if Assigned(FOnCloseUp) then FOnCloseUp(self);
end;
  
procedure TCheckComboBoxEx.DoDropDown;
begin
  if Assigned(FOnDropDown) then FOnDropDown(self);
end;

procedure TCheckComboBoxEx.DoEnter;
begin
  inherited;
  if FAutoDropDown then ShowPopup;
end;

procedure TCheckComboBoxEx.DoItemChange(AIndex: Integer);
begin
  if Assigned(FOnItemChange) then
    FOnItemChange(self, AIndex);
end;

procedure TCheckComboBoxEx.DoItemClick(AIndex: Integer);
begin
  if Assigned(FOnItemClick) then
    FOnItemClick(self, AIndex);
end;

procedure TCheckComboBoxEx.DoOnShowHint(HintInfo: PHintInfo); 
begin
  if FHintMode = cbhmItems then
    HintInfo^.HintStr := StringReplace(Text, FDelimiter+' ', LineEnding, [rfReplaceAll]);
  inherited;
end;

procedure TCheckComboBoxEx.EditKeyDown(var Key: Word; Shift: TShiftState); 
begin
  if (Key = VK_TAB) then
  begin
    inherited;
    exit;
  end;
  
  if (Key = VK_RETURN) or (Key = VK_SPACE) or 
     (((Key = VK_DOWN) or (Key = VK_UP)) and (Shift = [ssAlt])) 
  then
    ShowPopup;
  
  // Kill all other keys
  Key := 0;
end;

function TCheckComboBoxEx.GetAllowGrayed: Boolean;
begin
  Result := FCheckListbox.AllowGrayed;
end;

function TCheckComboBoxEx.GetBuddyClassType: TControlClass;
begin
  Result := TCCBButton;
end;

function TCheckComboBoxEx.GetChecked(AIndex: Integer): Boolean;
begin
  Result := FCheckListBox.Checked[AIndex];
end;

function TCheckComboBoxEx.GetEditorClassType: TGEEditClass; 
begin
  Result := TCCBEdit;
end;

function TCheckComboBoxEx.GetItemEnabled(AIndex: Integer): Boolean;
begin
  Result := FCheckListbox.ItemEnabled[AIndex];
end;

function TCheckComboBoxEx.GetItemIndex: Integer;
begin
  Result := TCheckComboBoxForm(FDropDownForm).FCheckListBox.ItemIndex;
end;

function TCheckComboBoxEx.GetItems: TStrings;
begin
  Result := FCheckListBox.Items;
end;

function TCheckComboBoxEx.GetSorted: Boolean;
begin
  Result := FCheckListbox.Sorted;
end;

function TCheckComboBoxEx.GetState(AIndex: Integer): TCheckboxState;
begin
  Result := FCheckListBox.State[AIndex];
end;

procedure TCheckComboBoxEx.ItemClickHandler(Sender: TObject; AIndex: Integer);
begin
  UpdateCaption;
  DoChange;
  DoItemChange(AIndex);
  DoItemClick(AIndex);
end;

procedure TCheckComboBoxEx.RestoreInitialChecks;
var
  i: Integer;
begin
  for i := 0 to FCheckListbox.Items.Count-1 do
    FCheckListbox.Checked[i] := false;
  for i := 0 to High(FSavedChecks) do
    FCheckListbox.Checked[FSavedChecks[i]] := true;
end;
  
procedure TCheckComboBoxEx.SaveInitialChecks;
var
  i, n: Integer;
begin
  SetLength(FSavedChecks, FCheckListbox.Items.Count);
  n := 0;
  for i := 0 to FCheckListbox.Items.Count-1 do
    if FCheckListbox.Checked[i] then 
    begin
      FSavedChecks[n] := i;
      inc(n);
    end;
  SetLength(FSavedChecks, n);
end;

procedure TCheckComboBoxEx.SetAllowGrayed(AValue: Boolean);
begin
  if GetAllowGrayed = AValue then exit;
  FCheckListBox.AllowGrayed := AValue;
end;

procedure TCheckComboBoxEx.SetBiDiMode(AValue: TBiDiMode);
begin
  if AValue = BiDiMode then exit;
  inherited SetBiDiMode(AValue);
  FDropDownForm.BiDiMode := AValue;
  if IsRightToLeft then
    Buddy.Align := alLeft 
  else
    Buddy.Align := alRight;
  UpdateCaption;
end;

procedure TCheckComboBoxEx.SetChecked(AIndex: Integer; const AValue: Boolean);
begin
  if GetChecked(AIndex) = AValue then
    exit;
  FCheckListBox.Checked[AIndex] := AValue;
  UpdateCaption;
  DoChange;
  DoItemChange(AIndex);
end;

procedure TCheckComboBoxEx.SetDelimiter(AValue: Char);
begin
  if FDelimiter = AValue then exit;
  FDelimiter := AValue;
  UpdateCaption;
end;

procedure TCheckComboBoxEx.SetDropDownCount(AValue: Integer);
begin
  if (FDropDownCount = AValue) or (AValue <= 0) then exit;
  FDropDownCount := AValue;
end;

procedure TCheckComboBoxEx.SetItemEnabled(AIndex: Integer; const AValue: Boolean);
begin
  if GetItemEnabled(AIndex) = AValue then exit;
  FCheckListbox.ItemEnabled[AIndex] := AValue;
end;

procedure TCheckComboBoxEx.SetItemIndex(AValue: Integer);
begin
  if GetItemIndex() = AValue then exit;
  FCheckListBox.ItemIndex := AValue;
  // todo: scroll in view
end;

procedure TCheckComboBoxEx.SetItems(const AValue: TStrings);
begin
  FCheckListBox.Items.Assign(AValue);
end;

procedure TCheckComboBoxEx.SetItemWidth(AValue: Integer);
begin
  if FItemWidth = AValue then exit;
  if AValue < 0 then
    FItemWidth := 0
  else
    FItemWidth := AValue;
end;

procedure TCheckComboBoxEx.SetSorted(AValue: Boolean);
begin
  FCheckListbox.Sorted := AValue;
  UpdateCaption;
end;

procedure TCheckComboBoxEx.SetState(AIndex: Integer; const AValue: TCheckBoxState);
begin
  FCheckListbox.State[AIndex] := AValue;
  DoChange;
  DoItemChange(AIndex);
end;

procedure TCheckComboBoxEx.ShowPopup;
var
  PopupOrigin: TPoint;
  PopupWidth: Integer;
begin
  if DoubleBuffered then
    TCheckComboBoxForm(FDropDownForm).ActivateDoubleBuffered;
  PopupOrigin := ControlToScreen(Point(0, Height));
  if FItemWidth > 0 then
    PopupWidth := FItemWidth
  else
    PopupWidth := Self.Width;
  TCheckComboBoxForm(FDropDownForm).Initialize(FDropDownCount, PopupOrigin, PopupWidth);
  SaveInitialChecks;
  FDropDownForm.Show;
  FDroppedDown := true;
  DoDropDown;
end;

procedure TCheckComboBoxEx.Toggle(AIndex: Integer);
begin
  SetChecked(AIndex, not GetChecked(AIndex));
end;

procedure TCheckComboBoxEx.UpdateCaption;
var
  i: Integer;
  s: String;
begin
  s := '';
  if IsRightToLeft then
  begin
    for i := FCheckListBox.Count-1 downto 0 do
      if FCheckListbox.Checked[i] then
        s := s + FCheckListbox.items[i] + FDelimiter + ' '
  end else  
  begin
    for i := 0 to FCheckListbox.Count-1 do
      if FCheckListbox.Checked[i] then
        s := s + FCheckListbox.Items[i] + FDelimiter + ' ';
  end;
  if s <> '' then
    SetLength(s, Length(s)-2);
  Text := s;
end;
  

end.