В оконной процедуре там делается кое-что лишнее связанное с отрисовкой пунктов меню - 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;
Комментариев нет:
Отправить комментарий