複数のExcelファイルにまたがるVBAコードを検索

Question

フォルダには約100個のマクロがありますが、特にaddGBEという名前のVBAモジュールを含むものを探しています。特定のフォルダ内のファイルのVBAコード内を検索できるソフトウェアプログラムはありますか？

Answer 1

私が更新した古いコード（2006）が見つかりました。検索文字列を入力するためのボックスが開き、フォルダを選択するダイアログボックスが開きます。次に、すべてのモジュールを検索し、文字列が見つかったファイル名とシート/モジュール名を表示するmsgboxを表示します。私はこれをしなかった、ちょうど更新した。 Origはhereを見つけました。 64ビットのチェックとデータ型の適切な宣言に関するMicrosoftのマニュアルについては、hereを参照してください。

Option Explicit 


#If VBA7 And Win64 Then ' VBA7 
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _ 
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 

Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _ 
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long 


Public Type BROWSEINFO 
    hOwner As LongPtr 
    pidlRoot As Long 
    pszDisplayName As String 
    lpszTitle As String 
    ulFlags As Long 
    lpfn As LongPtr 
    lParam As LongPtr 
    iImage As Long 
End Type 

#Else ' Downlevel when using previous version of VBA7 

Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _ 
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 

Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _ 
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long 


Public Type BROWSEINFO 
    hOwner As Long 
    pidlRoot As Long 
    pszDisplayName As String 
    lpszTitle As String 
    ulFlags As Long 
    lpfn As Long 
    lParam As Long 
    iImage As Long 
End Type 
#End If 


Function GetDirectory(Optional Msg) As String 

Dim bInfo As BROWSEINFO 
Dim Path As String 
Dim R As Long 
Dim x As Long 
Dim pos As Integer 

'Root folder (&H0 for Desktop, &H11 for My Computer) 
bInfo.pidlRoot = &H0 

'Title in the dialog 
If IsMissing(Msg) Then 
bInfo.lpszTitle = "Select a folder." 
Else 
bInfo.lpszTitle = Msg 
End If 

'Type of directory to return 
bInfo.ulFlags = &H1 

'Display the dialog 
x = SHBrowseForFolder(bInfo) 

'Parse the result 
Path = Space$(512) 
R = SHGetPathFromIDList(ByVal x, ByVal Path) 
If R Then 
pos = InStr(Path, Chr$(0)) 
GetDirectory = Left(Path, pos - 1) 
Else 
GetDirectory = "" 
End If 

End Function 

Function RecursiveFindFiles(strPath As String, _ 
strSearch As String, _ 
Optional bSubFolders As Boolean = True, _ 
Optional bSheet As Boolean = False, _ 
Optional lFileCount As Long = 0, _ 
Optional lDirCount As Long = 0) As Variant 

'adapted from the MS example: 
'http://support.microsoft.com/default.aspx?scid=kb;en-us;185476 
'--------------------------------------------------------------- 
'will list all the files in the supplied folder and it's 
'subfolders that fit the strSearch criteria 
'lFileCount and lDirCount will always have to start as 0 
'--------------------------------------------------------------- 

Dim strFileName As String 'Walking strFileName variable. 
Dim strDirName As String 'SubDirectory Name. 
Dim arrDirNames() As String 'Buffer for directory name entries. 
Dim nDir As Long 'Number of directories in this strPath. 
Dim i As Long 'For-loop counter. 
Dim n As Long 
Dim arrFiles 
Static strStartDirName As String 
Static strpathOld As String 

On Error GoTo sysFileERR 

If lFileCount = 0 Then 
Static collFiles As Collection 
Set collFiles = New Collection 
Application.Cursor = xlWait 
End If 

If Right$(strPath, 1) <> "\" Then 
strPath = strPath & "\" 
End If 

If lFileCount = 0 And lDirCount = 0 Then 
strStartDirName = strPath 
End If 

'search for subdirectories 
'------------------------- 
nDir = 0 

ReDim arrDirNames(nDir) 

