CÓDIGO:
'=============================================================================================
' Microsoft® Office Excel - DashBoard®, Developed by A&A - In Any Place®.
'
' CopyLeft© A&A - In Any Place, all Lefts Reserved.
'
' Cheque se existe referência ao "Microsoft Visual Basic for Applications Extensibility x.xx"
'=============================================================================================
Option Explicit
Const vbext_pp_none As Long = 0
Const vbext_pk_Proc As Long = 0
Dim x As Long
Dim objList()
Sub RetProject()
' Author: Date: Contact: URL:
' André Bernardes 22/09/2010 15:26 bernardess@gmail.com https://sites.google.com/site/vbabernardes/blogs
' Lista todos os módulos, e processos (functions & procedures) neles.
Dim oBJCT As Object
Dim Wb As Workbook
Let x = 2
For Each Wb In Workbooks
For Each oBJCT In Workbooks(Wb.Name).VBProject.VBComponents
If Workbooks(Wb.Name).VBProject.Protection = vbext_pp_none Then
Call LoadRoutines(Wb.Name, oBJCT.Name)
End If
Next
Next
With Sheets.Add
Let .[A1].Resize (, 3).Value = Array ("Aplicação", "Módulo", "Processos (Functions & Subs)")
Let .[A2].Resize (UBound (objList, 2), UBound(objList, 1)).Value = Application.Transpose (objList)
.Columns("A:C").Columns.AutoFit
End With
End Sub
CÓDIGO:
Sub LoadRoutines(nWBook As String, vbCmp As String)
' Author: Date: Contact: URL:
' André Bernardes 23/11/2010 15:28 bernardess@gmail.com https://sites.google.com/site/vbabernardes/blogs
' Retorna detalhes para a SUB 'RetProject'.
' Listening: .
Dim vbCode As Object
Dim StartRow As Long
On Error Resume Next
Set vbCode = Workbooks(nWBook).VBProject.VBComponents(vbCmp).vbCode
With vbCode
Let StartLine = .CountOfDeclarationLines + 1
Do Until StartLine >= .CountOfLines
ReDim Preserve aList (1 To 3, 1 To x - 1)
Let aList(1, x - 1) = nWBook
Let aList(2, x - 1) = vbCmp
Let aList(3, x - 1) = .ProcOfLine(StartRow, vbext_pk_Proc)
Let x = x + 1
Let StartLine = StartRow + .ProcCountLines(.ProcOfLine(StartRow, vbext_pk_Proc), vbext_pk_Proc)
If Err Then Exit Sub
Loop
End With
Set vbCode = Nothing
End Sub