Home |
Search |
Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Searching within VBA module
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, |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Searching within VBA module
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" wrote in message ... 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, |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Searching within VBA module
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" wrote in message ... 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, |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Searching within VBA module
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" wrote in message ... 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" wrote in message ... 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, |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Searching within VBA module
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" wrote in message ... 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" wrote in message ... 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, |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Searching within VBA module
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" 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" wrote in message ... 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" wrote in message ... 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, |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Searching within VBA module
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" wrote in message ... 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" 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" wrote in message ... 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" wrote in message ... 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, |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Searching within VBA module
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" wrote in message ... 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" 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" wrote in message ... 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" wrote in message ... 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, |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
Searching within VBA module
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" wrote in message ... 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" 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" wrote in message ... 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" wrote in message ... 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, |
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
Searching within VBA module
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Searching, matching then searching another list based on the match | Excel Discussion (Misc queries) | |||
code in module A to not execute a Worksheet_SelectionChange sub of another module | Excel Discussion (Misc queries) | |||
Run worksheet module code from workbook module? | Excel Programming | |||
Calls from sheet module to ThisWorkbook module | Excel Programming | |||
Variable from a sheet module in a class module in XL XP | Excel Programming |