Iconos con transperencia en ToolBar

[Chandra_]

Esto funciona con iconos de 48x48 (es ABSURDO, pero funciona):

Código Delphi [-]
procedure TForm1.Button1Click(Sender: TObject);
var
  Ico: TIcon;
begin
  Ico := TIcon.Create;
  try
   ConvertTo32BitImageList(ImageList1);
   Ico.LoadFromFile('icono48x48.ico');
   //   ImageList1.AddIcon(Ico);   <--- aquí falla
   TrayIcon1.Icon := Ico;
   ImageList1.AddIcon(TrayIcon1.Icon);
  finally
    Ico.Free;
  end;

Si pongo lo siguiente, deja de funcionar y vuelve con la chorrada del tamaño:

Código Delphi [-]
procedure TForm1.Button1Click(Sender: TObject);
begin
   ConvertTo32BitImageList(ImageList1);
   TrayIcon1.Icon.LoadFromFile('icono48x48.ico');
   ImageList1.AddIcon(TrayIcon1.Icon);
 end;

[jconnor82]

No lo he probado pero antes de cargar el icono no se tendria q dar las dimensiones?.

Código Delphi [-]
  Icon.Width  := ImageList.Width;
  Icon.Height := ImageList.Height;
  Icon.LoadFromFile('icono48x48.ico');

La siguiente unidad tiene rutinas para trabajar con iconos e ImageList.

Código Delphi [-]
unit MclXPIcons;

interface

uses
  Windows, SysUtils, Classes, Graphics, Controls, Consts;

procedure AddIconFileToImageList(const FileName: string; IconIndex: Integer;
  const ImageList: TImageList);

function AddIconResourceToImageList(const ResourceName: string;
  const ImageList: TImageList): Integer; overload;

function AddIconResourceToImageList(Instance: Cardinal;
  const ResourceName: string; const ImageList: TImageList): Integer; overload;

function AddIconResourceToImageList(const FileName, ResourceName: string;
  const ImageList: TImageList): Integer; overload;

procedure ConvertTo32BitImageList(const ImageList: TImageList);

function GetFileIcon(const FileName: string; IconIndex: Integer): THandle;

implementation

uses
  ShellAPI, CommCtrl;

type
  PHICON = ^HICON;

function ExtractIconEx(lpszFile: PChar; nIconIndex: Integer;  phIconLarge,
  phIconSmall: PHICON; nIcons: UINT): UINT; stdcall; external shell32;

procedure ConvertTo32BitImageList(const ImageList: TImageList);
const
  Mask: array[Boolean] of Longint = (0, ILC_MASK);
var
  TempList: TImageList;
begin
  if Assigned(ImageList) then
  begin
    TempList := TImageList.Create(nil);
    try
      TempList.Assign(ImageList);
      with ImageList do
      begin
        Handle := ImageList_Create(Width, Height, ILC_COLOR32 or Mask[Masked],
          0, AllocBy);

        if not HandleAllocated then
          raise EInvalidOperation.Create(SInvalidImageList);
      end;

      ImageList.AddImages(TempList);
    finally
      FreeAndNil(TempList);
    end;
  end;
end;

function GetFileIcon(const FileName: string; IconIndex: Integer): THandle;
var
  IconHandle: HICON;
  IconCount: UINT;
begin
  IconHandle := 0;
  IconCount := ExtractIconEx(PChar(FileName), IconIndex, @IconHandle, nil, 1);
  if (IconCount > 0) and (IconHandle > 0) then
    Result := IconHandle
  else
    Result := 0;
end;

procedure AddIconFileToImageList(const FileName: string; IconIndex: Integer;
  const ImageList: TImageList);
var
  TempIcon: TIcon;
begin
  TempIcon := TIcon.Create;
  try
    TempIcon.Width  := ImageList.Width;
    TempIcon.Height := ImageList.Height;
    TempIcon.Handle := GetFileIcon(FileName, IconIndex);
    if (TempIcon.Handle > 0) then
    begin
      ImageList.AddIcon(TempIcon);
      DestroyIcon(TempIcon.Handle);
    end;
  finally
    FreeAndNil(TempIcon);
  end;
