Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
    ByVal hwnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long

Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    wParam As Any, _
    lParam As Any) As Long

Public Const GWL_WNDPROC = (-4)

Dim PrevProc As Long

Public Sub HookWindow(hwnd As Long)
    PrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub UnHookWindow(hwnd As Long)
    SetWindowLong hwnd, GWL_WNDPROC, PrevProc
End Sub



Public Function WindowProc(ByVal hwnd As Long, _
                           ByVal uMsg As Long, _
                           ByVal wParam As Long, _
                           ByVal lParam As Long) As Long
                           
WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
  
Debug.Print uMsg, wParam, lParam

End Function

Private Sub Form_Load()
HookWindow Me.hwnd
End Sub

Private Sub Form_Unload(Cancel As Integer)
UnHookWindow Me.hwnd
End Sub

Public Function WindowProc(ByVal hwnd As Long, _
                           ByVal uMsg As Long, _
                           ByVal wParam As Long, _
                           ByVal lParam As Long) As Long
                           
Const WM_LBUTTONDOWN = &H201
                           
If uMsg <> WM_LBUTTONDOWN Then
    WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
Else
    Debug.Print uMsg, wParam, lParam
End If

End Function

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
MsgBox "no me puedo mostrar"
End Sub

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    wParam As Any, _
    lParam As Any) As Long

Private Sub Command1_Click()
WM_CLOSE = &H10
SendMessage Me.hwnd, WM_CLOSE, 1, 1
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
MsgBox UnloadMode
End Sub

