{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;

type Coff_header = packed record
   target_machine:word;
   NumberOfSections:word;
   TimeDataStamp:dword;
   PointerToSymbolTable:dword;
   NumberOfSymbols:dword;
   SizeOfOptionalHeaders:word;
   Characteristics:word;
   coffBodyMagic:word;
   end;

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
myCoff:coff_header;
coff,sectiontable,bs:longint;
addre,numnamest8,dat,siz,rva,fp,bc,bw:longint;
dw:longint;
w:word;
NumberOfRvaAndSizes:longint;
numnames:word;
numids:word;
x,y,z:word;
b:byte;
bit64type:byte;

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

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

nfin:file;
nfout:file;


   Function RVA2FP:longint;
   {call with rva returns fp modifies w
   I don't understand the original QB64 code. In my opinion in the original
   code never can happen when the loop ends unsuccesssfully what is wrong}
   var ww:word;
   begin
   ww:=0;
   repeat
     if rva < secsva[ww] then Break;
     inc(ww);
   until ww>myCoff.NumberOfSections - 1;
   dec(ww);
   IF ww>myCoff.NumberOfSections - 1 then Exit(-1);
   RVA2FP:=rva+(secfsp[ww]-secsva[ww]); {result is always RVA+0 ???}

   {
   was_found:=false;
   for ww:=0 TO myCoff.NumberOfSections - 1 do
       if rva < secsva[ww] then begin was_found:=true;Break;end;
   dec(ww);
   IF was_found=false then Exit(-1);
   RVA2FP:=rva+(secfsp[ww]-secsva[ww]);
   }
   end;


   Function Clex(a:byte):byte;
   begin
   Close(nfin);
   Clex:=a;
   end;


   Procedure ReadAt(poz:longint;var kam;bajtu:longint);
   begin
   Seek(nfin,poz);
   BlockRead(nfin,kam,bajtu);
   end;


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

Assign(nfin,inp);
Reset(nfin,1);

ReadAt(0,w,2);
if w<>$5a4d then Exit(Clex(2));   {Chybi MZ sign. na zac. EXE?}

ReadAt($3c,dw,4);
coff:=dw+4;

ReadAt(dw,dw,4);
if dw<>$4550 then Exit(Clex(3)); {Chybi PE sign?}


Seek(nfin,coff);
BlockRead(nfin,Mycoff,sizeOf(coff_header));

if myCoff.NumberOfSections=0 then Exit(Clex(4)); {chybi odd. sekci}
if myCoff.SizeOfOptionalHeaders=0 then Exit(Clex(5));

if myCoff.coffBodyMagic=$010b
   then bit64type:=0 else      {do we have 32-bit executable...}
if myCoff.coffBodyMagic=$020b
   then bit64type:=255         {...or 64-bit executable?}
   else Exit(Clex(6));         {or something strange?}

ReadAt(coff+20+92+(16 and bit64type),NumberOfRvaAndSizes,4);
if NumberOfRvaAndSizes<3 then Exit(Clex(7));


ReadAt(coff+20+112+(16 and bit64type),bs,4);
ReadAt(coff+20+112+4+(16 and bit64type),dw,4);
if (bs = 0) or (dw = 0) then Exit(Clex(8));

SectionTable:=coff+20+myCoff.SizeOfOptionalHeaders;

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

rva:=bs;
fp:=RVA2FP;

if fp=-1 then Exit(Clex(27));

bs:=fp;
addre:=bs;

{group icon, first level}
ReadAt(addre+12,numnames,2);
ReadAt(addre+14,numids,2);
numnamest8:=numnames * 8;

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

if was_found=false then Exit(Clex(9));
if (dw and $80000000)=0 then Exit(Clex(10));

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

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

if gi>=numnames+numids then Exit(Clex(11));

ReadAt(addre+16+4+(gi*8),dw,4);
if (dw and $80000000)=0 then Exit(Clex(12));

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

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

if numnames+numids=0 then Exit(Clex(13));
ReadAt(addre+16+4,dw,4);

if (dw and $80000000)<>0 then Exit(Clex(14));

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

fp:=RVA2fp;
dat:=fp;

if siz<6 then Exit(Clex(15));

ReadAt(dat,dw,4);
if dw<>$10000 then Exit(Clex(16));

ReadAt(dat+4,y,2);
if y=0 then Exit(Clex(17));
if siz<(6+(y*14)) then Exit(Clex(18));

bc:=0;
bw:=0;

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

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

if bc=0 then Exit(Clex(19));

addre:=bs;

{icon, first level}
ReadAt(addre+12,numnames,2);
ReadAt(addre+14,numids,2);
numnamest8:=numnames*8;
was_found:=false;
for x:=0 to numids-1 do
  begin
  ReadAt(addre+16+numnamest8+(x*8),dw,4);
  if dw=3 then
     begin
     ReadAt(addre+16+4+numnamest8+(x*8),dw,4);
     was_found:=true;
     Break;
     end;
  end;

if was_found=false then Exit(Clex(20));
if (dw and $80000000)=0 then Exit(Clex(21));
addre:=bs+(dw and $7FFFFFFF);

{icon, second level}
ReadAt(addre+12,numnames,2);
ReadAt(addre+14,numids,2);
numnamest8:=numnames*8;
was_found:=false;
for x:=0 to numids-1 do
  begin
  ReadAt(addre+16+numnamest8+(x*8),dw,4);
  if dw = z then
    begin
    ReadAt(addre+16+4+numnamest8+(x*8),dw,4);
    was_found:=true;
    Break;
    end;
  end;

if was_found=false then Exit(Clex(22));
if (dw and $80000000)=0 then Exit(Clex(23));
addre:=bs+(dw and $7FFFFFFF);

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

if numnames+numids=0 then Exit(Clex(24));
ReadAt(addre+16+4,dw,4);
if (dw and $80000000)<>0 then Exit(Clex(25));
                     {^? or should be ...=0 ?}

{extract icon}
dw:=bs+dw;
ReadAt(dw,rva,4);
ReadAt(dw+4,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:\hry\civilization3\civilization3.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:=64;  {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.
