Monitoring the Windows Shell ___ [Files and Folders activity]

[Jaafar Tribak]

Hi all,

I have been toying around with the shell notification apis in order to be able to monitor file activity in folders such as creating, deleting , renaming, copying, updating files & folders etc ... I thought I would post here what I have come up with in case someone finds it useful.

The old way to accomplish this was to create a new thread *CreateThread* and use *WaitForSingleObject* in a loop. I got this old method to work to some extent in the past but it wasn't stable plus it blocked the UI while monitoring.

The method I am using here seems stable despite using subclassing on a hidden window. The only precaution to be taken is to avoid unhandled errors inside the event handler... When testing errors occurring elsewhere in the vbaproject, it didn't seem to cause any problems. The code remained stable even when executing the Stop statement in code or when pressing the Break, Reset buttons in the IDE.

In this example, I decided to use a modeless userform to sink the shell events. I added a Minimize button to the form so the user can get it out of the way and work elsewhere while the minimised form is doing its job monitoring folder activity... Using a userform to sink the shell events was just out of convinience. This is actually not necessary as we can use, in the same way, any class module that allows using the *WithEvents* keyword.


ShellMonitor.xlsm

1- CShellEvents Class

Option Explicit

Implements IShellEvents

Event ShellEvent(ByVal sEvent As String, ByVal sPrevious As String, ByVal sNew As String)

Public Sub StartMonitoring( _
    Optional ByVal PathToMonitor As String, _
    Optional ByVal EventSink As Object = Nothing _
)
    Call StartWatching(Me, PathToMonitor, EventSink)
End Sub

Public Sub FinishMonitoring()
    Call StopWatching
End Sub

Private Sub Class_Terminate()
    Call StopWatching
    Debug.Print "Class Instances released."
End Sub

Private Sub IShellEvents_RaiseEvents(ByVal sEvent As String, ByVal sPrevious As String, ByVal sNew As String)
    RaiseEvent ShellEvent(sEvent, sPrevious, sNew)
End Sub

2- IShellEvents Interface:

Option Explicit

Public Sub RaiseEvents( _
    ByVal sEvent As String, _
    ByVal sPrevious As String, _
    ByVal sNew As String _
)
'
End Sub

3- API code in a Standard Module:

Option Explicit

Private Type SHNOTIFYSTRUCT
    #If Win64 Then
      dwItem1 As LongLong
      dwItem2 As LongLong
    #Else
      dwItem1 As Long
      dwItem2 As Long
    #End If
End Type

Private Type SHChangeNotifyEntry
    #If Win64 Then
        pidl As LongLong
    #Else
        pidl As Long
    #End If
    fRecursive As Long
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongLong, ByVal nIndex As Long) As LongLong
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    #End If
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function SHChangeNotifyRegister Lib "shell32" Alias "#2" (ByVal hWnd As LongPtr, ByVal fSources As Long, ByVal fEvents As Long, ByVal wMsg As Long, ByVal cEntries As Long, lpps As SHChangeNotifyEntry) As LongPtr
    Private Declare PtrSafe Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" (ByVal hNotify As LongPtr) As Boolean
    Private Declare PtrSafe Function SHChangeNotification_Lock Lib "shell32" (ByVal hChange As LongPtr, ByVal dwProcId As Long, pppidl As LongPtr, plEvent As Long) As LongPtr
    Private Declare PtrSafe Function SHChangeNotification_Unlock Lib "shell32" (ByVal hLock As LongPtr) As Long
    Private Declare PtrSafe Function SHGetPathFromIDListW Lib "shell32.dll" (ByVal pidl As LongPtr, ByVal pszPath As LongPtr) As LongPtr
    Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As LongPtr, ByVal nFolder As LongPtr, Optional pidl As LongPtr = 0) As Long
    Private Declare PtrSafe Function ILCreateFromPath Lib "shell32.dll" Alias "ILCreateFromPathW" (ByVal szPath As LongPtr) As LongPtr
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr)
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
 #Else
    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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function SHChangeNotifyRegister Lib "shell32" Alias "#2" (ByVal hWnd As Long, ByVal fSources As Long, ByVal fEvents As Long, ByVal wMsg As Long, ByVal cEntries As Long, lpps As SHChangeNotifyEntry) As Long
    Private Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" (ByVal hNotify As Long) As Boolean
    Private Declare Function SHChangeNotification_Lock Lib "shell32" (ByVal hChange As Long, ByVal dwProcId As Long, pppidl As Long, plEvent As Long) As Long
    Private Declare Function SHChangeNotification_Unlock Lib "shell32" (ByVal hLock As Long) As Long
    Private Declare Function SHGetPathFromIDListW Lib "shell32.dll" (ByVal pidl As Long, ByVal pszPath As Long) As Long
    Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, Optional pidl As Long = 0) As Long
    Private Declare Function ILCreateFromPath Lib "shell32.dll" Alias "ILCreateFromPathW" (ByVal szPath As String) As Long
    Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long)
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As Long) As Long
#End If

