В оконной процедуре там делается кое-что лишнее связанное с отрисовкой пунктов меню - WM_DRAWITEM и WM_MEASUREITEM. Если мы правильно всё поняли. Вот правки:
procedure Tl3Form.WndProc(var Message: TMessage);
//override;
{-}
var
SaveIndex : Integer;
MenuItem : TMenuItem;
DC : HDC;
begin
with Message do
case Msg of
WM_DRAWITEM:
if (Message.wParam = 0) then {V - WM_DRAWITEM посылает не только Menu, Message.wParam = 0 это точно Меню}
with PDrawItemStruct(Message.LParam)^ do
if (CtlType = ODT_MENU) and Assigned(Menu) then
begin
MenuItem := Menu.FindItem(itemID, fkCommand);
if (MenuItem <> nil) then
begin
if (f_Canvas = nil) then
f_Canvas := TCanvas.Create;
with f_Canvas do
try
SaveIndex := SaveDC(hDC);
try
Handle := hDC;
Font := Screen.MenuFont;
Menus.DrawMenuItem(MenuItem, f_Canvas, rcItem,
TOwnerDrawState(LongRec(itemState).Lo));
finally
Handle := 0;
RestoreDC(hDC, SaveIndex)
end;
finally
//Free;
end;//try..finally
Exit;
end;//MenuItem <> nil
end;//CtlType = ODT_MENU..
WM_MEASUREITEM:
if (Message.wParam = 0) then {V - WM_DRAWITEM посылает не только Menu, Message.wParam = 0 это точно Меню}
with PMeasureItemStruct(Message.LParam)^ do
if (CtlType = ODT_MENU) and Assigned(Menu) then
begin
MenuItem := Menu.FindItem(itemID, fkCommand);
if (MenuItem <> nil) then
begin
DC := GetWindowDC(Handle);
try
if (f_Canvas = nil) then
f_Canvas := TCanvas.Create;
with f_Canvas do
try
SaveIndex := SaveDC(DC);
try
Handle := DC;
Font := Screen.MenuFont;
TMenuItemAccess(MenuItem).MeasureItem(f_Canvas,
Integer(itemWidth), Integer(itemHeight));
finally
Handle := 0;
RestoreDC(DC, SaveIndex);
end;
finally
//f_Canvas.Free;
end;//try..finally
finally
ReleaseDC(Handle, DC);
end;//try..finally
Exit;
end;//MenuItem <> nil
end;//CtlType = ODT_MENU..
end;//case Msg of
inherited;
end;
Комментариев нет:
Отправить комментарий