Является ли тематическое Главное меню с иконками в Delphi?

Ответ 1

Я надеюсь, что этот ответ не назовешь слишком большим количеством напыщенности, но это та область, где Embarcadero имеет долгую историю ошибочных шагов. Я представил большое количество отчетов по контролю качества в этой области, поэтому, возможно, я немного горький. Тем не менее, последние выпуски Delphi, похоже, реализуют меню приемлемым образом. Мне не удалось отключить меню XE6, когда я взял их за спину. Но им потребовалось много времени, чтобы наверстать упущенное.

Предварительная дата Delphi Vista. И Vista была отличным водоемом для меню Windows. Хотя API-интерфейс темы был введен в XP, он не оказал реального влияния на меню. Это изменилось в Vista. Но Delphi 7 был до этого и был закодирован с XP в виду.

В XP рисование меню с помощью глифов было непростым. Структура MENUITEMINFO имеет поле растрового изображения, hbmpItem. Но в XP это ограниченное использование. Системное графическое меню XP не отображает чистый альфа-растровый рисунок в меню. Такие меню требуют рисования владельца. И поэтому в коде Delphi 7, если в вашем меню есть какие-либо глифы, тогда он будет нарисован владельцем. И владелец обращается с использованием API-интерфейсов XP.

Это объясняет разницу между двумя скриншотами в вашем вопросе. Тематический скриншот - это меню без глифов. Меню меню Delphi 7 требует, чтобы система рисовала меню. И он рисует тематические меню. С манифестом comctl32 или без него. Это стандартное меню в Vista и позже.

И когда вы добавляете глифы, код VCL, который знает только о XP, решает владелец рисовать меню. И делает это с использованием функциональности XP. В конце концов, нельзя ожидать использования API-интерфейсов Vista с тематическим меню. Код предшествует этому.

Современные версии Delphi постепенно добавили поддержку тематических меню Vista. Первоначальные реализации в блоке Menus были, честно говоря, жалкими. Дизайнеры Embarcadero решили нарисовать меню, используя API-интерфейс темы. API, который, во всех смыслах и целях, недокументирован. Вероятно, лучшим источником информации об этом API является исходный код Delphi (!) И исходный код Wine. Здесь бессмысленно искать MSDN. Итак, у меня есть симпатия к Embarcadero здесь, для плохого инженера, который должен был это обработать. И возьмите 5 выпусков программного обеспечения, чтобы очистить ошибки.

Тем не менее, Эмбаркадеро также заслуживает небольшого количества прозрений. Для этого можно заставить систему рисовать тематические меню на Vista и вверх, содержащие глифы. Секрет - это поле hbmpItem. Хотя он был ограниченным использованием в XP, он приходит в себя на Vista. Вы нигде не найдете документацию. Единственный хороший источник документации - статья блога, опубликованная сотрудником MS в блоге Shell Revealed, по какой-то причине была удалена из Интернета (но захвачена archive.org). Но детали достаточно просты. Поместите растровое изображение PARGB32 в hbmpItem, и пусть система рисует меню. И тогда все хорошо.

Конечно, модуль Delphi Menus не делает этого легко достижимым. На самом деле это невозможно с этой единицей в ванильной форме. Чтобы это произошло, вам необходимо изменить код в этом блоке. Вам нужно изменить код, который выбирает пользовательский, нарисовать меню. И вместо этого создайте растровые изображения PARGB32, которые будут размещены в hbmpItem, и попросите систему их нарисовать. Это требует определенного уровня мастерства, не в последнюю очередь потому, что вам нужно управлять временем жизни растровых изображений PARGB32, чтобы избежать утечек ресурсов.

Итак, как вы достигли тематического меню с иконками в Delphi 7. Я действительно реализовал это для Delphi 6 в то время, но код тот же. И даже в моей текущей кодовой базе, которая находится в XE3, я по-прежнему использую тот же подход. Зачем? Поскольку я доверяю системе рисовать меню больше, чем доверяю VCL-коду.

Я не могу легко передать код, потому что он включает в себя изменения в блоке Menus в нескольких местах. И код Menus не принадлежит мне. Но главное:

• Не владелец рисует меню для Vista и позже. Обратите внимание, что вам по-прежнему нужен лимит владельца для XP.
• Создайте растровые версии PARGB32 ваших значков.
• Поместите эти растровые изображения в hbmpItem, и пусть система сделает все остальное.