Private IOShell As IShellEvents
Private oEventSink As Object
Private sEvent As String, sPrevious As String, sNew As String
Private sPath As String

 
Public Sub StartWatching(oShell As CShellEvents, _
    Optional ByVal PathToMonitor As String, _
    Optional ByVal EventSink As Object = Nothing _
)
    #If Win64 Then
        Dim hWin As LongLong
    #Else
        Dim hWin As Long
    #End If
 
    If GetProp(Application.hWnd, "HiddenWnd") Then
        MsgBox "Already monitoring folders."
        Exit Sub
    End If
 
    If Len(Trim(Replace(Dir(PathToMonitor, vbDirectory), ".", ""))) Then
        sPath = PathToMonitor
    End If
 
    If Not EventSink Is Nothing Then
        Set oEventSink = EventSink
        Call AddMinButton(EventSink)
    End If

    Set IOShell = oShell
    hWin = CreateWindowEx(0, "Static", vbNullString, 0, 0, 0, 0, 0, 0, 0, 0, 0)
    Call SetProp(Application.hWnd, "HiddenWnd", hWin)
    Call SubClassHiddenWindow(hWin)
    Call StartNotify(hWin)
End Sub


Public Sub StopWatching(Optional ByVal Dummy As Boolean)
    Call StopNotify
    Call RemoveProp(Application.hWnd, "SHNotify")
    Call SubClassHiddenWindow(GetProp(Application.hWnd, "HiddenWnd"), False)
    Call DestroyWindow(GetProp(Application.hWnd, "HiddenWnd"))
    Call RemoveProp(Application.hWnd, "HiddenWnd")
    Set oEventSink = Nothing
    Set IOShell = Nothing
End Sub

#If Win64 Then
    Private Sub StartNotify(hWnd As LongLong, Optional pidlpath As LongLong = 0^)
        Dim pidl As LongLong, pidlDesktop As LongLong
        Dim hSHNotify As LongLong, lPIDLFolderToMonitor As LongLong
#Else
    Private Sub StartNotify(hWnd As Long, Optional pidlpath As Long = 0)
        Dim pidl As Long, pidlDesktop As Long
        Dim hSHNotify As Long, lPIDLFolderToMonitor As Long
