ghisler(Author) is right - combobox control by default doesn't handle right clicks, when dropped down.
However, here comes a solution:
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.
Usage example: attach this unit _after_ StdCtrls, create combobox, assign a popup menu to the combobox and try:
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;
or:
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;
)