Mensajes

[notepad]

hola, aver si puedo explicarte y que me entiendas, todas las ventanas , como ser un picturebox un commadbuton un textbox un formulario etc. reciven mensajes como por ejemplo click mousedown, repintado, etc. una forma de poder ver cuales son estos mensajes lo puedes hacer de esta forma

por ejemplo para ver los mensajes que recive un formulario

en un modulo

Código [Seleccionar] Expandir


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

y en un formulario

Código [Seleccionar] Expandir


Private Sub Form_Load()
HookWindow Me.hwnd
End Sub

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


bien como veras lo que hace este codigo es interceptar todos los mensajes que le son enviados al formulario, como por ejemplo cuando mueves el mouse, le das click , lo cierras, etc.
e inclusive puedes evitar que estos eventos se den, por ejemplo:

cambias la funcion WindowProc y la dejas asi

Código [Seleccionar] Expandir


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


El formulario dejara de recivir el evento Form_MouseDown oviamente con el boton izquierdo

por ejemplo si pones en el formulario te vas a dar cuenta

Código [Seleccionar] Expandir


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


como veras lo que hace es  si  uMsg es igual a la constnte WM_LBUTTONDOWN entonces no permite recivir el mensage al forulario.

si te fijas la constante WM_LBUTTONDOWN no es mas que el mensage Hex(uMsg) osea Hex(521) = &H201, con lo que hay tienes como saber cual es el mensage recivido, ahora existe listados de constantes para hacer que esto sea mas legible y entendible, una aplicacion muy completa con muchas constatne es el ApiViewer 2004.

Nota: no e podido nunca de esta forma interceptar los mensajes de una ventana que no alla sido creada por mi aplicacion por ejemplo interceptar el notepad, si alguien save como se hace que avise
(ya se que los mensajes serian los mismos, pero se podrian hacer muchas cosas como por ejemplo evitarlos)

bien todo esto es para llegar a como saber que mensage enviar a otra aplicacion para ello se utiliza SendMessage osea si pudes saber que mensajes recives puedes saber que mensage enviar

con respecto al tema del apagado o mensage para cerrar una aplicacion, pues no encontre dicho mensage, si bien con la constante WM_CLOSE lo cierra, no supe como aplicar el unloadmode

Código [Seleccionar] Expandir


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


te paso unas constantes muy utiles ( estan en tipo enum, pero bien vos ya sabras como usarlas)

Código [Seleccionar] Expandir


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


alunas constantes mas y un poco mas de informacion
http://www.canalvisualbasic.net/forum/forum_posts.asp?TID=29194

Saludos

hola yo hice el ocx y lamentablemente no se le pude asignar la transparencia, pero para lo que tu quieres te aconsejo la clase , y realmente no vi que incremente mucho la memoria creo que lo pudes usar sin problemas

Saludos

hola a lo mismo que como te dice YeIk0s seria muy importante que nos dijeras que quieres enviar y a que direccion paraa poder ayudarte.
yo me e instruido vastante en el tema y te podria ayudar pero nesesito saber que envias y adonde

por lo pronto te paso una aplicacion que hice te puede ayudar(pero  te advierto esta complicada para entender)

http://www.recursosvisualbasic.com.ar/htm/utilidades-codigo-fuente/server-at-leandro.htm

Saludos y espero tu respuesta

[(Aclaro esto es inofencivo no hay problemas solo cambia el icono)]

bueno siguiendo con el tema de los iconos, pongo un modulo para cambiar el icono de un exe por el de otro exe, esta un poco extenso ya que no esta echo para este proposito, pero se puede resumir vastante y optimizar mas,

En un modulo bas

Código [Seleccionar] Expandir


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


para provarlo en un formulario con un boton y un exe en c:\ llamdo virus.exe

(Aclaro esto es inofencivo no hay problemas solo cambia el icono)

Código [Seleccionar] Expandir


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


algunas apis solo trabajan vajo win XP pero hay substitutos asi que si les interesa se puede mejorar tambien, no lo hice porque no tengo win 98 y no sabia si iva a funcionar, pero cualquier cosa lo vemos y lo modificamos

Saludos

hola me temo que ninguno de los modulos presentes son eficientes la unica forma de que quede un buen trabajo es trabajar con las apis LoadResource,EnumResourceLanguages,EnumResourceNamesByNum
EnumResourceNamesByString,EnumResourceTypes
y especialmente
BeginUpdateResource,UpdateResource,EndUpdateResource