#End If

    Const SHCNE_ALLEVENTS = &H7FFFFFFF
    Const SHCNE_INTERRUPT = &H80000000
    Const SHCNRF_InterruptLevel = &H1
    Const SHCNRF_ShellLevel = &H2
    Const SHCNRF_RecursiveInterrupt = &H1000
    Const SHCNRF_NewDelivery = &H8000&
    Const CSIDL_DESKTOP = &H0
    Const WM_SHNOTIFY = &H488
 
    Dim tCNE As SHChangeNotifyEntry
 
    If GetProp(Application.hWnd, "SHNotify") = 0 Then
        If sPath = "" Then
            Call SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, lPIDLFolderToMonitor)
        Else
            lPIDLFolderToMonitor = ILCreateFromPath(StrPtr(sPath))
        End If
        If lPIDLFolderToMonitor Then
            tCNE.pidl = lPIDLFolderToMonitor
            tCNE.fRecursive = 1
            hSHNotify = SHChangeNotifyRegister(hWnd, SHCNRF_ShellLevel Or SHCNRF_InterruptLevel Or _
                SHCNRF_NewDelivery, SHCNE_ALLEVENTS Or SHCNE_INTERRUPT, WM_SHNOTIFY, 1, tCNE)
            If hSHNotify Then
                Call SetProp(Application.hWnd, "SHNotify", hSHNotify)
                Call SetProp(Application.hWnd, "PIDLFolderToMonitor", lPIDLFolderToMonitor)
            End If
        End If
    End If
End Sub

Private Sub StopNotify()
    Call SHChangeNotifyDeregister(GetProp(Application.hWnd, "SHNotify"))
    If GetProp(Application.hWnd, "PIDLFolderToMonitor") Then
        Call CoTaskMemFree(GetProp(Application.hWnd, "PIDLFolderToMonitor"))
        Call RemoveProp(Application.hWnd, "PIDLFolderToMonitor")
        sPath = ""
    End If
End Sub

#If Win64 Then
    Private Sub SubClassHiddenWindow(ByVal hWnd As LongLong, Optional ByVal bSubclass As Boolean = True)
#Else
    Private Sub SubClassHiddenWindow(ByVal hWnd As Long, Optional ByVal bSubclass As Boolean = True)
#End If
    Const GWL_WNDPROC = (-4)
    If bSubclass Then
        If GetProp(Application.hWnd, "PrevProcAddr") = 0 Then
            Call SetProp(Application.hWnd, "PrevProcAddr", _
                SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc))
        End If
    Else
        If GetProp(Application.hWnd, "PrevProcAddr") Then
            Call SetWindowLong(hWnd, GWL_WNDPROC, GetProp(Application.hWnd, "PrevProcAddr"))
            Call RemoveProp(Application.hWnd, "PrevProcAddr")
        End If
    End If
End Sub

#If Win64 Then
    Private Function WindowProc( _
        ByVal hWnd As LongLong, _
        ByVal uMsg As Long, _
        ByVal wParam As LongLong, _
        ByVal lParam As LongLong _
    ) As LongLong
        Dim pInfo As LongLong, hNotifyLock As LongLong
#Else
    Private Function WindowProc( _
        ByVal hWnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long _
    ) As Long
        Dim pInfo As Long, hNotifyLock As Long
#End If

    Const WM_SHNOTIFY = &H488
    Const WM_DESTROY = &H2
 
    Dim tInfo As SHNOTIFYSTRUCT
    Dim lEvent As Long
    Dim vDummy As Variant
 
    On Error GoTo Xit
    Select Case uMsg
        Case WM_SHNOTIFY
            hNotifyLock = SHChangeNotification_Lock(wParam, CLng(lParam), pInfo, lEvent)
            If hNotifyLock Then
                Call CopyMemory(tInfo, ByVal pInfo, LenB(tInfo))
                If tInfo.dwItem1 Then
                    sPrevious = GetPathFromPIDLW(tInfo.dwItem1)
                End If
                If tInfo.dwItem2 Then
                    sNew = GetPathFromPIDLW(tInfo.dwItem2)
                End If
                sEvent = LookUpSHCNE(lEvent)
                vDummy = Dummy
                Call IOShell.RaiseEvents(sEvent, sPrevious, sNew)
                Call SHChangeNotification_Unlock(hNotifyLock)
            End If
        Case WM_DESTROY
            Call SubClassHiddenWindow(hWnd, False)
            Exit Function
    End Select
    WindowProc = CallWindowProc(GetProp(Application.hWnd, "PrevProcAddr"), hWnd, uMsg, wParam, lParam)
    Exit Function
