{Program for icon extraction from windows's EXE files (with PE signature)
 Based in source written in QB64 by Michael Calkins
 Into pascal traslated by Laaca}

{$IFDEF FPC}

{$ELSE}
{$ENDIF}
uses Dos;


Function ExistFile(s:string):boolean;
{Zjisti,zda dany soubor existuje }
var r:searchrec;
begin
if s='' then begin ExistFile:=false;Exit;end;
FindFirst(s,archive+hidden+readonly+sysfile,r);
if DosError=0 then ExistFile:=true else ExistFile:=false;
FindClose(r);
end;


Function Power(co,naco:byte):longint;
var a:longint;
    c:byte;
begin
a:=co;
if co=0 then begin Power:=0;Exit;end;
if naco=0 then begin Power:=1;Exit;end;
for c:=1 to naco-1 do a:=a*co;
Power:=a;
end;


Function GetIcon (inp,outp:string; gi,wi,co:dword;bmpmode:boolean):byte;
{function extracts the best matching icon from a specified icon group from
 a specified PE image, and saves it to a specified file in a specified format.
 extracts the first language.

 fil = input file name
 fout = output file name
 gi = the number of the Icon Group (0 is first)
 wi = the preferred width (width is given priority over color)
 co = the preferred bits per pixel
 bmpmode: <false> for .ico, <true> for .bmp

 returns 0 for success, nonzero for error.}

const max_sections=1000;

var
coff,sectiontable,bs:longint;
addre,numnamest8,dat,siz,rva,fp,bc,bw:longint;
dw:longint;
w:word;
NumberofSections:word;
SizeOfOptionalHeader:word;
NumberOfRvaAndSizes:longint;
numnames:word;
numids:word;
x,y,z:word;
b:byte;
pe32plus:byte;

wide,hgh,bpp,pal,pb:word;

secsva:array[0..max_sections-1] of dword;
secfsp:array[0..max_sections-1] of dword;

nfin:file;
nfout:file;


   Function RVA2FP:longint;
   {call with rva returns fp modifies w}
   var ww:word;
   begin
   for ww:=0 TO NumberOfSections - 1 do
       if rva < secsva[ww] then Break;
   dec(ww);
   IF ww>NumberOfSections - 1 then Exit(-1);
   RVA2FP:=rva+(secfsp[ww]-secsva[ww]);
   end;


begin
if not ExistFile(inp) then Exit(1);

Assign(nfin,inp);
Reset(nfin,1);
BlockRead(nfin,w,2);
if w<>$5a4d then begin close(nfin);Exit(2);end; {Chybi MZ sign. na zac. EXE?}

Seek(nfin,$3c);
BlockRead(nfin,dw,4);
coff:=dw+4;

Seek(nfin,dw);
BlockRead(nfin,dw,4);

if dw<>$4550 then begin close(nfin);Exit(3);end; {Chybi PE sign?}

Seek(nfin,coff+2);
BlockRead(nfin,NumberOfSections,2);
if NumberOfSections=0 then begin close(nfin);Exit(4);end; {chybi odd. sekci}


Seek(nfin,coff+16);
BlockRead(nfin,SizeOfOptionalHeader,2);
if SizeOfOptionalHeader=0 then begin close(nfin);Exit(5);end;

Seek(nfin,coff+20);
BlockRead(nfin,w,2);

if w=$10b then pe32plus:=0 else
if w=$20b then pe32plus:=255 else begin close(nfin);Exit(6);end;


Seek(nfin,coff+20+92+(16 and pe32plus));
BLockRead(nfin,NumberOfRvaAndSizes,4);

if NumberOfRvaAndSizes<3 then begin close(nfin);Exit(7);end;

Seek(nfin,coff+20+112+(16 and pe32plus));
BlockRead(nfin,bs,4);

Seek(nfin,coff+20+112+4+(16 and pe32plus));
BlockRead(nfin,dw,4);
if (bs = 0) or (dw = 0) then begin close(nfin);Exit(8);end;

SectionTable:=coff+20+SizeOfOptionalHeader;

for w:=0 to NumberOfSections-1 do
  begin
  Seek(nfin,SectionTable+12+(40*w));BlockRead(nfin,secsva[w],4);
  Seek(nfin,SectionTable+20+(40*w));BlockRead(nfin,secfsp[w],4);
  end;


rva:=bs;
fp:=RVA2FP;

if fp=-1 then begin close(nfin);Exit(27);end;

bs:=fp;
addre:=bs;

{group icon, first level}
Seek(nfin,addre+12);BlockRead(nfin,numnames,2);
Seek(nfin,addre+14);BlockRead(nfin,numids,2);

numnamest8:=numnames * 8;


for x:=0 to numids-1 do
  begin
  Seek(nfin,addre+16+numnamest8+(x*8));
  BlockRead(nfin,dw,4);
  if dw=14 then
     begin
     Seek(nfin,addre+16+4+numnamest8+(x*8));
     BlockRead(nfin,dw,4);
     Break;
     end;
  end;

