德尔福 – 与alpha混合图标的图像列表失去透明度

我已经测试了@TOndrej answer.但似乎我需要启用视觉样式(XP Manifest)才能工作(将使用版本6.0的Windows常用控件 – 我现在不想要).我通过ExtractIconEx和ImageList_AddIcon在运行时添加图标.

显然将ImageList.Handle设置为使用System Image-List句柄,不需要XP Manifest.因此,当我使用系统图像列表显示文件列表(使用TListView)时,即使是我在D3中写回的旧程序也正确显示alpha混合图标.

我在徘徊系统图像列表有什么特别之处以及它是如何创建的,所以它在所有情况下都支持alpha混合？我无法弄明白.以下是一些示例代码：

unit Unit1;

interface

uses
  Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,Dialogs,Menus,ImgList,StdCtrls,ShellAPI,ExtCtrls,Commctrl;

type
  TForm1 = class(TForm)
    ImageList1: TImageList;
    PopupMenu1: TPopupMenu;
    MenuItem1: TMenuItem;
    Button1: TButton;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    FileName: string;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
// {$R WindowsXP.res}

procedure TForm1.FormCreate(Sender: TObject);
begin
  PopupMenu1.Images := ImageList1;
  FileName := 'C:Program FilesMozilla Firefoxfirefox.exe';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  IconPath: string;
  IconIndex: Integer;
  hIconLarge,hIconSmall: HICON;
begin
  IconPath := FileName;
  IconIndex := 0; // index can be other than 0

  ExtractIconEx(PChar(IconPath),IconIndex,hIconLarge,hIconSmall,1);

  Self.Refresh; // erase form
  DrawIconEx(Canvas.Handle,10,16,DI_IMAGE or DI_MASK); // this will draw ok on the form

  // ImageList1.DrawingStyle := dsTransparent;
  ImageList1.Handle := ImageList_Create(ImageList1.Width,ImageList1.Height,{ILC_COLORDDB} ILC_COLOR32 or ILC_MASK,ImageList1.AllocBy);
  ImageList_AddIcon(ImageList1.Handle,hIconSmall);

  MenuItem1.ImageIndex := 0;

  DestroyIcon(hIconSmall);
  DestroyIcon(hIconLarge);

  PopupMenu1.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
end;

procedure TForm1.Button2Click(Sender: TObject);
// using sys image-list will work with or without Manifest
type
  DWORD_PTR = DWORD;
var
  ShFileINfo :TShFileInfo;
  SysImageList: DWORD_PTR;
  FileName: string;
begin
  SysImageList := ShGetFileInfo(nil,ShFileInfo,SizeOf(ShFileInfo),SHGFI_SYSICONINDEX OR SHGFI_SMALLICON);

  if SysImageList = 0 then Exit;
  ImageList1.Handle := SysImageList;
  ImageList1.ShareImages := True;

  if ShGetFileInfo(PChar(FileName),SHGFI_SYSICONINDEX OR SHGFI_ICON OR SHGFI_SMALLICON) <> 0 then
  begin
    MenuItem1.ImageIndex := ShFileInfo.IIcon;
    Self.Refresh; // erase form
    DrawIconEx(Canvas.Handle,ShFileInfo.hIcon,DI_IMAGE or DI_MASK);
    DestroyIcon(ShFileInfo.hIcon); // todo: do I need to destroy here? 

    PopupMenu1.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
  end;      
end;

end.

视觉样式已禁用：

视觉样式已启用：

解决方法是使用插入器类或子类TImageList并覆盖DoDraw as shown here,但我真正想知道的是如何创建与系统映像列表相同的映像列表.

注意：我知道TPngImageList并且在这种情况下不想使用它.

编辑：
@ David的回答(和评论)准确无误：

You’ll have to explicitly link to ImageList_Create (v6) because
otherwise it is implicitly linked at module load time and will be
bound to v5.8

示例代码(不使用激活上下文API)：

function ImageList_Create_V6(CX,CY: Integer; Flags: UINT; Initial,Grow: Integer): HIMAGELIST;
var
  h: HMODULE;
  _ImageList_Create: function(CX,CY: Integer; Flags: UINT;
    Initial,Grow: Integer): HIMAGELIST; stdcall;
begin
  // TODO: find comctl32.dll v6 path programmatically
  h := LoadLibrary('C:WINDOWSWinSxSx86_Microsoft.Windows.Common-Controls_6595b64144ccf1df_6.0.2600.5512_x-ww_35d4ce83comctl32.dll');
  if h <> 0 then
  try
    _ImageList_Create := GetProcAddress(h,'ImageList_Create');
    if Assigned(_ImageList_Create) then
      Result := _ImageList_Create(CX,CY,Flags,Initial,Grow);
  finally
    FreeLibrary(h);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ...
  ImageList1.Handle := ImageList_Create_V6(ImageList1.Width,ILC_COLOR32 or ILC_MASK,ImageList1.AllocBy);
  ...
end;

Edi2：A sample code by @David,它通过激活上下文API显示它是如何正确完成的.