Description : contient l'objet LRJ_TPopupList qui contient les LRJ_TPopUpMenu disponibles
dans l'application. Contient l'objet LRJ_TPopUpMenu qui implémente une procédure of object permettant
d'être notifié lorsque le PopUp menu se referme et une propriété permettant d'aligner les
items du PopUp menu vers la droite ou la gauche.
Utilise les unités : Windows, Classes, Messages, Forms, Menus et
LRJ_ClassesPlus.
implementation
type
Int_TPopupList = class(TPopupList);
var
IntPricList : LRJ_TPopupList;
{--------------------------------------------------------------}
{--------------------------------------------------------------}
{----------------------- LRJ_TPopUpMenu ---------------------------------------}
{--------------------------------------------------------------}
{--------------------------------------------------------------}
procedure LRJ_TPopUpMenu.SetRightToLeftPopUp(ABool: boolean);
var
MenuItemInfo: TMenuItemInfo;
Buffer: array[0..79] of Char;
begin
FillChar(MenuItemInfo, sizeOf(MenuItemInfo), 0);
FillChar(Buffer, sizeOf(Buffer), 0);
MenuItemInfo.cbSize := 44;
MenuItemInfo.fMask := MIIM_TYPE;
MenuItemInfo.dwTypeData := Buffer;
MenuItemInfo.cch := SizeOf(Buffer);
if GetMenuItemInfo(items.Handle, 0, true, MenuItemInfo) then
begin
if ABool then
MenuItemInfo.fType := MenuItemInfo.fType or MFT_RIGHTORDER
else
if (MenuItemInfo.fType or MFT_RIGHTORDER) = MenuItemInfo.fType then
MenuItemInfo.fType := MenuItemInfo.fType xor MFT_RIGHTORDER;
MenuItemInfo.fMask := MIIM_TYPE;
if SetMenuItemInfo(items.Handle, 0, True, MenuItemInfo) then
DrawMenuBar(WindowHandle);
end;
end;
{--------------------------------------------------------------}
procedure LRJ_TPopUpMenu.SetIfSetRightToLeftPopUp(ABool: boolean);
begin
if ABool <> MOIfSetRightToLeftPopUp then
begin
MOIfSetRightToLeftPopUp := ABool;
SetRightToLeftPopUp(MOIfSetRightToLeftPopUp);
end;
end;
{--------------------------------------------------------------}
procedure LRJ_TPopUpMenu.DoOnClose;
begin
if assigned(MOOnClose) then MOOnClose(self);
end;
{--------------------------------------------------------------}
procedure LRJ_TPopUpMenu.Popup(X, Y: Integer);
begin
if assigned(IntPricList) then
IntPricList.MOLastPopUpOuvert := self;
if MOIfSetRightToLeftPopUp then SetRightToLeftPopUp(MOIfSetRightToLeftPopUp);
MenuAnimation := [maNone];
inherited Popup(X, Y);
end;
{--------------------------------------------------------------}
procedure LRJ_TPopUpMenu.AfterConstruction;
begin
inherited;
MOOnClose := nil;
MOIfSetRightToLeftPopUp := false;
SetRightToLeftPopUp(MOIfSetRightToLeftPopUp);
if IntPricList = nil then IntPricList := LRJ_TPopupList.create;
IntPricList.AddMenu(self);
end;
{--------------------------------------------------------------}
destructor LRJ_TPopUpMenu.Destroy;
begin
if assigned(IntPricList) then
begin
IntPricList.RemoveMenu(self);
if IntPricList.CountMenu = 0 then
begin
IntPricList.Free;
IntPricList := nil;
end;
end;
inherited;
end;
{--------------------------------------------------------------}
{--------------------------------------------------------------}
{----------------------- LRJ_TPopupList ---------------------------------------}
{--------------------------------------------------------------}
{--------------------------------------------------------------}
function LRJ_TPopupList.CountMenu: integer;
begin
result := 0;
if assigned(MOList) then result := MOList.count;
end;
{--------------------------------------------------------------}
procedure LRJ_TPopupList.AddMenu(const AMenu: LRJ_TPopUpMenu);
begin
if MOList = nil then MOList := LRJ_TList.Create;
MOList.Add(AMenu);
end;
{--------------------------------------------------------------}
procedure LRJ_TPopupList.RemoveMenu(const AMenu: LRJ_TPopUpMenu);
begin
if assigned(MOList) then MOList.remove(AMenu);
end;
{--------------------------------------------------------------}
procedure LRJ_TPopupList.AfterConstruction;
begin
inherited;
MOLastPopUpOuvert := nil;
MOList := nil;
MONewWndProc := Classes.MakeObjectInstance(LRJMainWndProc);
MOOldWndProc := TFNWndProc(GetWindowLong(PopupList.Window, GWL_WNDPROC));
SetWindowLong(PopupList.Window, GWL_WNDPROC, Longint(MONewWndProc));
end;
{--------------------------------------------------------------}
destructor LRJ_TPopupList.Destroy;
begin
SetWindowLong(PopupList.Window, GWL_WNDPROC, Longint(MOOldWndProc));
if MOList <> nil then
begin
MOList.ClearForObjetList;
MOList.Free;
end;
inherited;
end;
{--------------------------------------------------------------}
procedure LRJ_TPopupList.LRJMainWndProc(var Message: TMessage);
begin
try
LRJWndProc(Message);
except
Application.HandleException(Self);
end;
end;
{--------------------------------------------------------------}
procedure LRJ_TPopupList.LRJWndProc(var Message: TMessage);
begin
with Message do
begin
case Msg of
WM_EXITMENULOOP:
begin
if assigned(MOLastPopUpOuvert) then
begin
MOLastPopUpOuvert.DoOnClose;
MOLastPopUpOuvert := nil;
end;
end;
end;
Int_TPopupList(PopupList).WndProc(Message);
end;
end;
{--------------------------------------------------------------}
{--------------------------------------------------------------}
{----------------------- fin ---------------------------------------}
{--------------------------------------------------------------}
{--------------------------------------------------------------}
initialization
IntPricList := nil;
finalization
if assigned(IntPricList) then IntPricList.free;
end.