if x = numids then begin close(nfin);Exit(9);end;
if (dw and $80000000)=0 then begin close(nfin);Exit(10);end;

addre:=bs+(dw and $7FFFFFFF);

{group icon, second level}
Seek(nfin,addre+12);BlockRead(nfin,numnames,2);
Seek(nfin,addre+14);BlockRead(nfin,numids,2);

if gi>=numnames+numids then begin close(nfin);Exit(11);end;

Seek(nfin,addre+16+4+(gi*8));BlockRead(nfin,dw,4);
if (dw and $80000000)=0 then begin close(nfin);Exit(12);end;

addre:=bs+(dw and $7FFFFFFF);

{group icon, third level}
Seek(nfin,addre+12);BlockRead(nfin,numnames,2);
Seek(nfin,addre+14);BlockRead(nfin,numids,2);

if numnames+numids=0 then begin close(nfin);Exit(13);end;
Seek(nfin,addre+16+4);BlockRead(nfin,dw,4);

if (dw and $80000000)<>0 then begin close(nfin);Exit(14);end;

{search for best icon within icon group}
dw:=bs+dw;
Seek(nfin,dw);BlockRead(nfin,rva,4);
Seek(nfin,dw+4);BlockRead(nfin,siz,4);

fp:=RVA2fp;
dat:=fp;

if siz<6 then begin close(nfin);Exit(15);end;

Seek(nfin,dat);BlockRead(nfin,dw,4);
if dw<>$10000 then begin close(nfin);Exit(16);end;

Seek(nfin,dat+4);BlockRead(nfin,y,2);

if y=0 then begin close(nfin);Exit(17);end;
if siz<(6+(y*14)) then begin close(nfin);Exit(18);end;

bc:=0;
bw:=0;

for x:=0 to y-1 do
  begin
  Seek(nfin,dat+6+(x*4));
  BlockRead(nfin,b,1);
  if b=0 then b:=255;

  {best width, then best color}
  if (b>=bw) and (b<=wi) then
     begin
     Seek(nfin,dat+6+(x*14)+6);
     BlockRead(nfin,w,2);
     if ((w>bc) or (b>bw)) and (w<=co) then
         begin
         bc:=w;
         bw:=b;
         Seek(nfin,dat+6+(x*14)+12);
         BlockRead(nfin,z,2);
         end;
     end;
  end;

if bc=0 then begin close(nfin);Exit(19);end;

addre:=bs;

{icon, first level}
Seek(nfin,addre+12);BlockRead(nfin,numnames,2);
Seek(nfin,addre+14);BlockRead(nfin,numids,2);

numnamest8:=numnames*8;
for x:=0 to numids-1 do
  begin
  Seek(nfin,addre+16+numnamest8+(x*8));
  BlockRead(nfin,dw,4);
  if dw=3 then
     begin
     Seek(nfin,addre+16+4+numnamest8+(x*8));
     BlockRead(nfin,dw,4);
     Break;
     end;
  end;

if x=numids then begin close(nfin);Exit(20);end;
if (dw and $80000000)=0 then begin close(nfin);Exit(21);end;
addre:=bs+(dw and $7FFFFFFF);

{icon, second level}
Seek(nfin,addre+12);BlockRead(nfin,numnames,2);
Seek(nfin,addre+14);BlockRead(nfin,numids,2);

numnamest8:=numnames*8;
for x:=0 to numids-1 do
  begin
  Seek(nfin,addre+16+numnamest8+(x*8));
  BlockRead(nfin,dw,4);
  IF dw = z then
    begin
    Seek(nfin,addre+16+4+numnamest8+(x*8));
    BlockRead(nfin,dw,4);
    Break;
    end;
  end;

if x=numids then begin close(nfin);Exit(22);end;
if (dw and $80000000)=0 then begin close(nfin);Exit(23);end;
addre:=bs+(dw and $7FFFFFFF);

{icon, third level}
Seek(nfin,addre+12);BlockRead(nfin,numnames,2);
Seek(nfin,addre+14);BlockRead(nfin,numids,2);


if numnames+numids=0 then begin close(nfin);Exit(24);end;
Seek(nfin,addre+16+4);
BlockRead(nfin,dw,4);

if (dw and $80000000)<>0 then begin close(nfin);Exit(25);end;
                     {^? or should be ...=0 ?}

{extract icon}
dw:=bs+dw;

Seek(nfin,dw);BlockRead(nfin,rva,4);
Seek(nfin,dw+4);BlockRead(nfin,siz,4);

fp:=RVA2fp;
dat:=fp;

Assign(nfout,outp);
Rewrite(nfout,1);

Seek(nfin,dat+4);
BlockRead(nfin,dw,4);  {width, start 4 bytes into BMP header}
if dw<$100 then wide:=dw else wide:=wi;


BlockRead(nfin,dw,4);  {double height}
if dw<$1FF then hgh:=dw div 2 else hgh:=wi;