voy a ver si puedo hacer un modulo para cambiar el icono de un exe por otro exe

muy buena pregunta, este tipo sabe de verdad, y quien dijo eso de que suicido mmm, que mal si es asi, pero uviera que esta muy seguro de tal cosa, segun lei unaves no era bien benido en este foro pero seria muy bueno que vuelva o porlomenos saber por donde anda, si alguien sabe algo que chifle

saludos

http://www.recursosvisualbasic.com.ar/

En castellano y bien pintando muy bien

hola yo pense que era una versión diferente "mini" como lei en algunos lados pero no son mas que archivos del compilador de Visual Basic 6.0 y sus librerias, simplemente el compilador sin el entorno de desarrollo, pero en fin esta muy util ya que  como bien lo podemos portar facilmente en un pendrive o descargar rapidamente de los enlaces y otra muy util si no me equivoco no nesesitariamos instalarlo siendo el caso que no tengamos los privilegios de Administrador

Saludos

porque todo el mundo usa rapidshare nunca puedo descargar nada de ese lugar, digo porque no usar un ftp mas practico por ejemplo geocities u otro de haceso mas rapido o general

[Listview]

Un ejemplo muy interesante, Agrega solo un Listview pero que este sea de (Microsoft common controls 5.0(SP2) y no la versión 6.0 y el siguiente codigo

bien lo que hace es crear un imagelist virtual con los iconos correspondiente a las extensiones existentes/asociada , y las va obteniendo desde el registro

Option Explicit
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long
Const HKEY_CLASSES_ROOT = &H80000000

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const LVM_FIRST = &H1000
Const LVM_SETIMAGELIST = (LVM_FIRST + 3)
Const LVM_SETITEM = (LVM_FIRST + 6)
Const LVSIL_SMALL = 1
Const LVIF_IMAGE = &H2
Private Type LV_ITEM
    mask As Long
    iItem As Long
    iSubItem As Long
    State As Long
    StateMask As Long
    lpszText As Long
    cchTextMax As Long
    iImage As Long
    lParam As Long
End Type


Private Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Const SHGFI_SYSICONINDEX = &H4000
Const SHGFI_SMALLICON = &H1
Const MAX_PATH = 260
Const FILE_ATTRIBUTE_NORMAL = &H80
Const SHGFI_USEFILEATTRIBUTES = &H10
Const SHGFI_TYPENAME = &H400
Private Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type
Private Sub Form_Load()
    Dim sfi As SHFILEINFO, lvi As LV_ITEM
    'set view and add columns
    ListView1.View = lvwReport
    ListView1.ColumnHeaders.Add , , "Extension", 600
    ListView1.ColumnHeaders.Add , , "Description", 3000
    'associate the system image list (small icons) to the list view
    SendMessage ListView1.hWnd, LVM_SETIMAGELIST, LVSIL_SMALL, ByVal _
    SHGetFileInfo("C:\", 0, sfi, Len(sfi), SHGFI_SYSICONINDEX Or SHGFI_SMALLICON)
    Dim Index As Long, sName As String * 1000
    lvi.mask = LVIF_IMAGE
    'enumerate all file extensions from registry
    While RegEnumKeyEx(HKEY_CLASSES_ROOT, Index, sName, Len(sName), ByVal 0, vbNullString, ByVal 0, ByVal 0&) = 0
        If Asc(sName) = 46 Then
            'retrieve icon index and type description
            SHGetFileInfo sName, FILE_ATTRIBUTE_NORMAL, sfi, Len(sfi), SHGFI_USEFILEATTRIBUTES Or SHGFI_SMALLICON Or SHGFI_SYSICONINDEX Or SHGFI_TYPENAME
            'add the item (and subitem) to the listview
            ListView1.ListItems.Add(, , sName).SubItems(1) = sfi.szTypeName
            'set the icon index of the listitem
            lvi.iImage = sfi.iIcon
            lvi.iItem = ListView1.ListItems.Count - 1
            SendMessage ListView1.hWnd, LVM_SETITEM, 0, lvi
        End If
        Index = Index + 1
    Wend
End Sub
Private Sub Form_Resize()
    ListView1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub Form_Unload(Cancel As Integer)
    'Disassociate the listview from the system imagelist.
    'this MUST be done on Win98 otherwise the system listimage crashes.
    'and all icons in the shell are gone!.
    'WinXP/2K does not require this.
    SendMessage ListView1.hWnd, LVM_SETIMAGELIST, LVSIL_SMALL, ByVal 0&
End Sub

Saludos