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

[mpth]

ach du meintest EnumResourceNames... ja das kenn ich

hier mal meine version deiner routine (allerdings fehlen noch einige try...finally-blöcke, ich hab deine genommen und nur so abgeändert, damit sie nach meinem verständnis einigermaßen funktionieren müsste)

Delphi-Quellcode:

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;