Searching within VBA module

Ian · 04-19-2006, 11:00 AM

I am trying to find some code i wrote within a VBA module, but
i don't know which excel workbook it is in and I have got hundreds.

Is there a program available that will search within a module and
find some text?

Cheers,

Ian,

RB Smissaert · 04-19-2006, 11:30 AM

You could write some VBA code that loops through
all .xls/.xla files in a folder (or drive if you want) and
opens the workbook and searches for the text in modules.
Look at CodeModule.Find
This is fairly simple and somebody may have this code
ready.
Not sure it can be done without opening the files.

RBS

"Ian" <excel888uk-spam-@yahoo.co.uk> wrote in message
news:aqjc421abhkg9ih9hs8klg44361u5g3jo2@4ax.com...
>I am trying to find some code i wrote within a VBA module, but
> i don't know which excel workbook it is in and I have got hundreds.
>
> Is there a program available that will search within a module and
> find some text?
>
> Cheers,
>
> Ian,

RB Smissaert · 04-19-2006, 01:35 PM

Try this code.
It will need a reference to Microsoft Visual Basic for Applications
Extensibility.
Just paste in a normal module and run Sub SearchWBsForCode.

Option Explicit

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

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

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

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 bFound As Boolean

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

strFolder = GetDirectory()

arr = RecursiveFindFiles(strFolder, "*.xls", True, True)

Application.ScreenUpdating = False

For i = 1 To UBound(arr)

Application.StatusBar = "Searching " & arr(i)

On Error Resume Next
Workbooks.Open arr(i)
On Error GoTo 0

strWB = FileFromPath(arr(i))

For Each VBComp In Workbooks(strWB).VBProject.VBComponents
lEndLine = VBComp.CodeModule.CountOfLines
If VBComp.CodeModule.Find(strTextToFind, _
lStartLine, _
1, _
lEndLine, _
-1, _
False, _
False) = True Then
MsgBox "Workbook: " & arr(i) & vbCrLf & _
"VBComponent: " & VBComp.Name & vbCrLf & _
"Line of first find: " & lStartLine, , _
"found " & strTextToFind
Application.ScreenUpdating = True
Application.StatusBar = False
Exit Sub
End If
Next

Workbooks(strWB).Close savechanges:=False

Next

Application.ScreenUpdating = True
Application.StatusBar = False

End Sub

You can make it much faster by running the VBE search in Function
RecursiveFindFiles
and get out if you have found the string.

RBS

"Ian" <excel888uk-spam-@yahoo.co.uk> wrote in message
news:aqjc421abhkg9ih9hs8klg44361u5g3jo2@4ax.com...
>I am trying to find some code i wrote within a VBA module, but
> i don't know which excel workbook it is in and I have got hundreds.
>
> Is there a program available that will search within a module and
> find some text?
>
> Cheers,
>
> Ian,

RB Smissaert · 04-19-2006, 01:45 PM

One adjustment as it would give an error with protected workbooks:

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 bFound 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

arr = RecursiveFindFiles(strFolder, "*.xls", True, True)

Application.ScreenUpdating = False

For i = 1 To UBound(arr)

Application.StatusBar = "Searching " & arr(i)

On Error Resume Next
Workbooks.Open arr(i)
On Error GoTo 0

strWB = FileFromPath(arr(i))

On Error GoTo PAST 'for protected workbooks
For Each VBComp In Workbooks(strWB).VBProject.VBComponents
lEndLine = VBComp.CodeModule.CountOfLines
If VBComp.CodeModule.Find(strTextToFind, _
lStartLine, _
1, _
lEndLine, _
-1, _
False, _
False) = True Then
MsgBox "Workbook: " & arr(i) & vbCrLf & _
"VBComponent: " & VBComp.Name & vbCrLf & _
"Line of first find: " & lStartLine, , _
"found " & strTextToFind
Application.ScreenUpdating = True
Application.StatusBar = False
Exit Sub
End If
Next

PAST:
Workbooks(strWB).Close savechanges:=False

Next

Application.ScreenUpdating = True
Application.StatusBar = False

End Sub

RBS

