A quick and Dirty solution for your problem :
I just nedeed PopupMenus to be Ownerdrawn so this program doesn't works
fine with
MainMenus.
I hope it could help you :-)
Jean-Luc Mattei
France
jl...@club-internet.fr
unit ExMenus;
interface
uses Windows, SysUtils, Classes, Messages, Menus, DsgnIntf, Forms,
Controls, StdCtrls, Graphics;
type
TDrawMenuItemEvent = procedure(Control: TMenu; Index: Integer;
Rect: TRect; State: TOwnerDrawState) of object;
TMeasureMenuItemEvent = procedure(Control: TMenu; Index: Integer;
var Height, Width: Integer) of object;
TMenuExtender = class(TComponent)
private
FCanvas: TCanvas;
FMenu: TMenu;
FFont: TFont;
FBrush: TBrush;
FItemHeight: Integer;
FItemWidth: Integer;
FTPUHandle: THandle;
FNewWndProcInstance: Pointer;
FOldWndProc: Pointer;
FOnDrawItem: TDrawMenuItemEvent;
FOnMeasureItem: TMeasureMenuItemEvent;
protected
procedure SetMenu(Value: TMenu);
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
procedure CNMeasureItem(var Message: TWMMeasureItem); message
CN_MEASUREITEM;
procedure DrawItem(Index: Integer; Rect: TRect; State:
TOwnerDrawState); virtual;
procedure MeasureItem(Index: Integer; var Height, Width: Integer);
virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure NewWndProc(Var Message: TMessage);
published
property Menu: TMenu read FMenu write SetMenu;
property OnDrawItem: TDrawMenuItemEvent read FOnDrawItem write
FOnDrawItem;
property OnMeasureItem: TMeasureMenuItemEvent read FOnMeasureItem write
FOnMeasureItem;
property ItemHeigth: Integer read FItemHeight write FItemHeight;
property ItemWidth: Integer read FItemWidth write FItemWidth;
property Font: TFont read FFont write FFont;
property Color: TBrush read FBrush write FBrush;
property Canvas: TCanvas read FCanvas;
end;
procedure Register;
implementation
const FTPUCount: Integer = 0;
{ TMenuExtender }
constructor TMenuExtender.Create(AOwner: TComponent);
begin
// TPUtilWindow is a @#!!##@& window created by delphi
// It's defaultProc Eats WM_DRAWITEM and WM_MEASUREITEM from Menus !!!
???
// So We Have to Override this problem :
// Get the Handle of this @#!!##@& window
Inc(FTPUCount);
if ( FTPUCount = 1 ) then begin
FTPUHandle:= FindWindow('TPUtilWindow', '');
// Create a new proc pointer
FNewWndProcInstance := MakeObjectInstance(NewWndProc);
// Keep the old DefaultProc
FOldWndProc := Pointer(GetWindowLong(FTPUHandle, GWL_WNDPROC));
// Set the new Proc
SetWindowLong(FTPUHandle, GWL_WNDPROC, Longint(FNewWndProcInstance));
end;
FMenu:= nil;
inherited Create(AOwner);
FCanvas:= TCanvas.Create;
FItemHeight:= 15;
FItemWidth:= 100;
FFont:= TFont.Create;
FBrush:= TBrush.Create;
FBrush.Color:= clBtnFace;
FOnDrawItem:= nil;
FOnMeasureItem:= nil;
end;
destructor TMenuExtender.Destroy;
begin
FFont.Free;
FBrush.Free;
FCanvas.Free;
Dec(FTPUCount);
// We have to set back the old default Proc
SetWindowLong(FTPUHandle, GWL_WNDPROC, Longint(FOldWndProc));
// and to release Our WndProc instance
FreeObjectInstance(FNewWndProcInstance);
inherited Destroy;
end;
procedure TMenuExtender.SetMenu(Value: TMenu);
Var i: Integer;
begin
if ( FMenu <> Value ) then begin
if ( FMenu <> nil ) and ( Value = nil ) then begin
for i:= 0 to FMenu.Items.Count - 1 do begin
if ( FMenu.Items[i].Break <> mbBarBreak ) then
ModifyMenu(FMenu.Handle, FMenu.Items[i].Command, MF_BYCOMMAND,
FMenu.Items[i].Command, nil);
end;
end
else begin
if ( FMenu = nil ) and ( Value <> nil ) then begin
FMenu:= Value;
for i:= 0 to FMenu.Items.Count - 1 do begin
if ( FMenu.Items[i].Break <> mbBarBreak ) then
ModifyMenu(FMenu.Handle, FMenu.Items[i].Command, MF_BYCOMMAND
or MF_OWNERDRAW, FMenu.Items[i].Command, nil)
else
ModifyMenu(FMenu.Handle, FMenu.Items[i].Command, MF_BYCOMMAND
or MF_OWNERDRAW or MF_MENUBREAK, FMenu.Items[i].Command, nil)
end;
end;
end;
FMenu:= Value;
end;
end;
procedure TMenuExtender.CNDrawItem(var Message: TWMDrawItem);
var
State: TOwnerDrawState;
begin
with Message.DrawItemStruct^ do
begin
State := TOwnerDrawState(WordRec(LongRec(itemState).Lo).Lo);
FCanvas.Handle := hDC;
FCanvas.Font := FFont;
FCanvas.Brush := FBrush;
if (Integer(itemID) >= 0) and (odSelected in State) then
begin
FCanvas.Brush.Color := clHighlight;
FCanvas.Font.Color := clHighlightText
end;
if Integer(itemID) >= 0 then
DrawItem(itemID, rcItem, State) else
FCanvas.FillRect(rcItem);
if odFocused in State then DrawFocusRect(hDC, rcItem);
FCanvas.Handle := 0;
end;
end;
procedure TMenuExtender.CNMeasureItem(var Message: TWMMeasureItem);
begin
with Message.MeasureItemStruct^ do
begin
itemHeight := FItemHeight;
itemWidth := FItemWidth;
MeasureItem(itemID, Integer(itemHeight), Integer(itemWidth));
end;
end;
procedure TMenuExtender.NewWndProc(Var Message: TMessage);
begin
// Only used to handle WM_DRAWITEM and WM_MEASUREITEM from Menus
if ( FMenu <> nil ) then begin
case Message.Msg of
WM_DRAWITEM : if ( TWMDrawItem(Message).DrawItemStruct^.CtlType =
ODT_MENU ) and
( TWMDrawItem(Message).DrawItemStruct^.hwndItem =
FMenu.Handle ) then begin
Message.Msg:= Message.Msg + CN_BASE;
Dispatch(Message);
end;
WM_MEASUREITEM : if ( TWMMeasureItem(Message).idCtl = 0 ) then begin
Message.Msg:= Message.Msg + CN_BASE;
Dispatch(Message);
end;
end;
end;
// else we call the old DefaultProc.
Message.Result:= CallWindowProc(FOldWndProc, FTPUHandle, Message.Msg,
Message.WParam, Message.LParam);
end;
procedure TMenuExtender.MeasureItem(Index: Integer; var Height, Width:
Integer);
begin
if Assigned(FOnMeasureItem) then FOnMeasureItem(FMenu, Index, Height,
Width)
end;
procedure TMenuExtender.DrawItem(Index: Integer; Rect: TRect;
State: TOwnerDrawState);
begin
if Assigned(FOnDrawItem) then FOnDrawItem(FMenu, Index, Rect, State)
else
begin
FCanvas.FillRect(Rect);
FCanvas.TextOut(Rect.Left + 2, Rect.Top, FMenu.Items[Index-1].Caption);
end;
end;
procedure Register;
begin
RegisterComponents('Exemples', [TMenuExtender]);
end;
end.
