Поиск документов с макросами на жестком диске компьютера

Option Explicit
 
 
' Выбор папки для обработки через диалог
Sub FindMacro()
    Dim fd As FileDialog, vrtSelectedItem As Variant, sFolder As String
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    fd.AllowMultiSelect = False
    fd.InitialFileName = ThisWorkbook.Path & "\"
    
    If fd.Show = -1 Then
        Application.ScreenUpdating = False
        For Each vrtSelectedItem In fd.SelectedItems
            sFolder = vrtSelectedItem
            If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
            ' на всю глубину -1; текущ. папка 0, уроверь вложения >=1
            Call RecureiveSearch(sFolder, -1)
        Next vrtSelectedItem
        Application.ScreenUpdating = True
    End If
End Sub
 
 
' Рекурсия по папкам с управляемой глубиной обхода
Private Sub RecureiveSearch(MyPath As String, ByVal Level As Long)
    Dim MyName As String, PS As String, DirList() As String
    Dim i As Long, n As Long
    
    PS = Application.PathSeparator
    ReDim DirList(0 To 0) As String
    
    MyName = Dir(MyPath, vbDirectory)
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            n = GetAttr(MyPath & MyName)
            If (n And vbDirectory) = vbDirectory Then
                ReDim Preserve DirList(0 To UBound(DirList) + 1) As String
                DirList(UBound(DirList)) = MyPath & MyName & PS
            Else
                If MyName Like "*.xls*" And Not MyName Like ThisWorkbook.Name Then
                    Call CheckMacro(MyPath, MyName)
                End If
            End If
        End If
        MyName = Dir
    Loop
    If Level = 0 Then Exit Sub
    If Level > 0 Then Level = Level - 1
    If UBound(DirList) > 0 Then
        For i = 1 To UBound(DirList)
            Call RecureiveSearch(DirList(i), Level)
        Next i
    End If
End Sub
 
 
Private Sub CheckMacro(MyPath As String, MyName As String)
    Dim wbk As Workbook, vbc As Object, s As String, b As Boolean
    
    Set wbk = Workbooks.Open(MyPath & MyName, False, True)
    
    b = False
    For Each vbc In wbk.VBProject.VBComponents
        If vbc.CodeModule.CountOfLines > 0 Then
            s = vbc.CodeModule.Lines(1, vbc.CodeModule.CountOfLines)
            s = Replace(s, "Option Explicit", "")
            s = Trim$(Replace(s, vbCrLf, ""))
            If Len(s) > 0 Then
                b = True
                Exit For
            End If
        End If
        s = vbc.CodeModule.Name
    Next
    
    If b Then
        Debug.Print MyPath & MyName
    End If
    
    wbk.Close False
    Set wbk = Nothing
End Sub