"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:Oa9RMa9YGHA.1764@TK2MSFTNGP05.phx.gbl...
> Try this code.
> It will need a reference to Microsoft Visual Basic for Applications
> Extensibility.
> Just paste in a normal module and run Sub SearchWBsForCode.
>
> Option Explicit
>
> 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
>
> Declare Function SHGetPathFromIDList _
> Lib "shell32.dll" _
> Alias "SHGetPathFromIDListA" _
> (ByVal pidl As Long, _
> ByVal pszPath As String) As Long
>
> Declare Function SHBrowseForFolder _
> Lib "shell32.dll" _
> Alias "SHBrowseForFolderA" _
> (lpBrowseInfo As BROWSEINFO) As Long
>
> 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 bFound As Boolean
>
> strTextToFind = InputBox("Type the text to find", _
> "finding text in VBE")
>
> strFolder = GetDirectory()
>
> arr = RecursiveFindFiles(strFolder, "*.xls", True, True)
>
> Application.ScreenUpdating = False
>
> For i = 1 To UBound(arr)
>
> Application.StatusBar = "Searching " & arr(i)
>
> On Error Resume Next
> Workbooks.Open arr(i)
> On Error GoTo 0
>
> strWB = FileFromPath(arr(i))
>
> For Each VBComp In Workbooks(strWB).VBProject.VBComponents
> lEndLine = VBComp.CodeModule.CountOfLines
> If VBComp.CodeModule.Find(strTextToFind, _
> lStartLine, _
> 1, _
> lEndLine, _
> -1, _
> False, _
> False) = True Then
> MsgBox "Workbook: " & arr(i) & vbCrLf & _
> "VBComponent: " & VBComp.Name & vbCrLf & _
> "Line of first find: " & lStartLine, , _
> "found " & strTextToFind
> Application.ScreenUpdating = True
> Application.StatusBar = False
> Exit Sub
> End If
> Next
>
> Workbooks(strWB).Close savechanges:=False
>
> Next
>
> Application.ScreenUpdating = True
> Application.StatusBar = False
>
> End Sub
>
> You can make it much faster by running the VBE search in Function
> RecursiveFindFiles
> and get out if you have found the string.
>
>
> RBS
>
>
> "Ian" <excel888uk-spam-@yahoo.co.uk> wrote in message
> news:aqjc421abhkg9ih9hs8klg44361u5g3jo2@4ax.com...
>>I am trying to find some code i wrote within a VBA module, but
>> i don't know which excel workbook it is in and I have got hundreds.
>>
>> Is there a program available that will search within a module and
>> find some text?
>>
>> Cheers,
>>
>> Ian,
>

RB Smissaert · 04-19-2006, 02:20 PM

Still not quite right, but this may do:

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 bFound As Boolean
Dim lType As Long

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

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

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

strFolder = GetDirectory()

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

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

Application.ScreenUpdating = False
Application.EnableEvents = False

For i = 1 To UBound(arr)

Application.StatusBar = "Searching " & arr(i)

On Error Resume Next
Workbooks.Open arr(i)
On Error GoTo 0

strWB = FileFromPathVBA(arr(i))

On Error Resume Next
For Each VBComp In Workbooks(strWB).VBProject.VBComponents
If Err.Number <> 0 Then
GoTo PAST
End If
lEndLine = VBComp.CodeModule.CountOfLines
If VBComp.CodeModule.Find(strTextToFind, _
lStartLine, _
1, _
lEndLine, _
-1, _
False, _
False) = True Then
MsgBox "Workbook: " & arr(i) & vbCrLf & _
"VBComponent: " & VBComp.Name & vbCrLf & _
"Line of first find: " & lStartLine, , _
"found " & strTextToFind
Application.ScreenUpdating = True
Application.StatusBar = False
Application.EnableEvents = True
Exit Sub
End If
Next

PAST:
Workbooks(strWB).Close savechanges:=False
On Error GoTo 0

Next

Application.ScreenUpdating = True
Application.StatusBar = False
Application.EnableEvents = True

End Sub

RBS

