GetVBEDetails

'---------------------------------------------------------------------------------------
' Procedure : GetVBEDetails
' OAuthor   : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Edits     : ACC
' Purpose  : Goes throught the VBE and creates a text file which give a brief listing
'             of the procedures within each module and a line count for each
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Requirements: reference to the Microsoft Visual Basic for Application Extensibility
'               library.
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2011-06-04              Initial Release
' 2         2017-09-15              Code tweaks thanks to comments from Rob Hoffman
' 3         2018-10-15              Updated Copyright
' 4         2022-02-11              Altered by ACC to write to a local table "_mdlVBEDetails"
'---------------------------------------------------------------------------------------
Public Function GetVBEDetailsCurrent(Optional ByVal strDatabasePath = "")
On Error GoTo ErrHandler
Dim vbProj As VBIDE.VBProject
Dim vbComponent As VBIDE.vbComponent
Dim vbCodeModule As VBIDE.CodeModule
Dim pk As VBIDE.vbext_ProcKind
Dim dbLocal As Database
Dim accdbExternal As Access.Application
Dim dbRemote As Database
Dim rstDM As Recordset
Dim strDBFile As String
Dim strDBPath As String
Dim strProjectName As String
Dim strComponentName As String
Dim strProcedureName As String
Dim lngProdedureFirstLine As Long
Dim strPrevProcName As String
Dim strCompLineText As String
Dim lngComponentLineNumber As Long
Dim lngProcLineNumber As Long
Dim lngDeclarationLineCount As Long

    Set dbLocal = CurrentDb
    Set rstDM = dbLocal.OpenRecordset("_mdlVBEDetails")
    Call Quixecute(, "DELETE DISTINCTROW [_mdlVBEDetails].* FROM _mdlVBEDetails;")

    strDBPath = DirFromPath(strDatabasePath)
    strDBFile = FileNameFromPath(strDatabasePath)

    Set accdbExternal = CreateObject("Access.Application")

    With accdbExternal
        .OpenCurrentDatabase strDatabasePath
        .Visible = True
        .UserControl = True
        .OpenAccessProject strDatabasePath
    End With

    'Loop through each project
    For Each vbProj In accdbExternal.VBE.VBProjects
        strProjectName = vbProj.Name

        'Loop through each module (component)
        For Each vbComponent In vbProj.VBComponents
            Set vbCodeModule = vbComponent.CodeModule

            strComponentName = vbComponent.Name
            lngComponentLineNumber = 1
            lngProcLineNumber = 1
            lngDeclarationLineCount = vbCodeModule.CountOfDeclarationLines

            'Loop through each line of the module
            Do While lngComponentLineNumber < vbCodeModule.CountOfLines  'Loop through each procedure
                strProcedureName = vbCodeModule.ProcOfLine(lngComponentLineNumber, pk)

                If strProcedureName <> strPrevProcName And strProcedureName <> "" Then
                    lngProcLineNumber = 1
                    'lngProdedureFirstLine = vbCodeModule.ProcBodyLine(strProcedureName, vbext_pk_Get)
                    'Debug.Print strProcedureName, lngProdedureFirstLine
                End If

                If strProcedureName <> "" Then
                    strCompLineText = vbCodeModule.Lines(lngComponentLineNumber, 1)
                    If Trim(strCompLineText) <> "" Then
                        With rstDM
                            .AddNew
                            !DBPath = strDBPath
                            !DBFile = strDBFile
                            !ProjectName = strProjectName
                            !ComponentName = strComponentName
                            !ProcedureName = strProcedureName
                            !ComponentLineNumber = lngComponentLineNumber
                            !ProcedureLineNumber = lngProcLineNumber
                            !ComponentLineText = strCompLineText
                            .Update
                        End With
                        lngProcLineNumber = lngProcLineNumber + 1
                    End If
                End If
                strPrevProcName = strProcedureName
                lngComponentLineNumber = lngComponentLineNumber + 1
            Loop

        Next vbComponent
    Next vbProj

ExitProcedure:
    On Error Resume Next
    Set dbLocal = Nothing
    Set dbRemote = Nothing
    Set accdbExternal = Nothing
    Set rstDM = Nothing
    Set vbCodeModule = Nothing
    Set vbComponent = Nothing
    Set vbProj = Nothing
Exit Function


ErrHandler:
    Select Case Err.Number
        Case Else
            Call UnexpectedError(Err.Number, "GetVBEDetails: " & vbNewLine & vbNewLine & Err.Description, Err.Source, Err.HelpFile, Err.HelpContext)
            Resume ExitProcedure
            Resume
    End Select

End Function