comctl32 v6 activation context for kobik

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.CommCtrl, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus, Vcl.StdCtrls, Vcl.ImgList, Winapi.ShellAPI;

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}

procedure TForm1.FormCreate(Sender: TObject);
begin
  PopupMenu1.Images := ImageList1;
  FileName := 'C:\Program Files (x86)\Embarcadero\RAD Studio\9.0\bin\bds.exe';
end;

type
  (* TActivationContext is a loose wrapper around the Windows Activation Context API and can be used
     to ensure that comctl32 v6 and visual styles are available for UI elements created from a DLL .*)
  TActivationContext = class
  private
    FCookie: LongWord;
    FSucceeded: Boolean;
  public
    constructor Create;
    destructor Destroy; override;
  end;

var
  ActCtxHandle: THandle=INVALID_HANDLE_VALUE;
  CreateActCtx: function(var pActCtx: TActCtx): THandle; stdcall;
  ActivateActCtx: function(hActCtx: THandle; var lpCookie: LongWord): BOOL; stdcall;
  DeactivateActCtx: function(dwFlags: DWORD; ulCookie: LongWord): BOOL; stdcall;
  ReleaseActCtx: procedure(hActCtx: THandle); stdcall;

constructor TActivationContext.Create;
begin
  inherited;
  FSucceeded := (ActCtxHandle<>INVALID_HANDLE_VALUE) and ActivateActCtx(ActCtxHandle, FCookie);
end;

destructor TActivationContext.Destroy;
begin
  if FSucceeded then begin
    DeactivateActCtx(0, FCookie);
  end;
  inherited;
end;

procedure InitialiseActivationContext;
var
  ActCtx: TActCtx;
  hKernel32: HMODULE;
begin
  hKernel32 := GetModuleHandle(kernel32);
  CreateActCtx := GetProcAddress(hKernel32, 'CreateActCtxW');
  if Assigned(CreateActCtx) then begin
    ReleaseActCtx := GetProcAddress(hKernel32, 'ReleaseActCtx');
    ActivateActCtx := GetProcAddress(hKernel32, 'ActivateActCtx');
    DeactivateActCtx := GetProcAddress(hKernel32, 'DeactivateActCtx');
    ZeroMemory(@ActCtx, SizeOf(ActCtx));
    ActCtx.cbSize := SizeOf(ActCtx);
    ActCtx.lpSource := 'C:\desktop\manifest.txt';
    ActCtxHandle := CreateActCtx(ActCtx);
  end;
end;

procedure FinaliseActivationContext;
begin
  if ActCtxHandle<>INVALID_HANDLE_VALUE then begin
    ReleaseActCtx(ActCtxHandle);
  end;
end;

var
  comctllib: HMODULE;

function ImageList_Create_V6(CX, CY: Integer; Flags: UINT; Initial, Grow: Integer): HIMAGELIST;
var
  _ImageList_Create: function(CX, CY: Integer; Flags: UINT;
    Initial, Grow: Integer): HIMAGELIST; stdcall;
begin
  with TActivationContext.Create do
    try
      if comctllib=0 then
        comctllib := LoadLibrary('comctl32.dll');
      if comctllib=0 then
        RaiseLastOSError;
      _ImageList_Create := GetProcAddress(comctllib, 'ImageList_Create');
      if not Assigned(_ImageList_Create) then
        RaiseLastOSError;
      Result := _ImageList_Create(CX, CY, Flags, Initial, Grow);
    finally
      Free;
    end;
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, 10, hIconSmall, 0, 16, 16, 0,
    DI_IMAGE or DI_MASK); // this will draw ok on the form

  // ImageList1.DrawingStyle := dsTransparent;
  ImageList1.Handle := {ImageList_Create}ImageList_Create_V6(ImageList1.Width, ImageList1.Height,
    {ILC_COLORDDB} ILC_COLOR32 or ILC_MASK, 0, 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('c:\desktop\SHGetFileInfo function.htm', 0, ShFileInfo, SizeOf(ShFileInfo),
    SHGFI_SYSICONINDEX OR SHGFI_SMALLICON);

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

  if ShGetFileInfo(PChar(FileName), 0, ShFileInfo, SizeOf(ShFileInfo),
    SHGFI_SYSICONINDEX OR SHGFI_ICON OR SHGFI_SMALLICON) <> 0 then
  begin
    MenuItem1.ImageIndex := ShFileInfo.IIcon;
    Self.Refresh; // erase form
    DrawIconEx(Canvas.Handle, 10, 10, ShFileInfo.hIcon, 0, 16, 16, 0,
      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;

initialization
  InitialiseActivationContext;

finalization
  FinaliseActivationContext;

end.


**Manifest file**

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
  <dependency>
    <dependentAssembly>
      <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0"
        processorArchitecture="*" publicKeyToken="6595b64144ccf1df"/>
    </dependentAssembly>
  </dependency>
</assembly>