end;

function AddIconResourceToImageList(const ResourceName: string;
  const ImageList: TImageList): integer;
var
  TempIcon: TIcon;
begin
  Result := -1;

  TempIcon := TIcon.Create;
  try
    TempIcon.Width  := ImageList.Width;
    TempIcon.Height := ImageList.Height;
    TempIcon.Handle := LoadIcon(HInstance, PChar(ResourceName));
    if (TempIcon.Handle > 0) then
    begin
      Result := ImageList.AddIcon(TempIcon);
      DestroyIcon(TempIcon.Handle);
    end;
  finally
    FreeAndNil(TempIcon);
  end;
end;

function AddIconResourceToImageList(Instance: Cardinal;
  const ResourceName: string; const ImageList: TImageList): integer;
var
  TempIcon: TIcon;
begin
  Result := -1;

  TempIcon := TIcon.Create;
  try
    TempIcon.Width  := ImageList.Width;
    TempIcon.Height := ImageList.Height;
    TempIcon.Handle := LoadIcon(Instance, PChar(ResourceName));
    if (TempIcon.Handle > 0) then
    begin
      Result := ImageList.AddIcon(TempIcon);
      DestroyIcon(TempIcon.Handle);
    end;
  finally
    FreeAndNil(TempIcon);
  end;
end;

function AddIconResourceToImageList(const FileName, ResourceName: string;
  const ImageList: TImageList): Integer;
var
  Instance: Cardinal;
  TempIcon: TIcon;
begin
  Result := -1;

  if FileExists(FileName) then
  begin
    Instance := LoadLibrary(PChar(FileName));
    if (0 < Instance) then
      try
        TempIcon := TIcon.Create;
        try
          TempIcon.Width  := ImageList.Width;
          TempIcon.Height := ImageList.Height;
          TempIcon.Handle := LoadIcon(Instance, PChar(ResourceName));
          if (0 < TempIcon.Handle) then
          begin
            Result := ImageList.AddIcon(TempIcon);
            DestroyIcon(TempIcon.Handle);
          end;
        finally
          FreeAndNil(TempIcon);
        end;
      finally
        FreeLibrary(Instance);
      end;
  end;
end;

end.

PD: Despues de usar ConvertTo32BitImageList cargar los iconos.

[Chandra_]

Gracias por tu tiempo, jconnor82.

Empezado por jconnor82

No lo he probado pero antes de cargar el icono no se tendria q dar las dimensiones?.

Pues tampoco funciona. A continuación tienes el código con las líneas que propones y... sigue dando el mismo mensaje de error:

Proyect Proyect1.exe raised exception class EInvalidOperation with message 'Invalid Image Size'

Código Delphi [-]
procedure TForm1.Button2Click(Sender: TObject);
var
  Ico: TIcon;
begin
  Ico := TIcon.Create;
  try
   ConvertTo32BitImageList(ImageList1);
   Ico.Width  := ImageList1.Width;
   Ico.Height := ImageList1.Height;
   Ico.LoadFromFile('icono48x48.ico');
   ImageList1.AddIcon(Ico);   // <--- aquí salta de nuevo el error
  finally
    Ico.Free;
  end;
end;

Lo curioso es que lo siguiente no falla, pero, aunque el Height y el Width del ImageList los pongo en tiempo de diseño en 48 (lo juro), el icono final lo reconvierte a 32x32 y sin canal alfa

Código Delphi [-]
procedure TForm1.Button2Click(Sender: TObject);
var
  Ico: TIcon;
begin
  Ico := TIcon.Create;
  try
   ConvertTo32BitImageList(ImageList1);
   Ico.Width  := 48;
   Ico.Height := 48; //esto se lo pasa Delphi por las narices: el Ico sigue a 32x32
   Ico.LoadFromFile('icono48x48.ico');

     Label1.Caption := ('ImageList1.Width: '+IntToStr (ImageList1.Width) + '; Ico.Width: '+IntToStr (Ico.Width));
   ImageList1.Width := Ico.Width;
     Label2.Caption := ('ImageList1.Width: '+IntToStr (ImageList1.Width) + '; Ico.Width: '+IntToStr (Ico.Width));

     Label3.Caption := ('ImageList1.Height: '+IntToStr (ImageList1.Height) + '; Ico.Height: '+IntToStr (Ico.Height));
   ImageList1.Height := Ico.Height;
     Label4.Caption := ('ImageList1.Height: '+IntToStr (ImageList1.Height) + '; Ico.Height: '+IntToStr (Ico.Height));

   ImageList1.AddIcon(Ico);
  finally
    Ico.Free;
  end;
