// Viele Icon-Dateien enthalten mehrere Icons verschiedener Größen.
// Mit dem folgenden Code kann man deren Anzahl und Abmaße anzeigen
// lassen, oder die einzelnen Icons abbilden, oder ein bestimmtes
// Icon (mittels Doppelklick auf eine Listbox) speichern.
// Siehe auch: große Icons in ein Image laden

// Getestet mit RS 10.4 unter Win11

uses Winapi.shellapi, Vcl.graphics, UITypes; 
 
function PrivateExtractIcons(lpszFile: PChar; 
  nIconIndex, cxIcon, cyIcon: Integer; phicon: PHANDLE; piconid: PDWORD; 
  nicon, flags: DWORD): DWORD; stdcall; 
  external 'user32.dll' name 'PrivateExtractIconsW'; 
 
var 
  bm: array of TBitmap; 
  sl: TStringList; 
 
const 
  sx = ' x '; 
  Maxzahl = 70; 
 
  // Anzahl und Größen auslesen 
procedure IcoValues(IcoName: String; Lst: TStrings); 
type 
  TIconEntry = packed record 
    FWidth: Byte; 
    FHeight: Byte; 
    FColorCount: Byte; 
    FReserved: Byte; 
    FPlanes: Word; 
    FBitCount: Word; 
    FBytesInRes: DWORD; 
    FImageOffset: DWORD; 
  end; 
 
  TIconDir = packed record 
    FReserved: Word; 
    FType: Word; 
    FCOUNT: Word; 
    FEntries: array [0 .. Maxzahl - 1] of TIconEntry; 
  end; 
 
var 
  fs: TFilestream; 
  IconDir: TIconDir; 
  Count, I: Integer; 
begin 
  Lst.Clear; 
  if not FileExists(IcoName) then 
    exit; 
  fs := TFilestream.create(IcoName, fmOpenRead or fmShareDenyNone); 
  fs.Position := 0; 
  fs.read(IconDir, sizeof(IconDir)); 
  Count := IconDir.FCOUNT; 
  if Count > Maxzahl then 
    Count := Maxzahl; 
  for I := 0 to pred(Count) do 
  begin 
    fs.Position := IconDir.FEntries[I].FImageOffset; 
    Lst.Add(IntToStr(IconDir.FEntries[I].FWidth) + sx + 
      IntToStr(IconDir.FEntries[I].FHeight)); 
  end; 
  fs.free;
  for I := 0 to Lst.Count - 1 do 
    if sl[I] = '0 x 0' then 
      sl[I] := '256 x 256'; 
end; 
 
// Die verschiedenen Icons auslesen 
procedure Bilder(IcoName: String; hb: HBrush); 
var 
  cx, cy, p, I: Integer; 
  Id: Word; 
  ico: HIcon; 
begin 
  IcoValues(IcoName, sl); 
  if sl.Count = 0 then 
    exit; 
  if sl.Count > length(bm) then 
    SetLength(bm, sl.Count); 
  for I := 0 to sl.count - 1 do 
  begin 
    p := pos(sx, sl[I]); 
    cx := StrToIntDef(copy(sl[I], 1, p - 1), 0); 
    cy := StrToIntDef(copy(sl[I], p + length(sx), maxint), 0); 
    if not assigned(bm[I]) then 
      bm[I] := TBitmap.create; 
    bm[I].SetSize(cx, cy); 
    PrivateExtractIcons(PChar(IcoName), 0, cx, cy, @ico, @Id, 0, 
      LR_LOADFROMFILE); 
    DrawIconEx(bm[I].Canvas.Handle, 0, 0, ico, cx, cy, 0, hb, DI_NORMAL); 
  end; 
  DestroyIcon(ico); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  sl := TStringList.create; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  I: Integer; 
begin 
  for I := Low(bm) to High(bm) do 
    bm[I].free; 
  bm := nil; 
  sl.free; 
end; 
 
 
 
// --- Beispiele --- 
 
// Werte in einer Listbox anzeigen 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  I: Integer; 
  z: String; 
begin 
  IcoValues('D:\Icons\Icon\apps\access.ico', sl); 
  if sl.Count = 1 then 
    z := '' 
  else 
    z := 'n'; 
  with ListBox1.Items do 
  begin 
    Clear; 
    if sl.Count = 0 then 
    begin 
      Add('Nichts gefunden'); 
      exit; 
    end; 
    Add('Anzahl: ' + IntToStr(sl.Count)); 
    Add(''); 
    Add('Größe' + z + ':'); 
    Add(''); 
    for I := 0 to sl.Count - 1 do 
      Add(sl[I]); 
  end; 
end; 
 
// --------------------------------------------- 
 
// Bilder waagerecht auf Canvas ausgeben 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  hb: HBrush; 
  procedure zeige(cnv: TCanvas; x, y: Integer; mitText: Boolean); 
  var 
    I, abst, gr, yy, h, w: Integer; 
  begin 
    h := 256; 
    gr := 256; 
    if mitText then 
      abst := 55 // z.B.
    else 
      abst := 10; 
    for I := 0 to sl.count - 1 do 
    begin 
      yy := y + (gr - bm[I].height) div 2; 
      if yy < y then 
        yy := y; 
      cnv.draw(x + abst div 2, yy, bm[I]); 
      if mitText then 
      begin 
        if h <= bm[I].height then 
          h := bm[I].height + 10;
        w := cnv.TextWidth(sl[I]); 
        cnv.TextOut(x + (abst + (bm[I].width - w)) div 2, h + 5, sl[I]); 
      end; 
      inc(x, bm[I].width + abst); 
    end; 
  end; 
 
begin 
  hb := CreateSolidBrush(ColorToRGB(Color)); 
  Bilder('D:\Icons\Icon\apps\access.ico', hb); 
  zeige(Canvas, 10, 10, false); 
  DeleteObject(hb); 
end; 
 
// ---------------------------------------------------- 
 
// Ein einzelnes Icon bestimmter Größe mittels Doppelklick speichern 
procedure TForm1.ListBox2DblClick(Sender: TObject); 
var 
  cx, cy, p, I: Integer; 
  ico: HIcon; 
  ch: PChar; 
  ic: TIcon; 
  Id: Word; 
begin 
  I := ListBox2.itemindex; 
  if I >= 0 then 
  begin 
    ic := TIcon.create; 
    ch := PChar(ListBox2.tag); 
    p := pos(sx, ListBox2.Items[I]); 
    cx := StrToIntDef(copy(ListBox2.Items[I], 1, p - 1), 0); 
    cy := StrToIntDef(copy(ListBox2.Items[I], p + length(sx), maxint), 0); 
    PrivateExtractIcons(ch, 0, cx, cy, @ico, @Id, 0, LR_LOADFROMFILE); 
    ic.Handle := ico; 
    ic.SaveToFile('D:\MyIcon.ico'); // z.B. 
    ic.free; 
    DestroyIcon(ico); 
    Showmessage('Gespeichert'); 
  end; 
end; 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  s: string; 
begin 
  ListBox2.Clear; 
  s := 'D:\Icons\Icon\apps\access.ico'; 
  IcoValues(s, ListBox2.Items); 
  ListBox2.tag := LongInt(PChar(s)); 
end;

Zugriffe seit 6.9.2001 auf Delphi-Ecke