GFShellHook/GFShellHookmod.bas
Attribute VB_Name = "GFShellHookmod"
Option Explicit
'(c)2000, 2002, 2004 by Louis.
'
'NOTE: the code is a manipulation of 'Shell Ueberwachung', which is a manipulation
'of code written by James Holderness.
'A link appeared to http://www.geocities.com/SiliconValley/4942/, but nobody knows
'if this link is still valid.
'Usage: call SetSH([hWnd of any form or picture box], SHCallBackForm), the present
'code will call the callback sub set in SetSH() and pass a shell notification data if a
'shell event occurred.
'
'SHCallBackForm must contain the following sub:
'Public Sub GFShellHook_ReceiveEvent( _
ByVal SHDescription As String, ByVal SHDrive As String, byval SHImageNumber As Integer, _
ByVal SHFirstItemName As String, ByVal SHFirstItemPath As String, _
ByVal SHSecondItemName As String, ByVal SHSecondItemPath As String)
'on error resume next
'End Sub
'
'View original code located in TestPrograms\ for original annotations.
'
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
'SHNotify_[Un]Register
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SHChangeNotifyRegister Lib "shell32.dll" Alias "#2" (ByVal hWnd As Long, ByVal uFlags As SHCN_ItemFlags, ByVal EventID As SHCN_EventIDs, ByVal uMsg As Long, ByVal cItems As Long, lpps As PIDLSTRUCT) As Long
Private Declare Function SHChangeNotifyDeregister Lib "shell32.dll" Alias "#4" (ByVal hNotify As Long) As Boolean
'SH[Un]SubclassObject
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'GetPIDLFromFolderID
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As SHSpecialFolderIDs, PIDL As Long) As Long
'GetPathFromPIDL
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal PIDL As Long, ByVal pszPath As String) As Long
'GetDisplayNameFromPIDL
Private Declare Function SHGetFileInfoPIDL Lib "shell32" Alias "SHGetFileInfoA" (ByVal PIDL As Long, ByVal dwFileAttributes As Long, psfib As SHFILEINFOBYTE, ByVal cbFileInfo As Long, ByVal uFlags As SHGFI_FLAGS) As Long
'ShellHookProcSub
Private Const WM_NCDESTROY = &H82
Private Const WM_SHNOTIFY = &H401
'other
Private Const WNDPROCOLD_INFO_TEXT = "WNDPROCOLD_INFO_TEXT"
Private Const MAX_PATH = 260
'SHReceiveMessage
Private Type SHRESULTSTRUCT
SHDescription As String
SHDrive As String
SHFirstItemName As String
SHFirstItemPath As String
SHSecondItemName As String
SHSecondItemPath As String
SHImageNumber As Long
End Type
'other
Private Type SHNOTIFYSTRUCT
dwItem1 As Long
dwItem2 As Long
End Type
'other
Private Type PIDLSTRUCT
PIDL As Long
bWatchSubFolders As Long
End Type
'other
Private Type SHFILEINFOBYTE
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName(1 To MAX_PATH) As Byte
szTypeName(1 To 80) As Byte
End Type
'other
Private Enum SHCN_ItemFlags
SHCNF_IDLIST = &H0
SHCNF_PATHA = &H1
SHCNF_PRINTERA = &H2
SHCNF_DWORD = &H3
SHCNF_PATHW = &H5
SHCNF_PRINTERW = &H6
SHCNF_TYPE = &HFF
SHCNF_FLUSH = &H1000
SHCNF_FLUSHNOWAIT = &H2000
#If UNICODE Then
SHCNF_PATH = SHCNF_PATHW
SHCNF_PRINTER = SHCNF_PRINTERW
#Else
SHCNF_PATH = SHCNF_PATHA
SHCNF_PRINTER = SHCNF_PRINTERA
#End If
End Enum
'other
Public Enum SHSpecialFolderIDs 'must be Public
CSIDL_DESKTOP = &H0
CSIDL_INTERNET = &H1
CSIDL_PROGRAMS = &H2
CSIDL_CONTROLS = &H3
CSIDL_PRINTERS = &H4
CSIDL_PERSONAL = &H5
CSIDL_FAVORITES = &H6
CSIDL_STARTUP = &H7
CSIDL_RECENT = &H8
CSIDL_SENDTO = &H9
CSIDL_BITBUCKET = &HA
CSIDL_STARTMENU = &HB
CSIDL_DESKTOPDIRECTORY = &H10
CSIDL_DRIVES = &H11
CSIDL_NETWORK = &H12
CSIDL_NETHOOD = &H13
CSIDL_FONTS = &H14
CSIDL_TEMPLATES = &H15
CSIDL_COMMON_STARTMENU = &H16
CSIDL_COMMON_PROGRAMS = &H17
CSIDL_COMMON_STARTUP = &H18
CSIDL_COMMON_DESKTOPDIRECTORY = &H19
CSIDL_APPDATA = &H1A
CSIDL_PRINTHOOD = &H1B
CSIDL_ALTSTARTUP = &H1D
CSIDL_COMMON_ALTSTARTUP = &H1E
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum
'Shell notification event IDs
Private Enum SHCN_EventIDs
SHCNE_RENAMEITEM = &H1 '(D) a non‑folder item has been renamed
SHCNE_CREATE = &H2 '(D) a non‑folder item has been created
SHCNE_DELETE = &H4 '(D) a non‑folder item has been deleted
SHCNE_MKDIR = &H8 '(D) a folder item has been created
SHCNE_RMDIR = &H10 '(D) a folder item has been removed
SHCNE_MEDIAINSERTED = &H20 '(G) storage media has been inserted into a drive
SHCNE_MEDIAREMOVED = &H40 '(G) storage media has been removed from a drive
SHCNE_DRIVEREMOVED = &H80 '(G) a drive has been removed
SHCNE_DRIVEADD = &H100 '(G) a drive has been added
SHCNE_NETSHARE = &H200 'a folder on the local computer is shared via the network
SHCNE_NETUNSHARE = &H400 'a folder on the local computer is no longer shared via the network
SHCNE_ATTRIBUTES = &H800 '(D) the attributes of an item or folder have changed
SHCNE_UPDATEDIR = &H1000 '(D) the contents of an existing folder have changed, but the folder still exists and has not been renamed
SHCNE_UPDATEITEM = &H2000 '(D) an existing non‑folder item has changed, but the item still exists and has not been renamed
SHCNE_SERVERDISCONNECT = &H4000 'the computer has disconnected from a server
SHCNE_UPDATEIMAGE = &H8000& '(G) an image in the system image list has changed
SHCNE_DRIVEADDGUI = &H10000 '(G) a drive has been added and the shell should create a new window for the drive
SHCNE_RENAMEFOLDER = &H20000 '(D) the name of a folder has changed
SHCNE_FREESPACE = &H40000 '(G) the amount of free space on a drive has changed
'#If (WIN32_IE >= &H400) Then
' SHCNE_EXTENDED_EVENT = &H4000000 '(G) not supported yet
'#End If
SHCNE_ASSOCCHANGED = &H8000000 '(G) a file type association has changed
SHCNE_DISKEVENTS = &H2381F '(D) specifies a combination of all of the disk event identifiers
SHCNE_GLOBALEVENTS = &HC0581E0 '(G) specifies a combination of all of the global event identifiers
SHCNE_ALLEVENTS = &H7FFFFFFF
SHCNE_INTERRUPT = &H80000000 'the specified event occurred as a result of a system interruption; it is stripped out before the clients of SHCNNotify_ notify it
End Enum
'other
Private Enum SHGFI_FLAGS
SHGFI_LARGEICON = &H0
SHGFI_SMALLICON = &H1
SHGFI_OPENICON = &H2
SHGFI_SHELLICONSIZE = &H4
SHGFI_PIDL = &H8
SHGFI_USEFILEATTRIBUTES = &H10
SHGFI_ICON = &H100
SHGFI_DISPLAYNAME = &H200
SHGFI_TYPENAME = &H400
SHGFI_ATTRIBUTES = &H800
SHGFI_ICONLOCATION = &H1000
SHGFI_EXETYPE = &H2000
SHGFI_SYSICONINDEX = &H4000
SHGFI_LINKOVERLAY = &H8000
SHGFI_SELECTED = &H10000
End Enum
'SHSubClassObject
Dim ObjecthWndOld As Long
Dim ObjecthWndUnchanged As Long
'other
Dim SHSetFlag As Boolean
Dim SHCallBackForm As Object
Dim SHNotifyRegisterHandle As Long
Dim SHDesktopPIDL As Long
'*************************************CALLBACK SUBS*************************************
Public Sub SetSH(ByVal SubClassObjectHandle As Long, ByRef CallBackForm As Object)
On Error Resume Next
Set SHCallBackForm = CallBackForm
If SHSetFlag = False Then 'verify
SHSetFlag = True
Call SHSubclassObject(SubClassObjectHandle)
Call RegisterSH(SubClassObjectHandle)
'Else
' Debug.Print "internal error in SetSH() (GFShellHook): call RemoveSH before !"
End If
End Sub
Public Sub RemoveSH()
On Error Resume Next
If SHSetFlag = True Then
SHSetFlag = False
Call UnregisterSH
Call SHUnsubclassObject
End If
End Sub
'*********************************END OF CALLBACK SUBS**********************************
'**************************************SHELL HOOK***************************************
'NOTE: to set up the ShellHook an object is required that will receive the shell hook
'messages. The handle of this object is stored in the var ObjecthWnd.
Private Function RegisterSH(ByVal ObjecthWnd As Long) As Boolean
'On Error Resume Next
Dim PIDLSTRUCTVar As PIDLSTRUCT
'begin
If SHNotifyRegisterHandle = 0 Then
SHDesktopPIDL = GetPIDLFromFolderID(0, CSIDL_DESKTOP)
If Not (SHDesktopPIDL = 0) Then 'verify
PIDLSTRUCTVar.PIDL = SHDesktopPIDL
PIDLSTRUCTVar.bWatchSubFolders = True
SHNotifyRegisterHandle = SHChangeNotifyRegister(ObjecthWnd, SHCNF_TYPE Or SHCNF_IDLIST, SHCNE_ALLEVENTS Or SHCNE_INTERRUPT, WM_SHNOTIFY, 1, PIDLSTRUCTVar)
RegisterSH = CBool(SHNotifyRegisterHandle)
Else
RegisterSH = False 'error
Call CoTaskMemFree(SHDesktopPIDL)
End If
End If
End Function
Private Function UnregisterSH() As Boolean
'On Error Resume Next
'begin
If Not (SHNotifyRegisterHandle = 0) Then 'verify
If Not (SHChangeNotifyDeregister(SHNotifyRegisterHandle) = 0) Then 'verify
UnregisterSH = True 'ok
SHNotifyRegisterHandle = 0 'reset
Call CoTaskMemFree(SHDesktopPIDL)
SHDesktopPIDL = 0 'reset
Else
GoTo Error:
End If
Else
GoTo Error:
End If
Exit Function
Error:
UnregisterSH = False 'reset (error)
Exit Function
End Function
'***********************************END OF SHELL HOOK***********************************
'*****************************GENERAL SHELL HOOK FUNCTIONS******************************
Private Function GetDisplayNameFromPIDL(ByVal PIDL As Long) As String
'On Error Resume Next
Dim SHFILEINFOBYTEVar As SHFILEINFOBYTE
'begin
If Not (SHGetFileInfoPIDL(PIDL, 0, SHFILEINFOBYTEVar, Len(SHFILEINFOBYTEVar), SHGFI_PIDL Or SHGFI_DISPLAYNAME) = 0) Then
GetDisplayNameFromPIDL = FormatBufferString(StrConv(SHFILEINFOBYTEVar.szDisplayName, vbUnicode))
Else
GetDisplayNameFromPIDL = "" 'reset
End If
End Function
Private Function GetPIDLFromFolderID(ByVal OwnerHandle As Long, ByVal Folder As SHSpecialFolderIDs) As Long
'On Error Resume Next
Dim PIDL As Long
'begin
If SHGetSpecialFolderLocation(OwnerHandle, Folder, PIDL) = 0 Then
GetPIDLFromFolderID = PIDL
Else
GetPIDLFromFolderID = 0 'reset
End If
End Function
Private Function GetPathFromPIDL(ByVal PIDL As Long) As String
'On Error Resume Next
Dim SHPath As String * MAX_PATH
'begin
If Not (SHGetPathFromIDList(PIDL, SHPath) = 0) Then
GetPathFromPIDL = FormatBufferString(SHPath)
Else
GetPathFromPIDL = "" 'reset
End If
End Function
Private Function FormatBufferString(ByVal BufferString As String) As String
'On Error Resume Next 'returns string without null termination
'begin
If Not (InStr(BufferString, vbNullChar) = 0) Then
FormatBufferString = Left$(BufferString, InStr(BufferString, vbNullChar) ‑ 1)
Else
FormatBufferString = BufferString
End If
End Function
'**************************END OF GENERAL SHELL HOOK FUNCTIONS**************************
'***********************************UPDATE FUNCTIONS************************************
Private Sub SHReceiveMessage(ByVal SHMessagewParam As Long, ByVal SHMessagelParam As Long)
On Error Resume Next
Dim SHNOTIFYSTRUCTVar As SHNOTIFYSTRUCT
Dim SHRESULTSTRUCTVar As SHRESULTSTRUCT
Dim SHReceiveMessageTemp As Integer
'begin
SHRESULTSTRUCTVar.SHDescription = GetEventIDDescription(SHMessagelParam)
'SHMessagelParam is the ID of the notification event (see SHCN_EventIDs)
Call CopyMemory(SHNOTIFYSTRUCTVar, ByVal SHMessagewParam, Len(SHNOTIFYSTRUCTVar))
Select Case SHMessagelParam
Case SHCNE_FREESPACE
Dim SHDriveBitNumber As Long
Dim SHHighBitNumber As Integer
'
'NOTE: for annotations view original code located in TestPrograms\.
'
Call CopyMemory(SHDriveBitNumber, ByVal SHNOTIFYSTRUCTVar.dwItem1 + 2, 4)
SHHighBitNumber = Int(Log(SHDriveBitNumber) / Log(2))
For SHReceiveMessageTemp = 0 To SHHighBitNumber
If (2 ^ SHReceiveMessageTemp) And SHDriveBitNumber Then 'check if current bit is set
SHRESULTSTRUCTVar.SHDrive = Chr$(65 + SHReceiveMessageTemp) + ":" + "\"
End If
Next
'
Case SHCNE_UPDATEIMAGE
Dim SHImageNumber As Long
Call CopyMemory(SHImageNumber, ByVal SHNOTIFYSTRUCTVar.dwItem1 + 2, 4)
'
'NOTE: for annotations view original code located in TestPrograms\.
'
SHRESULTSTRUCTVar.SHImageNumber = SHImageNumber 'index of image in system image list (whatever this means)
'
Case Else
Dim SHDisplayName As String
If Not (SHNOTIFYSTRUCTVar.dwItem1 = 0) Then 'verify
SHDisplayName = GetDisplayNameFromPIDL(SHNOTIFYSTRUCTVar.dwItem1)
If Not (SHDisplayName = "") Then
SHRESULTSTRUCTVar.SHFirstItemName = SHDisplayName 'first item display name
SHRESULTSTRUCTVar.SHFirstItemPath = GetPathFromPIDL(SHNOTIFYSTRUCTVar.dwItem1) 'first item path
Else
SHRESULTSTRUCTVar.SHFirstItemName = "" 'reset
SHRESULTSTRUCTVar.SHFirstItemPath = "" 'reset
End If
End If
If Not (SHNOTIFYSTRUCTVar.dwItem2 = 0) Then 'verify
SHDisplayName = GetDisplayNameFromPIDL(SHNOTIFYSTRUCTVar.dwItem2)
If Not (SHDisplayName = "") Then
SHRESULTSTRUCTVar.SHSecondItemName = SHDisplayName 'second item display name
SHRESULTSTRUCTVar.SHSecondItemPath = GetPathFromPIDL(SHNOTIFYSTRUCTVar.dwItem2) 'second item path
Else
SHRESULTSTRUCTVar.SHSecondItemName = "" 'reset
SHRESULTSTRUCTVar.SHSecondItemPath = "" 'reset
End If
End If
End Select
'***SUB RECEIVING SHRESULTSTRUCT***
If Not (SHCallBackForm Is Nothing) Then 'verify
Call SHCallBackForm.GFShellHook_ReceiveEvent(SHRESULTSTRUCTVar.SHDescription, SHRESULTSTRUCTVar.SHDrive, SHRESULTSTRUCTVar.SHImageNumber, SHRESULTSTRUCTVar.SHFirstItemName, SHRESULTSTRUCTVar.SHFirstItemPath, SHRESULTSTRUCTVar.SHSecondItemName, SHRESULTSTRUCTVar.SHSecondItemPath) 'ShellHookReceiveData()
Else
Debug.Print "internal error in SHReceiveMessage: target form not set !"
End If
'***END***
End Sub
'********************************END OF UPDATE FUNCTIONS********************************
'*******************************GENERAL HOOKING FUNCTIONS*******************************
Private Function SHSubclassObject(ByVal ObjecthWnd As Long) As Boolean
On Error Resume Next
'
'NOTE: when later calling SHUnsubclassObject, the object used to set up
'the subclassing will be unsubclassed (no passing of object hWnd necessary).
'
ObjecthWndOld = ObjecthWnd
ObjecthWndUnchanged = SetWindowLong(ObjecthWnd, (‑4), AddressOf ShellHookProcSub)
If Not (ObjecthWndUnchanged = 0) Then 'verify
SHSubclassObject = True 'ok
Else
SHSubclassObject = False 'error
End If
End Function
Private Function SHUnsubclassObject() As Boolean
On Error Resume Next
'begin
If Not (SetWindowLong(ObjecthWndOld, (‑4), ObjecthWndUnchanged) = 0) Then 'verify
SHUnsubclassObject = True 'ok
Else
SHUnsubclassObject = False 'error
End If
End Function
Private Function ShellHookProcSub(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
Select Case uMsg
Case WM_SHNOTIFY
Call SHReceiveMessage(wParam, lParam) 'shell notification message
Case WM_NCDESTROY
Call SHUnsubclassObject
End Select
ShellHookProcSub = CallWindowProc(ObjecthWndUnchanged, hWnd, uMsg, wParam, lParam)
End Function
'***************************END OF GENERAL HOOKING FUNCTIONS****************************
'*****************************************OTHER*****************************************
Private Function GetEventIDDescription(ByVal EventID As Long) As String
On Error Resume Next
Select Case EventID
Case SHCNE_RENAMEITEM
GetEventIDDescription = "SHCNE_RENAMEITEM"
'GetEventIDDescription = "1"
Case SHCNE_CREATE
GetEventIDDescription = "SHCNE_CREATE"
'GetEventIDDescription = "2"
Case SHCNE_DELETE
GetEventIDDescription = "SHCNE_DELETE"
'GetEventIDDescription = "3"
Case SHCNE_MKDIR
GetEventIDDescription = "SHCNE_MKDIR"
'GetEventIDDescription = "4"
Case SHCNE_RMDIR
GetEventIDDescription = "SHCNE_RMDIR"
'GetEventIDDescription = "5"
Case SHCNE_MEDIAINSERTED
GetEventIDDescription = "SHCNE_MEDIAINSERTED"
'GetEventIDDescription = "6"
Case SHCNE_MEDIAREMOVED
GetEventIDDescription = "SHCNE_MEDIAREMOVED"
'GetEventIDDescription = "7"
Case SHCNE_DRIVEREMOVED
GetEventIDDescription = "SHCNE_DRIVEREMOVED"
'GetEventIDDescription = "8"
Case SHCNE_DRIVEADD
GetEventIDDescription = "SHCNE_DRIVEADD"
'GetEventIDDescription = "9"
Case SHCNE_NETSHARE
GetEventIDDescription = "SHCNE_NETSHARE"
'GetEventIDDescription = "10"
Case SHCNE_NETUNSHARE
GetEventIDDescription = "SHCNE_NETUNSHARE"
'GetEventIDDescription = "11"
Case SHCNE_ATTRIBUTES
'GetEventIDDescription = "SHCNE_ATTRIBUTES"
GetEventIDDescription = "12"
Case SHCNE_UPDATEDIR
GetEventIDDescription = "SHCNE_UPDATEDIR"
'GetEventIDDescription = "13"
Case SHCNE_UPDATEITEM
GetEventIDDescription = "SHCNE_UPDATEITEM"
'GetEventIDDescription = "14"
Case SHCNE_SERVERDISCONNECT
GetEventIDDescription = "SHCNE_SERVERDISCONNECT"
'GetEventIDDescription = "15"
Case SHCNE_UPDATEIMAGE
GetEventIDDescription = "SHCNE_UPDATEIMAGE"
'GetEventIDDescription = "16"
Case SHCNE_DRIVEADDGUI
GetEventIDDescription = "SHCNE_DRIVEADDGUI"
'GetEventIDDescription = "17"
Case SHCNE_RENAMEFOLDER
GetEventIDDescription = "SHCNE_RENAMEFOLDER"
'GetEventIDDescription = "18"
Case SHCNE_FREESPACE
GetEventIDDescription = "SHCNE_FREESPACE"
'GetEventIDDescription = "19"
'#If (WIN32_IE >= &H400) Then
' Case SHCNE_EXTENDED_EVENT
' GetEventIDDescription = "SHCNE_EXTENDED_EVENT"
'#End If
Case SHCNE_ASSOCCHANGED
GetEventIDDescription = "SHCNE_ASSOCCHANGED"
'GetEventIDDescription = "20"
Case SHCNE_DISKEVENTS
GetEventIDDescription = "SHCNE_DISKEVENTS"
'GetEventIDDescription = "21"
Case SHCNE_GLOBALEVENTS
GetEventIDDescription = "SHCNE_GLOBALEVENTS"
'GetEventIDDescription = "22"
Case SHCNE_ALLEVENTS
GetEventIDDescription = "SHCNE_ALLEVENTS"
'GetEventIDDescription = "23"
Case SHCNE_INTERRUPT
GetEventIDDescription = "SHCNE_INTERRUPT"
'GetEventIDDescription = "24"
Case Else
GetEventIDDescription = "[SH event unknown]"
'GetEventIDDescription = "0" 'error
End Select
End Function
'***END OF MODULE***
[END OF FILE]