"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:Oa9RMa9YGHA.1764@TK2MSFTNGP05.phx.gbl...
> Try this code.
> It will need a reference to Microsoft Visual Basic for Applications
> Extensibility.
> Just paste in a normal module and run Sub SearchWBsForCode.
>
> Option Explicit
>
> 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
>
> Declare Function SHGetPathFromIDList _
> Lib "shell32.dll" _
> Alias "SHGetPathFromIDListA" _
> (ByVal pidl As Long, _
> ByVal pszPath As String) As Long
>
> Declare Function SHBrowseForFolder _
> Lib "shell32.dll" _
> Alias "SHBrowseForFolderA" _
> (lpBrowseInfo As BROWSEINFO) As Long
>
> 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 bFound As Boolean
>
> strTextToFind = InputBox("Type the text to find", _
> "finding text in VBE")
>
> strFolder = GetDirectory()
>
> arr = RecursiveFindFiles(strFolder, "*.xls", True, True)
>
> Application.ScreenUpdating = False
>
> For i = 1 To UBound(arr)
>
> Application.StatusBar = "Searching " & arr(i)
>
> On Error Resume Next
> Workbooks.Open arr(i)
> On Error GoTo 0
>
> strWB = FileFromPath(arr(i))
>
> For Each VBComp In Workbooks(strWB).VBProject.VBComponents
> lEndLine = VBComp.CodeModule.CountOfLines
> If VBComp.CodeModule.Find(strTextToFind, _
> lStartLine, _
> 1, _
> lEndLine, _
> -1, _
> False, _
> False) = True Then
> MsgBox "Workbook: " & arr(i) & vbCrLf & _
> "VBComponent: " & VBComp.Name & vbCrLf & _
> "Line of first find: " & lStartLine, , _
> "found " & strTextToFind
> Application.ScreenUpdating = True
> Application.StatusBar = False
> Exit Sub
> End If
> Next
>
> Workbooks(strWB).Close savechanges:=False
>
> Next
>
> Application.ScreenUpdating = True
> Application.StatusBar = False
>
> End Sub
>
> You can make it much faster by running the VBE search in Function
> RecursiveFindFiles
> and get out if you have found the string.
>
>
> RBS
>
>
> "Ian" <excel888uk-spam-@yahoo.co.uk> wrote in message
> news:aqjc421abhkg9ih9hs8klg44361u5g3jo2@4ax.com...
>>I am trying to find some code i wrote within a VBA module, but
>> i don't know which excel workbook it is in and I have got hundreds.
>>
>> Is there a program available that will search within a module and
>> find some text?
>>
>> Cheers,
>>
>> Ian,
>

Ian · 04-19-2006, 03:25 PM

Thanks for that. I have got it working now and it finds the text
okay.

cheers,

It was a big help.

Ian,

On Wed, 19 Apr 2006 19:15:06 +0100, "RB Smissaert"
<bartsmissaert@blueyonder.co.uk> wrote:

