unit ATCheckedComboBox;

interface

uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
type

   TATCBQuoteStyle = (qsNone,qsSingle,qsDouble);

   TATCheckedComboBox = class(TCustomComboBox)
   private
      { Private declarations }
      FListInstance   : Pointer;
      FDefListProc   : Pointer;
      FListHandle    : HWnd;
      FQuoteStyle      : TATCBQuoteStyle;
      FColorNotFocus: TColor;
      FCheckedCount : integer;
      FTextAsHint    : boolean;
      FOnCheckClick : TNotifyEvent;
      FVersion       : String;
      procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
      procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
      procedure CMExit(var Message: TCMExit); message CM_EXIT;
      procedure ListWndProc(var Message: TMessage);
      procedure SetColorNotFocus(value:TColor);
      procedure SetVersion(value:String);
   protected
      { Protected declarations }
      m_strText          : string;
      m_bTextUpdated   : boolean;
      procedure WndProc(var Message: TMessage);override;
      procedure RecalcText;
      function GetText: string;
      function GetCheckedCount:integer;
   public
      { Public declarations }
      constructor Create(AOwner: TComponent);override;
      destructor    Destroy; override;
      procedure    SetCheck(nIndex:integer;checked:boolean);
      function       AddChecked(value:string;checked:boolean):integer;
      function       IsChecked(nIndex: integer):boolean;
      procedure    CheckAll(checked:boolean);
      property       Text:string read GetText;
      property      CheckedCount :integer read GetCheckedCount;
   published
      { Published declarations }
      property Anchors;
      property BiDiMode;
      property Color;
      property ColorNotFocus : TColor   read FColorNotFocus write SetColorNotFocus;
      property Constraints;
      property Ctl3D;
      property DragCursor;
      property DragKind;
      property DragMode;
      property DropDownCount;
      property Enabled;
      property Font;
      property ImeMode;
      property ImeName;
      property ItemHeight;
      property Items;
      property MaxLength;
      property ParentBiDiMode;
      property ParentColor;
      property ParentCtl3D;
      property ParentFont;
      property ParentShowHint;
      property PopupMenu;
      property QuoteStyle   : TATCBQuoteStyle read FQuoteStyle   write FQuoteStyle default qsNone;
      property ShowHint;
      property ShowTextAsHint : Boolean read FTextAsHint write FTextAsHint default true;
      property Sorted;
      property TabOrder;
      property TabStop;
      property Visible;
      property Version :string read FVersion write SetVersion; // ver 1.1
      property OnChange;
      property OnCheckClick: TNotifyEvent read FOnCheckClick write FOnCheckClick;
      property OnClick;
      property OnDblClick;
      property OnDragDrop;
      property OnDragOver;
      property OnDropDown;
      property OnEndDock;
      property OnEndDrag;
      property OnEnter;
      property OnExit;
      property OnKeyDown;
      property OnKeyPress;
      property OnKeyUp;
      property OnStartDock;
      property OnStartDrag;
   end;

procedure Register;

implementation

{ TATCheckedComboBox }
procedure Register;
begin
   RegisterComponents('Samples', [TATCheckedComboBox]);
end;

var
   FCheckWidth, FCheckHeight: Integer;

procedure GetCheckSize;
begin
   with TBitmap.Create do
      try
         Handle := LoadBitmap(0, PChar(32759));
         FCheckWidth := Width div 4;
         FCheckHeight := Height div 3;
      finally
         Free;
      end;
end;

procedure TATCheckedComboBox.SetVersion(value: String);
begin
   // read only
end;

procedure TATCheckedComboBox.SetCheck(nIndex:integer;checked:boolean);
begin
   if (nIndex>-1) and (nIndex<Items.count) then
   begin
      Items.Objects[nIndex] := TObject(checked);
      m_bTextUpdated := FALSE;
      Invalidate;
      if Assigned(FOnCheckClick) then
         OnCheckClick(self)
   end;
end;

function TATCheckedComboBox.AddChecked(value:string;checked:boolean):integer;
begin
   result := Items.AddObject(value, TObject(checked));
   if result>=0 then
   begin
      m_bTextUpdated := FALSE;
      Invalidate;
   end;
end;

function TATCheckedComboBox.IsChecked(nIndex: integer):boolean;
begin
   result := false;
   if (nIndex>-1) and (nIndex<Items.count) then
      result := Items.Objects[nIndex] = TObject(TRUE)
