Total Commander

Code: Select all

unit ExtendedComboBox;

{Tested with Delphi 5 and Delphi 2006}
{Tested with Win95, Win98, WinME, WinNT4, Win2k, WinXP}

interface

uses
  Windows, Messages, Forms, Classes, StdCtrls;

type
  TComboBox = class(StdCtrls.TComboBox)
  private
    FObjectInstance : Pointer;
    FDropDownWnd : HWND;
    FDropDownWndProc : Pointer;
    FHandlingDropDownContextMenu : LongWord;
    procedure SubclassedListBoxWndProc(var Message : TMessage);
  protected
    procedure WndProc(var Message : TMessage); override;
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  end;

implementation

uses
  Menus;

constructor TComboBox.Create(AOwner : TComponent);
begin
  FObjectInstance:=MakeObjectInstance(SubclassedListBoxWndProc);
  inherited;
end;

{Every combobox window has it's own listbox window, however, listbox window
 is not a child of combobox window. So we can't be sure that listbox window
 will be destroyed before destroying combobox - we must un-subclass listbox
 window before destroying combobox}
destructor TComboBox.Destroy;
begin
  if FDropDownWnd <> 0 then
    SetWindowLong(FDropDownWnd,GWL_WNDPROC,Integer(FDropDownWndProc));
  if FObjectInstance <> nil then
    FreeObjectInstance(FObjectInstance);
  inherited;
end;

{In order to override WM_CTLCOLORLISTBOX handler, we must override WndProc -
 because of special handling of WM_CTLCOLORLISTBOX by Delphi, "message
 WM_CTLCOLORLISTBOX" handler doesn't work}
procedure TComboBox.WndProc(var Message: TMessage);
begin
  inherited;
  with Message do
  begin
    {Grab handle of the listbox}
    if Msg = WM_CTLCOLORLISTBOX then
    if FDropDownWnd = 0 then
    begin
      FDropDownWnd:=LParam;
      FDropDownWndProc:=Pointer(SetWindowLong(FDropDownWnd,GWL_WNDPROC,Integer(FObjectInstance)));
    end;
  end;
end;

{Subclassed window procedure for listbox}
procedure TComboBox.SubclassedListBoxWndProc(var Message : TMessage);
var
  SaveDropDownWnd : HWND;
  Pt : TPoint;
  TempPt : TPoint;
  R : TRect;
  Handled : Boolean;
  PopupMenu : TPopupMenu;
  TempMsg : TMsg;
begin
  with Message do
  begin
    {Don't close listbox when displaying a popup menu}
    if Msg = WM_CAPTURECHANGED then
    if FHandlingDropDownContextMenu > 0 then
    begin
      Result:=0;
      Exit;
    end;

    SaveDropDownWnd:=FDropDownWnd;

    {Un-subclass listbox}
    if Msg = WM_DESTROY then
    begin
      SetWindowLong(FDropDownWnd,GWL_WNDPROC,Integer(FDropDownWndProc));
      FDropDownWnd:=0;
    end;

    Result:=CallWindowProc(FDropDownWndProc,SaveDropDownWnd,Msg,WParam,LParam);

    {Handle right clicks on the listbox (on the basis of TControl.WMContextMenu)}
    if Msg = WM_CONTEXTMENU then
    if Result = 0 then {if not handled yet}
    try
      Inc(FHandlingDropDownContextMenu);

      Pt:=SmallPointToPoint(TWMContextMenu(Message).Pos);
      TempPt:=Pt;
      if Pt.X >= 0 then {if not InvalidPoint(Pt) then}
      begin
        {Listbox has mouse captured, so we get mouse clicks from the whole
         screen - so don't allow to display popup menu outside listbox}
        if Windows.ScreenToClient(FDropDownWnd,TempPt) then
        if Windows.GetClientRect(FDropDownWnd,R) then
        if not PtInRect(R,TempPt) then
          Exit;
        TempPt:=ScreenToClient(Pt);
      end;

      Handled:=False;
      DoContextPopup(TempPt,Handled);
      Result:=Ord(Handled);

      if not Handled then
      begin
        PopupMenu:=GetPopupMenu;
        if PopupMenu <> nil then
        if PopupMenu.AutoPopup then
        begin
          PopupMenu.PopupComponent:=Self;
          if Pt.X < 0 then {if InvalidPoint(Pt) then}
            Pt:=ClientToScreen(Point(0,0));
          PopupMenu.Popup(Pt.X,Pt.Y);
          Result:=1;
        end;
      end;

      if GetCapture <> FDropDownWnd then {if popup menu has been displayed}
      begin
        SetCapture(FDropDownWnd);

        {Remove all waiting WM_LBUTTONDOWN messages - so closing popup menu by
         clicking left mouse button on the listbox will not close the listbox}
        while PeekMessage(TempMsg,FDropDownWnd,WM_LBUTTONDOWN,WM_LBUTTONDOWN,PM_REMOVE) do;
      end;
    finally
      Dec(FHandlingDropDownContextMenu);
    end;
  end;
end;

(******************************************************************************)

type
  TPopupListEx = class(TPopupList)
  protected
    procedure WndProc(var Message : TMessage); override;
  end;

{If the component, which is displaying a popup menu, is a combobox,
 close its listbox when the popup menu item has been executed}
procedure TPopupListEx.WndProc(var Message : TMessage);
var
  I : Integer;
begin
  with Message do
  begin
    if Msg = WM_COMMAND then
      Result:=1; {not handled}

    inherited;

    if Result = 0 then
      Exit;
    Result:=0;

    for I:=0 to Count-1 do
    with TPopupMenu(Items[I]) do
    if FindItem(wParam,fkCommand) <> nil then
    begin
      if PopupComponent is TComboBox then
      with TComboBox(PopupComponent) do
        DroppedDown:=False;
      Break;
    end;
  end;
end;

var
  PopupListEx : TPopupListEx;
initialization
  {Replace PopupList global variable with TPopupListEx object}
  PopupListEx:=TPopupListEx.Create;
  while PopupList.Count > 0 do
  try
    PopupListEx.Add(PopupList[0]);
  finally
    PopupList.Remove(PopupList[0]); {Force DeallocateHWnd call for the last item}
  end;
  PopupList.Free;
  PopupList:=TPopupList(PopupListEx);
end.

Code: Select all

procedure TForm1.ComboBox1ContextPopup(Sender: TObject; MousePos: TPoint; var Handled: Boolean);
begin
  with Sender as TComboBox do
  if PopupMenu <> nil then
  if PopupMenu.Items.Count > 0 then
    PopupMenu.Items[0].Caption:=Text;
end;

Code: Select all

procedure TForm1.ComboBox1ContextPopup(Sender: TObject; MousePos: TPoint; var Handled: Boolean);
begin
  with Sender as TComboBox do
  if PopupMenu <> nil then
  if PopupMenu.Items.Count > 0 then
  begin
    PopupMenu.Items[0].Caption:=Text;
    MousePos:=ClientToScreen(MousePos);
    PopupMenu.PopupComponent:=TComboBox(Sender); {important!}
    PopupMenu.Popup(MousePos.X,MousePos.Y);
    Handled:=True;
  end;
end;

Code: Select all

type
  TWMContextMenu = packed record
    Msg: Cardinal;
    hWnd: HWND;
    case Integer of
      0: (
        XPos: Smallint;
        YPos: Smallint);
      1: (
        Pos: TSmallPoint;
        Result: Longint);
  end;

Code: Select all

      Handled:=False;
//      DoContextPopup(TempPt,Handled);
//      Result:=Ord(Handled);