Icon einer Anwendung speichern

[Harry M.]

Delphi-Quellcode:

Function GetIconFromFile(FileName: String; Index: Integer): Ticon;
Begin
  Result := TIcon.Create;
  Result.Handle := ExtractIcon(HInstance, PCHAR(FileName), Index);
End;

[Luckie]

Zitat von Harry M.:

Delphi-Quellcode:

Function GetIconFromFile(FileName: String; Index: Integer): Ticon;
Begin
  Result := TIcon.Create;
  Result.Handle := ExtractIcon(HInstance, PCHAR(FileName), Index);
End;

Zitat:

Ahja, das ganze sollte NonVCL sein. Nicht sowas wie TIcon

[ErazerZ]

ja klar, hier ist die Unit mit einem Example,
den echten Source war in C, hab aber ne Unit auf einer Chinesischen seite gefunden und habs einwenig umgeändert.

Icons.pas

Delphi-Quellcode:

unit Icons;

interface

uses Windows;

type
  PByte = ^Byte;
  PBitmapInfo = ^BitmapInfo;

/// These first two structs represent how the icon information is stored
/// when it is bound into a EXE or DLL file. Structure members are WORD
/// aligned and the last member of the structure is the ID instead of
/// the imageoffset.

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;

/// These next two structs represent how the icon information is stored
/// in an ICO file.

type
  PICONDIRENTRY = ^TICONDIRENTRY;
  TICONDIRENTRY = packed record
    bWidth:           Byte;
    bHeight:          Byte;
    bColorCount:      Byte;
    bReserved:        Byte;
    wPlanes:          Word;
    wBitCount:        Word;
    dwBytesInRes:     DWORD;
    dwImageOffset:    DWORD;
  end;

type
  PICONDIR = ^TICONDIR;
  TICONDIR = packed record
    idReserved:       Word;
    idType:           Word;
    idCount:          Word;
    idEntries:        Array[0..0] of TICONDIRENTRY;
  end;

/// The following two structs are for the use of this program in
/// manipulating icons. They are more closely tied to the operation
/// of this program than the structures listed above. One of the
/// main differences is that they provide a pointer to the DIB
/// information of the masks.

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;

type
  TPageInfo = packed record
    Width:            Byte;
    Height:           Byte;
    ColorQuantity:    Integer;
    Reserved:         DWORD;
    PageSize:         DWORD;
    PageOffSet:       DWORD;
  end;

type
  TPageDataHeader = packed record
    PageHeadSize:     DWORD;
    XSize:            DWORD;
    YSize:            DWORD;
    SpeDataPerPixSize: Integer;
    ColorDataPerPixSize: Integer;
    Reserved:         DWORD;
    DataAreaSize:     DWORD;
    ReservedArray:    Array[0..15] of char;
  end;

type
  TIcoFileHeader = packed record
    FileFlag:         Array[0..3] of byte;
    PageQuartity:     Integer;
    PageInfo:         TPageInfo;
  end;

function ExtractIconFromFile(ResFileName: string; IcoFileName: string; nIndex: string): Boolean;
function WriteIconResourceToFile(hFile: hwnd; lpIR: PICONRESOURCE): Boolean;

implementation

function SysErrorMessage(ErrorCode: Integer): string;
var
  Len: Integer;
  Buffer: array[0..255] of Char;
begin
  Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer, SizeOf(Buffer), nil);
  while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);
  SetString(Result, Buffer, Len);
end;

function StrToInt(X: String): Integer;
var
  V, Code: Integer;
begin
  Val(X, V, Code);
  StrToInt := V;
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;

function AWriteIconToFile(bitmap: hBitmap; Icon: hIcon; szFileName: string): Boolean;
var
  fh: file of byte;
  IconInfo: _ICONINFO;
  PageInfo: TPageInfo;
  PageDataHeader: TPageDataHeader;
  IcoFileHeader: TIcoFileHeader;
  BitsInfo: tagBITMAPINFO;
  p: pointer;
  PageDataSize: integer;
