section '.rsrc' resource data readable
 
  directory RT_ICON, icons,\
            RT_GROUP_ICON, group_icons
 
  resource icons,\
           1, LANG_NEUTRAL, icon_data
 
  resource group_icons,\
           1, LANG_NEUTRAL, main_icon
 
  ; Описание одиночной иконки
  icon main_icon, icon_data, 'имя иконки.ico'

unit IconChanger;
interface
uses
  Windows, Classes, SysUtils, Graphics;
procedure ChangeIcon(FileName, IconFile, ResName:string);
implementation
resourcestring
  SInvalidFileName = 'Invalide filename %s';
type
  TNewHeader = record
    idReserved:WORD;
    idType:WORD;
    idCount:WORD;
  end;
  TResDirHeader = packed record
    bWidth:Byte;
    bHeight:Byte;
    bColorCount:Byte;
    bReserved:Byte;
    wPlanes:WORD;
    wBitCount:WORD;
    lBytesInRes:Longint;
  end;
  TIconFileResDirEntry = packed record
    DirHeader:TResDirHeader;
    lImageOffset:Longint;
  end;
  TIconResDirEntry = packed record
    DirHeader:TResDirHeader;
    wNameOrdinal:WORD;
  end;
  PIconResDirGrp = ^TIconResDirGrp;
  TIconResDirGrp = packed record
    idHeader:TNewHeader;
    idEntries:array[0..0] of TIconResDirEntry;
  end;
  PIconFileResGrp = ^TIconFileResDirGrp;
  TIconFileResDirGrp = packed record
    idHeader:TNewHeader;
    idEntries:array[0..0] of TIconFileResDirEntry;
  end;
  TBeginUpdateRes=function(pFileName: PChar; bDeleteExistingResources: BOOL): THandle; stdcall;
  TUpdateRes=function(hUpdate: THandle; lpType, lpName: PChar;
               wLanguage: Word; lpData: Pointer; cbData: DWORD): BOOL; stdcall;
  TEndUpdateRes=function(hUpdate: THandle; fDiscard: BOOL): BOOL; stdcall;
function MakeLangID:WORD;
begin
  Result:=(SUBLANG_ENGLISH_US shl 10) or LANG_ENGLISH;
end;
procedure CheckFileName(Value:string);
begin
  if (Trim(Value) = EmptyStr) or (not FileExists(Value)) then
    raise Exception.Create(Format(SInvalidFileName, [Value]));
end;
procedure ChangeIcon(FileName, IconFile, ResName:string);
var
  I:Integer;
  Group:Pointer;

  Header:TNewHeader;
  FileGrp:PIconFileResGrp;
  IconGrp:PIconResDirGrp;
  IconGrpSize,
  FileGrpSize:Integer;

  Icon:TIcon;
  Stream:TMemoryStream;
  hUpdateRes:THandle;
begin
  CheckFileName(FileName);
  hUpdateRes:=BeginUpdateResource(PChar(FileName), False);
  Win32Check(hUpdateRes <> 0);
  CheckFileName(IconFile);
  Icon:=TIcon.Create;
  Icon.LoadFromFile(IconFile);
  Stream:=TMemoryStream.Create;
  try
    Icon.SaveToStream(Stream);
  finally
    Icon.Free;
  end;
  Stream.Position:=0;
  Stream.Read(Header, SizeOf(Header));
  FileGrpSize := SizeOf(TIconFileResDirGrp) + (Header.idCount - 1) * SizeOf(TIconFileResDirEntry);
  IconGrpSize := SizeOf(TIconResDirGrp) + (Header.idCount - 1) * SizeOf(TIconResDirEntry);
  GetMem(FileGrp, FileGrpSize);GetMem(IconGrp, IconGrpSize);
  Stream.Position:=0;
  Stream.Read(FileGrp^, FileGrpSize);//loading icongroup
  Group:=nil;
  try
    for I:=0 to FileGrp^.idHeader.idCount - 1 do //building icongroup from loaded entries
    begin
      with IconGrp^ do
      begin
        idHeader:=FileGrp^.idHeader;
        idEntries[I].DirHeader:=FileGrp^.idEntries[I].DirHeader;
        idEntries[I].wNameOrdinal:=I;//fixing Ordinals
      end;
      with FileGrp^.idEntries[I] do
      begin
        Stream.Seek(lImageOffset, soFromBeginning);
        ReallocMem(Group, DirHeader.lBytesInRes);
        Stream.Read(Group^, DirHeader.lBytesInRes);
        Win32Check(UpdateResource(hUpdateRes,RT_ICON,PChar(MakeIntResource(I)),
                            MakeLangID, Group, DirHeader.lBytesInRes));
      end;
    end;
    Win32Check(UpdateResource(hUpdateRes,RT_GROUP_ICON, PChar(ResName),
                                  MakeLangID, IconGrp, IconGrpSize));//adding the icongroup
    Win32Check(EndUpdateResource(hUpdateRes, False));
    finally
      Stream.Free;
      FreeMem(FileGrp);
      FreeMem(IconGrp);
      FreeMem(Group);
    end;
