unit HSComboBox;
{ Позволяет запрещать для выбора отдельные строки, по умолчанию, начинающиеся со знака '-', выбор определяется внешним обработчиком }

interface
uses
  Windows, Messages, Classes, Controls, StdCtrls;

type
  TOnCanSelectEvent = procedure (Sender : TObject; Index : Integer;
                                 var CanSelect : Boolean) of object;
  TOnDrawFocusRectEvent = procedure (Sender : TObject;
                                     const Rect : TRect;
                                     State: TOwnerDrawState) of object;
  TFocusRectKind = (frStandard, frCustom);

  THSComboBox = class(TCustomComboBox)
  private
    { Список ассоциированных значений }
    FValues : TStrings;
    FLastKey : Integer;
    FOnCanSelect: TOnCanSelectEvent;
    FFocusRectKind: TFocusRectKind;
    FOnDrawFocusRect: TOnDrawFocusRectEvent;
    function CanSelectItem (AItemIndex : Integer) : Boolean;
    function GetValue: String;
    procedure SetValue(const Value: String);
    procedure SetValues(const Value: TStrings);
    procedure SetFocusRectKind(const Value: TFocusRectKind);
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  protected
    { Обработчик события определения доступности элемента списка }
    { Сделан виртуальным для возможности переопределения в наследниках компонента}
    procedure DoCanSelect (AItemIndex : Integer; var CanSelect : Boolean); dynamic;
    { Отрисовка FocusRect }
    procedure DoDrawFocusRect (const Rect : TRect;
       State: TOwnerDrawState); dynamic;
    procedure Change; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure SetStyle (Value : TComboBoxStyle); override;
    { Для рисования разделительных строк не надо
      вызывать процедуру пользователя }
    procedure DrawItem(Index: Integer; Rect: TRect;
      State: TOwnerDrawState); override;
  public
    constructor Create(AOwner : TComponent); override;
    destructor  Destroy; override;
    { Ассоциированное с элементом списка значение из списка значений.
      Сделано только в runtime, так как в design-time оно не имеет смысла }
    property Value : String read GetValue write SetValue;
  published
    property Style; {Must be published before Items}
    property Anchors;
    property BiDiMode;
    property Color;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property DropDownCount;
    property Enabled;
    property Font;
    property ImeMode;
    property ImeName;
    property ItemHeight;
    property MaxLength;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Sorted;
    property TabOrder;
    property TabStop;
    property Text;
    property Visible;
    { Список ассоциированных значений для редактирования, копирования и т.д. }
    property Values : TStrings read FValues write SetValues;
    { Тип прямоугольника фокуса }
    property FocusRectKind : TFocusRectKind
            read FFocusRectKind write SetFocusRectKind default frStandard;
    { События }
    property OnChange;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnDropDown;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnStartDock;
    property OnStartDrag;

    property Items; { Must be published after OnMeasureItem }
    { Событие для определения доступности элемента списка ComboBox'а }
    property OnCanSelect : TOnCanSelectEvent read FOnCanSelect
             write FOnCanSelect;
    { Событие для отрисовки FocusRect,когда компонент имеет фокус }
    { Вызывается только в случае установки FocusRectKind в frCustom }
    property OnDrawFocusRect : TOnDrawFocusRectEvent read FOnDrawFocusRect
             write FOnDrawFocusRect;

  end;

implementation
uses
  Graphics, SysUtils;

{ THSComboBox }

function THSComboBox.CanSelectItem(AItemIndex: Integer): Boolean;
var
  CanSelect : Boolean;
begin
  DoCanSelect (AItemIndex, CanSelect);
  Result := CanSelect;
end;

procedure THSComboBox.Change;
var
  OldIndex, NewIndex : Integer;
begin
  OldIndex := ItemIndex;
  NewIndex := OldIndex;
  while NOT CanSelectItem(NewIndex) do
    if FLastKey = VK_UP then begin
      Dec(NewIndex);
      if NewIndex < 0 then
        FLastKey := VK_DOWN;
    end else begin
      Inc(NewIndex);
      if NewIndex > Pred(Items.Count) then
        FLastKey := VK_UP;
    end;
  if NewIndex <> OldIndex then
    ItemIndex := NewIndex;
  inherited;
end;

{ Переписано с небольшими исправлениями из TCustomComboBox.CNDrawItem }
procedure THSComboBox.CNDrawItem(var Message: TWMDrawItem);
var
  State: TOwnerDrawState;
begin
  with Message.DrawItemStruct^ do begin
    State := TOwnerDrawState(LongRec(itemState).Lo);
    if itemState and ODS_COMBOBOXEDIT <> 0 then
      Include(State, odComboBoxEdit);
    if itemState and ODS_DEFAULT <> 0 then
      Include(State, odDefault);
    Canvas.Handle := hDC;
    Canvas.Font := Font;
    Canvas.Brush := Brush;
    if (Integer(itemID) >= 0) and (odSelected in State) then begin
      Canvas.Brush.Color := clHighlight;
      Canvas.Font.Color := clHighlightText
    end;
    if Integer(itemID) >= 0 then
      DrawItem(itemID, rcItem, State)
    else
      Canvas.FillRect(rcItem);
    if odFocused in State then
      DoDrawFocusRect(rcItem, State);
    Canvas.Handle := 0;
  end;
end;

constructor THSComboBox.Create(AOwner: TComponent);
begin
  inherited;
  FValues := TStringList.Create;
  FLastKey := VK_DOWN; { По умолчанию, последнее движение было вниз, при выборе
  недоступного элемента фокус автоматически перемещается на следующий
  доступный элемент }
  FFocusRectKind := frStandard;
end;

destructor THSComboBox.Destroy;
begin
  FValues.Free();
  inherited;
end;

procedure THSComboBox.DoCanSelect(AItemIndex: Integer;
  var CanSelect: Boolean);
begin
  CanSelect := NOT ((Style = csOwnerDrawFixed) AND (Items[AItemIndex] = '-'));
  if Assigned(FOnCanSelect) then
    FOnCanSelect (Self, AItemIndex, CanSelect);
end;

procedure THSComboBox.DoDrawFocusRect(const Rect: TRect;
      State: TOwnerDrawState);
begin
  case FFocusRectKind of
  frStandard:
    Windows.DrawFocusRect(Canvas.Handle, Rect);
  frCustom:
    if Assigned(OnDrawFocusRect) then
      FOnDrawFocusRect(Self, Rect, State);
  end;
end;

procedure THSComboBox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
begin
  if (Style = csOwnerDrawFixed) AND (Items[Index] = '-') AND
     NOT (odComboBoxEdit in State) then begin
    { Нарисовать разделительную линию }
    with TControlCanvas(Canvas) do begin
      FillRect(Rect);
      if odFocused in State then
        Pen.Color := clWhite
      else
        Pen.Color := clBlack;
      Pen.Width := 1;
      MoveTo (Rect.Left, Rect.Top + (Rect.Bottom - Rect.Top) DIV 2);
      LineTo (Rect.Right, Rect.Top + (Rect.Bottom - Rect.Top) DIV 2);
    end;
  end else
    inherited;
end;

{ Вернуть ассоциированное с текущим элементом списка значение }
function THSComboBox.GetValue: String;
begin
  Result := '';
  if (ItemIndex >= 0) AND (ItemIndex < FValues.Count) then
    Result := FValues[ItemIndex];
end;

procedure THSComboBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
{ Для определения того, в какую сторону двигаться, если выбран недоступный
  элемент, запоминаем последнюю нажатую клавишу. }
  FLastKey := Key;
  inherited;
end;

{ Установить новый стиль с запретом стилей csSimple,csDropDown. }
procedure THSComboBox.SetFocusRectKind(const Value: TFocusRectKind);
begin
  if (FFocusRectKind <> Value) then begin
    FFocusRectKind := Value;
    Invalidate();
  end;
end;

procedure THSComboBox.SetStyle(Value: TComboBoxStyle);
begin
  if Value in [csSimple, csDropDown] then
    Value := csDropDownList;
  inherited SetStyle(Value);
end;

{ Установить элемент списка, с которым ассоциируется значение.
  Если нового значения нет в списке, то установить выбранный индекс в -1 }
procedure THSComboBox.SetValue(const Value: String);
var NewIndex : Integer;
begin
  NewIndex := FValues.IndexOf(Value);
  if NewIndex > Pred(Items.Count) then
    NewIndex := -1;
  ItemIndex := NewIndex;
  Change();
end;

procedure THSComboBox.SetValues(const Value: TStrings);
begin
  FValues.Assign(Value);
end;

end.