Excel VBA or any free tool for list all VBA function procedure and Sub Procedure

[bennyys]

Hi all,
I am in the stage of tidy up all my UDF and and Sub Procedure I wrote since several years ago.
As of now those excel files scatter in many folders and sub folders.
What I am looking for now is excel VBA with ability to loop through folder and all its sub folders and create a list of
" folder name, sub folder name, excel file name, and all UDF and and Sub Procedure contain on the file".
Or if there are any free tools for this purpose would be nice.


Regards,
Benny

 

[Worf]

Hi Benny

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


Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
  
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type


Sub Main()                                                  ' run me
Dim dtr$, sht As Worksheet, i%, wb As Workbook
Set sht = Sheets("sheet1")
dtr = GetDirectory("Select the folder:")
If dtr = "" Then Exit Sub
If Right(dtr, 1) <> "\" Then dtr = dtr & "\"
sht.[a:e].ClearContents
sht.Activate
RecursiveDir dtr
For i = 2 To Range("b" & Rows.Count).End(xlUp).Row
    If Cells(i, 2) Like "*.xls?" Then
        Set wb = Workbooks.Open(Cells(i, 1) & Cells(i, 2))
        sht.Cells(i, 5) = ListProc(wb)
        wb.Close False
    End If
Next
End Sub


Function ListProc$(wb As Workbook)
Dim VBP As VBIDE.VBProject, VBC As VBComponent, CM As CodeModule, sl&, Msg$
Msg = ""
Set VBP = wb.VBProject
For Each VBC In VBP.VBComponents
    Set CM = VBC.CodeModule
    Msg = Msg & "///"
    sl = CM.CountOfDeclarationLines + 1
    Do Until sl >= CM.CountOfLines
        Msg = Msg & VBC.Name & ": " & CM.ProcOfLine(sl, vbext_pk_Proc) & "///"
        sl = sl + CM.ProcCountLines(CM.ProcOfLine(sl, vbext_pk_Proc), vbext_pk_Proc)
    Loop
Next
ListProc = Msg
End Function


Public Sub RecursiveDir(ByVal CurrDir$)
Dim Dirs() As String, NumDirs&, FileName$, pn$, i&
If Right(CurrDir, 1) <> "\" Then CurrDir = CurrDir & "\"
Cells(1, 1) = "Path"
Cells(1, 2) = "Filename"
Cells(1, 3) = "Size"
Cells(1, 4) = "Date/Time"
Cells(1, 5) = "Subs"
[a1:e1].Font.Bold = True
FileName = Dir(CurrDir & "*.*", vbDirectory)
Do While Len(FileName) <> 0
  If Left(FileName, 1) <> "." Then          'Current dir
    pn = CurrDir & FileName
    If (GetAttr(pn) And vbDirectory) = vbDirectory Then
       ReDim Preserve Dirs$(0 To NumDirs)
       Dirs(NumDirs) = pn
       NumDirs = NumDirs + 1
    Else
      Cells(WorksheetFunction.CountA(Range("A:A")) + 1, 1) = CurrDir
      Cells(WorksheetFunction.CountA(Range("B:B")) + 1, 2) = FileName
      Cells(WorksheetFunction.CountA([c:c]) + 1, 3) = FileLen(pn)
      Cells(WorksheetFunction.CountA([d:d]) + 1, 4) = FileDateTime(pn)
    End If
  End If
    FileName = Dir()
Loop
For i = 0 To NumDirs - 1
    RecursiveDir Dirs(i)
Next
End Sub


Function GetDirectory$(Optional Msg)
Dim bInfo As BROWSEINFO, path$, r&, x&, pos%
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
    bInfo.lpszTitle = "Select a folder."
Else
    bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
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