strDirName = Dir(strPath, _ 
vbDirectory Or _ 
vbHidden Or _ 
vbArchive Or _ 
vbReadOnly Or _ 
vbSystem) 'Even if hidden, and so on. 

Do While Len(strDirName) > 0 
'ignore the current and encompassing directories 
'----------------------------------------------- 
If (strDirName <> ".") And (strDirName <> "..") Then 
'check for directory with bitwise comparison 
'------------------------------------------- 
If GetAttr(strPath & strDirName) And vbDirectory Then 
arrDirNames(nDir) = strDirName 
lDirCount = lDirCount + 1 
nDir = nDir + 1 
DoEvents 
ReDim Preserve arrDirNames(nDir) 
End If 'directories. 
sysFileERRCont1: 
End If 
strDirName = Dir() 'Get next subdirectory 

DoEvents 
Loop 

'Search through this directory 
'----------------------------- 
strFileName = Dir(strPath & strSearch, _ 
vbNormal Or _ 
vbHidden Or _ 
vbSystem Or _ 
vbReadOnly Or _ 
vbArchive) 

While Len(strFileName) <> 0 

'dump file in sheet 
'------------------ 
If bSheet Then 
If lFileCount < 65536 Then 
Cells(lFileCount + 1, 1) = strPath & strFileName 
End If 
End If 

lFileCount = lFileCount + 1 

collFiles.Add strPath & strFileName 

If strPath <> strpathOld Then 
Application.StatusBar = " " & lFileCount & _ 
" " & strSearch & " files found. " & _ 
"Now searching " & strPath 
End If 

strpathOld = strPath 

strFileName = Dir() 'Get next file 

DoEvents 
Wend 

If bSubFolders Then 
'If there are sub-directories.. 
'------------------------------ 
If nDir > 0 Then 
'Recursively walk into them 
'-------------------------- 
For i = 0 To nDir - 1 
RecursiveFindFiles strPath & arrDirNames(i) & "\", _ 
strSearch, _ 
bSubFolders, _ 
bSheet, _ 
lFileCount, _ 
lDirCount 

DoEvents 
Next 
End If 'If nDir > 0 

'only bare main folder left, so get out 
'-------------------------------------- 
If strPath & arrDirNames(i) = strStartDirName Then 
ReDim arrFiles(1 To lFileCount) As String 
For n = 1 To lFileCount 
arrFiles(n) = collFiles(n) 
Next 
RecursiveFindFiles = arrFiles 
Application.Cursor = xlDefault 
Application.StatusBar = False 
End If 

Else 'If bSubFolders 
ReDim arrFiles(1 To lFileCount) As String 
For n = 1 To lFileCount 
arrFiles(n) = collFiles(n) 
Next 
RecursiveFindFiles = arrFiles 
Application.Cursor = xlDefault 
Application.StatusBar = False 
End If 'If bSubFolders 

Exit Function 
sysFileERR: 

Resume sysFileERRCont1 

End Function 

Function FileFromPath(ByVal strFullPath As String, _ 
Optional bExtensionOff As Boolean = False) _ 
As String 

Dim FPL As Long 'len of full path 
Dim PLS As Long 'position of last slash 
Dim pd As Long 'position of dot before exension 
Dim strFile As String 

On Error GoTo ERROROUT 