>Still not quite right, but this may do:
>
>
>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 bFound As Boolean
> Dim lType As Long
>
> strTextToFind = InputBox("Type the text to find", _
> "finding text in VBE")
>
> If Len(strTextToFind) = 0 Or StrPtr(strTextToFind) = 0 Then
> Exit Sub
> End If
>
> lType = Application.InputBox("File type to search" & vbCrLf & vbCrLf & _
> "1 for only .xls files" & vbCrLf & _
> "2 for only .xla files" & vbCrLf & _
> "3 for both file types", _
> "finding text in VBE", 1, Type:=1)
>
> strFolder = GetDirectory()
>
> If Len(strFolder) = 0 Then
> Exit Sub
> End If
>
> 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
>
> Application.ScreenUpdating = False
> Application.EnableEvents = False
>
> For i = 1 To UBound(arr)
>
> Application.StatusBar = "Searching " & arr(i)
>
> On Error Resume Next
> Workbooks.Open arr(i)
> On Error GoTo 0
>
> strWB = FileFromPathVBA(arr(i))
>
> On Error Resume Next
> For Each VBComp In Workbooks(strWB).VBProject.VBComponents
> If Err.Number <> 0 Then
> GoTo PAST
> End If
> lEndLine = VBComp.CodeModule.CountOfLines
> If VBComp.CodeModule.Find(strTextToFind, _
> lStartLine, _
> 1, _
> lEndLine, _
> -1, _
> False, _
> False) = True Then
> MsgBox "Workbook: " & arr(i) & vbCrLf & _
> "VBComponent: " & VBComp.Name & vbCrLf & _
> "Line of first find: " & lStartLine, , _
> "found " & strTextToFind
> Application.ScreenUpdating = True
> Application.StatusBar = False
> Application.EnableEvents = True
> Exit Sub
> End If
> Next
>
>PAST:
> Workbooks(strWB).Close savechanges:=False
> On Error GoTo 0
>
> Next
>
> Application.ScreenUpdating = True
> Application.StatusBar = False
> Application.EnableEvents = True
>
>End Sub
>
>
>RBS
>
>
>
>"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
>news:Oa9RMa9YGHA.1764@TK2MSFTNGP05.phx.gbl...
>> Try this code.
>> It will need a reference to Microsoft Visual Basic for Applications
>> Extensibility.
>> Just paste in a normal module and run Sub SearchWBsForCode.
>>
>> Option Explicit
>>
>> 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
>>
>> Declare Function SHGetPathFromIDList _
>> Lib "shell32.dll" _
>> Alias "SHGetPathFromIDListA" _
>> (ByVal pidl As Long, _
>> ByVal pszPath As String) As Long
>>
>> Declare Function SHBrowseForFolder _
>> Lib "shell32.dll" _
>> Alias "SHBrowseForFolderA" _
>> (lpBrowseInfo As BROWSEINFO) As Long
>>
>> 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 bFound As Boolean
>>
>> strTextToFind = InputBox("Type the text to find", _
>> "finding text in VBE")
>>
>> strFolder = GetDirectory()
>>
>> arr = RecursiveFindFiles(strFolder, "*.xls", True, True)
>>
>> Application.ScreenUpdating = False
>>
>> For i = 1 To UBound(arr)
>>
>> Application.StatusBar = "Searching " & arr(i)
>>
>> On Error Resume Next
>> Workbooks.Open arr(i)
>> On Error GoTo 0
>>
>> strWB = FileFromPath(arr(i))
>>
>> For Each VBComp In Workbooks(strWB).VBProject.VBComponents
>> lEndLine = VBComp.CodeModule.CountOfLines
>> If VBComp.CodeModule.Find(strTextToFind, _
>> lStartLine, _
>> 1, _
>> lEndLine, _
>> -1, _
>> False, _
>> False) = True Then
>> MsgBox "Workbook: " & arr(i) & vbCrLf & _
>> "VBComponent: " & VBComp.Name & vbCrLf & _
>> "Line of first find: " & lStartLine, , _
>> "found " & strTextToFind
>> Application.ScreenUpdating = True
>> Application.StatusBar = False
>> Exit Sub
>> End If
>> Next
>>
>> Workbooks(strWB).Close savechanges:=False
>>
>> Next
>>
>> Application.ScreenUpdating = True
>> Application.StatusBar = False
>>
>> End Sub
>>
>> You can make it much faster by running the VBE search in Function
>> RecursiveFindFiles
>> and get out if you have found the string.
>>
>>
>> RBS
>>
>>
>> "Ian" <excel888uk-spam-@yahoo.co.uk> wrote in message
>> news:aqjc421abhkg9ih9hs8klg44361u5g3jo2@4ax.com...
>>>I am trying to find some code i wrote within a VBA module, but
>>> i don't know which excel workbook it is in and I have got hundreds.
>>>
>>> Is there a program available that will search within a module and
>>> find some text?
>>>
>>> Cheers,
>>>
>>> Ian,
>>

RB Smissaert · 04-19-2006, 04:20 PM

Ok, you found your text, but it still isn't perfect and will
upload a better one in a bit.
I needed this myself, so I will see if I can get it right.

RBS

