I Have modified the Shell Hook code that I download from planetsource code. I am trying to modify the code to close the application window if it appears. I am testing with the calculator. It should close the application the wait for a few seconds then start the program back up. But I get an error from VB6 then the project just closes. Below is the Modified shell hook code that I am using to try this. Does anyone know what I am doing wrong.
Here is the code You can copy and past it into a new project there is one form and one module.
This is a module!!!!! My changes are marked clearly.
'--------MODULE CODE STARTS HERE!!!!---------------'
' Bas module for implementing system - wide shell hook.
' Using undocumented Shell32 function RegisterShellHook.
' Thanks to James Holderness for his help on using this function.
' You can find many othar undoc shell32 functions at
'
Public Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Public Declare Function RegisterShellHook Lib "Shell32" Alias "#181" (ByVal hwnd As Long, ByVal nAction As Long) As Long
Public 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
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex 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 GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
'----------------------------------------------------------
' My add code to Close the application that is desired
Private Declare Function FindWindow% Lib "user" (ByVal lpClassName As Any, ByVal lpCation As Any)
Private Declare Function SendMessage& Lib "user" (ByVal hwnd%, ByVal wMsg%, ByVal wParam%, ByVal lparam As Long)
'-----------------------------------------------------------
Public Const GWL_WNDPROC = (-4)
Public Const RSH_DEREGISTER = 0
Public Const RSH_REGISTER = 1
Public Const RSH_REGISTER_PROGMAN = 2
Public Const RSH_REGISTER_TASKMAN = 3
Const HSHELL_ACTIVATESHELLWINDOW = 3
Const HSHELL_WINDOWCREATED = 1
Const HSHELL_WINDOWDESTROYED = 2
Const HSHELL_WINDOWACTIVATED = 4
Const HSHELL_GETMINRECT = 5
Const HSHELL_REDRAW = 6
Const HSHELL_TASKMAN = 7
Const HSHELL_LANGUAGE = 8
Const HSHELL_ACCESSIBILITYSTATE = 11
Const LOCALE_SENGLANGUAGE As Long = &H1001
'---------------------------------------------------------
'This is Code I have added for what I need it to do
Const NILL = 0&
Const WM_SYSCOMMAND = &H112
Const SC_CLOSE = &HF060
'----------------------------------------------------------
Public OldProc As Long, uRegMsg As Long
Public Function WndProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
If wMsg = uRegMsg Then
Dim sText As String
'------------------------------------------------
Dim watch As Date 'Added this for the time
'------------------------------------------------
Select Case wParam
Case HSHELL_WINDOWCREATED
sText = "Created " & GetWndText(lparam) & " Handle = " & lparam
Case HSHELL_WINDOWDESTROYED
sText = "Destroy " & GetWndText(lparam) & " Handle = " & lparam
Case HSHELL_WINDOWACTIVATED
sText = "Activat " & GetWndText(lparam) & " Handle = " & lparam
Case HSHELL_LANGUAGE
Dim LocId As Long
LocId = LoWord(GetKeyboardLayout(0&))
sText = "Language changed to " & GetLanguageInfo(LocId, LOCALE_SENGLANGUAGE)
Case HSHELL_GETMINRECT
sText = "Get Window RECT"
Case HSHELL_REDRAW
sText = "Taskbar " & GetWndText(lparam) & " Handle = " & lparam
Case HSHELL_TASKMAN
sText = "Task Manager"
Case HSHELL_ACTIVATESHELLWINDOW
sText = "Shell window activated"
End Select
'---------------------------------------------------------
'These are my modifications below
watch = Format(Now, "h:mm AM/PM"
If watch > "5:00 PM" Or watch < "6:30 AM" Then
If GetWndText(lparam = "Calculator" Then
' This is what should Kill the Application
' This where I seem to be geting the fatal error
X% = SendMessage(lparam, WM_SYSCOMMAND, SC_CLOSE, NILL)
' These two lines are remarked out not need for this test
' Works like a timer My module
'Wait (5)
' This one starts any application just give it the path one of my modules
'RunApp ("C:\WINDOWS\Start Menu\Programs\Accessories\Calculator.exe"
End If
End If
'----------------------------------------------------------
'This is the end of my Changes
Else
WndProc = CallWindowProc(OldProc, hwnd, wMsg, wParam, lparam)
End If
End Function
Private Function GetWndText(hwnd As Long) As String
Dim k As Long, sName As String
sName = Space$(128)
k = GetWindowText(hwnd, sName, 128)
If k > 0 Then sName = Left$(sName, k) Else sName = "No caption"
GetWndText = sName
End Function
Private Function LoWord(DWORD As Long) As Integer
If DWORD And &H8000& Then
LoWord = &H8000 Or (DWORD And &H7FFF&)
Else
LoWord = DWORD And &HFFFF&
End If
End Function
Private Function GetLanguageInfo(ByVal dwLocaleID As Long, ByVal dwLCType As Long) As String
Dim sReturn As String, nRet As Long
sReturn = String$(128, 0)
nRet = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))
If nRet > 0 Then GetLanguageInfo = Left$(sReturn, nRet - 1)
End Function
'----------MODULE CODE ENDS HERE--------------'
Here is the Form code no changes made here.
'-------FORM CODE STARTS HERE-----------'
Private Sub Form_Load()
Text1 = ""
Caption = "Shell log"
uRegMsg = RegisterWindowMessage(ByVal "SHELLHOOK"
Call RegisterShellHook(hwnd, RSH_REGISTER) ' Or RSH_REGISTER_TASKMAN Or RSH_REGISTER_PROGMAN)
OldProc = GetWindowLong(hwnd, GWL_WNDPROC)
SetWindowLong hwnd, GWL_WNDPROC, AddressOf WndProc
End Sub
Private Sub Form_Resize()
Text1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call RegisterShellHook(hwnd, RSH_DEREGISTER)
SetWindowLong hwnd, GWL_WNDPROC, OldProc
End Sub
'------FORM CODE ENDS HERE--------------'
Here is the code You can copy and past it into a new project there is one form and one module.
This is a module!!!!! My changes are marked clearly.
'--------MODULE CODE STARTS HERE!!!!---------------'
' Bas module for implementing system - wide shell hook.
' Using undocumented Shell32 function RegisterShellHook.
' Thanks to James Holderness for his help on using this function.
' You can find many othar undoc shell32 functions at
'
Public Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Public Declare Function RegisterShellHook Lib "Shell32" Alias "#181" (ByVal hwnd As Long, ByVal nAction As Long) As Long
Public 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
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex 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 GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
'----------------------------------------------------------
' My add code to Close the application that is desired
Private Declare Function FindWindow% Lib "user" (ByVal lpClassName As Any, ByVal lpCation As Any)
Private Declare Function SendMessage& Lib "user" (ByVal hwnd%, ByVal wMsg%, ByVal wParam%, ByVal lparam As Long)
'-----------------------------------------------------------
Public Const GWL_WNDPROC = (-4)
Public Const RSH_DEREGISTER = 0
Public Const RSH_REGISTER = 1
Public Const RSH_REGISTER_PROGMAN = 2
Public Const RSH_REGISTER_TASKMAN = 3
Const HSHELL_ACTIVATESHELLWINDOW = 3
Const HSHELL_WINDOWCREATED = 1
Const HSHELL_WINDOWDESTROYED = 2
Const HSHELL_WINDOWACTIVATED = 4
Const HSHELL_GETMINRECT = 5
Const HSHELL_REDRAW = 6
Const HSHELL_TASKMAN = 7
Const HSHELL_LANGUAGE = 8
Const HSHELL_ACCESSIBILITYSTATE = 11
Const LOCALE_SENGLANGUAGE As Long = &H1001
'---------------------------------------------------------
'This is Code I have added for what I need it to do
Const NILL = 0&
Const WM_SYSCOMMAND = &H112
Const SC_CLOSE = &HF060
'----------------------------------------------------------
Public OldProc As Long, uRegMsg As Long
Public Function WndProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
If wMsg = uRegMsg Then
Dim sText As String
'------------------------------------------------
Dim watch As Date 'Added this for the time
'------------------------------------------------
Select Case wParam
Case HSHELL_WINDOWCREATED
sText = "Created " & GetWndText(lparam) & " Handle = " & lparam
Case HSHELL_WINDOWDESTROYED
sText = "Destroy " & GetWndText(lparam) & " Handle = " & lparam
Case HSHELL_WINDOWACTIVATED
sText = "Activat " & GetWndText(lparam) & " Handle = " & lparam
Case HSHELL_LANGUAGE
Dim LocId As Long
LocId = LoWord(GetKeyboardLayout(0&))
sText = "Language changed to " & GetLanguageInfo(LocId, LOCALE_SENGLANGUAGE)
Case HSHELL_GETMINRECT
sText = "Get Window RECT"
Case HSHELL_REDRAW
sText = "Taskbar " & GetWndText(lparam) & " Handle = " & lparam
Case HSHELL_TASKMAN
sText = "Task Manager"
Case HSHELL_ACTIVATESHELLWINDOW
sText = "Shell window activated"
End Select
'---------------------------------------------------------
'These are my modifications below
watch = Format(Now, "h:mm AM/PM"
If watch > "5:00 PM" Or watch < "6:30 AM" Then
If GetWndText(lparam = "Calculator" Then
' This is what should Kill the Application
' This where I seem to be geting the fatal error
X% = SendMessage(lparam, WM_SYSCOMMAND, SC_CLOSE, NILL)
' These two lines are remarked out not need for this test
' Works like a timer My module
'Wait (5)
' This one starts any application just give it the path one of my modules
'RunApp ("C:\WINDOWS\Start Menu\Programs\Accessories\Calculator.exe"
End If
End If
'----------------------------------------------------------
'This is the end of my Changes
Else
WndProc = CallWindowProc(OldProc, hwnd, wMsg, wParam, lparam)
End If
End Function
Private Function GetWndText(hwnd As Long) As String
Dim k As Long, sName As String
sName = Space$(128)
k = GetWindowText(hwnd, sName, 128)
If k > 0 Then sName = Left$(sName, k) Else sName = "No caption"
GetWndText = sName
End Function
Private Function LoWord(DWORD As Long) As Integer
If DWORD And &H8000& Then
LoWord = &H8000 Or (DWORD And &H7FFF&)
Else
LoWord = DWORD And &HFFFF&
End If
End Function
Private Function GetLanguageInfo(ByVal dwLocaleID As Long, ByVal dwLCType As Long) As String
Dim sReturn As String, nRet As Long
sReturn = String$(128, 0)
nRet = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))
If nRet > 0 Then GetLanguageInfo = Left$(sReturn, nRet - 1)
End Function
'----------MODULE CODE ENDS HERE--------------'
Here is the Form code no changes made here.
'-------FORM CODE STARTS HERE-----------'
Private Sub Form_Load()
Text1 = ""
Caption = "Shell log"
uRegMsg = RegisterWindowMessage(ByVal "SHELLHOOK"
Call RegisterShellHook(hwnd, RSH_REGISTER) ' Or RSH_REGISTER_TASKMAN Or RSH_REGISTER_PROGMAN)
OldProc = GetWindowLong(hwnd, GWL_WNDPROC)
SetWindowLong hwnd, GWL_WNDPROC, AddressOf WndProc
End Sub
Private Sub Form_Resize()
Text1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call RegisterShellHook(hwnd, RSH_DEREGISTER)
SetWindowLong hwnd, GWL_WNDPROC, OldProc
End Sub
'------FORM CODE ENDS HERE--------------'