Хорошим местом для поиска идей является исходный код Tortoise SVN. Это использует эту недокументированную технику для рисования своих тематических глифов тяжелыми меню.

Некоторые ссылки:

• http://www.nanoant.com/programming/themed-menus-icons-a-complete-vista-xp-solution
• http://tortoisesvn.tigris.org/ds/viewMessage.do?dsForumId=757&dsMessageId=892948
• http://web.archive.org/web/20080422080614/http://shellrevealed.com/blogs/shellblog/archive/2007/02/06/Vista-Style -Menus_2C00_-Part-1-2D00-Добавление-иконки-на-стандарт-menus.aspx

Я выкопал часть своего кода из временного интервала Delphi. Я уверен, что он по-прежнему применим.

В верхней части раздела интерфейса моей измененной версии модуля Menus я объявил этот интерфейс:

type
  IImageListConvertIconToPARGB32Bitmap = interface
    ['{4D3E7D64-1288-4D0D-98FC-E61501573204}']
    function GetPARGB32Bitmap(ImageIndex: Integer): HBITMAP;
  end;

Это реализуется классом списка изображений и используется для создания растровых изображений PARGB32. Затем в TMenuItem.AppendTo, если версия Vista или выше, и если код VCL планирует провести рисование владельца, я устанавливаю IsOwnerDraw в False. И затем используйте IImageListConvertIconToPARGB32Bitmap, чтобы получить растровое изображение PARGB32.

if Supports(GetImageList, IImageListConvertIconToPARGB32Bitmap, Intf) then 
begin
  BitmapHandle := Intf.GetPARGB32Bitmap(ImageIndex);
  if BitmapHandle<>0 then 
  begin
    MenuItemInfo.fMask := MenuItemInfo.fMask or MIIM_BITMAP;
    MenuItemInfo.hbmpItem := BitmapHandle;
  end;
end;

Реализация списка изображений выглядит следующим образом:

type
  TMyImageList = class(TImageList, IImageListConvertIconToPARGB32Bitmap)
  private
    FPARGB32BitmapHandles: array of HBITMAP;
    procedure DestroyPARGB32BitmapHandles;
    function CreatePARGB32BitmapFromIcon(ImageIndex: Integer): HBITMAP;
  protected
    procedure Change; override;
  public
    destructor Destroy; override;
    function GetPARGB32Bitmap(ImageIndex: Integer): HBITMAP;
  end;

destructor TMyImageList.Destroy;
begin
  DestroyPARGB32BitmapHandles;
  inherited;
end;

function TMyImageList.GetPARGB32Bitmap(ImageIndex: Integer): HBITMAP;
begin
  if InRange(ImageIndex, 0, Count-1) then begin
    SetLength(FPARGB32BitmapHandles, Count);
    if FPARGB32BitmapHandles[ImageIndex]=0 then begin
      FPARGB32BitmapHandles[ImageIndex] := CreatePARGB32BitmapFromIcon(ImageIndex);
    end;
    Result := FPARGB32BitmapHandles[ImageIndex];
  end else begin
    Result := 0;
  end;
end;

procedure TMyImageList.Change;
begin
  inherited;
  DestroyPARGB32BitmapHandles;
end;

procedure TMyImageList.DestroyPARGB32BitmapHandles;
var
  i: Integer;
begin
  for i := 0 to high(FPARGB32BitmapHandles) do begin
    if FPARGB32BitmapHandles[i]<>0 then begin
      DeleteObject(FPARGB32BitmapHandles[i]);
    end;
  end;
  Finalize(FPARGB32BitmapHandles);
end;

