Advertisement
CuttittaOfAllTrades

GetVBEDetails

Feb 11th, 2022
1,242
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. '---------------------------------------------------------------------------------------
  2. ' Procedure : GetVBEDetails
  3. ' OAuthor   : CARDA Consultants Inc.
  4. ' Website   : http://www.cardaconsultants.com
  5. ' Edits     : ACC
  6. ' Purpose  : Goes throught the VBE and creates a text file which give a brief listing
  7. '             of the procedures within each module and a line count for each
  8. ' Copyright : The following is release as Attribution-ShareAlike 4.0 International
  9. '             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
  10. ' Requirements: reference to the Microsoft Visual Basic for Application Extensibility
  11. '               library.
  12. '
  13. ' Revision History:
  14. ' Rev       Date(yyyy/mm/dd)        Description
  15. ' **************************************************************************************
  16. ' 1         2011-06-04              Initial Release
  17. ' 2         2017-09-15              Code tweaks thanks to comments from Rob Hoffman
  18. ' 3         2018-10-15              Updated Copyright
  19. ' 4         2022-02-11              Altered by ACC to write to a local table "_mdlVBEDetails"
  20. '---------------------------------------------------------------------------------------
  21. Public Function GetVBEDetailsCurrent(Optional ByVal strDatabasePath = "")
  22. On Error GoTo ErrHandler
  23. Dim vbProj As VBIDE.VBProject
  24. Dim vbComponent As VBIDE.vbComponent
  25. Dim vbCodeModule As VBIDE.CodeModule
  26. Dim pk As VBIDE.vbext_ProcKind
  27. Dim dbLocal As Database
  28. Dim accdbExternal As Access.Application
  29. Dim dbRemote As Database
  30. Dim rstDM As Recordset
  31. Dim strDBFile As String
  32. Dim strDBPath As String
  33. Dim strProjectName As String
  34. Dim strComponentName As String
  35. Dim strProcedureName As String
  36. Dim lngProdedureFirstLine As Long
  37. Dim strPrevProcName As String
  38. Dim strCompLineText As String
  39. Dim lngComponentLineNumber As Long
  40. Dim lngProcLineNumber As Long
  41. Dim lngDeclarationLineCount As Long
  42.  
  43.     Set dbLocal = CurrentDb
  44.     Set rstDM = dbLocal.OpenRecordset("_mdlVBEDetails")
  45.     Call Quixecute(, "DELETE DISTINCTROW [_mdlVBEDetails].* FROM _mdlVBEDetails;")
  46.    
  47.     strDBPath = DirFromPath(strDatabasePath)
  48.     strDBFile = FileNameFromPath(strDatabasePath)
  49.  
  50.     Set accdbExternal = CreateObject("Access.Application")
  51.  
  52.     With accdbExternal
  53.         .OpenCurrentDatabase strDatabasePath
  54.         .Visible = True
  55.         .UserControl = True
  56.         .OpenAccessProject strDatabasePath
  57.     End With
  58.  
  59.     'Loop through each project
  60.    For Each vbProj In accdbExternal.VBE.VBProjects
  61.         strProjectName = vbProj.Name
  62.        
  63.         'Loop through each module (component)
  64.        For Each vbComponent In vbProj.VBComponents
  65.             Set vbCodeModule = vbComponent.CodeModule
  66.            
  67.             strComponentName = vbComponent.Name
  68.             lngComponentLineNumber = 1
  69.             lngProcLineNumber = 1
  70.             lngDeclarationLineCount = vbCodeModule.CountOfDeclarationLines
  71.                        
  72.             'Loop through each line of the module
  73.            Do While lngComponentLineNumber < vbCodeModule.CountOfLines  'Loop through each procedure
  74.                strProcedureName = vbCodeModule.ProcOfLine(lngComponentLineNumber, pk)
  75.                
  76.                 If strProcedureName <> strPrevProcName And strProcedureName <> "" Then
  77.                     lngProcLineNumber = 1
  78.                     'lngProdedureFirstLine = vbCodeModule.ProcBodyLine(strProcedureName, vbext_pk_Get)
  79.                    'Debug.Print strProcedureName, lngProdedureFirstLine
  80.                End If
  81.                
  82.                 If strProcedureName <> "" Then
  83.                     strCompLineText = vbCodeModule.Lines(lngComponentLineNumber, 1)
  84.                     If Trim(strCompLineText) <> "" Then
  85.                         With rstDM
  86.                             .AddNew
  87.                             !DBPath = strDBPath
  88.                             !DBFile = strDBFile
  89.                             !ProjectName = strProjectName
  90.                             !ComponentName = strComponentName
  91.                             !ProcedureName = strProcedureName
  92.                             !ComponentLineNumber = lngComponentLineNumber
  93.                             !ProcedureLineNumber = lngProcLineNumber
  94.                             !ComponentLineText = strCompLineText
  95.                             .Update
  96.                         End With
  97.                         lngProcLineNumber = lngProcLineNumber + 1
  98.                     End If
  99.                 End If
  100.                 strPrevProcName = strProcedureName
  101.                 lngComponentLineNumber = lngComponentLineNumber + 1
  102.             Loop
  103.            
  104.         Next vbComponent
  105.     Next vbProj
  106.  
  107. ExitProcedure:
  108.     On Error Resume Next
  109.     Set dbLocal = Nothing
  110.     Set dbRemote = Nothing
  111.     Set accdbExternal = Nothing
  112.     Set rstDM = Nothing
  113.     Set vbCodeModule = Nothing
  114.     Set vbComponent = Nothing
  115.     Set vbProj = Nothing
  116. Exit Function
  117.  
  118.  
  119. ErrHandler:
  120.     Select Case Err.Number
  121.         Case Else
  122.             Call UnexpectedError(Err.Number, "GetVBEDetails: " & vbNewLine & vbNewLine & Err.Description, Err.Source, Err.HelpFile, Err.HelpContext)
  123.             Resume ExitProcedure
  124.             Resume
  125.     End Select
  126.  
  127. End Function
Advertisement
RAW Paste Data Copied
Advertisement