"Ian" <excel888uk-spam-@yahoo.co.uk> wrote in message
news:tg3d4258uss44qjrroegfenr90ndl4h11q@4ax.com...
>
>
> Thanks for that. I have got it working now and it finds the text
> okay.
>
> cheers,
>
> It was a big help.
>
> Ian,
>
>
> On Wed, 19 Apr 2006 19:15:06 +0100, "RB Smissaert"
> <bartsmissaert@blueyonder.co.uk> wrote:
>
>>Still not quite right, but this may do:
>>
>>
>>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 bFound As Boolean
>> Dim lType As Long
>>
>> strTextToFind = InputBox("Type the text to find", _
>> "finding text in VBE")
>>
>> If Len(strTextToFind) = 0 Or StrPtr(strTextToFind) = 0 Then
>> Exit Sub
>> End If
>>
>> lType = Application.InputBox("File type to search" & vbCrLf & vbCrLf &
>> _
>> "1 for only .xls files" & vbCrLf & _
>> "2 for only .xla files" & vbCrLf & _
>> "3 for both file types", _
>> "finding text in VBE", 1, Type:=1)
>>
>> strFolder = GetDirectory()
>>
>> If Len(strFolder) = 0 Then
>> Exit Sub
>> End If
>>
>> 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
>>
>> Application.ScreenUpdating = False
>> Application.EnableEvents = False
>>
>> For i = 1 To UBound(arr)
>>
>> Application.StatusBar = "Searching " & arr(i)
>>
>> On Error Resume Next
>> Workbooks.Open arr(i)
>> On Error GoTo 0
>>
>> strWB = FileFromPathVBA(arr(i))
>>
>> On Error Resume Next
>> For Each VBComp In Workbooks(strWB).VBProject.VBComponents
>> If Err.Number <> 0 Then
>> GoTo PAST
>> End If
>> lEndLine = VBComp.CodeModule.CountOfLines
>> If VBComp.CodeModule.Find(strTextToFind, _
>> lStartLine, _
>> 1, _
>> lEndLine, _
>> -1, _
>> False, _
>> False) = True Then
>> MsgBox "Workbook: " & arr(i) & vbCrLf & _
>> "VBComponent: " & VBComp.Name & vbCrLf & _
>> "Line of first find: " & lStartLine, , _
>> "found " & strTextToFind
>> Application.ScreenUpdating = True
>> Application.StatusBar = False
>> Application.EnableEvents = True
>> Exit Sub
>> End If
>> Next
>>
>>PAST:
>> Workbooks(strWB).Close savechanges:=False
>> On Error GoTo 0
>>
>> Next
>>
>> Application.ScreenUpdating = True
>> Application.StatusBar = False
>> Application.EnableEvents = True
>>
>>End Sub
>>
>>
>>RBS
>>
>>
>>
>>"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
>>news:Oa9RMa9YGHA.1764@TK2MSFTNGP05.phx.gbl...
>>> Try this code.
>>> It will need a reference to Microsoft Visual Basic for Applications
>>> Extensibility.
>>> Just paste in a normal module and run Sub SearchWBsForCode.
>>>
>>> Option Explicit
>>>
>>> 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
>>>
>>> Declare Function SHGetPathFromIDList _
>>> Lib "shell32.dll" _
>>> Alias "SHGetPathFromIDListA" _
>>> (ByVal pidl As Long, _
>>> ByVal pszPath As String) As Long
>>>
>>> Declare Function SHBrowseForFolder _
>>> Lib "shell32.dll" _
>>> Alias "SHBrowseForFolderA" _
>>> (lpBrowseInfo As BROWSEINFO) As Long
>>>
>>> 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 bFound As Boolean
>>>
>>> strTextToFind = InputBox("Type the text to find", _
>>> "finding text in VBE")
>>>
>>> strFolder = GetDirectory()
>>>
>>> arr = RecursiveFindFiles(strFolder, "*.xls", True, True)
>>>
>>> Application.ScreenUpdating = False
>>>
>>> For i = 1 To UBound(arr)
>>>
>>> Application.StatusBar = "Searching " & arr(i)
>>>
>>> On Error Resume Next
>>> Workbooks.Open arr(i)
>>> On Error GoTo 0
>>>
>>> strWB = FileFromPath(arr(i))
>>>
>>> For Each VBComp In Workbooks(strWB).VBProject.VBComponents
>>> lEndLine = VBComp.CodeModule.CountOfLines
>>> If VBComp.CodeModule.Find(strTextToFind, _
>>> lStartLine, _
>>> 1, _
>>> lEndLine, _
>>> -1, _
>>> False, _
>>> False) = True Then
>>> MsgBox "Workbook: " & arr(i) & vbCrLf & _
>>> "VBComponent: " & VBComp.Name & vbCrLf & _
>>> "Line of first find: " & lStartLine, , _
>>> "found " & strTextToFind
>>> Application.ScreenUpdating = True
>>> Application.StatusBar = False
>>> Exit Sub
>>> End If
>>> Next
>>>
>>> Workbooks(strWB).Close savechanges:=False
>>>
>>> Next
>>>
>>> Application.ScreenUpdating = True
>>> Application.StatusBar = False
>>>
>>> End Sub
>>>
>>> You can make it much faster by running the VBE search in Function
>>> RecursiveFindFiles
>>> and get out if you have found the string.
>>>
>>>
>>> RBS
>>>
>>>
>>> "Ian" <excel888uk-spam-@yahoo.co.uk> wrote in message
>>> news:aqjc421abhkg9ih9hs8klg44361u5g3jo2@4ax.com...
>>>>I am trying to find some code i wrote within a VBA module, but
>>>> i don't know which excel workbook it is in and I have got hundreds.
>>>>
>>>> Is there a program available that will search within a module and
>>>> find some text?
>>>>
>>>> Cheers,
>>>>
>>>> Ian,
>>>
>

RB Smissaert · 04-19-2006, 04:40 PM

This will be better.
It will select the line in the VBE as well with the searched string:

Sub SearchWBsForCodeU()

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

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

If Len(strTextToFind) = 0 Or StrPtr(strTextToFind) = 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)

strFolder = GetDirectory()

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

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
Workbooks.Open arr(i)
bOpen = False
Else
'for preventing closing WB's that are open already
bOpen = True
End If

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

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

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