type
  TWICRect = record
    X, Y, Width, Height: Integer;
  end;

  IWICBitmapSource = interface//only GetSize and CopyPixels have been correctly defined
    ['{00000120-A8F2-4877-BA0A-FD2B6645FB94}']
    function GetSize(out Width, Height: UINT): HResult; stdcall;
    function GetPixelFormat: HResult; stdcall;
    function GetResolution: HResult; stdcall;
    function CopyPalette: HResult; stdcall;
    function CopyPixels(const rc: TWICRect; cbStride, cbBufferSize: UINT; Buffer: Pointer): HResult; stdcall;
  end;

  IWICImagingFactory = interface//only CreateBitmapFromHICON has been correctly defined
    ['{EC5EC8A9-C395-4314-9C77-54D7A935FF70}']
    function CreateDecoderFromFileName: HRESULT; stdcall;
    function CreateDecoderFromStream: HRESULT; stdcall;
    function CreateDecoderFromFileHandle: HRESULT; stdcall;
    function CreateComponentInfo: HRESULT; stdcall;
    function CreateDecoder: HRESULT; stdcall;
    function CreateEncoder: HRESULT; stdcall;
    function CreatePalette: HRESULT; stdcall;
    function CreateFormatConverter: HRESULT; stdcall;
    function CreateBitmapScaler: HRESULT; stdcall;
    function CreateBitmapClipper: HRESULT; stdcall;
    function CreateBitmapFlipRotator: HRESULT; stdcall;
    function CreateStream: HRESULT; stdcall;
    function CreateColorContext: HRESULT; stdcall;
    function CreateColorTransformer: HRESULT; stdcall;
    function CreateBitmap: HRESULT; stdcall;
    function CreateBitmapFromSource: HRESULT; stdcall;
    function CreateBitmapFromSourceRect: HRESULT; stdcall;
    function CreateBitmapFromMemory: HRESULT; stdcall;
    function CreateBitmapFromHBITMAP: HRESULT; stdcall;
    function CreateBitmapFromHICON(Icon: HICON; out Bitmap: IWICBitmapSource): HRESULT; stdcall;
    function CreateComponentEnumerator: HRESULT; stdcall;
    function CreateFastMetadataEncoderFromDecoder: HRESULT; stdcall;
    function CreateFastMetadataEncoderFromFrameDecode: HRESULT; stdcall;
    function CreateQueryWriter: HRESULT; stdcall;
    function CreateQueryWriterFromReader: HRESULT; stdcall;
  end;

var
  ImagingFactory: IWICImagingFactory;
  ImagingFactoryCreationAttempted: Boolean;

function TMyImageList.CreatePARGB32BitmapFromIcon(ImageIndex: Integer): HBITMAP;
const
  CLSID_WICImagingFactory: TGUID = '{CACAF262-9370-4615-A13B-9F5539DA4C0A}';
var
  Icon: THandle;
  Bitmap: IWICBitmapSource;
  cx, cy, cbStride, cbBuffer: UINT;
  bmi: TBitmapInfo;
  bits: Pointer;
begin
  Try
    Result := 0;
    if not Assigned(ImagingFactory) then begin
      if ImagingFactoryCreationAttempted then begin
        exit;
      end;
      ImagingFactoryCreationAttempted := True;
      if not Succeeded(CoCreateInstance(CLSID_WICImagingFactory, nil, CLSCTX_INPROC_SERVER, IWICImagingFactory, ImagingFactory)) then begin
        exit;
      end;
    end;
    Icon := ImageList_GetIcon(Handle, ImageIndex, ILD_NORMAL);
    if Icon<>0 then begin
      if Succeeded(ImagingFactory.CreateBitmapFromHICON(Icon, Bitmap)) and Succeeded(Bitmap.GetSize(cx, cy)) then begin
        ZeroMemory(@bmi, SizeOf(bmi));
        bmi.bmiHeader.biSize := SizeOf(bmi.bmiHeader);
        bmi.bmiHeader.biPlanes := 1;
        bmi.bmiHeader.biCompression := BI_RGB;
        bmi.bmiHeader.biWidth := cx;
        bmi.bmiHeader.biHeight := -cy;
        bmi.bmiHeader.biBitCount := 32;
        Result := CreateDIBSection(0, bmi, DIB_RGB_COLORS, bits, 0, 0);
        if Result<>0 then begin
          cbStride := cx*SizeOf(DWORD);
          cbBuffer := cy*cbStride;
          if not Succeeded(Bitmap.CopyPixels(TWICRECT(nil^), cbStride, cbBuffer, bits)) then begin
            DeleteObject(Result);
            Result := 0;
          end;
        end;
      end;
      DestroyIcon(Icon);
    end;
  Except
    //none of the methods called here raise exceptions, but we still adopt a belt and braces approach
    Result := 0;
  End;
end;