end;

procedure TATCheckedComboBox.CheckAll(checked:boolean);
var i:integer;
begin
   for i:= 0 to Items.count-1 do
      Items.Objects[i] := TObject(checked);
end;

function GetFormatedText(kind:TATCBQuoteStyle;str:string):string;
var s : string;
begin
   result := str;
   if length(str)>0 then
   begin
      s := str;
      case kind of
         qsSingle   : result :=
               ''''+
               StringReplace(S, ',', ''',''',[rfReplaceAll])+
               '''';
         qsDouble    : result :=
               '"'+
               StringReplace(S, ',', '","',[rfReplaceAll])+
               '"';
      end;
   end;
end;

function TATCheckedComboBox.GetText: string;
begin
   RecalcText;
   if FQuoteStyle = qsNone then
      result := m_strText
   else
      result := GetFormatedText(FQuoteStyle,m_strText);
end;

function TATCheckedComboBox.GetCheckedCount:integer;
begin
   RecalcText;
   result := FCheckedCount;
end;


procedure TATCheckedComboBox.RecalcText;
var
      nCount,i    : integer;
      strItem,
      strText,
      strSeparator : string;
begin
   if (not m_bTextUpdated) then
   begin
      FCheckedCount   := 0;
      nCount       := items.count;
      strSeparator    := '; ';
      strText          := '';
      for i := 0 to nCount - 1 do
         if IsChecked(i) then
         begin
            inc(FCheckedCount);
            strItem := items[i];
            if (strText<>'') then
               strText := strText + strSeparator;
            strText := strText + strItem;
         end;
      // Set the text
      m_strText          := strText;
      if FTextAsHint then
         Hint := m_strText;
      m_bTextUpdated    := TRUE;
   end;
end;

procedure TATCheckedComboBox.SetColorNotFocus(value:TColor);
begin
    if FColorNotFocus <> Value then
      FColorNotFocus := Value;
   Invalidate
end;

procedure TATCheckedComboBox.CMEnter(var Message: TCMEnter);
begin
   Self.Color      := clWhite;
   if Assigned(OnEnter) then OnEnter(Self);
end;

procedure TATCheckedComboBox.CMExit(var Message: TCMExit);
begin
   Self.Color       := FColorNotFocus;
   if Assigned(OnExit) then OnExit(Self);
end;


procedure TATCheckedComboBox.CNDrawItem(var Message: TWMDrawItem);
var
   State                  : TOwnerDrawState;
   rcBitmap,rcText   : Trect;
   nCheck               : integer; // 0 - No check, 1 - Empty check, 2 - Checked
   nState                : integer;
   strText             : string;
   ItId                  : Integer;
   dc                     : HDC;
begin
   with Message.DrawItemStruct^ do
   begin
      State       := TOwnerDrawState(LongRec(itemState).Lo);
      dc             := hDC;
      rcBitmap   := rcItem;
      rcText    := rcItem;
      ItId         := itemID;
   end;
   // Check if we are drawing the static portion of the combobox
  if (itID < 0) then
   begin
      RecalcText();
      strText := m_strText;
      nCheck := 0;
   end
   else
   begin
      strtext             := Items[ItId];
      rcBitmap.Left    := 2;
      rcBitmap.Top       := rcText.Top + (rcText.Bottom - rcText.Top - FCheckWidth) div 2;
      rcBitmap.Right    := rcBitmap.Left + FCheckWidth;
      rcBitmap.Bottom := rcBitmap.Top + FCheckHeight;

      rcText.left := rcBitmap.right;
      nCheck := 1;
      if IsChecked(ItId) then
         inc(nCheck);
   end;
   if (nCheck > 0) then
   begin
       SetBkColor(dc, GetSysColor(COLOR_WINDOW));
       SetTextColor(dc, GetSysColor(COLOR_WINDOWTEXT));
       nState := DFCS_BUTTONCHECK;
      if (nCheck > 1) then
    nState := nState or DFCS_CHECKED;
      DrawFrameControl(dc, rcBitmap, DFC_BUTTON, nState);
   end;
   if (odSelected in State) then
   begin
      SetBkColor(dc, $0091622F);
      SetTextColor(dc, GetSysColor(COLOR_HIGHLIGHTTEXT));
   end
   else
   begin
      if (nCheck=0) then
      begin
         SetTextColor(dc, ColorToRGB(Font.Color));
         SetBkColor(dc, ColorToRGB(FColorNotFocus));
      end
      else
      begin
         SetTextColor(dc, ColorToRGB(Font.Color));
      SetBkColor(dc,     ColorToRGB(Brush.Color));
      end;
   end;
   if itID >= 0 then
  strText := ' ' + strtext;
   ExtTextOut(dc, 0, 0, ETO_OPAQUE, @rcText, Nil, 0, Nil);
   DrawText(dc, pchar(strText), Length(strText), rcText, DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS);
   if odFocused in State then DrawFocusRect(dc, rcText);