'------------------------------------------------------------------------------
' Enumeración con los mensajes de windows (Window Messages)
'
' Esta lista está sacada de ApiViewer 2004,
' algunas declaraciones están en el fichero Win32API.txt
'
' En los casos que se indique #if ... es que son para otras versiones de Windows:
' #if(WINVER >= 0x0400)     Será Windows NT 4 y superior y Windows 98
' #if(WINVER >= 0x0500)     Será Windows 2000 y superior (Windows NT 5) (creo)
Public Enum eWSCWM

    WM_NULL = &H0
    WM_CREATE = &H1
    WM_DESTROY = &H2
    WM_MOVE = &H3
    WM_SIZE = &H5
    
    WM_ACTIVATE = &H6
    
    WM_SETFOCUS = &H7
    WM_KILLFOCUS = &H8
    WM_ENABLE = &HA
    WM_SETREDRAW = &HB
    WM_SETTEXT = &HC
    WM_GETTEXT = &HD
    WM_GETTEXTLENGTH = &HE
    WM_PAINT = &HF
    WM_CLOSE = &H10
    WM_QUERYENDSESSION = &H11
    WM_QUIT = &H12
    WM_QUERYOPEN = &H13
    WM_ERASEBKGND = &H14
    WM_SYSCOLORCHANGE = &H15
    WM_ENDSESSION = &H16
    WM_SHOWWINDOW = &H18
    WM_WININICHANGE = &H1A
    ' #if(WINVER >= 0x0400)
    WM_SETTINGCHANGE = WM_WININICHANGE
    ' #endif /* WINVER >= 0x0400 */
    WM_DEVMODECHANGE = &H1B
    WM_ACTIVATEAPP = &H1C
    WM_FONTCHANGE = &H1D
    WM_TIMECHANGE = &H1E
    WM_CANCELMODE = &H1F
    WM_SETCURSOR = &H20
    WM_MOUSEACTIVATE = &H21
    WM_CHILDACTIVATE = &H22
    WM_QUEUESYNC = &H23
    
    WM_GETMINMAXINFO = &H24
    
    WM_PAINTICON = &H26
    WM_ICONERASEBKGND = &H27
    WM_NEXTDLGCTL = &H28
    WM_SPOOLERSTATUS = &H2A
    WM_DRAWITEM = &H2B
    WM_MEASUREITEM = &H2C
    WM_DELETEITEM = &H2D
    WM_VKEYTOITEM = &H2E
    WM_CHARTOITEM = &H2F
    WM_SETFONT = &H30
    WM_GETFONT = &H31
    WM_SETHOTKEY = &H32
    WM_GETHOTKEY = &H33
    WM_QUERYDRAGICON = &H37
    WM_COMPAREITEM = &H39
    ' #if(WINVER >= 0x0500)
    WM_GETOBJECT = &H3D
    ' #endif /* WINVER >= 0x0500 */
    WM_COMPACTING = &H41
    
    WM_WINDOWPOSCHANGING = &H46
    WM_WINDOWPOSCHANGED = &H47
    
    WM_POWER = &H48
    
    WM_COPYDATA = &H4A
    WM_CANCELJOURNAL = &H4B
    
    ' #if(WINVER >= 0x0400)
    WM_NOTIFY = &H4E
    WM_INPUTLANGCHANGEREQUEST = &H50
    WM_INPUTLANGCHANGE = &H51
    WM_TCARD = &H52
    WM_HELP = &H53
    WM_USERCHANGED = &H54
    WM_NOTIFYFORMAT = &H55
    '
    '#define NFR_ANSI                             1
    '#define NFR_UNICODE                          2
    '#define NF_QUERY                             3
    '#define NF_REQUERY                           4
    '
    WM_CONTEXTMENU = &H7B
    WM_STYLECHANGING = &H7C
    WM_STYLECHANGED = &H7D
    WM_DISPLAYCHANGE = &H7E
    WM_GETICON = &H7F
    WM_SETICON = &H80
    ' #endif /* WINVER >= 0x0400 */
    '
    WM_NCCREATE = &H81
    WM_NCDESTROY = &H82
    WM_NCCALCSIZE = &H83
    WM_NCHITTEST = &H84
    WM_NCPAINT = &H85
    WM_NCACTIVATE = &H86
    WM_GETDLGCODE = &H87
    WM_NCMOUSEMOVE = &HA0
    WM_NCLBUTTONDOWN = &HA1
    WM_NCLBUTTONUP = &HA2
    WM_NCLBUTTONDBLCLK = &HA3
    WM_NCRBUTTONDOWN = &HA4
    WM_NCRBUTTONUP = &HA5
    WM_NCRBUTTONDBLCLK = &HA6
    WM_NCMBUTTONDOWN = &HA7
    WM_NCMBUTTONUP = &HA8
    WM_NCMBUTTONDBLCLK = &HA9
    '
    'WM_KEYFIRST = &H100
    WM_KEYDOWN = &H100
    WM_KEYUP = &H101
    WM_CHAR = &H102
    WM_DEADCHAR = &H103
    WM_SYSKEYDOWN = &H104
    WM_SYSKEYUP = &H105
    WM_SYSCHAR = &H106
    WM_SYSDEADCHAR = &H107
    'WM_KEYLAST = &H108
    '
    ' #if(WINVER >= 0x0400)
    WM_IME_STARTCOMPOSITION = &H10D
    WM_IME_ENDCOMPOSITION = &H10E
    WM_IME_COMPOSITION = &H10F
    'WM_IME_KEYLAST = &H10F
    ' #endif /* WINVER >= 0x0400 */
    '
    WM_INITDIALOG = &H110
    WM_COMMAND = &H111
    WM_SYSCOMMAND = &H112
    WM_TIMER = &H113
    WM_HSCROLL = &H114
    WM_VSCROLL = &H115
    WM_INITMENU = &H116
    WM_INITMENUPOPUP = &H117
    WM_MENUSELECT = &H11F
    WM_MENUCHAR = &H120
    WM_ENTERIDLE = &H121
    '
    ' #if(WINVER >= 0x0500)
    WM_MENURBUTTONUP = &H122
    WM_MENUDRAG = &H123
    WM_MENUGETOBJECT = &H124
    WM_UNINITMENUPOPUP = &H125
    WM_MENUCOMMAND = &H126
    ' #endif /* WINVER >= 0x0500 */
    '
    WM_CTLCOLORMSGBOX = &H132
    WM_CTLCOLOREDIT = &H133
    WM_CTLCOLORLISTBOX = &H134
    WM_CTLCOLORBTN = &H135
    WM_CTLCOLORDLG = &H136
    WM_CTLCOLORSCROLLBAR = &H137
    WM_CTLCOLORSTATIC = &H138
    
    'WM_MOUSEFIRST = &H200
    WM_MOUSEMOVE = &H200
    WM_LBUTTONDOWN = &H201
    WM_LBUTTONUP = &H202
    WM_LBUTTONDBLCLK = &H203
    WM_RBUTTONDOWN = &H204
    WM_RBUTTONUP = &H205
    WM_RBUTTONDBLCLK = &H206
    WM_MBUTTONDOWN = &H207
    WM_MBUTTONUP = &H208
    WM_MBUTTONDBLCLK = &H209
    ' #if (_WIN32_WINNT >= 0x0400) || (_WIN32_WINDOWS > 0x0400)
    WM_MOUSEWHEEL = &H20A
    'WM_MOUSELAST = &H20A
    ' #else
    'WM_MOUSELAST = &H209
    ' #endif /* if (_WIN32_WINNT < 0x0400) */
    
    WM_PARENTNOTIFY = &H210
    WM_ENTERMENULOOP = &H211
    WM_EXITMENULOOP = &H212
    
    ' #if(WINVER >= 0x0400)
    WM_NEXTMENU = &H213
    WM_SIZING = &H214
    WM_CAPTURECHANGED = &H215
    WM_MOVING = &H216
    
    WM_POWERBROADCAST = &H218
    WM_DEVICECHANGE = &H219
    ' #endif /* WINVER >= 0x0400 */
    
    WM_MDICREATE = &H220
    WM_MDIDESTROY = &H221
    WM_MDIACTIVATE = &H222
    WM_MDIRESTORE = &H223
    WM_MDINEXT = &H224
    WM_MDIMAXIMIZE = &H225
    WM_MDITILE = &H226
    WM_MDICASCADE = &H227
    WM_MDIICONARRANGE = &H228
    WM_MDIGETACTIVE = &H229
    WM_MDISETMENU = &H230
    WM_DROPFILES = &H233
    WM_MDIREFRESHMENU = &H234
    
    ' #if(WINVER >= 0x0400)
    WM_IME_SETCONTEXT = &H281
    WM_IME_NOTIFY = &H282
    WM_IME_CONTROL = &H283
    WM_IME_COMPOSITIONFULL = &H284
    WM_IME_SELECT = &H285
    WM_IME_CHAR = &H286
    ' #endif /* WINVER >= 0x0400 */
    ' #if(WINVER >= 0x0500)
    WM_IME_REQUEST = &H288
    ' #endif /* WINVER >= 0x0500 */
    ' #if(WINVER >= 0x0400)
    WM_IME_KEYDOWN = &H290
    WM_IME_KEYUP = &H291
    ' #endif /* WINVER >= 0x0400 */
    '
    ' #if(_WIN32_WINNT >= 0x0400)
    WM_MOUSEHOVER = &H2A1
    WM_MOUSELEAVE = &H2A3
    ' #endif /* _WIN32_WINNT >= 0x0400 */
    
    WM_CUT = &H300
    WM_COPY = &H301
    WM_PASTE = &H302
    WM_CLEAR = &H303
    WM_UNDO = &H304
    WM_RENDERFORMAT = &H305
    WM_RENDERALLFORMATS = &H306
    WM_DESTROYCLIPBOARD = &H307
    WM_DRAWCLIPBOARD = &H308
    WM_PAINTCLIPBOARD = &H309
    WM_VSCROLLCLIPBOARD = &H30A
    WM_SIZECLIPBOARD = &H30B
    WM_ASKCBFORMATNAME = &H30C
    WM_CHANGECBCHAIN = &H30D
    WM_HSCROLLCLIPBOARD = &H30E
    WM_QUERYNEWPALETTE = &H30F
    WM_PALETTEISCHANGING = &H310
    WM_PALETTECHANGED = &H311
    WM_HOTKEY = &H312
    '
    ' #if(WINVER >= 0x0400)
    WM_PRINT = &H317
    WM_PRINTCLIENT = &H318
    '
    WM_HANDHELDFIRST = &H358
    WM_HANDHELDLAST = &H35F
    '
    WM_AFXFIRST = &H360
    WM_AFXLAST = &H37F
    ' #endif /* WINVER >= 0x0400 */
    '
    WM_PENWINFIRST = &H380
    WM_PENWINLAST = &H38F
    '
    ' #if(WINVER >= 0x0400)
    WM_APP = &H8000
    ' #endif /* WINVER >= 0x0400 */
    
    ' NOTE: All Message Numbers below 0x0400 are RESERVED.
    
    ' Private Window Messages Start Here:
    WM_USER = &H400
