Is a themed Main Menu with icons possible in Delph

I'm using Delphi 7. Testing this on Windows 7.

Drop a TMainMenu and a TImageList on a form. Add some menus to the TMainMenu and some images to the TImageList. When the TImageList is NOT assigned to the TMainMenu's Images property, the application looks like this:

But once the TImageList is assigned to the TMainMenu's Images property, the application looks like this:

Further more, if the Images property is changed (assigned or unassigned) at run-time, only the submenu items change, the root menu items (File, Edit, Tools, Settings, and Help in my example application) never change -- they always stay themed if the Images property was not assigned at design time, or they always stay non-themed if the Images property was assigned at design time.

And finally, all of this is happening whether or not XPManifest is used.

So, my questions are:

1. Why is the theming disappearing when icons are used? I would guess that icons are drawn internally using something like Owner Drawing, which breaks the theming, but that's just a guess.

2. Why is the main menu themed, even when XPManifest is not used?

3. And most importantly, how can I have a themed menu with icons?

I hope this answer does not come across as too much of a rant, but this is an area where Embarcadero have a long history of mis-steps. I have submitted a large number of QC reports in this area so perhaps I am a little bitter. That said, the most recent releases of Delphi seem to implement menus in an acceptable way. I wasn't able to trip up XE6 menus when I took them for a spin recently. But it has taken them a long time to catch up.

Your Delphi pre-dates Vista. And Vista was the great water-shed for Windows menus. Although the theme API was introduced in XP, it had no real impact on menus. That changed in Vista. But Delphi 7 was before all that and was coded with XP in mind.

In XP, drawing menus with glyphs was not easy. The MENUITEMINFO struct has a bitmap field, hbmpItem. But in XP it is of limited use. A system drawn XP menu will not draw a clean alpha bitmap on a menu. Such menus require owner drawing. And so in the Delphi 7 code, if your menu has any glyphs then it will be owner drawn. And owner drawn using the XP APIs.

That explains the difference between the two screenshots in your question. The themed screenshot is a menu with no glyphs. The Delphi 7 menus code asks the system to draw the menu. And it draws themed menus. With or without the comctl32 manifest. That's the standard menu on Vista and later.

And when you add glyphs, the VCL code which only knows about XP, decides to owner draw the menus. And does so using XP functionality. After all, it cannot be expected to use the Vista themed menu APIs. The code pre-dates those.

Modern versions of Delphi have gradually added support for Vista themed menus. The original implementations in the Menus unit were, in all honesty, pitiful. The Embarcadero designers elected to draw the menus using the theme API. An API that is, to all intents and purposes, undocumented. Probably the best source of information on that API is the Delphi source code (!), and the Wine source code. It is pointless looking to MSDN for help here. So, I do have sympathy for Embarcadero here, for the poor engineer who had to work this out. And take 5 releases of the software to flush out the bugs.

However, Embarcadero do also deserve a smattering of opprobrium. For it is possible to get the system to draw themed menus on Vista and up that contain glyphs. The secret is the hbmpItem field. Although it was of limited use on XP, it comes into its own on Vista. You won't find documentation of this anywhere. The only good source of documentation, a blog article published by an MS staffer on the Shell Revealed blog, has for some reason been removed from the internet (but captured by archive.org). But the details are simple enough. Put a PARGB32 bitmap into hbmpItem, and let the system draw the menu. And then it's all good.

Of course the Delphi Menus unit doesn't make this easy to achieve. In fact it is not possible with that unit in vanilla form. In order to make this happen you need to modify the code in that unit. You need to change the code which elects to custom draw the menu. And instead create PARGB32 bitmaps to be placed in hbmpItem, and ask the system to paint them. This takes a degree of skill, not least because you need to manage the lifetime of the PARGB32 bitmaps to avoid resource leaks.

So, that's how you achieve a themed menu with icons in Delphi 7. I actually implemented this for Delphi 6 at the time, but the code is the same. And even in my current codebase which is in XE3, I still use the same approach. Why? Because I trust the system to draw the menus more than I trust the VCL code.

I cannot share the code easily because it involves modifications to the Menus unit in a handful of places. And the Menus code is not mine to share. But the essentials are:

Don't owner draw the menu for Vista and later. Note that you still need owner draw for XP.
Create PARGB32 bitmap versions of your icons.
Put these bitmaps into hbmpItem and let the system do the rest.

A good place to look for ideas on this is the Tortoise SVN source code. That uses this undocumented technique to paint its themed glyph heavy menus.

Some links:

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-Adding-icons-to-standard-menus.aspx

I dug out some of my code from the Delphi 6 time frame. I'm sure it is still applicable.

Right at the top of the interface section of my modified version of the Menus unit I declared this interface:

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

This is implemented by an image list class and is used to provide PARGB32 bitmaps. Then in TMenuItem.AppendTo, if the version is Vista or up, and if the VCL code is planning to owner draw, I set IsOwnerDraw to False. And then use IImageListConvertIconToPARGB32Bitmap to get a PARGB32 bitmap.

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;

The implementation of the image list looks like this:

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;