Seek(nfin,dat+14);
BlockRead(nfin,w,2);   {bpp}
if w<=$20 then bpp:=w else bpp:=co;

IF bmpmode then {Create bitmap format pre-header info of 14 bytes}
  begin
  w:=$4d42;  {"BM"}
  BlockWrite(nfout,w,2);       {magic}
  if bpp<=8 then
     begin
     pal:=Power(2,bpp)*4;
     pb:=bpp div 8;
     end
     else begin
     pal:=0;
     pb:=3;
     end;

  dw:=54+(wide * hgh * pb) + pal;
  BlockWrite(nfout,dw,4);             {file size}

  dw:=0;
  BlockWrite(nfout,dw,4);             {2 reserved}

  dw:=54+pal;                         {bitmap header offset + palette if used}
  BlockWrite(nfout,dw,4);             {data offset}
  end
  else begin
  {Create icon format Icon header and Entry header}
  w:=0;
  BlockWrite(nfout,w,2);              {reserved}

  w:=1;    {1 = icon, 2 = cursor(this could be set by mode value)}
  BlockWrite(nfout,w,2);         {resource id}
  BlockWrite(nfout,w,2);         {icon count is always one in this procedure}

  b:=wide;
  BlockWrite(nfout,b,1);         {width in Entry header}


  b:=hgh;
  BlockWrite(nfout,b,1);         {height}

  if bpp<8 then b:=Power(2,bpp) else b:=0;
  BlockWrite(nfout,b,1);         {num of colors}
  b:=0;w:=0;

  BlockWrite(nfout,b,1);         {reserved}
  BlockWrite(nfout,w,2);         {column hot spot for cursor}
  BlockWrite(nfout,w,2);         {row hot spot for cursor}

  BlockWrite(nfout,siz,4);       {size of data}
  dw:=22;                        {offset of bmp header is 6 + 16 bytes}
  BlockWrite(nfout,dw,4);
  end;


Seek(nfin,dat);  {seek start of bmp 40 byte header}
IF bmpmode then
  begin
  BlockRead(nfin,dw,4);
  BlockWrite(nfout,dw,4);        {header size}

  BlockRead(nfin,dw,4);
  dw:=wide;
  BlockWrite(nfout,dw,4);        {width}

  dw:=hgh;
  BlockWrite(nfout,dw,4);        {height}

  BlockRead(nfin,dw,4);          {ignore double height}

  siz:=(wide*hgh*pb)+28+pal;     {stop at AND mask}
  end;

for dw:=1 to siz do
  begin
  {get remaining image data including}
  BlockRead(nfin,b,1);
  BlockWrite(nfout,b,1);
  end;

close(nfout);
close(nfin);
GetIcon:=0;
end;


Function GetIconError(n:byte):string;
{revision date, last person to revise revision 20111031, michael calkins
(derivitives may list sources of derivision) october 2011, public domain, michael calkins}
var s:string;
begin
case n of
0: s:='success';
1: s:='input file not found';
2: s:='MZ signature not found';
3: s:='PE signature not found';
4: s:='no sections found';
5: s:='optional header not found';
6: s:='unknown PE optional header';
7: s:='no resource table';
8: s:='no resource table';
9: s:='icon groups not found';
10: s:='icon group: 1st level entry is a leaf';
11: s:='specified icon group not found';
12: s:='icon group: 2nd level entry is a leaf';
13: s:='no language for specified icon group';
14: s:='icon group: 3rd level entry is not a leaf';
15: s:='icon group data is too small';
16: s:='icon group data is not as expected';
17: s:='no icons in group';
18: s:='icon array is too small';
19: s:='could not find an icon matching the specifications';
20: s:='icons not found';
21: s:='icon: 1st level entry is a leaf';
22: s:='target icon not found';
23: s:='icon: 2nd level entry is a leaf';
24: s:='no language for target icon';
25: s:='icon: 3rd level is not a leaf';
26: s:='output file already exists';
27: s:='could not convert rva to fp';
else s:= 'unknown error';
end; {case}
GetIconError:=s;
end;



{==========================================================================}

var n:byte;
    gi:dword;
    wi:longint;
    bpp:dword;

    bmpmode:boolean;


const
      {fil:string = 'd:\windows\notepad.exe';}
      fil:string = 'd:\windows\calc.exe';
      del:string = '';


begin
if fil='' then readln(fil);

gi:=0;   {first icon group is normally 0 in most EXE or DLL files}
wi:=32;  {16 to 256 max width     '<<<<<<<<<<< change settings for other sizes}
bpp:=8;  {4 to 32 bit max color   '<<<<<<<<<<< 4 bit may use older style images}
bmpmode:=false;

if bmpmode=true then del:='delme.bmp' else del:='delme.ico';

n:=GetIcon(fil, del, gi, wi, bpp, bmpmode);
if n<>0 then writeln('Error: ',n,' - ',geticonerror(n));

end.