End Enum

Public Enum eWSCHitTest
    ' WM_NCHITTEST and MOUSEHOOKSTRUCT Mouse Position Codes
    HTERROR = (-2)
    HTTRANSPARENT = (-1)
    HTNOWHERE = 0
    HTCLIENT = 1
    HTCAPTION = 2
    HTSYSMENU = 3
    HTGROWBOX = 4
    HTSIZE = HTGROWBOX
    HTMENU = 5
    HTHSCROLL = 6
    HTVSCROLL = 7
    HTMINBUTTON = 8
    HTMAXBUTTON = 9
    HTLEFT = 10
    HTRIGHT = 11
    HTTOP = 12
    HTTOPLEFT = 13
    HTTOPRIGHT = 14
    HTBOTTOM = 15
    HTBOTTOMLEFT = 16
    HTBOTTOMRIGHT = 17
    HTBORDER = 18
    HTREDUCE = HTMINBUTTON
    HTZOOM = HTMAXBUTTON
    HTSIZEFIRST = HTLEFT
    HTSIZELAST = HTBOTTOMRIGHT
End Enum

Public Enum eWSCMF
    ' Menú Flags para WM_MENUSELECT
    'MF_UNCHECKED = &H0&
    MF_GRAYED = &H1&
    MF_DISABLED = &H2&
    MF_BITMAP = &H4&
    MF_CHECKED = &H8&
    MF_POPUP = &H10&
    MF_HILITE = &H80&
    MF_OWNERDRAW = &H100&
    MF_SYSMENU = &H2000&
    MF_MOUSESELECT = &H8000&
