Получить имя модуля в excel

Я работаю над вспомогательным макросом, который изучает функцию списка для данного имени модуля в активной книге Excel. Пример: у меня есть имя модуля «Module1». Внутри этого модуля есть следующая функция или подпрограмма

Sub Sub1()
End Sub

Sub Sub2()
End Sub

Function Func1()
End Function

Function Func2()
End Function

Есть ли команда или процедура, которая может возвращать список имен функций и подпрограмм?

Вот ссылка на сайт Чипа Пирсона. Я иду сюда, когда мне нужно запрограммировать что-то, что влияет на VBE или использует его. Есть 2 раздела, которые могут вас заинтересовать. Один будет перечислять все модули в проекте. А другой перечислит все процедуры в модуле. Надеюсь, это поможет.

http://www.cpearson.com/excel/vbe.aspx

Код с сайта (обязательно посетите сайт для получения инструкций по добавлению ссылки на библиотеку объектов VBIDE:

Этот код перечислит все процедуры в Module1, начиная с ячейки A1.

Sub ListProcedures()
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule
    Dim LineNum As Long
    Dim NumLines As Long
    Dim WS As Worksheet
    Dim Rng As Range
    Dim ProcName As String
    Dim ProcKind As VBIDE.vbext_ProcKind

    Set VBProj = ActiveWorkbook.VBProject
    Set VBComp = VBProj.VBComponents("Module1")
    Set CodeMod = VBComp.CodeModule

    Set WS = ActiveWorkbook.Worksheets("Sheet1")
    Set Rng = WS.Range("A1")
    With CodeMod
        LineNum = .CountOfDeclarationLines + 1
        Do Until LineNum >= .CountOfLines
            ProcName = .ProcOfLine(LineNum, ProcKind)
            Rng.Value = ProcName
            Rng(1, 2).Value = ProcKindString(ProcKind)
            LineNum = .ProcStartLine(ProcName, ProcKind) + _
                    .ProcCountLines(ProcName, ProcKind) + 1
            Set Rng = Rng(2, 1)
        Loop
    End With

End Sub

Function ProcKindString(ProcKind As VBIDE.vbext_ProcKind) As String
    Select Case ProcKind
        Case vbext_pk_Get
            ProcKindString = "Property Get"
        Case vbext_pk_Let
            ProcKindString = "Property Let"
        Case vbext_pk_Set
            ProcKindString = "Property Set"
        Case vbext_pk_Proc
            ProcKindString = "Sub Or Function"
        Case Else
            ProcKindString = "Unknown Type: " & CStr(ProcKind)
    End Select
End Function

Также существует бесплатный инструмент под названием «MZ-Tools». Установите его как надстройку, он нумерует ваши строки кода, генерирует стандартный код управления ошибками, проверяет неиспользуемые переменные, упорядочивает ваши функции и подпрограммы и … документирует ваш код, автоматически генерируя список ваших процедур с параметрами, комментариями и т.д …. Отличный инструмент!

Для тех, кто ищет функцию, возвращающую коллекцию строк, вот код, адаптированный из ответа guitarthrower:

'Collection of Strings of Sub names in that module
Private Function getAllProcNames(module As VBIDE.CodeModule) As Collection
    Dim lineNum As Integer
    Dim procName As String
    Dim coll As New Collection
    Dim ProcKind As VBIDE.vbext_ProcKind
    With module
        lineNum = .CountOfDeclarationLines + 1
        Do Until lineNum >= .CountOfLines
            procName = .ProcOfLine(lineNum, ProcKind)
            lineNum = .ProcStartLine(procName, ProcKind) + _
                    .ProcCountLines(procName, ProcKind) + 1
            coll.Add Item:=procName
        Loop
    End With
    Set getAllProcNames = coll
End Function

Переменная ProcKind просто выбрасывается — она ​​дает только имена.

' a bit more info for those who like me looking for help
' without Chip Pearson and many others my programming would still be at
' x=x+4

    Option Explicit
'
' to list or sort procedure names
'
'
' on a spare sheet
'
Private Sub CommandButton1_Click()

   Dim URA$, RaSort As Range, ModName$, VBC As VBComponent

   Dim RangeStartAddress$: RangeStartAddress = "H11" ' any spare region

   Set RaSort = Range(RangeStartAddress)

   ' sort and display needs 5 un-bordered columns so best done from spare worksheet

   RaSort(0, 0).Resize(UsedRange.Rows.Count, 7).Clear
   URA = UsedRange.Address                 ' tidy of used range

   ModName = [c6]

   ' from cell C4 ... or whatever is needed name is needed

   ' OR ... to do all modules ... Skipping workbook try something like
   '
   'For Each VBC In ActiveWorkbook.VBProject.VBComponents

     ' Range("G11:N" & UsedRange.Rows.Count).Clear

     ' URA = UsedRange.Address

     'Set RaSort = Range("h11")

      'If Not (VBC.Name Like "Workbook") Then

       ' SortSUBLGFUN VBC.Name, RaSort

      'End If

  ' Next VBC


   SortSUBLGFUN ModName, RaSort

End Sub
'
' in a module
'
' sort the procedure names  for a module

' Reference to VBE  ..    Microsoft Visual Basic for Applications Extensibility

' RaSort as some spare Range CurrentRegion
'
Sub SortSUBLGFUN(ComponentName$, RaSort As Range)

   Dim LineI%, PBLI&, RowI&, RowOut&, LineStr$

   Dim PLSG As vbext_ProcKind              '  0 Fun or Sub 1 Let 2 Set 3 Get
   Dim ProcName$
   Dim StartLineI&, CountLinesI&, LinesOfProc$


   With ActiveWorkbook.VBProject.VBComponents(ComponentName).CodeModule

      LineI = .CountOfDeclarationLines + 1

      While LineI < .CountOfLines
         PLSG = 0
         While PLSG < 3 And LineI < .CountOfLines ' look for all types

            On Error GoTo LookMore         ' msny may not exist

            ProcName = .ProcOfLine(LineI, PLSG)
            CountLinesI = .ProcCountLines(ProcName, PLSG)
            StartLineI = .ProcStartLine(ProcName, PLSG)

            RowOut = RowOut + 1
            RaSort(RowOut, 1) = ProcName
            RaSort(RowOut, 2) = PLSG
            RaSort(RowOut, 3) = StartLineI
            RaSort(RowOut, 4) = CountLinesI


            ' the procedure can have blanks or comment lines at the top
            ' so start line is not always the Procedure body line
            ' the  ProcBodyLine may be extended for over  about 20 lines
            ' using the  line-continuation char  " _"
            ' so it looks a bit complex to find the actual line

            PBLI = .ProcBodyLine(ProcName, PLSG)
            LineStr = .Lines(PBLI, 1)
            While Right(LineStr, 2) = " _" ' if extended get the other lines
               PBLI = PBLI + 1
               LineStr = Left(LineStr, Len(LineStr) - 2) & " " & .Lines(PBLI, 1)
            Wend

            RaSort(RowOut, 5) = LineStr

            LineI = StartLineI + CountLinesI + 1
            If LineI > .CountOfLines Then PLSG = 14 ' > 3
LookMore:

            On Error GoTo 0
            PLSG = PLSG + 1
         Wend

         LineI = LineI + 1
      Wend
      Set RaSort = RaSort.CurrentRegion
      RaSort.Sort RaSort(1, 1), xlAscending
      '
      'bring each to the top  from Z to A results in  sorted alphabetically
      '
      For RowI = RaSort.Rows.Count To 1 Step -1

         ProcName = RaSort(RowI, 1)
         PLSG = RaSort(RowI, 2)
         '
         ' since they have moved need to refind them before moving to top
         '
         CountLinesI = .ProcCountLines(ProcName, PLSG)
         StartLineI = .ProcStartLine(ProcName, PLSG)

         LinesOfProc = .Lines(StartLineI, CountLinesI)
         .DeleteLines StartLineI, CountLinesI
         .InsertLines .CountOfDeclarationLines + 1, LinesOfProc
      Next RowI
   End With


End Sub

'
' you may find the two below of interest
'
Sub TabsAscending()

   Dim I&, J&

   For I = 1 To Application.Sheets.Count

      For J = 1 To Application.Sheets.Count - 1

         If UCase$(Application.Sheets(J).Name) > UCase$(Application.Sheets(J + 1).Name) then
            Sheets(J).Move after:=Sheets(J + 1)
         End If
      Next J
   Next I
End Sub

Sub ResetCodeNames(WkWb As Workbook)

  'Changes the codename conventional name  gets rid of Sheet3 Sheet7 where they have been given a name


   Dim VarItem  As VBIDE.VBComponent

   For Each VarItem In WkWb.VBProject.VBComponents

   'Type 100 is a worksheet

   If VarItem.Type = 100 And VarItem.Name <> "ThisWorkbook" Then

       VarItem.Name = VarItem.Properties("Name").Value

    End If

 Next

End Sub

' hope it helps others

'---------------------------------------------------------------------------------------
' Procedure : IsVBProjLock
'             http://www.excel-vba.ru
' Purpose   : Функция проверки наличия защиты у VBA проекта
'             True  - вернет, если проект защищен
'             False - вернет, если проект доступен для внесения изменений
'---------------------------------------------------------------------------------------
Function IsVBProjLock(wbCheck As Workbook) As Boolean
    Dim oVBProj As Object
    Set oVBProj = wbCheck.VBProject
    If Not oVBProj Is Nothing Then
        IsVBProjLock = (oVBProj.Protection <> 0)
    End If
End Function

Sub Check_VBProjLock()
    MsgBox "VB проект книги " & IIf(IsVBProjLock(ActiveWorkbook), "закрыт", "доступен"), vbInformation
End Sub

'---------------------------------------------------------------------------------------
' Procedure : IsModuleExists
'             http://www.excel-vba.ru
' Purpose   : Функция проверки наличия нужного модуля в проекте
' Аргументы функции:
'             sModuleName - имя VBA компонента для проверки
'             objVBProj   - если указан, наличие компонента проверяется в указанном VBA проекте
'                           если не указан - в проекте активной книги
' Результат функции:
'             True        - вернет, если модуль существует
'             False       - вернет, если модуль отсутствует
'---------------------------------------------------------------------------------------
Function IsModuleExists(sModuleName As String, Optional ByVal objVBProj As Object = Nothing) As Boolean
    If objVBProj Is Nothing Then
        Set objVBProj = ActiveWorkbook.VBProject
    End If
    On Error Resume Next
    IsModuleExists = CBool(Len(objVBProj.VBComponents(sModuleName).Name))
End Function

Sub Check_VBComponentExists()
    MsgBox "Модуль 'Module1' " & IIf(IsModuleExists("Module2"), "существует", "отсутствует"), vbInformation
End Sub

'---------------------------------------------------------------------------------------
' Procedure : IsFunctionExists
'             http://www.excel-vba.ru
' Purpose   : Функция проверки наличия функции/процедуры в проекте
' Аргументы функции:
'             sProcName   - имя функции/процедуры для проверки
'             objVBProj   - если указан, наличие функции/процедуры проверяется в указанном VBA проекте
'                           если не указан - в проекте активной книги
' Результат функции:
'             Имя модуля, в котором найдена искомая процедура или функция
'---------------------------------------------------------------------------------------
Function IsFunctionExists(sProcName As String, Optional ByVal objVBProj As Object = Nothing)
    If objVBProj Is Nothing Then
        Set objVBProj = ActiveWorkbook.VBProject
    End If
    On Error Resume Next
    Dim lProcLineNum As Long, lProcKind As Long, vMdl
    'цикл по всем модулям проекта(стандартные, классы, формы, листы, книги)
    For Each vMdl In objVBProj.VBComponents
        'ProcStartLine требует в обязательном порядке указания типа процедуры
        'Всего 4 типа:
        '   vbext_pk_Proc  = 0 (Sub or Function procedure)
        '   vbext_pk_Let   = 1 (Property Let procedure)
        '   vbext_pk_Set   = 2 (Property Set procedure)
        '   vbext_pk_Get   = 3 (Property Get procedure)
        For lProcKind = 0 To 3
            'ProcStartLine - встроенная функция
            ' ищет в указанном модуле(vMdl) номер строки с именем заданной процедуры
            lProcLineNum = vMdl.CodeModule.ProcStartLine(sProcName, lProcKind)
            'если lProcLineNum не равно 0 - процедура есть в модуле
            If lProcLineNum > 0 Then
                IsFunctionExists = vMdl.Name
                Exit Function
            End If
        Next
    Next
End Function

Sub IsPocedureExists()
    Dim sFunctionName As String, sRes As String
    'имя искомой процедуры
    sFunctionName = "MessageFrom_Excel_vba_ru"
    'вызов функции для поиска
    sRes = IsFunctionExists(sFunctionName)
    If sRes <> "" Then
        MsgBox "Функция '" & sFunctionName & "' найдена в модуле: " & sRes, vbInformation
    Else
        MsgBox "Функция '" & sFunctionName & "' отсутствует", vbInformation
    End If
End Sub