FPL = Len(strFullPath) 
PLS = InStrRev(strFullPath, "\", , vbBinaryCompare) 
strFile = Right$(strFullPath, FPL - PLS) 

If bExtensionOff = False Then 
FileFromPath = strFile 
Else 
pd = InStr(1, strFile, ".", vbBinaryCompare) 
FileFromPath = Left$(strFile, pd - 1) 
End If 

Exit Function 
ERROROUT: 

On Error GoTo 0 
FileFromPath = "" 

End Function 

Sub SearchWBsForCode() 

Dim strTextToFind As String 
Dim strFolder As String 
Dim arr 
Dim i As Long 
Dim strWB As String 
Dim VBProj As VBProject 
Dim VBComp As VBComponent 
Dim lStartLine As Long 
Dim lEndLine As Long 
Dim lFound As Long 
Dim lType As Long 
Dim lSkipped As Long 
Dim oWB As Workbook 
Dim bOpen As Boolean 
Dim bNewBook As Boolean 

strTextToFind = InputBox("Type the text to find", _ 
"finding text in VBE") 

If Len(strTextToFind) = 0 Or StrPtr(strTextToFind) = 0 Then 
Exit Sub 
End If 

strFolder = GetDirectory() 

If Len(strFolder) = 0 Then 
Exit Sub 
End If 

lType = Application.InputBox("Type file type to search" & _ 
vbCrLf & vbCrLf & _ 
"1. Only .xls files" & vbCrLf & _ 
"2. Only .xla files" & vbCrLf & _ 
"3. Either file type", _ 
"finding text in VBE", 1, Type:=1) 

Select Case lType 
Case 1 
arr = RecursiveFindFiles(strFolder, "*.xls", True, True) 
Case 2 
arr = RecursiveFindFiles(strFolder, "*.xla", True, True) 
Case 3 
arr = RecursiveFindFiles(strFolder, "*.xl*", True, True) 
Case Else 
Exit Sub 
End Select 

With Application 
.ScreenUpdating = False 
.EnableEvents = False 
.DisplayAlerts = False 
End With 

For i = 1 To UBound(arr) 

Application.StatusBar = i & "/" & UBound(arr) & _ 
" - Searching " & arr(i) 

strWB = FileFromPath(arr(i)) 

On Error Resume Next 
Set oWB = Workbooks(strWB) 

If oWB Is Nothing Then 
bOpen = False 
Workbooks.Open arr(i) 
Else 
'for preventing closing WB's that are open already 
bOpen = True 
Set oWB = Nothing 
End If 

bNewBook = True 

For Each VBComp In Workbooks(strWB).VBProject.VBComponents 

If Err.Number = 50289 Then 'for protected WB's 
lSkipped = lSkipped + 1 
Err.Clear 
GoTo PAST 
End If 

lEndLine = VBComp.CodeModule.CountOfLines 
If VBComp.CodeModule.Find(strTextToFind, _ 
lStartLine, _ 
1, _ 
lEndLine, _ 
-1, _ 
False, _ 
False) = True Then 

If bNewBook = True Then 
lFound = lFound + 1 
bNewBook = False 
End If 

Application.ScreenUpdating = True 

If MsgBox("Workbook: " & arr(i) & vbCrLf & _ 
"VBComponent: " & VBComp.Name & vbCrLf & _ 
"Line number: " & lStartLine & _ 
vbCrLf & vbCrLf & _ 
"WB's found so far: " & lFound & vbCrLf & _ 
"Protected WB's skipped: " & lSkipped & _ 
vbCrLf & vbCrLf & _ 
"Stop searching?", _ 
vbYesNo + vbDefaultButton1 + vbQuestion, _ 
i & "/" & UBound(arr) & _ 
" - found " & strTextToFind) = vbYes Then 

With Application 
.StatusBar = False 
.EnableEvents = True 
.DisplayAlerts = True 
End With 

With VBComp.CodeModule.CodePane 
.SetSelection lStartLine, 1, lStartLine, 1 
.Show 
End With 

Exit Sub 
End If 

Application.ScreenUpdating = False 

End If 
Next 

PAST: 
If bOpen = False Then 
Workbooks(strWB).Close savechanges:=False 
End If 
On Error GoTo 0 

Next 

On Error Resume Next 
If bOpen = False Then 
Workbooks(strWB).Close savechanges:=False 
End If 

With Application 
.ScreenUpdating = True 
.StatusBar = False 
.EnableEvents = True 
.DisplayAlerts = True 
End With 

MsgBox lFound & " WB's found with " & strTextToFind & " in VBE" & _ 
vbCrLf & vbCrLf & _ 
"protected WB's skipped: " & lSkipped, , _ 
"finding text in VBE" 

End Sub