End Enum

' Valores de fuSource para el mensaje WM_ENTERIDLE
Public Enum eWSCMSFG
    MSGF_DIALOGBOX = 0
    MSGF_MENU = 2
End Enum

' Mensajes varios
Public Enum eWSCMisc
    ' WM_ACTIVATE state values
    WA_INACTIVE = 0
    WA_ACTIVE = 1
    WA_CLICKACTIVE = 2
    
    ' wParam for WM_POWER window message and DRV_POWER driver notification
    PWR_OK = 1
    PWR_FAIL = (-1)
    PWR_SUSPENDREQUEST = 1
    PWR_SUSPENDRESUME = 2
    PWR_CRITICALRESUME = 3
    
    ' WM_SYNCTASK Commands
    ST_BEGINSWP = 0
    ST_ENDSWP = 1
    
    ' SendMessageTimeout values
    SMTO_NORMAL = &H0
    SMTO_BLOCK = &H1
    SMTO_ABORTIFHUNG = &H2
    
    ' WM_MOUSEACTIVATE Return Codes
    MA_ACTIVATE = 1
    MA_ACTIVATEANDEAT = 2
    MA_NOACTIVATE = 3
    MA_NOACTIVATEANDEAT = 4
    
    ' WM_SIZE message wParam values
    SIZE_RESTORED = 0
    SIZE_MINIMIZED = 1
    SIZE_MAXIMIZED = 2
    SIZE_MAXSHOW = 3
    SIZE_MAXHIDE = 4
    
    ' WM_NCCALCSIZE return flags
    WVR_ALIGNTOP = &H10
    WVR_ALIGNLEFT = &H20
    WVR_ALIGNBOTTOM = &H40
    WVR_ALIGNRIGHT = &H80
    WVR_HREDRAW = &H100
    WVR_VREDRAW = &H200
    WVR_REDRAW = (WVR_HREDRAW Or WVR_VREDRAW)
    WVR_VALIDRECTS = &H400
    
    ' Key State Masks for Mouse Messages
    MK_LBUTTON = &H1
    MK_RBUTTON = &H2
    MK_SHIFT = &H4
    MK_CONTROL = &H8
    MK_MBUTTON = &H10
    
    ' Constantes para el menú del sistema
    SC_RESTORE = &HF120&
    SC_MOVE = &HF010&
    SC_SIZE = &HF000&
    SC_MINIMIZE = &HF020&
    SC_MAXIMIZE = &HF030&
    SC_CLOSE = &HF060&

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