end;

 //DefWindowProc
procedure TATCheckedComboBox.ListWndProc(var Message: TMessage);
var
   nItemHeight, nTopIndex, nIndex: Integer;
   rcItem,rcClient: TRect;
   pt              : TPoint;
begin
   case Message.Msg of
      LB_GETCURSEL : // this is for to not draw the selected in the text area
         begin
            Message.result := -1;
            exit;
         end;
      WM_CHAR: // pressing space toggles the checked
         begin
            if (TWMKey(Message).CharCode = VK_SPACE) then
            begin
               // Get the current selection
               nIndex := CallWindowProcA(FDefListProc, FListHandle, LB_GETCURSEL,Message.wParam, Message.lParam);
               SendMessage(FListHandle, LB_GETITEMRECT, nIndex, LongInt(@rcItem));
               InvalidateRect(FListHandle, @rcItem, FALSE);
               SetCheck(nIndex, not IsChecked(nIndex));
               SendMessage(WM_COMMAND, handle, CBN_SELCHANGE,handle);
               Message.result := 0;
               exit;
            end
         end;
      WM_LBUTTONDOWN:
         begin
            Windows.GetClientRect(FListHandle, rcClient);
            pt.x := TWMMouse(Message).XPos; //LOWORD(Message.lParam);
            pt.y := TWMMouse(Message).YPos; //HIWORD(Message.lParam);
            if (PtInRect(rcClient, pt)) then
            begin
               nItemHeight := SendMessage(FListHandle, LB_GETITEMHEIGHT, 0, 0);
               nTopIndex := SendMessage(FListHandle, LB_GETTOPINDEX, 0, 0);
               // Compute which index to check/uncheck
               nIndex := trunc(nTopIndex + pt.y / nItemHeight);
               SendMessage(FListHandle, LB_GETITEMRECT, nIndex, LongInt(@rcItem));
               if (PtInRect(rcItem, pt)) then
               begin
                  InvalidateRect(FListHandle, @rcItem, FALSE);
                  SetCheck(nIndex, not IsChecked(nIndex));
                  SendMessage(WM_COMMAND, handle, CBN_SELCHANGE,handle);
               end
            end
         end;
      WM_LBUTTONUP:
         begin
            Message.result := 0;
            exit;
         end;
   end;
   ComboWndProc(Message, FListHandle, FDefListProc);
end;

constructor TATCheckedComboBox.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   ShowHint            := true;
   Fversion            := '1.2';
   FTextAsHint       := true;
   ParentShowHint := False;
   FListHandle       := 0;
   FQuoteStyle       := qsNone;
   FColorNotFocus   := clInfoBk;
   Style                := csOwnerDrawVariable;
   m_bTextUpdated := FALSE;
   FListInstance    := MakeObjectInstance(ListWndProc);
end;

destructor TATCheckedComboBox.Destroy;
begin
   FreeObjectInstance(FListInstance);
   inherited Destroy;
end;

procedure TATCheckedComboBox.WndProc(var Message: TMessage);
var lWnd : HWND;
begin
   if message.Msg = WM_CTLCOLORLISTBOX then
   begin
      // If the listbox hasn't been subclassed yet, do so...
      if (FListHandle = 0) then
      begin
         lwnd := message.LParam;
         if (lWnd <> 0) and (lWnd <> FDropHandle) then
         begin
            // Save the listbox handle
            FListHandle := lWnd;
            FDefListProc := Pointer(GetWindowLong(FListHandle, GWL_WNDPROC));
            SetWindowLong(FListHandle, GWL_WNDPROC, Longint(FListInstance));
         end;
      end;
   end;
   inherited;
end;

initialization
   GetCheckSize;

end.