lFound = lFound + 1

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

If MsgBox("Workbook: " & arr(i) & vbCrLf & _
"VBComponent: " & .Name & vbCrLf & _
"Line of first find: " & lStartLine & _
vbCrLf & vbCrLf & _
"protected WB's skipped: " & lSkipped & _
vbCrLf & vbCrLf & _
"Stop searching?", _
vbYesNo + vbDefaultButton1 + vbQuestion, _
"found " & strTextToFind) = vbYes Then

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

Exit Sub
End If

End If
End With
Next

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

Next

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

Will be interested in any bugs or improvements.

RBS

"Ian" <excel888uk-spam-@yahoo.co.uk> wrote in message
news:tg3d4258uss44qjrroegfenr90ndl4h11q@4ax.com...
>
>
> Thanks for that. I have got it working now and it finds the text
> okay.
>
> cheers,
>
> It was a big help.
>
> Ian,
>
>
> On Wed, 19 Apr 2006 19:15:06 +0100, "RB Smissaert"
> <bartsmissaert@blueyonder.co.uk> wrote:
>
>>Still not quite right, but this may do:
>>
>>
>>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 bFound As Boolean
>> Dim lType As Long
>>
>> strTextToFind = InputBox("Type the text to find", _
>> "finding text in VBE")
>>
>> If Len(strTextToFind) = 0 Or StrPtr(strTextToFind) = 0 Then
>> Exit Sub
>> End If
>>
>> lType = Application.InputBox("File type to search" & vbCrLf & vbCrLf &
>> _
>> "1 for only .xls files" & vbCrLf & _
>> "2 for only .xla files" & vbCrLf & _
>> "3 for both file types", _
>> "finding text in VBE", 1, Type:=1)
>>
>> strFolder = GetDirectory()
>>
>> If Len(strFolder) = 0 Then
>> Exit Sub
>> End If
>>
>> 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
>>
>> Application.ScreenUpdating = False
>> Application.EnableEvents = False
>>
>> For i = 1 To UBound(arr)
>>
>> Application.StatusBar = "Searching " & arr(i)
>>
>> On Error Resume Next
>> Workbooks.Open arr(i)
>> On Error GoTo 0
>>
>> strWB = FileFromPathVBA(arr(i))
>>
>> On Error Resume Next
>> For Each VBComp In Workbooks(strWB).VBProject.VBComponents
>> If Err.Number <> 0 Then
>> GoTo PAST
>> End If
>> lEndLine = VBComp.CodeModule.CountOfLines
>> If VBComp.CodeModule.Find(strTextToFind, _
>> lStartLine, _
>> 1, _
>> lEndLine, _
>> -1, _
>> False, _
>> False) = True Then
>> MsgBox "Workbook: " & arr(i) & vbCrLf & _
>> "VBComponent: " & VBComp.Name & vbCrLf & _
>> "Line of first find: " & lStartLine, , _
>> "found " & strTextToFind
>> Application.ScreenUpdating = True
>> Application.StatusBar = False
>> Application.EnableEvents = True
>> Exit Sub
>> End If
>> Next
>>
>>PAST:
>> Workbooks(strWB).Close savechanges:=False
>> On Error GoTo 0
>>
>> Next
>>
>> Application.ScreenUpdating = True
>> Application.StatusBar = False
>> Application.EnableEvents = True
>>
>>End Sub
>>
>>
>>RBS
>>
>>
>>
>>"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
>>news:Oa9RMa9YGHA.1764@TK2MSFTNGP05.phx.gbl...
>>> Try this code.
>>> It will need a reference to Microsoft Visual Basic for Applications
>>> Extensibility.
>>> Just paste in a normal module and run Sub SearchWBsForCode.
>>>
>>> Option Explicit
>>>
>>> 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
>>>
>>> Declare Function SHGetPathFromIDList _
>>> Lib "shell32.dll" _
>>> Alias "SHGetPathFromIDListA" _
>>> (ByVal pidl As Long, _
>>> ByVal pszPath As String) As Long
>>>
>>> Declare Function SHBrowseForFolder _
>>> Lib "shell32.dll" _
>>> Alias "SHBrowseForFolderA" _
>>> (lpBrowseInfo As BROWSEINFO) As Long
>>>
>>> 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 bFound As Boolean
>>>
>>> strTextToFind = InputBox("Type the text to find", _
>>> "finding text in VBE")
>>>
>>> strFolder = GetDirectory()
>>>
>>> arr = RecursiveFindFiles(strFolder, "*.xls", True, True)
>>>
>>> Application.ScreenUpdating = False
>>>
>>> For i = 1 To UBound(arr)
>>>
>>> Application.StatusBar = "Searching " & arr(i)
>>>
>>> On Error Resume Next
>>> Workbooks.Open arr(i)
>>> On Error GoTo 0
>>>
>>> strWB = FileFromPath(arr(i))
>>>
>>> For Each VBComp In Workbooks(strWB).VBProject.VBComponents
>>> lEndLine = VBComp.CodeModule.CountOfLines
>>> If VBComp.CodeModule.Find(strTextToFind, _
>>> lStartLine, _
>>> 1, _
>>> lEndLine, _
>>> -1, _
>>> False, _
>>> False) = True Then
>>> MsgBox "Workbook: " & arr(i) & vbCrLf & _
>>> "VBComponent: " & VBComp.Name & vbCrLf & _
>>> "Line of first find: " & lStartLine, , _
>>> "found " & strTextToFind
>>> Application.ScreenUpdating = True
>>> Application.StatusBar = False
>>> Exit Sub
>>> End If
>>> Next
>>>
>>> Workbooks(strWB).Close savechanges:=False
>>>
>>> Next
>>>
>>> Application.ScreenUpdating = True
>>> Application.StatusBar = False
>>>
>>> End Sub
>>>
>>> You can make it much faster by running the VBE search in Function
>>> RecursiveFindFiles
>>> and get out if you have found the string.
>>>
>>>
>>> RBS
>>>
>>>
>>> "Ian" <excel888uk-spam-@yahoo.co.uk> wrote in message
>>> news:aqjc421abhkg9ih9hs8klg44361u5g3jo2@4ax.com...
>>>>I am trying to find some code i wrote within a VBA module, but
>>>> i don't know which excel workbook it is in and I have got hundreds.
>>>>
>>>> Is there a program available that will search within a module and
>>>> find some text?
>>>>
>>>> Cheers,
>>>>
>>>> Ian,
>>>
>