end;

También da error si el ImageList no está vacío, y está ya precargado con un icono 48x48 (es decir, si por co**nes el ImageList está a 48x48).

¿Por qué sí se puede hacer si carcas el icono a través de un TrayIcon? No sé... misterios insondables de Delphi

CONCLUSIÓN: Los TIcon, según les pilla, no aceptam iconos de más de 32x32. Es decir, si le van a pasar el icono a un TrayIcon, se lo pasan de 48x48 sin despeinarse; si el que recibe es un ImageList... se vuelven tontos y dicen que el icono es de 32x32

Se pueden "cazar" fácilmente las gamberradas de Delphi en el siguiente código con 4 TLabel:

Código Delphi [-]
//Funciona, pero dibuja iconos 32x32 sin canal alfa
procedure TForm1.Button2Click(Sender: TObject);
var
  Ico: TIcon;
begin
  Ico := TIcon.Create;
  try
   ConvertTo32BitImageList(ImageList1);
   Ico.Width  := 48;
   Ico.Height := 48;
   Ico.LoadFromFile('browser.ico');

     //salida de label1: ImageList1.Width: 48; Ico.Width: 32
     Label1.Caption := ('ImageList1.Width: '+IntToStr (ImageList1.Width) + '; Ico.Width: '+IntToStr (Ico.Width));
   ImageList1.Width := Ico.Width;
     //salida de label2: ImageList1.Width: 32; Ico.Width: 32
     Label2.Caption := ('ImageList1.Width: '+IntToStr (ImageList1.Width) + '; Ico.Width: '+IntToStr (Ico.Width));

     //salida de label3: ImageList1.Height: 48; Ico.Height: 32
     Label3.Caption := ('ImageList1.Height: '+IntToStr (ImageList1.Height) + '; Ico.Height: '+IntToStr (Ico.Height));
   ImageList1.Height := Ico.Height;
     //salida de label4: ImageList1.Height: 32; Ico.Height: 32
     Label4.Caption := ('ImageList1.Height: '+IntToStr (ImageList1.Height) + '; Ico.Height: '+IntToStr (Ico.Height));

   ImageList1.AddIcon(Ico);
  finally
    Ico.Free;
  end;
end;

//funciona
procedure TForm1.Button3Click(Sender: TObject);
var
  Ico: TIcon;
begin
  Ico := TIcon.Create;
  try
   ConvertTo32BitImageList(ImageList1);
   Ico.LoadFromFile('browser.ico');
     //salida de label1: ImageList1.Width: 48; Ico.Width: 32
     Label1.Caption := ('ImageList1.Width: '+IntToStr (ImageList1.Width) + '; Ico.Width: '+IntToStr (Ico.Width));
     //salida de label2: ImageList1.Height: 48; Ico.Height: 32
     Label2.Caption := ('ImageList1.Height: '+IntToStr (ImageList1.Height) + '; Ico.Height: '+IntToStr (Ico.Height));
   TrayIcon1.Icon := Ico;
   ImageList1.AddIcon(TrayIcon1.Icon);
      //salida de label3: ImageList1.Width: 48; Ico.Width: 48   ¡¡¡Sorpresa!!! ha cambiado el tamaño
      Label3.Caption := ('ImageList1.Width: '+IntToStr (ImageList1.Width) + '; Ico.Width: '+IntToStr (Ico.Width));
     //salida de label4: ImageList1.Height: 48; Ico.Height: 48   ¡¡¡Sorpresa!!! ha cambiado el tamaño
     Label4.Caption := ('ImageList1.Height: '+IntToStr (ImageList1.Height) + '; Ico.Height: '+IntToStr (Ico.Height));
  finally
    Ico.Free;
  end;
