суббота, 13 июля 2013 г.

Ещё смешное из VCL

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

Комментариев нет:

Отправить комментарий