Cambiar Icono de Aplicación en tiempo de ejecución

[.Slasher-K.]

A pedido de KiZar me puse a investigar y logré escribir un code que funciona tanto en Win9X como en Win2K y demás.

El problema erradicaba en los datos que había que ingresar en el ejecutable, no tanto en la llamada a UpdateResource. Así que escribí una función que extrae los datos crudos de un archivo de ícono (*.ico), o sea, la imagen en sí, de esta manera ya funciona perfectamente.

Módulo basChangeRes.bas

Código [Seleccionar] Expandir


'
'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



Módulo basIcons.bas

Código [Seleccionar] Expandir


'
'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


[Kizar]

RT_ICON = ¿?
Salu2

[.Slasher-K.]

RT_ICON = 3

Declarada en win.tlb

[Kizar]

Yo tengo windows XP y pongo:

Código [Seleccionar] Expandir


Private Sub Form_Load()
ChangeIcon "C:\f.exe", "C:\a.ico"
End Sub


Y el programa se cuelga y deja el exe como esta sin cambiar el icono....

[.Slasher-K.]

Bajate unicows.dll y copiala al direcotorio del sistema, si no funciona cambia las declaraciones para usar las de kernel32.dll.

Descargar unicows.dll

Saludos.

[Kizar]

Ya la tenia instalada de antes, pero el problema no es ese, el problema es que da un fallo de windows que pone que:
"La aplicacion ha provocado un error y debe ser cerrada..."

Ya es tarde aqui , mañana busco informacion sobre el uso de esas apis y algun ejemplo, aunke hay poca cosa en internet....

Salu2

[.Slasher-K.]

El problema está en que Windows 9x no implementa esas llamadas porque son funciones Unicode, por eso hay que usar la otra librería (unicows.dll), en cambio Windows NT/2k sí, por lo que se pueden usar tranquilamente las funciones de kernel32.dll, pero las Unicode, o sea, BeginUpdateResourceW, etc.

Por eso lo que se puede hacer es verificar qué sistema es y usar distintas llamadas dependiendo de la versión. Dejo el code modificado para que sea independiente del SO.

Código [Seleccionar] Expandir


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


Eso debería funcionar. A mi en win9x me funciona perfecto. Y por inet no vas a encontrar mucho ni menos código, te lo aseguro .

[Kizar]

Eso debería funcionar. A mi en win9x me funciona perfecto. Y por inet no vas a encontrar mucho ni menos código, te lo aseguro .

Encontre algo, pero en frances y era muy largo el code, porl o menos ahora ya no da el error, pero no cambia el icono. (llorar)

Mañana mirare a ver lo que pasa.

[.Slasher-K.]

¿A ver, pero cómo lo llamas?

El argumento IconFilename tiene que ser un archivo *.ico. Probando en XP (gracias Crack_X ), me di cuenta que las llamadas unicode no funcionan, tienen que ser las Ansi

Código [Seleccionar] Expandir


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


[Kizar]

Código [Seleccionar] Expandir

Private Sub Form_Load()
ChangeIcon "C:\f.exe", "C:\a.ico"
End Sub

Salu2