Delphi-PRAXiS - Delphi Icon anderer EXE Datei ändern

Probier's mal damit:

Delphi-Quellcode:

			// Transplant / inject icon resources.

// Author: SMO, DelphiPraxis.net, 2015

uses

  System.Types;  // TWordDynArray

const

  ICON_HEADER_RESERVED = 0;

  ICON_HEADER_TYPE_ICO = 1;

  ICON_HEADER_TYPE_CUR = 2;

type

  PGroupIconRsrcEntry = ^TGroupIconRsrcEntry;

  TGroupIconRsrcEntry = packed record

    bWidth, bHeight: Byte;    // 0 means 256, which is the maximum

    bColorCount:     Byte;    // number of colors in image (0 if wBitCount > 8)

    bReserved:       Byte;    // 0

    wPlanes:         Word;    // 1

    wBitCount:       Word;    // number of bits per pixel

    dwSize:          DWORD;   // size of the icon data, in bytes

    wID:             Word;    // resource ID of the icon (for RT_ICON entry)

  end;

  PGroupIconRsrcHeader = ^TGroupIconRsrcHeader;

  TGroupIconRsrcHeader = packed record

    wReserved: Word;    // 0

    wType:     Word;    // 1 for icons

    wCount:    Word;    // number of icons in this group, each has a following TGroupIconRsrcEntry

    // Entries: array [0..idType - 1] of TGroupIconRsrcEntry;

  end;

  TSmoGroupIcon = record

    Header:   TGroupIconRsrcHeader;

    Entries:  array of TGroupIconRsrcEntry;

    IconData: array of array of Byte;

  end;

function GetGroupIconFromIcoFile(const FileName: string; out GroupIcon: TSmoGroupIcon): Boolean;

var

  hFile: THandle;

  i, Size: Integer;

  Offsets: array of DWORD;

begin

  // clear the output record

  Finalize(GroupIcon);

  FillChar(GroupIcon.Header, SizeOf(GroupIcon.Header), 0);

  hFile := FileOpen(FileName, fmOpenRead or fmShareDenyNone);

  Result := hFile <> INVALID_HANDLE_VALUE;

  if Result then

  try

    // read header

    Size := SizeOf(GroupIcon.Header);

    Result := FileRead(hFile, GroupIcon.Header, Size) = Size;

    if not Result then Exit;

    with GroupIcon.Header do

      if (wReserved <> ICON_HEADER_RESERVED) or (wType <> ICON_HEADER_TYPE_ICO) then

      begin

        SetLastError(ERROR_BAD_FORMAT);

        Exit(False); // invalid data in header

      end;

    // read entries...

    // ico file entries are almost identical to TGroupIconRsrcEntry, with one small difference

    SetLength(GroupIcon.Entries, GroupIcon.Header.wCount);

    SetLength(Offsets, GroupIcon.Header.wCount);

    Size := SizeOf(GroupIcon.Entries[0]) - 2;

    for i := 0 to High(GroupIcon.Entries) do

    begin

      // read a TGroupIconRsrcEntry but without the last "wID" field

      Result := Result and (FileRead(hFile, GroupIcon.Entries[i], Size) = Size);

      // ico files have a dwFileOffset field there instead, read it separately

      Result := Result and (FileRead(hFile, Offsets[i], 4) = 4);

      GroupIcon.Entries[i].wID := i + 1;

    end;

    if not Result then Exit;

    // read icon image data

    SetLength(GroupIcon.IconData, GroupIcon.Header.wCount);

    for i := 0 to High(GroupIcon.IconData) do

    begin

      Size := GroupIcon.Entries[i].dwSize;

      SetLength(GroupIcon.IconData[i], Size);

      FileSeek(hFile, Offsets[i], FILE_BEGIN);

      Result := FileRead(hFile, GroupIcon.IconData[i, 0], Size) = Size;

      if not Result then Exit;

    end;

  finally

    FileClose(hFile);

    if not Result then

    begin

      // clear the output record

      Finalize(GroupIcon);

      FillChar(GroupIcon.Header, SizeOf(GroupIcon.Header), 0);

    end;

  end;

end;

// GetRsrcPointer: get pointer to the specified resource

// Returns nil on error

function GetRsrcPointer(hModule: HMODULE; lpName, lpType: PChar): Pointer;

var

  hResInfo: HRSRC;

  hResData: HGLOBAL;

begin

  Result := nil;

  hResInfo := FindResource(hModule, lpName, lpType);

  if hResInfo <> 0 then

  begin

    hResData := LoadResource(hModule, hResInfo);

    if hResData <> 0 then

      Result := LockResource(hResData);

    // UnlockResource & FreeResource are not necessary in 32 & 64 bit Windows

  end;

end;

// GetGroupIcon: get the complete data from the specified RT_GROUP_ICON resource.

// Returns true on success and false on error.

function GetGroupIcon(const FileName: string; GroupName: PChar; out GroupIcon: TSmoGroupIcon): Boolean;

