function SaveApplicationIconGroup(icofile: PChar; exefile: PChar): Boolean;
function GetProgramAssociation(Ext:
string):
string;
var
reg: TRegistry;
s:
string;
Buffer, Buffer1:
array[0..MAX_PATH]
of Char;
begin
s := '
';
reg := TRegistry.Create;
try
reg.RootKey := HKEY_CLASSES_ROOT;
if reg.OpenKeyReadOnly(ext + '
\DefaultIcon') <> false
then
begin
s := reg.ReadString('
');
reg.CloseKey;
end
else
begin
if reg.OpenKeyReadOnly(ext) <> false
then
begin
s := reg.ReadString('
');
reg.CloseKey;
if s <> '
'
then
begin
if reg.OpenKeyReadOnly(s + '
\DefaultIcon') <> false
then
s := reg.ReadString('
');
reg.CloseKey;
end;
end;
end;
if Pos('
%', s) > 0
then
begin
FillChar(Buffer, sizeof(Buffer),#0);
FillChar(Buffer1, sizeof(Buffer),#0);
StrPLCopy(Buffer, s, sizeof(Buffer)-1);
if ExpandEnvironmentStrings(Buffer, Buffer1, sizeof(Buffer1)) > 0
then
s := Buffer1;
end;
// ???
if Pos('
%', s) > 0
then
Delete(s, Pos('
%', s), length(s));
if ((length(s) > 0)
and (s[1] = '
"'))
then
Delete(s, 1, 1);
if ((length(s) > 0)
and (s[length(s)] = '
"'))
then
Delete(s, Length(s), 1);
while ((length(s) > 0)
and ((s[length(s)] = #32)
or (s[length(s)] = '
"')))
do
Delete(s, Length(s), 1);
result := s;
finally
reg.Free;
end;
end;
function EnumResourceNamesProc(Module: HMODULE; ResType: PChar; ResName:
PChar; lParam: TStringList): Integer;
stdcall;
var
ResourceName:
string;
begin
if hiword(Cardinal(ResName)) = 0
then
begin
ResourceName := IntToStr(loword(Cardinal(ResName)));
end
else
begin
ResourceName := ResName;
if Pos('
#', Resourcename) = 1
then
Delete(Resourcename,1,1);
end;
lParam.Add(ResourceName);
Result := 1;
end;
function ExtractIconFromFile(ResFileName:
string; IcoFileName:
string; nIndex:
string): Boolean;
type
PMEMICONDIRENTRY = ^TMEMICONDIRENTRY;
TMEMICONDIRENTRY =
packed record
bWidth: Byte;
bHeight: Byte;
bColorCount: Byte;
bReserved: Byte;
wPlanes: Word;
wBitCount: Word;
dwBytesInRes: DWORD;
nID: Word;
end;
type
PMEMICONDIR = ^TMEMICONDIR;
TMEMICONDIR =
packed record
idReserved: Word;
idType: Word;
idCount: Word;
idEntries:
array[0..15]
of TMEMICONDIRENTRY;
end;
type
PICONDIRENTRY = ^TICONDIRENTRY;
TICONDIRENTRY =
packed record
bWidth: Byte;
bHeight: Byte;
bColorCount: Byte;
bReserved: Byte;
wPlanes: Word;
wBitCount: Word;
dwBytesInRes: DWORD;
dwImageOffset: DWORD;
end;
type
PICONIMAGE = ^TICONIMAGE;
TICONIMAGE =
packed record
Width,
Height,
Colors: UINT;
lpBits: Pointer;
dwNumBytes: DWORD;
pBmpInfo: PBitmapInfo;
end;
type
PICONRESOURCE = ^TICONRESOURCE;
TICONRESOURCE =
packed record
nNumImages: UINT;
IconImages:
array[0..15]
of TICONIMAGE;
end;
function AdjustIconImagePointers(lpImage: PICONIMAGE): Bool;
begin
if lpImage =
nil then
begin
Result := False;
exit;
end;
lpImage.pBmpInfo := PBitMapInfo(lpImage^.lpBits);
lpImage.Width := lpImage^.pBmpInfo^.bmiHeader.biWidth;
lpImage.Height := (lpImage^.pBmpInfo^.bmiHeader.biHeight)
div 2;
lpImage.Colors := lpImage^.pBmpInfo^.bmiHeader.biPlanes *
lpImage^.pBmpInfo^.bmiHeader.biBitCount;
Result := true;
end;
function WriteICOHeader(hFile: THandle; nNumEntries: UINT): Boolean;
type
TFIcoHeader =
record
wReserved: WORD;
wType: WORD;
wNumEntries: WORD;
end;
var
IcoHeader: TFIcoHeader;
dwBytesWritten: DWORD;
begin
Result := False;
IcoHeader.wReserved := 0;
IcoHeader.wType := 1;
IcoHeader.wNumEntries := WORD(nNumEntries);
if not WriteFile(hFile, IcoHeader, SizeOf(IcoHeader), dwBytesWritten,
nil)
then
begin
MessageBox(0, pchar(SysErrorMessage(GetLastError)), '
Error',
MB_ICONERROR);
Result := False;
Exit;
end;
if dwBytesWritten <> SizeOf(IcoHeader)
then
Exit;
Result := True;
end;
function CalculateImageOffset(lpIR: PICONRESOURCE; nIndex: UINT): DWORD;
var
dwSize: DWORD;
i: Integer;
begin
dwSize := 3 * SizeOf(WORD);
inc(dwSize, lpIR.nNumImages * SizeOf(TICONDIRENTRY));
for i := 0
to nIndex - 1
do
inc(dwSize, lpIR.IconImages[i].dwNumBytes);
Result := dwSize;
end;
function WriteIconResourceToFile(hFile: hwnd; lpIR: PICONRESOURCE): Boolean;
var
i: UINT;
dwBytesWritten: DWORD;
ide: TICONDIRENTRY;
dwTemp: DWORD;
begin
Result := False;
for i := 0
to lpIR^.nNumImages - 1
do
begin
/// Convert internal format to ICONDIRENTRY
ide.bWidth := lpIR^.IconImages[i].Width;
ide.bHeight := lpIR^.IconImages[i].Height;
ide.bReserved := 0;
ide.wPlanes := lpIR^.IconImages[i].pBmpInfo.bmiHeader.biPlanes;
ide.wBitCount := lpIR^.IconImages[i].pBmpInfo.bmiHeader.biBitCount;
if ide.wPlanes *
ide.wBitCount >= 8
then
ide.bColorCount := 0
else
ide.bColorCount := 1
shl (
ide.wPlanes *
ide.wBitCount);
ide.dwBytesInRes := lpIR^.IconImages[i].dwNumBytes;
ide.dwImageOffset := CalculateImageOffset(lpIR, i);
if not WriteFile(hFile,
ide, sizeof(TICONDIRENTRY), dwBytesWritten,
nil)
then
Exit;
if dwBytesWritten <> sizeof(TICONDIRENTRY)
then
Exit;
end;
for i := 0
to lpIR^.nNumImages - 1
do
begin
dwTemp := lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage;
lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage := 0;
if not WriteFile(hFile, lpIR^.IconImages[i].lpBits^,
lpIR^.IconImages[i].dwNumBytes, dwBytesWritten,
nil)
then
Exit;
if dwBytesWritten <> lpIR^.IconImages[i].dwNumBytes
then
Exit;
lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage := dwTemp;
end;
Result := True;
end;
var
h: HMODULE;
lpMemIcon: PMEMICONDIR;
lpIR: TICONRESOURCE;
src: HRSRC;
Global: HGLOBAL;
i: integer;
hFile: hwnd;
begin
Result := False;
hFile := CreateFile(pchar(IcoFileName), GENERIC_WRITE, 0,
nil,
CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
if hFile = INVALID_HANDLE_VALUE
then
Exit;
h := LoadLibraryEx(pchar(ResFileName), 0, LOAD_LIBRARY_AS_DATAFILE);
if h = 0
then
exit;
try
src := FindResource(h, pchar(nIndex), RT_GROUP_ICON);
if src = 0
then
Src := FindResource(h, Pointer(StrToInt(nIndex)), RT_GROUP_ICON);
if src <> 0
then
begin
Global := LoadResource(h, src);
if Global <> 0
then
begin
lpMemIcon := LockResource(Global);
if Global <> 0
then
begin
try
lpIR.nNumImages := lpMemIcon.idCount;
// Write the header
for i := 0
to lpMemIcon^.idCount - 1
do
begin
src := FindResource(h,
MakeIntResource(lpMemIcon^.idEntries[i].nID), RT_ICON);
if src <> 0
then
begin
Global := LoadResource(h, src);
if Global <> 0
then
begin
try
lpIR.IconImages[i].dwNumBytes := SizeofResource(h, src);
except
MessageBox(0, PChar('
Unable to Read Icon'), '
NTPacker',
MB_ICONERROR);
Result := False;
ExitProcess(0);
end;
GetMem(lpIR.IconImages[i].lpBits,
lpIR.IconImages[i].dwNumBytes);
CopyMemory(lpIR.IconImages[i].lpBits, LockResource(Global),
lpIR.IconImages[i].dwNumBytes);
if not AdjustIconImagePointers(@(lpIR.IconImages[i]))
then
exit;
end;
end;
end;
if WriteICOHeader(hFile, lpIR.nNumImages)
then
if WriteIconResourceToFile(hFile, @lpIR)
then
Result := True;
finally
for i := 0
to lpIR.nNumImages - 1
do
if assigned(lpIR.IconImages[i].lpBits)
then
FreeMem(lpIR.IconImages[i].lpBits);
end;
end;
end;
end;
finally
FreeLibrary(h);
end;
CloseHandle(hFile);
end;
var
hExe: THandle;
SL: TStringList;
Tmp1, Tmp2:
string;
index: LongInt;
// wichtig!
myexefile: PChar;
begin
index := 0;
Tmp1 := exefile;
myexefile := PChar(Tmp1);
{ Hier versuche ich bei NICHT-EXEn doch an das vollständige Icon zu kommen... }
if LowerCase(ExtractFileExt(myexefile)) <> '
.exe'
then
begin
myexefile := PChar(GetProgramAssociation(ExtractFileExt(myexefile)));
if Pos('
,', myexefile) > 0
then
begin
Tmp1 := myexefile;
Tmp2 := Trim(Copy(Tmp1, Pos('
,', Tmp1) + 1, Length(Tmp1)));
Tmp1 := Trim(Copy(Tmp1, 1, Pos('
,', Tmp1) - 1));
index := StrToIntDef(Tmp2, 0);
end;
myexefile := PChar(Tmp1);
end;
Result := False;
SL := TStringList.Create;
hExe := LoadLibraryEx(PChar(myexefile), 0, LOAD_LIBRARY_AS_DATAFILE);
if hExe = 0
then
Exit;
EnumResourceNames(hExe, RT_GROUP_ICON, @EnumResourceNamesProc, Integer(SL));
if SL.Count = 0
then
begin
SL.Free;
//MessageBox(0, 'No Icons found in the EXE/DLL', 'Error', MB_ICONERROR);
Exit;
end;
if index < 0
then // falls ein negativer wert, dann nach dem namen suchen, nicht den index verwenden!
begin
index := sl.IndexOf(IntToStr(-
index));
if index = -1
then
index := 0;
// nicht gefunden, schade :-(
end;
ExtractIconFromFile(myexefile, icofile, SL[
index]);
FreeLibrary(hExe);
SL.Free;
Result := True;
end;