Parsi Coders
یونیت تغییر ایکون دلفی - نسخه قابل چاپ

+- Parsi Coders (http://parsicoders.com)
+-- انجمن: Software Development Programming (http://parsicoders.com/forumdisplay.php?fid=37)
+--- انجمن: Pascal/Delphi (http://parsicoders.com/forumdisplay.php?fid=45)
+---- انجمن: Delphi (http://parsicoders.com/forumdisplay.php?fid=69)
+---- موضوع: یونیت تغییر ایکون دلفی (/showthread.php?tid=1101)

یونیت تغییر ایکون دلفی - Amin_Mansouri - 10-17-2011

Hi guys didn't find anywhere an unit capable of changing icons for apps compiled with delphi xe so i decided to write one. Is not exactly scientific but gets the job done

کد:
//Credits ??

unit vIconChanger;

interface

uses
  Windows, Classes, SysUtils, Graphics;

procedure ChangeIcon(FileName, IconFile, ResName:string);

implementation

type
  TNewHeader = record
    idReserved:WORD;
    idType:WORD;
    idCount:WORD;
  end;

  TResDirHeader = packed record
    bWidth:Byte;
    bHeight:Byte;
    bColorCount:Byte;
    bReserved:Byte;
    wPlanes:WORD;
    wBitCount:WORD;
    lBytesInRes:Longint;
  end;

  TIconFileResDirEntry = packed record
    DirHeader:TResDirHeader;
    lImageOffset:Longint;
  end;

  TIconResDirEntry = packed record
    DirHeader:TResDirHeader;
    wNameOrdinal:WORD;
  end;

  PIconResDirGrp = ^TIconResDirGrp;
  TIconResDirGrp = packed record
    idHeader:TNewHeader;
    idEntries:array[0..0] of TIconResDirEntry;
  end;

  PIconFileResGrp = ^TIconFileResDirGrp;
  TIconFileResDirGrp = packed record
    idHeader:TNewHeader;
    idEntries:array[0..0] of TIconFileResDirEntry;
  end;

  TBeginUpdateRes=function(pFileName: PChar; bDeleteExistingResources: BOOL): THandle; stdcall;

  TUpdateRes=function(hUpdate: THandle; lpType, lpName: PChar;
               wLanguage: Word; lpData: Pointer; cbData: DWORD): BOOL; stdcall;

  TEndUpdateRes=function(hUpdate: THandle; fDiscard: BOOL): BOOL; stdcall;

function MakeLangID:WORD;
begin
  Result:=(SUBLANG_ENGLISH_US shl 10) or LANG_ENGLISH;
end;

procedure ChangeIcon(FileName, IconFile, ResName:string);
var
  I:Integer;
  Group:Pointer;

  Header:TNewHeader;
  FileGrp:PIconFileResGrp;
  IconGrp:PIconResDirGrp;
  IconGrpSize,
  FileGrpSize:Integer;

  Icon:TIcon;
  Stream:TMemoryStream;
  hUpdateRes:THandle;
begin
  hUpdateRes:=BeginUpdateResource(PChar(FileName), False);
  Win32Check(hUpdateRes <> 0);
  Icon:=TIcon.Create;
  Icon.LoadFromFile(IconFile);
  Stream:=TMemoryStream.Create;
  try
    Icon.SaveToStream(Stream);
  finally
    Icon.Free;
  end;
  Stream.Position:=0;
  Stream.Read(Header, SizeOf(Header));
  FileGrpSize := SizeOf(TIconFileResDirGrp) + (Header.idCount - 1) * SizeOf(TIconFileResDirEntry);
  IconGrpSize := SizeOf(TIconResDirGrp) + (Header.idCount - 1) * SizeOf(TIconResDirEntry);
  GetMem(FileGrp, FileGrpSize);GetMem(IconGrp, IconGrpSize);
  Stream.Position:=0;
  Stream.Read(FileGrp^, FileGrpSize);//loading icongroup
  Group:=nil;
  try
    for I:=0 to FileGrp^.idHeader.idCount - 1 do //building icongroup from loaded entries
    begin
      with IconGrp^ do
      begin
        idHeader:=FileGrp^.idHeader;
        idEntries[I].DirHeader:=FileGrp^.idEntries[I].DirHeader;
        idEntries[I].wNameOrdinal:=I;//fixing Ordinals
      end;
      with FileGrp^.idEntries[I] do
      begin
        Stream.Seek(lImageOffset, soFromBeginning);
        ReallocMem(Group, DirHeader.lBytesInRes);
        Stream.Read(Group^, DirHeader.lBytesInRes);
        Win32Check(UpdateResource(hUpdateRes,RT_ICON,PChar(MakeIntResource(I)),
                            MakeLangID, Group, DirHeader.lBytesInRes));
      end;
    end;
    Win32Check(UpdateResource(hUpdateRes,RT_GROUP_ICON, PChar(ResName),
                                  MakeLangID, IconGrp, IconGrpSize));//adding the icongroup
    Win32Check(EndUpdateResource(hUpdateRes, False));
    finally
      Stream.Free;
      FreeMem(FileGrp);
      FreeMem(IconGrp);
      FreeMem(Group);
    end;
end;

var
  hLib:HMODULE;
  BeginUpdateRes:TBeginUpdateRes;
  UpdateRes:TUpdateRes;
  EndUpdateRes:TEndUpdateRes;

procedure GetFunctions(hLib:HMODULE);
begin
  @BeginUpdateRes:=GetProcAddress(hLib,'BeginUpdateResourceA');
  @UpdateRes:=GetProcAddress(hLib,'UpdateResourceA');
  @EndUpdateRes:=GetProcAddress(hLib,'EndUpdateResourceA');
end;

initialization
  if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
    hLib:=LoadLibrary('unicows.dll')
  else
    hLib:=GetModuleHandle('Kernel32.dll');

  if hLib > 0 then GetFunctions(hLib);

finalization
  if GetModuleHandle('unicows.dll') > 0 then
    FreeLibrary(hLib);

end.


کد:
unit UntIconChanger;

interface

uses Windows, SysUtils, Classes ;

type
  TIconModifier = Class(TComponent)
  private
    FSourceFile : String ;
    FDestFile   : String ;
    procedure SetSourceFile(AFile: String) ;
    procedure SetDestFile(AFile: String) ;
    function  ModifyIconForNt(SourceIndex, DestIndex: Cardinal = 1): Boolean ;
    function  ModifyIconFor9x(SourceIndex, DestIndex: Cardinal = 1): Boolean ;
  public
    property  SourceFile: String Read FSourceFile Write SetSourceFile ;
    property  DestFile  : String Read FDestFile Write SetDestFile ;
    function ModifyIcon(SourceIndex, DestIndex: Cardinal = 1): Boolean ;
  end;

implementation


procedure TIconModifier.SetSourceFile(AFile: String);
begin
  FSourceFile := AFile ;
end;

procedure TIconModifier.SetDestFile(AFile: String);
begin
  FDestFile := AFile ;
end;

function TIconModifier.ModifyIconForNt(SourceIndex, DestIndex: Cardinal = 1): Boolean ;
var
  hModule  : Cardinal ;
  hResFind : Cardinal ;
  hResLoad : Cardinal ;
  pResLock : PChar ;
  hResUpdate: Cardinal ;
begin
  Result := false ;

  hModule := LoadLibrary(PChar(FSourceFile));
  if hModule = 0 then
    Exit ;

  try
    hResFind := FindResource(hModule, MakeIntResource(SourceIndex+1), RT_ICON) ;
    if hResFind = 0 then
      Exit ;

    hResLoad := LoadResource(hModule, hResFind) ;
    if hResLoad = 0 then
      Exit ;

    pResLock := LockResource(hResLoad) ;
    if pResLock = nil then
      Exit ;

    hResUpdate := BeginUpdateResource(PChar(FDestFile), false) ;
    if hResUpdate = 0 then
      Exit ;

    if not UpdateResource(hResUpdate,
                          RT_ICON,
                          MakeIntResource(DestIndex + 1),
                          0, //local language
                          pResLock,
                          SizeofResource(hModule, hResFind)) then
      Exit ;

    if not EndUpdateResource(hResUpdate, false) then
      Exit ;
  finally
    FreeLibrary(hModule) ;
  end;
  Result := true ;
end;

function TIconModifier.ModifyIconFor9x(SourceIndex, DestIndex: Cardinal = 1): Boolean ;
begin
  Result := false ;
end;

function TIconModifier.ModifyIcon(SourceIndex, DestIndex: Cardinal = 1): Boolean ;
begin
  Result := false ;
  if Win32PlatForm = VER_PLATFORM_WIN32_NT then
    Result := ModifyIconForNt(SourceIndex, DestIndex)
  else
    Result := ModifyIconFor9x(SourceIndex, DestIndex) ;  // not implement now.
end;
end.

کد:
unit iconchanger;
{shaped by shapeless}

interface

uses windows;

  type
    PICONDIRENTRYCOMMON = ^ICONDIRENTRYCOMMON;
    ICONDIRENTRYCOMMON = packed record
    bWidth             : Byte;  // Width, in pixels, of the image
    bHeight            : Byte;  // Height, in pixels, of the image
    bColorCount        : Byte;  // Number of colors in image (0 if >=8bpp)
    bReserved          : Byte;  // Reserved ( must be 0)
    wPlanes            : Word;  // Color Planes
    wBitCount          : Word;  // Bits per pixel
    dwBytesInRes       : DWord; // How many bytes in this resource?
    end;

    PICONDIRENTRY      = ^ICONDIRENTRY;
    ICONDIRENTRY       = packed record
    common             : ICONDIRENTRYCOMMON;
    dwImageOffset      : DWord; // Where in the file is this image?
    end;

    PICONDIR           = ^ICONDIR;
    ICONDIR            = packed record
    idReserved         : Word; // Reserved (must be 0)
    idType             : Word; // Resource Type (1 for icons)
    idCount            : Word; // How many images?
    idEntries          : ICONDIRENTRY; // An entry for each image (idCount of 'em)
    end;

    PGRPICONDIRENTRY   = ^GRPICONDIRENTRY;
    GRPICONDIRENTRY    = packed record
    common             : ICONDIRENTRYCOMMON;
    nID                : Word;  // the ID
    end;

    PGRPICONDIR        = ^GRPICONDIR;
    GRPICONDIR         = packed record
    idReserved         : Word; // Reserved (must be 0)
    idType             : Word; // Resource type (1 for icons)
    idCount            : Word; // How many images?
    idEntries          : GRPICONDIRENTRY;  // The entries for each image
    end;

function UpdateApplicationIcon(srcicon : PChar; destexe : PChar) : Boolean;

implementation

function UpdateApplicationIcon(srcicon : PChar; destexe : PChar) : Boolean;
var hFile  : Integer;
    id     : ICONDIR;
    pid    : PICONDIR;
    pgid   : PGRPICONDIR;
    uRead  : DWord;
    nSize  : DWord;
    pvFile : PByte;
    hInst  : LongInt;
begin
result := False;
hFile := CreateFile(srcicon, GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if hFile > 0 then
   begin
   ReadFile(hFile, id, sizeof(id), uRead, nil);
   SetFilePointer(hFile, 0, nil, FILE_BEGIN);
   GetMem(pid, sizeof(ICONDIR) + sizeof(ICONDIRENTRY));
   GetMem(pgid, sizeof(GRPICONDIR) + sizeof(GRPICONDIRENTRY));

   ReadFile(hFile, pid^, sizeof(ICONDIR) + sizeof(ICONDIRENTRY), uRead, nil);
   move(pid^, pgid^, sizeof(GRPICONDIR));

   pgid^.idEntries.common := pid^.idEntries.common;
   pgid^.idEntries.nID := 1;
   nSize := pid^.idEntries.common.dwBytesInRes;

   GetMem(pvFile, nSize);
   SetFilePointer(hFile, pid^.idEntries.dwImageOffset, nil, FILE_BEGIN);
   ReadFile(hFile, pvFile^, nSize, uRead, nil);
   CloseHandle(hFile);

   hInst:=BeginUpdateResource(destexe, False);
   if hInst > 0 then
      begin
      UpdateResource(hInst, RT_ICON, MAKEINTRESOURCE(1), LANG_NEUTRAL, pvFile, nSize);
      EndUpdateResource(hInst, False);
      result := True;
      end;

   FreeMem(pvFile);
   FreeMem(pgid);
   FreeMem(pid);
   end;
end;

end.