'
'Coded by Slasher-K
'
Public Declare Function BeginUpdateResource Lib "unicows.dll" Alias "BeginUpdateResourceA" (ByVal pFileName As String, ByVal bDeleteExistingResources As Long) As Long
Public Declare Function UpdateResource Lib "unicows.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
Public Declare Function EndUpdateResource Lib "unicows.dll" Alias "EndUpdateResourceA" (ByVal hUpdate As Long, ByVal fDiscard As Long) As Long


Function ChangeIcon(Filename As String, IconFilename As String) As Boolean
  On Error GoTo ErrRes
  
        Dim hRes&, r&
        Dim btData() As Byte
  
  hRes = BeginUpdateResource(Filename, False)
  
  If hRes = 0 Then
    Debug.Print "No se pudo abrir el archivo"
    
    Exit Function
  End If

  btData = GetIconData(IconFilename)
  r = UpdateResource(hRes, RT_ICON, 1, 3082, btData(0), UBound(btData))

ErrRes:
  r = EndUpdateResource(hRes, False)
End Function

'
'Coded by Slasher-K
'

Option Explicit

Type ICONDIRENTRY
  bWidth        As Byte     '  Ancho, en píxeles, de la imagen.
  bHeight       As Byte     '  Alto, en píxeles, de la imagen.
  bColorCount   As Byte     '  Número de colores en la imagen (0 si >=8bpp).
  bReserved     As Byte     '  Reservado ( debe ser 0).
  wPlanes       As Integer  '  Color Planes.
  wBitCount     As Integer  '  Bits por pixel.
  dwBytesInRes  As Long     '  Bytes in the resource.
  dwImageOffset As Long     '  Puntero a los datos en el archivo.
End Type

Type ICONDIR
  idReserved  As Integer
  idType      As Integer
  idCount     As Integer
End Type

Function GetIconData(IcoFile As String, Optional IconIndex As Integer) As Byte()
  On Error Resume Next
  
      
      Dim lpIconDir   As ICONDIR
      Dim lpIconEntry As ICONDIRENTRY
      Dim btData()    As Byte
      Dim lOffset&, iCnt%
      Dim hFile%, i%

  hFile = FreeFile
  
  Open IcoFile For Binary As #hFile
  
  Get #hFile, 1, lpIconDir
  
  With lpIconDir
    lOffset = Len(lpIconDir) + 1
    
    If (IconIndex > .idCount) Or (IconIndex < 1) Then IconIndex = 1
    
    For i = 1 To .idCount
      Get #hFile, lOffset, lpIconEntry
      
      If i = IconIndex Then
        ReDim btData(lpIconEntry.dwBytesInRes) As Byte
        
        Get #hFile, lpIconEntry.dwImageOffset + 1, btData
        
        GetIconData = btData
        
        Exit For
      End If
      
      lOffset = lOffset + Len(lpIconEntry)
    Next
    
  End With
  
ErrRead:
  Close #hFile
End Function

Public Declare Function BeginUpdateResource9x Lib "unicows.dll" Alias "BeginUpdateResourceA" (ByVal pFileName As String, ByVal bDeleteExistingResources As Long) As Long
Public Declare Function UpdateResource9x Lib "unicows.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
Public Declare Function EndUpdateResource9x Lib "unicows.dll" Alias "EndUpdateResourceA" (ByVal hUpdate As Long, ByVal fDiscard As Long) As Long

Public Declare Function BeginUpdateResourceNT Lib "kernel32" Alias "BeginUpdateResourceW" (ByVal pFileName As String, ByVal bDeleteExistingResources As Long) As Long
Public Declare Function UpdateResourceNT Lib "kernel32" Alias "UpdateResourceW" (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
Public Declare Function EndUpdateResourceNT Lib "kernel32" Alias "EndUpdateResourceW" (ByVal hUpdate As Long, ByVal fDiscard As Long) As Long

Function ChangeIcon(Filename As String, IconFilename As String) As Boolean
  On Error GoTo ErrRes
  
        Dim hRes&, r&
        Dim btData() As Byte
  
  If IsWin9x Then
    hRes = BeginUpdateResource9x(Filename, False)
  Else
    hRes = BeginUpdateResourceNT(Filename, False)
  End If
  
  If hRes = 0 Then
    Debug.Print "No se pudo abrir el archivo"
    
    Exit Function
  End If

  btData = GetIconData(IconFilename)
  
  If IsWin9x Then
    r = UpdateResource9x(hRes, RT_ICON, 1, 3082, btData(0), UBound(btData))
  Else
    r = UpdateResourceNT(hRes, RT_ICON, 1, 3082, btData(0), UBound(btData))
  End If
  
ErrRes:
  If IsWin9x Then
    r = EndUpdateResource9x(hRes, False)
  Else
    r = EndUpdateResourceNT(hRes, False)
  End If
End Function

Function IsWin9x() As Boolean
      Dim lpVerInfo As OSVERSIONINFO
      Dim r&

  lpVerInfo.dwOSVersionInfoSize = Len(lpVerInfo)
  
  r = GetVersionEx(lpVerInfo)
  IsWin9x = (lpVerInfo.dwPlatformId = 1)
End Function

Public Declare Function BeginUpdateResourceNT Lib "kernel32" Alias "BeginUpdateResourceA" (ByVal pFileName As String, ByVal bDeleteExistingResources As Long) As Long
Public Declare Function UpdateResourceNT Lib "kernel32" 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
Public Declare Function EndUpdateResourceNT Lib "kernel32" Alias "EndUpdateResourceA" (ByVal hUpdate As Long, ByVal fDiscard As Long) As Long