RB Smissaert · 04-19-2006, 05:10 PM

Still not right, maybe now it is:

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

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

If Len(strTextToFind) = 0 Or StrPtr(strTextToFind) = 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)

strFolder = GetDirectory()

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

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
Workbooks.Open arr(i)
bOpen = False
Else
'for preventing closing WB's that are open already
bOpen = True
Set oWB = Nothing 'this is needed
End If

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

lFound = lFound + 1

If MsgBox("Workbook: " & arr(i) & vbCrLf & _
"VBComponent: " & VBComp.Name & vbCrLf & _
"Line of first find: " & lStartLine & _
vbCrLf & vbCrLf & _
"protected WB's skipped: " & lSkipped & _
vbCrLf & vbCrLf & _
"Stop searching?", _
vbYesNo + vbDefaultButton1 + vbQuestion, _
"found " & strTextToFind) = vbYes Then

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

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

Exit Sub
End If

End If
Next

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

Next

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

RBS

"Ian" <excel888uk-spam-@yahoo.co.uk> wrote in message
news:tg3d4258uss44qjrroegfenr90ndl4h11q@4ax.com...
>
>
> Thanks for that. I have got it working now and it finds the text
> okay.
>
> cheers,
>
> It was a big help.
>
> Ian,
>
>
> On Wed, 19 Apr 2006 19:15:06 +0100, "RB Smissaert"
> <bartsmissaert@blueyonder.co.uk> wrote:
>
>>Still not quite right, but this may do:
>>
>>
>>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 bFound As Boolean
>> Dim lType As Long
>>
>> strTextToFind = InputBox("Type the text to find", _
>> "finding text in VBE")
>>
>> If Len(strTextToFind) = 0 Or StrPtr(strTextToFind) = 0 Then
>> Exit Sub
>> End If
>>
>> lType = Application.InputBox("File type to search" & vbCrLf & vbCrLf &
>> _
>> "1 for only .xls files" & vbCrLf & _
>> "2 for only .xla files" & vbCrLf & _
>> "3 for both file types", _
>> "finding text in VBE", 1, Type:=1)
>>
>> strFolder = GetDirectory()
>>
>> If Len(strFolder) = 0 Then
>> Exit Sub
>> End If
>>
>> 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
>>
>> Application.ScreenUpdating = False
>> Application.EnableEvents = False
>>
>> For i = 1 To UBound(arr)
>>
>> Application.StatusBar = "Searching " & arr(i)
>>
>> On Error Resume Next
>> Workbooks.Open arr(i)
>> On Error GoTo 0
>>
>> strWB = FileFromPathVBA(arr(i))
>>
>> On Error Resume Next
>> For Each VBComp In Workbooks(strWB).VBProject.VBComponents
>> If Err.Number <> 0 Then
>> GoTo PAST
>> End If
>> lEndLine = VBComp.CodeModule.CountOfLines
>> If VBComp.CodeModule.Find(strTextToFind, _
>> lStartLine, _
>> 1, _
>> lEndLine, _
>> -1, _
>> False, _
>> False) = True Then
>> MsgBox "Workbook: " & arr(i) & vbCrLf & _
>> "VBComponent: " & VBComp.Name & vbCrLf & _
>> "Line of first find: " & lStartLine, , _
>> "found " & strTextToFind
>> Application.ScreenUpdating = True
>> Application.StatusBar = False
>> Application.EnableEvents = True
>> Exit Sub
>> End If
>> Next
>>
>>PAST:
>> Workbooks(strWB).Close savechanges:=False
>> On Error GoTo 0
>>
>> Next
>>
>> Application.ScreenUpdating = True
>> Application.StatusBar = False
>> Application.EnableEvents = True
>>
>>End Sub
>>
>>
>>RBS
>>
>>
>>
>>"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
>>news:Oa9RMa9YGHA.1764@TK2MSFTNGP05.phx.gbl...
>>> Try this code.
>>> It will need a reference to Microsoft Visual Basic for Applications
>>> Extensibility.
>>> Just paste in a normal module and run Sub SearchWBsForCode.
>>>
>>> Option Explicit
>>>
>>> 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
>>>
>>> Declare Function SHGetPathFromIDList _
>>> Lib "shell32.dll" _
>>> Alias "SHGetPathFromIDListA" _
>>> (ByVal pidl As Long, _
>>> ByVal pszPath As String) As Long
>>>
>>> Declare Function SHBrowseForFolder _
>>> Lib "shell32.dll" _
>>> Alias "SHBrowseForFolderA" _
>>> (lpBrowseInfo As BROWSEINFO) As Long
>>>
>>> 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 bFound As Boolean
>>>
>>> strTextToFind = InputBox("Type the text to find", _
>>> "finding text in VBE")
>>>
>>> strFolder = GetDirectory()
>>>
>>> arr = RecursiveFindFiles(strFolder, "*.xls", True, True)
>>>
>>> Application.ScreenUpdating = False
>>>
>>> For i = 1 To UBound(arr)
>>>
>>> Application.StatusBar = "Searching " & arr(i)
>>>
>>> On Error Resume Next
>>> Workbooks.Open arr(i)
>>> On Error GoTo 0
>>>
>>> strWB = FileFromPath(arr(i))
>>>
>>> For Each VBComp In Workbooks(strWB).VBProject.VBComponents
>>> lEndLine = VBComp.CodeModule.CountOfLines
>>> If VBComp.CodeModule.Find(strTextToFind, _
>>> lStartLine, _
>>> 1, _
>>> lEndLine, _
>>> -1, _
>>> False, _
>>> False) = True Then
>>> MsgBox "Workbook: " & arr(i) & vbCrLf & _
>>> "VBComponent: " & VBComp.Name & vbCrLf & _
>>> "Line of first find: " & lStartLine, , _
>>> "found " & strTextToFind
>>> Application.ScreenUpdating = True
>>> Application.StatusBar = False
>>> Exit Sub
>>> End If
>>> Next
>>>
>>> Workbooks(strWB).Close savechanges:=False
>>>
>>> Next
>>>
>>> Application.ScreenUpdating = True
>>> Application.StatusBar = False
>>>
>>> End Sub
>>>
>>> You can make it much faster by running the VBE search in Function
>>> RecursiveFindFiles
>>> and get out if you have found the string.
>>>
>>>
>>> RBS
>>>
>>>
>>> "Ian" <excel888uk-spam-@yahoo.co.uk> wrote in message
>>> news:aqjc421abhkg9ih9hs8klg44361u5g3jo2@4ax.com...
>>>>I am trying to find some code i wrote within a VBA module, but
>>>> i don't know which excel workbook it is in and I have got hundreds.
>>>>
>>>> Is there a program available that will search within a module and
>>>> find some text?
>>>>
>>>> Cheers,
>>>>
>>>> Ian,
>>>
>

RB Smissaert · 04-19-2006, 06:15 PM

Now it should be OK:

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

RBS