Option Explicit
Private Declare Function RegisterShellHook Lib "Shell32" Alias "#181" (ByVal hwnd As Long, ByVal nAction As Long) As Long 'use in 98
Private Declare Function RegisterShellHookWindow Lib "user32" (ByVal hwnd As Long) As Long 'use in NT5
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
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 GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch 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
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Private Const HSHELL_WINDOWCREATED = 1
Private Const HSHELL_WINDOWDESTROYED = 2
Private Const HSHELL_ACTIVATESHELLWINDOW = 3
Private Const HSHELL_WINDOWACTIVATED = 4
Private Const HSHELL_GETMINRECT = 5
Private Const HSHELL_REDRAW = 6
Private Const HSHELL_TASKMAN = 7
Private Const HSHELL_LANGUAGE = 8
Private Const HSHELL_SYSMENU = 9
Private Const HSHELL_ENDTASK = 10
Private Const HSHELL_ACCESSIBILITYSTATE = 11
Private Const HSHELL_APPCOMMAND = 12
Private Const HSHELL_WINDOWREPLACED = 13
Private Const HSHELL_WINDOWREPLACING = 14
Private Const HSHELL_HIGHBIT = &H8000
Private Const HSHELL_FLASH = (HSHELL_REDRAW Or HSHELL_HIGHBIT)
Private Const HSHELL_RUDEAPPACTIVATED = (HSHELL_WINDOWACTIVATED Or HSHELL_HIGHBIT)
Private Const GWL_WNDPROC = -4
Private Shell_Hook_Msg_ID As Long
Private LogWinOldProc As Long
Public Function IniciarHook(ByVal hwnd As Long) As Boolean
On Error Resume Next
Dim tmp As Long
Shell_Hook_Msg_ID = RegisterWindowMessage("SHELLHOOK")
IniciarHook = Shell_Hook_Msg_ID
IniciarHook = IniciarHook And (RegisterShellHook(hwnd, 1) Or RegisterShellHookWindow(hwnd))
LogWinOldProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Function
Public Function DescargarHook(hwnd As Long)
Call RegisterShellHook(hwnd, 0)
Call SetWindowLong(hwnd, GWL_WNDPROC, LogWinOldProc)
End Function
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long ' ????
Dim i As Long
Dim m_Out_String As String
Dim recTime As String
Dim recParam As String
If uMsg = Shell_Hook_Msg_ID Then
recTime = Format$(Now(), "YY-MM-DD:HH-NN-SS ") & vbTab & " 0x" & Hex$(wParam) & vbTab & " 0x" & Hex$(lParam) & vbTab & " "
Select Case wParam
Case HSHELL_WINDOWCREATED
m_Out_String = String$(260, vbNullChar)
i = GetWindowText(lParam, m_Out_String, 260)
If i > 0 Then m_Out_String = Left$(m_Out_String, i) Else m_Out_String = "UnNamed"
m_Out_String = recTime & "HSHELL_WINDOWCREATED" & vbTab & " " & m_Out_String
Debug.Print m_Out_String
Case HSHELL_WINDOWDESTROYED
m_Out_String = String$(260, vbNullChar)
i = GetWindowText(lParam, m_Out_String, 260)
If i > 0 Then m_Out_String = Left$(m_Out_String, i) Else m_Out_String = "UnNamed"
m_Out_String = recTime & "HSHELL_WINDOWDESTROYED" & vbTab & " " & m_Out_String
Debug.Print m_Out_String
Case HSHELL_ACTIVATESHELLWINDOW
m_Out_String = recTime & "HSHELL_ACTIVATESHELLWINDOW"
Debug.Print m_Out_String
Case HSHELL_WINDOWACTIVATED
m_Out_String = String$(260, vbNullChar)
i = GetWindowText(lParam, m_Out_String, 260)
If i > 0 Then m_Out_String = Left$(m_Out_String, i) Else m_Out_String = "UnNamed"
m_Out_String = recTime & "HSHELL_WINDOWACTIVATEED" & vbTab & " " & m_Out_String
Debug.Print m_Out_String
Case HSHELL_GETMINRECT
m_Out_String = recTime & "HSHELL_GETMINRECT"
Case HSHELL_REDRAW
m_Out_String = String$(260, vbNullChar)
i = GetWindowText(lParam, m_Out_String, 260)
If i > 0 Then m_Out_String = Left$(m_Out_String, i) Else m_Out_String = "UnNamed"
m_Out_String = recTime & "HSHELL_REDRAW" & vbTab & " " & m_Out_String
Case HSHELL_TASKMAN
m_Out_String = recTime & "HSHELL_TASKMAN"
Case HSHELL_LANGUAGE
m_Out_String = recTime & "HSHELL_LANGUAGE"
Case HSHELL_SYSMENU
m_Out_String = recTime & "HSHELL_SYSMENU"
Case HSHELL_ENDTASK
m_Out_String = String$(260, vbNullChar)
i = GetWindowText(lParam, m_Out_String, 260)
If i > 0 Then m_Out_String = Left$(m_Out_String, i) Else m_Out_String = "UnNamed"
m_Out_String = recTime & "HSHELL_ENDTASK" & vbTab & " " & m_Out_String
Case HSHELL_ACCESSIBILITYSTATE
m_Out_String = recTime & "HSHELL_ACCESSIBILITYSTATE"
Case HSHELL_APPCOMMAND
m_Out_String = recTime & "HSHELL_APPCOMMAND"
Case HSHELL_WINDOWREPLACED
m_Out_String = String$(260, vbNullChar)
i = GetWindowText(lParam, m_Out_String, 260)
If i > 0 Then m_Out_String = Left$(m_Out_String, i) Else m_Out_String = "UnNamed"
m_Out_String = recTime & "HSHELL_WINDOWREPLACED" & vbTab & " " & m_Out_String
Case HSHELL_WINDOWREPLACING
m_Out_String = String$(260, vbNullChar)
i = GetWindowText(lParam, m_Out_String, 260)
If i > 0 Then m_Out_String = Left$(m_Out_String, i) Else m_Out_String = "UnNamed"
m_Out_String = recTime & "HSHELL_WINDOWREPLACING" & vbTab & " " & m_Out_String
Case HSHELL_FLASH
m_Out_String = String$(260, vbNullChar)
i = GetWindowText(lParam, m_Out_String, 260)
If i > 0 Then m_Out_String = Left$(m_Out_String, i) Else m_Out_String = "UnNamed"
m_Out_String = recTime & "HSHELL_FLASH" & vbTab & " " & m_Out_String
Case HSHELL_RUDEAPPACTIVATED
m_Out_String = String$(260, vbNullChar)
i = GetWindowText(lParam, m_Out_String, 260)
If i > 0 Then m_Out_String = Left$(m_Out_String, i) Else m_Out_String = "UnNamed"
m_Out_String = recTime & "HSHELL_RUDEAPPACTIVATEED" & vbTab & " " & m_Out_String
End Select
Else
WindowProc = CallWindowProc(LogWinOldProc, hwnd, uMsg, wParam, lParam)
End If
End Function