var

  hLib: HMODULE;

  PData: Pointer;

  PEntry: PGroupIconRsrcEntry;

  LastError: DWORD;

  i: Integer;

begin

  // clear the output record

  Finalize(GroupIcon);

  FillChar(GroupIcon.Header, SizeOf(GroupIcon.Header), 0);

  hLib := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);

  Result := hLib <> 0;

  if Result then

  try

    PData := GetRsrcPointer(hLib, PChar(GroupName), RT_GROUP_ICON);

    if not Assigned(PData) then Exit(False); // resource not found

    with PGroupIconRsrcHeader(PData)^ do

      if (wReserved <> ICON_HEADER_RESERVED) or (wType <> ICON_HEADER_TYPE_ICO) then

      begin

        SetLastError(ERROR_BAD_FORMAT);

        Exit(False); // invalid data in header

      end;

    // copy header

    GroupIcon.Header := PGroupIconRsrcHeader(PData)^;

    i := GroupIcon.Header.wCount;

    SetLength(GroupIcon.Entries, i);

    SetLength(GroupIcon.IconData, i);

    // copy entries & icon data

    PEntry := PGroupIconRsrcEntry(UIntPtr(PData) + SizeOf(TGroupIconRsrcHeader));

    for i := 0 to i - 1 do

    begin

      GroupIcon.Entries[i] := PEntry^;

      // load icon data (bitmap or PNG)

      PData := GetRsrcPointer(hLib, MakeIntResource(PEntry^.wID), RT_ICON);

      if Assigned(PData) then

      begin

        SetLength(GroupIcon.IconData[i], PEntry^.dwSize);

        Move(PData^, GroupIcon.IconData[i, 0], PEntry^.dwSize);

      end

      else // icon data wasn't found... wrong ID? Should not happen...

        GroupIcon.Entries[i].dwSize := 0;

      Inc(PEntry);

    end;

  finally

    LastError := GetLastError;

    FreeLibrary(hLib);

    if LastError <> ERROR_SUCCESS then SetLastError(LastError);

  end;

end;

function EnumResLangProc(hModule: HMODULE; lpszType, lpszName: PChar; wIDLanguage: Word;

  var LangArray: TWordDynArray): BOOL; stdcall;

var

  i: Integer;

begin

  i := Length(LangArray);

  SetLength(LangArray, i + 1);

  LangArray[i] := wIDLanguage;

  Result := True;

end;

function GetResourceLangIDs(hModule: HMODULE; lpType, lpName: PChar): TWordDynArray;

begin

  Result := nil;

  if not EnumResourceLanguages(hModule, lpType, lpName, @EnumResLangProc, IntPtr(@Result)) then

    Result := nil;

end;

// DeleteIconGroup: deletes the specified RT_GROUP_ICON resource and the referenecd RT_ICON

// resources. Deletes ALL language versions, if several exist.

// Returns true if the resource does not exist or was deleted successfully.

// Returns false if an error occured.

function DeleteGroupIcon(const FileName: string; GroupName: PChar): Boolean;

var

  GroupIcon: TSmoGroupIcon;

  hUpdate: THandle;

  hLib: HMODULE;

  LastError: DWORD;

  i, n: Integer;

  LangArray: TWordDynArray;

begin

  Result := GetGroupIcon(FileName, GroupName, GroupIcon);

  if not Result then

  begin

    case GetLastError of

      ERROR_RESOURCE_DATA_NOT_FOUND,

      ERROR_RESOURCE_TYPE_NOT_FOUND,

      ERROR_RESOURCE_NAME_NOT_FOUND,

      ERROR_RESOURCE_LANG_NOT_FOUND: Result := True;

    end;

    Exit;

  end;

  Assert(GroupIcon.Header.wCount = Length(GroupIcon.Entries));

  hLib := 0;

  hUpdate := 0;

  try

    hUpdate := BeginUpdateResource(PChar(FileName), False);

    if hUpdate <> 0 then

      hLib := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);

    Result := (hUpdate <> 0) and (hLib <> 0);

    if not Result then Exit;

    // delete the RT_GROUP_ICON, all languages

    LangArray := GetResourceLangIDs(hLib, RT_GROUP_ICON, PChar(GroupName));

    for n := 0 to High(LangArray) do

      Result := Result and UpdateResource(hUpdate, RT_GROUP_ICON, PChar(GroupName),

        LangArray[n], nil, 0);

    // delete the actual icon data (RT_ICON), all languages

    // TODO: check if we're actually allowed to do that... other RT_GROUP_ICON could still

    // be referencing some of these RT_ICON we're about to delete!

    for i := 0 to High(GroupIcon.Entries) do

    begin

      if not Result then Break;

      LangArray := GetResourceLangIDs(hLib, RT_ICON, MakeIntResource(GroupIcon.Entries[i].wID));

      for n := 0 to High(LangArray) do

        Result := Result and UpdateResource(hUpdate, RT_ICON,

          MakeIntResource(GroupIcon.Entries[i].wID), LangArray[n], nil, 0);

    end;

  finally

    LastError := GetLastError;

    if hLib <> 0 then FreeLibrary(hLib);

    if hUpdate <> 0 then EndUpdateResource(hUpdate, not Result);

    if LastError <> ERROR_SUCCESS then SetLastError(LastError);

  end;