Xit:
    Call StopWatching
    Debug.Print "ERROR.... Monitoring cancelled."
 
End Function


#If Win64 Then
    Private Function GetPathFromPIDLW(ByVal pidl As LongLong) As String
#Else
    Private Function GetPathFromPIDLW(ByVal pidl As Long) As String
#End If
    Const MAX_PATH = 260
    Dim pszPath As String
    pszPath = String(MAX_PATH, 0)
    If SHGetPathFromIDListW(pidl, StrPtr(pszPath)) Then
        If InStr(pszPath, vbNullChar) Then
            GetPathFromPIDLW = Left$(pszPath, InStr(pszPath, vbNullChar) - 1)
        End If
    End If
End Function


Private Function LookUpSHCNE(lEvent As Long) As String
    Select Case lEvent
        Case &H1: LookUpSHCNE = "SHCNE_RENAMEITEM"
        Case &H2: LookUpSHCNE = "SHCNE_CREATE"
        Case &H4: LookUpSHCNE = "SHCNE_DELETE"
        Case &H8: LookUpSHCNE = "SHCNE_MKDIR"
        Case &H10: LookUpSHCNE = "SHCNE_RMDIR"
        Case &H20: LookUpSHCNE = "SHCNE_MEDIAINSERTED"
        Case &H40: LookUpSHCNE = "SHCNE_MEDIAREMOVED"
        Case &H80: LookUpSHCNE = "SHCNE_DRIVEREMOVED"
        Case &H100: LookUpSHCNE = "SHCNE_DRIVEADD"
        Case &H200: LookUpSHCNE = "SHCNE_NETSHARE"
        Case &H400: LookUpSHCNE = "SHCNE_NETUNSHARE"
        Case &H800: LookUpSHCNE = "SHCNE_ATTRIBUTES"
        Case &H1000: LookUpSHCNE = "SHCNE_UPDATEDIR"
        Case &H2000: LookUpSHCNE = "SHCNE_UPDATEITEM"
        Case &H4000: LookUpSHCNE = "SHCNE_SERVERDISCONNECT"
        Case &H8000&: LookUpSHCNE = "SHCNE_UPDATEIMAGE"
        Case &H10000: LookUpSHCNE = "SHCNE_DRIVEADDGUI"
        Case &H20000: LookUpSHCNE = "SHCNE_RENAMEFOLDER"
        Case &H40000: LookUpSHCNE = "SHCNE_FREESPACE"
        Case &H4000000: LookUpSHCNE = "SHCNE_EXTENDED_EVENT"
        Case &H8000000: LookUpSHCNE = "SHCNE_ASSOCCHANGED"
        Case &H2381F: LookUpSHCNE = "SHCNE_DISKEVENTS"
        Case &HC0581E0: LookUpSHCNE = "SHCNE_GLOBALEVENTS"
        Case &H7FFFFFFF: LookUpSHCNE = "SHCNE_ALLEVENTS"
        Case &H80000000: LookUpSHCNE = "SHCNE_INTERRUPT"
    End Select
End Function

Private Function Dummy() As Boolean
'
End Function

Private Sub AddMinButton(UF As Object)
    Const GWL_STYLE As Long = (-16)
    Const WS_SYSMENU As Long = &H80000
    Const WS_MINIMIZEBOX As Long = &H20000
    #If Win64 Then
        Dim hWnd As LongLong, lStyle As LongLong
    #Else
        Dim hWnd As Long, lStyle As Long
    #End If
 
    Call IUnknown_GetWindow(UF, VarPtr(hWnd))
    lStyle = GetWindowLong(hWnd, GWL_STYLE)
        lStyle = lStyle Or WS_SYSMENU Or WS_MINIMIZEBOX
    Call SetWindowLong(hWnd, GWL_STYLE, (lStyle))
    Call DrawMenuBar(hWnd)
