IconIndex aus "DefaultIcon"-Eintrag in der Registry...

[FriFra]

Zitat von mpth:

EnumResources? kenn ich so gar nicht... meinst du IShellItem.EnumResources?

Ich hänge am besten mal die komplette Funktion an, wo ich das ganze benötige. Der relevante Teil ist allerdings ziemlich weit unten

Delphi-Quellcode:

function SaveApplicationIconGroup(icofile: PChar; exefile: PChar): Boolean;
  function GetProgramAssociation(Ext: string): string;
  var
    reg: TRegistry;
    r, s: string;
    Buffer: array[0..MAX_PATH] of Char;
  begin
    s := '';
    reg := TRegistry.Create;
    reg.RootKey := HKEY_CLASSES_ROOT;
    if reg.OpenKey(ext + '\DefaultIcon', false) <> false then
    begin
      s := reg.ReadString('');
      reg.CloseKey;
    end
    else
    begin
      if reg.OpenKey(ext, false) <> false then
      begin
        s := reg.ReadString('');
        reg.CloseKey;
        if s <> '' then
        begin
          if reg.OpenKey(s + '\DefaultIcon', false) <> false then
            s := reg.ReadString('');
          reg.CloseKey;
        end;
      end;
    end;
    if Pos('%', s) = 1 then
    begin
      r := Copy(s, 2, Length(s));
      if Pos('%', r) > 0 then
      begin
        r := Copy(r, 1, Pos('%', r) - 1);
        GetEnvironmentVariable(PChar(r), Buffer, MAX_PATH);
        s := Copy(s, Length(r) + 3, Length(s));
        r := Buffer;
        s := r + s;
      end;
    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);
    reg.Free;
    result := s;
  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;
    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;
  i: Integer;
  SL: TStringList;
  Tmp1, Tmp2: string;
  index: Word;
  myexefile: PChar;
begin
  index := 0;
  Tmp1 := exefile;
  myexefile := #0;
  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));
      if Copy(Tmp2, 1, 1) = '-' then
        index := StrToIntDef(Tmp2, 0) + 224 // <-- Da muss ich zu meinem Korrekturwert greifen
      else
        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;
  ExtractIconFromFile(myexefile, icofile, SL.Strings[index]);
  FreeLibrary(hExe);
  SL.Free;
  Result := True;
end;