end;

// FindUnusedIconID: returns the first unused RT_ICON resource ID in the specified module.

// A return value of 0 means that no unused ID could be found.

function FindUnusedIconID(const hModule: HMODULE; const StartID: Word = 0): Word;

var

  hResInfo: HRSRC;

begin

  Result := StartID;

  if Result = 0 then Inc(Result);

  while Result > 0 do

  begin

    hResInfo := FindResource(hModule, MakeIntResource(Result), RT_ICON);

    if hResInfo = 0 then Break;

    Inc(Result);

  end;

end;

// SetGroupIcon: set the complete data of the specified RT_GROUP_ICON resource, and add the

// referenced RT_ICON resources. If a RT_GROUP_ICON of the same name exists, it'll be deleted

// first, including all RT_ICON resources it references.

// Returns true on success and false on error.

function SetGroupIcon(const FileName: string; GroupName: PChar; var GroupIcon: TSmoGroupIcon): Boolean;

var

  hLib: HMODULE;

  hUpdate: THandle;

  PData: Pointer;

  LastError: DWORD;

  i, SizeOfEntries: Integer;

  wLanguage, IconID: Word;

begin

  Assert(GroupIcon.Header.wCount = Length(GroupIcon.Entries));

  Assert(Length(GroupIcon.Entries) = Length(GroupIcon.IconData));

  // if the group already exists, then delete it first

  Result := DeleteGroupIcon(FileName, GroupName);

  hLib := 0;

  hUpdate := 0;

  PData := nil;

  if Result then

  try

    hUpdate := BeginUpdateResource(PChar(FileName), False);

    if hUpdate <> 0 then

      hLib := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);

    Result := (hUpdate <> 0) and (hLib <> 0);

    if not Result then Exit;

    wLanguage := MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL);

    IconID := 0;

    // add the RT_ICON data

    for i := 0 to High(GroupIcon.Entries) do

    begin

      // find the next unused ID

      IconID := FindUnusedIconID(hLib, IconID + 1);

      Result := Result and (IconID > 0) and

        UpdateResource(hUpdate, RT_ICON, MakeIntResource(IconID), wLanguage,

        @GroupIcon.IconData[i, 0], Length(GroupIcon.IconData[i]));

      // update the entry's ID with the new value

      GroupIcon.Entries[i].wID := IconID;

    end;

    // add the RT_GROUP_ICON data

    if Result then

    begin

      // copy data from the GroupIcon structure to a contiguous block of memory

      i := SizeOf(GroupIcon.Header);

      SizeOfEntries := GroupIcon.Header.wCount * SizeOf(GroupIcon.Entries[0]);

      GetMem(PData, i + SizeOfEntries);

      PGroupIconRsrcHeader(PData)^ := GroupIcon.Header;

      Move(GroupIcon.Entries[0], Pointer(IntPtr(PData) + i)^, SizeOfEntries);

      Result := UpdateResource(hUpdate, RT_GROUP_ICON, PChar(GroupName), wLanguage,

        PData, i + SizeOfEntries);

    end;

  finally

    LastError := GetLastError;

    if Assigned(PData) then FreeMem(PData);

    if hLib <> 0 then FreeLibrary(hLib);

    if hUpdate <> 0 then EndUpdateResource(hUpdate, not Result);

    if LastError <> ERROR_SUCCESS then SetLastError(LastError);

  end;

end;

Benutzt wird das ganze dann so:

Delphi-Quellcode:

			procedure Test;

var

  IconA, IconB, IconC: TSmoGroupIcon;

begin

  // Hole die Symbolgruppe "ICO_MYCOMPUTER" aus Explorer.exe

  if not GetGroupIcon('C:\Windows\System32\Explorer.exe', 'ICO_MYCOMPUTER', IconA) then

    RaiseLastOSError;

  // Hole die Symbolgruppe mit der ID 2 aus Notepad.exe

  if not GetGroupIcon('C:\Windows\System32\Notepad.exe', MakeIntResource(2), IconB) then

    RaiseLastOSError;

  // Lade eine Symbolgruppe aus einer Ico-Datei

  if not GetGroupIconFromIcoFile('D:\Test.ico', IconC) then

    RaiseLastOSError;

  // Speichere die Symbolgruppen in Test.exe unter verschiedenen Namen/IDs

  if not (SetGroupIcon('D:\Test.exe', 'MAINICON', IconA) 

    and SetGroupIcon('D:\Test.exe', MakeIntResource(123), IconB)

    and SetGroupIcon('D:\Test.exe', 'A', IconC)) then

    RaiseLastOSError;

end;

Der Code ist nicht perfekt, er löscht eventuell Symbole, die noch von anderen Gruppen referenziert werden. Außerdem könnte man eine schöne Klasse daraus machen, oder einen Record mit Methoden, aber für den Anfang sollte es reichen. ;)