end;

Os animo a hacer las pruebas y vereis qué "divertido" puede llegar a ser Delphi...

Por cierto, jconnor82, voy a probar la unit ahora, a ver qué tal me va. Luego te cuento. Ah, y muchas gracias.

[Chandra_]

jconnor82: he usado la unit que me has pasado, concretamente la procedure AddIconFileToImageList, y sigue dando el mensaje de error de "invalid Image size" con iconos mayores de 32x32:

Código Delphi [-]
procedure TForm1.Button4Click(Sender: TObject);
  begin
    ConvertTo32BitImageList(ImageList1);
    AddIconFileToImageList('icono48x48.ico', 0, ImageList1);
  end;

Nada, que no hay manera, es imposible

[jconnor82]

Al parecer el problema es con la clase TIcon, sus dimensiones no superan la 32x32 o almenos no veo formar de cambiar ese limite, pero si se trabaja directamente con HICON no hay problema

Código Delphi [-]
function GetFile48hIcon(const FileName: string; IconIndex: Integer = 0): HICON;
var
  DeskTopISF: IShellFolder;
  IExIcon: IExtractIcon;
  PathPidl: PItemIDList;
  hIconL, hIconS: HIcon;
begin
  Result := 0;
  if SHGetDesktopFolder(DeskTopISF) <> NOERROR then
    Exit;

  PathPidl := nil;
  if DeskTopISF.GetUIObjectOf(0, 1, PathPidl, IID_IExtractIconA,
    nil, IExIcon) <> NOERROR then
    Exit;

  if (IExIcon.Extract(PChar(FileName), IconIndex, hIconL, hIconS,
    48 or (16 shl 16)) = NOERROR) and (hIconL <> 0) then
    Result := hIconL;

  DestroyIcon(hIconS);
end;

solo quedaria agregar la siguiente funcion:

Código Delphi [-]
procedure AddIconFile48hToImageList(const FileName: string; IconIndex: Integer;
  const ImageList: TImageList);
var
  IconLarge: HICON;
begin
  IconLarge := GetFile48hIcon(FileName, IconIndex);
  if 0 < IconLarge then
  begin
    ImageList_AddIcon(ImageList.Handle, IconLarge);
    DestroyIcon(IconLarge);
  end;
end;

Webs de referencia:
DelphiZeus
HILPERS

[Chandra_]

Hola de nuevo, jconnor82:

Antes de seguir, quiero agradecerte todo el interés que te estás tomando

Perdona que no te agradeciera antes tu último comentario, pero es que llevo todo el día tratando de solucionar un problemilla:

He estado probando las nuevas funciones que me comentas, haciendo uso de HICON, pero no consigo compilar, porque me debe de faltar alguna unit por declarar en uses, porque me da varios mensajes de error con los siguientes tipos:

Undeclared identifier: 'IShellFolder'
Undeclared identifier: 'IExtractIcon'
Undeclared identifier: 'PItemIDList'
Undeclared identifier: 'SHGetDesktopFolder'

(omito, lógicamente, todas las variables declaradas basadas en estos tipos, que también aparecen como "undeclared identifier")

Buscando en la ayuda de Delphi, he visto que son para tener acceso al shell de windows, a la Microsoft Windows Shell interfaces, pero no termino de encontrar las clases de Delphi que manejan eso para declararlas (en la ayuda de delphi, todo lo que es el SDK de Windows aparece desligado del código de Object Pascal). Creía que con declarar, como haces tú, ShellAPI, era suficiente, pero parece que no. Si me pudieras decir algo, te estaría muy agradecido

Gracias de nuevo


ACTUALIZACIÓN:

Nada, ni caso a lo anterior: ya he encontrado la cláusula uses en la web de DelphiZeus con la "unit mágica" (pero qué burro soy!): ShlObj.

Voy a disfrutarlo, por fin

Un millón de gracias, jconnor82, por tu inestimable ayuda.

[jconnor82]

Algo me decia q me estaba olvidando algo