begin
  Result := False;
  GetIconInfo(Icon, IconInfo);
  AssignFile(fh, szFileName);
  FileMode := 1;
  Reset(fh);

  GetDIBits(0, Icon, 0, 32, nil, BitsInfo, DIB_PAL_COLORS);
  GetDIBits(0, Icon, 0, 32, p, BitsInfo, DIB_PAL_COLORS);
  PageDataSize := SizeOf(PageDataHeader) + BitsInfo.bmiHeader.biBitCount;

  PageInfo.Width := 32;
  PageInfo.Height := 32;
  PageInfo.ColorQuantity := 65535;
  Pageinfo.Reserved := 0;
  PageInfo.PageSize := PageDataSize;
  PageInfo.PageOffSet := SizeOf(IcoFileHeader);

  IcoFileHeader.FileFlag[0] := 0;
  IcoFileHeader.FileFlag[1] := 0;
  IcoFileHeader.FileFlag[2] := 1;
  IcoFileHeader.FileFlag[3] := 0;
  IcoFileHeader.PageQuartity := 1;
  IcoFileHeader.PageInfo := PageInfo;

  FillChar(PageDataHeader, SizeOf(PageDataHeader), 0);
  PageDataHeader.XSize := 32;
  PageDataHeader.YSize := 32;
  PageDataHeader.SpeDataPerPixSize := 0;
  PageDataHeader.ColorDataPerPixSize := 32;
  PageDataHeader.PageHeadSize := SizeOf(PageDataHeader);
  PageDataHeader.Reserved := 0;
  PageDataHeader.DataAreaSize := BitsInfo.bmiHeader.biBitCount;

  BlockWrite(fh, IcoFileHeader, SizeOf(IcoFileHeader));
  BlockWrite(fh, PageDataHeader, SizeOf(PageDataHeader));
  BlockWrite(fh, p, BitsInfo.bmiHeader.biBitCount);
  CloseFile(fh);
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 ExtractIconFromFile(ResFileName: string; IcoFileName: string; nIndex: string): Boolean;
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;

end.

und hier ein example NonVCL code:

Delphi-Quellcode:

program Project1;

uses
  Windows, Icons;

// Die StringList die man braucht um alle Resourcenamen zu speichern
type
  TStringList = class(TObject)
    private
      SList: Array of String;
    public
      Count: Integer;
      constructor Create;
      procedure Add(S: String);
      function Strings(Index: Integer): String;
  end;

constructor TStringList.Create;
begin
  Count := 0;
  SetLength(SList, Count +1);
end;

procedure TStringList.Add(S: String);
begin
  SetLength(SList, Count +1);
  SList[Count] := S;
  Inc(Count);
end;

function TStringList.Strings(Index: Integer): String;
begin
  Result := SList[Index];
end;

///////////////////////////////////////////////////////////

var
  ResourceName: String;

function IntToStr(X: Integer): String;
var
  S: String;
begin
  Str(X, S);
  IntToStr := S;
end;

function ExtractFilePath(FileName: string): string;
begin
  Result := '';
  while Pos('\', FileName) <> 0 do
  begin
    Result := Result + Copy(FileName, 1, 1);
    Delete(FileName, 1, 1);
  end;
end;

function EnumResourceNamesProc(Module: HMODULE; ResType: PChar; ResName: PChar; lParam: TStringList): Integer; stdcall;
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 SaveIcon(Filename: String): Boolean;
var
  hExe: THandle;
  i: Integer;
  SL: TStringList;
begin
  Result := False;
  SL := TStringList.Create;
  hExe := LoadLibraryEx(PChar(Filename), 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;
  for i := 0 to SL.Count -1 do
  begin
    Icons.ExtractIconFromFile(Filename, ExtractFilePath(Filename) + SL.Strings(i) + '.ico', SL.Strings(i));
  end;
  FreeLibrary(hExe);
  SL.Free;
  Result := True;
end;

begin
  SaveIcon('C:\Windows\System32\shell32.dll');
end.