End Sub

Private Sub auto_close()
    Call StopWatching
End Sub

4- Code Usage Example in a UserForm Module ( as per workbook demo)

Option Explicit

Private WithEvents oShell As CShellEvents

Private Sub UserForm_Initialize()
    Set oShell = New CShellEvents
    cmb_Finish.Enabled = False
End Sub

Private Sub UserForm_Terminate()
    oShell.FinishMonitoring
    Set oShell = Nothing
End Sub

Private Sub cmb_Start_Click()
    Call oShell.StartMonitoring(Me.TextBox1, Me)
    cmb_Finish.Enabled = True
    cmb_Start.Enabled = False
End Sub

Private Sub cmb_Finish_Click()
    oShell.FinishMonitoring
    cmb_Finish.Enabled = False
    cmb_Start.Enabled = True
End Sub

Private Sub cmb_Reset_Click()
    Me.ListBox1.Clear
End Sub

Private Sub cmb_Go_Click()
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            sFolder = .SelectedItems(1)
        End If
    End With
    If sFolder <> "" Then
        Me.TextBox1 = sFolder
    End If
End Sub

'_______________________________________ EVENT HANDLER _____________________________________________

Private Sub oShell_ShellEvent(ByVal sEvent As String, ByVal sPrevious As String, ByVal sNew As String)

    'CAUTION:
    '=======
        'No error allowed inside this event handler.
        'So propper error handling required.

    Static i As Long
 
    With Me.ListBox1
        If .ListCount = 0 Then i = 0
        i = i + 1
        .AddItem i
        .List(.ListCount - 1, 1) = "Event:  " & sEvent
        .List(.ListCount - 1, 2) = "Previous:  " & sPrevious
        .List(.ListCount - 1, 3) = "New:  " & sNew
        .List(.ListCount - 1, 4) = Format(Now, "hh:mm:ss")
        .ListIndex = .ListCount - 1
        .ListIndex = -1
    End With

End Sub

Tested on Win10 x64 Excel2016 x64.

Regards.

 

[Dan_W]

I can report back that it works perfectly for me, thank you!
I noticed you used this method (CreateWindowEx/Subclass) with the clipboard monitoring solution as well; what else do you think this method would be well-suited for?

 

[Jaafar Tribak]

I can report back that it works perfectly for me, thank you!

Thanks for testing and providing feedback.

I noticed you used this method (CreateWindowEx/Subclass) with the clipboard monitoring solution as well; what else do you think this method would be well-suited for?

The system can notify a top level window of certain changes as long as the top level window is first registered to be notified.

In the case of the clipboard monitoring that you mentioned, I registered the window with the AddClipboardFormatListener api and in the case of Shell monitoring I used here, I called SHChangeNotifyRegister. Notice how these two apis conviniently have a hwnd argument ready to be passed the window to be notified.

I can think of other similar apis that also register windows for intercepting system wide messages such apis are RegisterShellHookWindow and DragAcceptFiles... There should be other similar apis I haven't used before.

Now the problem is that after registering a window , we need to subclass it in order for it to be able to handle the target message and respond to it whenever notified. As we know, subclassing is cumbersome in vba and can make the host application unstable specially if we subclass the main excel window or modeless userforms. That's the reason why I always create a hidden top level window (CreateWindow\CreateWindEx) within the excel process and subclass it (instead of subclassing the excel or the userform windows) . That way, I can still receive the registered window messages (since the newly created hidden window exists within the excel process) without needing to subclass excel or the userform and risking a crash or at least slowing down the application. Based on my humble experience, I can say that this trick makes some subclassing situations in vba\office possible, lighter and pretty stable.

 

[Dan_W]

Thank you for this. I would have assumed that subclassing any window within the Excel process would carry with it an equivalent risk of crashing Excel, so am very happy/relieved that this appears not to be the case in all scenarios. I feel like I've developed a sixth sense for being able predict when Excel is about to crash...(sigh)