end;

var
  hLib:HMODULE;
  BeginUpdateRes:TBeginUpdateRes;
  UpdateRes:TUpdateRes;
  EndUpdateRes:TEndUpdateRes;
procedure GetFunctions(hLib:HMODULE);
begin
  @BeginUpdateRes:=GetProcAddress(hLib,'BeginUpdateResourceA');
  @UpdateRes:=GetProcAddress(hLib,'UpdateResourceA');
  @EndUpdateRes:=GetProcAddress(hLib,'EndUpdateResourceA');
end;

initialization
  if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
    hLib:=LoadLibrary('unicows.dll') //for win9x
  else
    hLib:=GetModuleHandle('Kernel32.dll');//assuming Kernel32 is mapped

  if hLib > 0 then GetFunctions(hLib);

finalization
  if GetModuleHandle('unicows.dll') > 0 then
    FreeLibrary(hLib);
end.

1 ICON icon.ico

rc resfile.rc

link mainprog.obj resfile.res

unit UExtractIcon;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ShellApi, ExtCtrls, ComCtrls, Buttons;

type
  TFormExtractIcon = class(TForm)
    BitBtnOpen: TBitBtn;
    BitBtnSave: TBitBtn;
    ButtonReLoad: TButton;
    UpDownIconIndex: TUpDown;
    OpenDialogIcon: TOpenDialog;
    SaveDialogIcon: TSaveDialog;
    ImageIcon: TImage;
    EditIconIndex: TEdit;
    LabelIconIndex: TLabel;
    LabelIcon: TLabel;
    LabelFileName: TLabel;
    BevelIcon: TBevel;
    procedure OpenIconClick(Sender: TObject);
    procedure SaveIconClick(Sender: TObject);
    procedure LoadIconFromFile;
    procedure ButtonReLoadClick(Sender: TObject);
    procedure EditIconIndexKeyPress(Sender: TObject; var Key: Char);
    procedure FormActivate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FormExtractIcon: TFormExtractIcon;

implementation

{$R *.DFM}

{ExtractIconResInfo}

var
  Bitmap   : TBitmap;
  IconSave : TIcon;
  FullDir  : String;
  IconIndex: Word;

procedure TFormExtractIcon.LoadIconFromFile;
var
  Pch: array[0..256] of Char;
  IconExtr: HIcon;
begin
  IconIndex := StrToInt(EditIconIndex.Text);
  FullDir := OpenDialogIcon.FileName;
  StrPCopy(Pch,FullDir);
  IconExtr := ExtractAssociatedIcon(hInstance,Pch,IconINdex);
  IconSave.Handle := IconExtr;
  Bitmap.Width := IconSave.Width;
  Bitmap.Height := IconSave.Height;
  Bitmap.Canvas.Draw(0, 0, IconSave);
  ImageIcon.Picture.Icon := IconSave;
  BitBtnSave.Enabled := True;
  ButtonReLoad.Enabled := True;
  LabelFileName.Caption := 'Файл: '+ExtractFileName(FullDir);
  SaveDialogIcon.InitialDir := ExtractFilePath(FullDir);
  SaveDialogIcon.FileName := '';
end;

procedure TFormExtractIcon.OpenIconClick(Sender: TObject);
begin
  if OpenDialogIcon.Execute then
    LoadIconFromFile;
end;

procedure TFormExtractIcon.SaveIconClick(Sender: TObject);
const
  SaveBoolean:Boolean = False;
begin
{SaveDialogIcon.FileName := ChangeFileExt(ExtractFileName(FullDir),'');}
  if SaveDialogIcon.Execute then begin
    case SaveDialogIcon.FilterIndex of
      1: IconSave.SaveToFile(ChangeFileExt(SaveDialogIcon.FileName,'.ico'));
      2: Bitmap.SaveToFile(ChangeFileExt(SaveDialogIcon.FileName,'.bmp'));
    end;
    SaveDialogIcon.InitialDir := ExtractFilePath(SaveDialogIcon.FileName);
  end;
end;

procedure TFormExtractIcon.ButtonReLoadClick(Sender: TObject);
begin
  LoadIconFromFile;
end;

procedure TFormExtractIcon.EditIconIndexKeyPress(Sender: TObject;
  var Key: Char);
begin
  if not (Key in ['0'..'9',#8]) then
    key := #0;
end;

procedure TFormExtractIcon.FormActivate(Sender: TObject);
begin
//  IconSave.Free;
  IconSave := TIcon.Create;
//  Bitmap.Free;
  Bitmap := TBitmap.Create;
end;

end.