Code Samples for Businesses, Schools & Developers

Click any image to view a larger version

Version 1.2                   Last Updated 30 Jan 2022


This article was originally published as a reply to a thread at Access World Forums

The attached database includes a procedure GetDatabaseStatistics which examines all tables, forms, reports, macros and modules in a project and produces statistics about the number of fields, controls, VBA functions, lines of code etc.

The output is sent to the VBE immediate window
For convenience, I have copied the output into Notepad in the attached screenshots:

Small database statistics

DatabaseStatsJSON
Large database statistics

DatabaseStatsSDA

The process will only take a couple of seconds for small to medium size applications.
However it may take up to a minute or so for VERY large applications (as shown above)

The results are also displayed as a message box although the layout isn't as neat as I'd like:

Database statistics message box

DatabaseStatsMsgBox



The main code used is shown below:

CODE:

Sub GetDatabaseStatistics()

'============================================
' Procedure :     GetDatabaseStatistics
' Author :           Colin Riddington, Mendip Data Systems
' Date :               11 Oct 2017
' Website :         https://isladogs.co.uk
' Purpose :         Examines all tables, forms, reports, macros and modules in a project and produces
'                            statistics about the number of fields, controls, VBA functions, lines of code etc

' Copyright :     The following may be altered and reused as you wish so long as the copyright notice is left unchanged
'                           (including Author, Website and Copyright).
'                           It may not be sold/resold or reposted on other sites (links back to this site are allowed).
'============================================


On Error GoTo Err_Handler

Dim strFilename As String
Dim Start As Long, Finish As Long, TimeTaken As Long
Dim strFileSize As String
Dim lngFileSize As Long
Dim varItem As Variant
Dim N As Long
Dim strName As String
Dim tdf As DAO.TableDef
Dim CodeLines As Long, LineNumber As Long
Dim lngF As Long, lngR As Long, lngFC As Long, lngRC As Long
Dim strH As String, strB As String

'get start time
Start = Timer

'get file size
strFilename = Application.CurrentProject.FullName
lngFileSize = FileLen(strFilename)

If lngFileSize < 1024 Then       'less than 1KB
      strFileSize = lngFileSize & " bytes"
ElseIf lngFileSize < 1024 ^ 2 Then       'less than 1MB
      strFileSize = Round((lngFileSize / 1024), 0) & " KB"
ElseIf lngFileSize < 1024 ^ 3 Then 'less than 1GB
      strFileSize = Round((lngFileSize / 1024), 0) & " KB (" & Round((lngFileSize / 1024 ^ 2), 1) & " MB)"
Else 'more than 1GB
      strFileSize = Round((lngFileSize / 1024), 0) & " KB (" & Round((lngFileSize / 1024 ^ 3), 2) & " GB)"
End If

'get header text for summary
strH = "Database summary : " & Application.CurrentProject.Name & vbCrLf
N = Len("Path : " & Application.CurrentProject.FullName)
strH = strH & String(N, "=")

'build summary body text
strB = "Path : " & Application.CurrentProject.FullName & vbCrLf
strB = strB & "File size = " & strFileSize & vbCrLf
strB = strB & "Analysis completed on : " & Now() & vbCrLf & vbCrLf

'tables
strB = strB & "Tables : " & String(28 - Len("Tables : "), " ") & _
DSum("ObjectCount", "qryDatabaseObjectCount", "Object='Table'") & vbCrLf

For Each tdf In CurrentDb.TableDefs
      lngF = lngF + tdf.Fields.count
      'lngR = lngR + tdf.RecordCount 'doesn't work on linked tables
      lngR = lngR + DCount("*", tdf.Name)
Next tdf

strB = strB & "Fields : " & String(28 - Len("Fields : "), " ") & lngF & vbCrLf
strB = strB & "Records : " & String(28 - Len("Records : "), " ") & lngR & vbCrLf & vbCrLf

'queries
strB = strB & "Queries : " & String(28 - Len("Queries : "), " ") & _
DSum("ObjectCount", "qryDatabaseObjectCount", "Object='Query'") & vbCrLf & vbCrLf

'forms
strB = strB & "Forms : " & String(28 - Len("Forms : "), " ") & _
DSum("ObjectCount", "qryDatabaseObjectCount", "Object='Form'") & vbCrLf

'form controls
For varItem = 0 To CurrentDb.Containers("Forms").Documents.count - 1
      strName = CurrentDb.Containers("Forms").Documents(varItem).Name
      DoCmd.OpenForm strName, acDesign, , , , acHidden
      lngFC = lngFC + Forms(strName).Controls.count
      DoCmd.Close acForm, strName, acSaveYes
Next varItem

strB = strB & "Form Controls : " & String(28 - Len("Form Controls : "), " ") & lngFC & vbCrLf

'form modules
N = DCount("*", "qryDatabaseObjects", "Object='Form/Report Module' And Name Like '~sq_f*'") _
      + DCount("*", "qryDatabaseObjects", "Object='Form/Report Module' And Name Like '~sq_c*'")
strB = strB & "Form Modules : " & String(28 - Len("Form Modules : "), " ") & N & vbCrLf & vbCrLf

'reports
strB = strB & "Reports : " & String(28 - Len("Reports : "), " ") & _
DSum("ObjectCount", "qryDatabaseObjectCount", "Object='Report'") & vbCrLf

For varItem = 0 To CurrentDb.Containers("Reports").Documents.count - 1
      strName = CurrentDb.Containers("Reports").Documents(varItem).Name
      DoCmd.OpenReport strName, acDesign, , , acHidden
      lngRC = lngRC + Reports(strName).Controls.count
      DoCmd.Close acReport, strName, acSaveYes
Next varItem

strB = strB & "Report Controls : " & String(28 - Len("Report Controls : "), " ") & lngRC & vbCrLf

'report modules
N = DCount("*", "qryDatabaseObjects", "Object='Form/Report Module' And Name Like '~sq_r*'") _
      + DCount("*", "qryDatabaseObjects", "Object='Form/Report Module' And Name Like '~sq_d*'")
strB = strB & "Report Modules : " & String(28 - Len("Report Modules : "), " ") & N & vbCrLf & vbCrLf

'macros
strB = strB & "Macros : " & String(28 - Len("Macros : "), " ") & DSum("ObjectCount", "qryDatabaseObjectCount", "Object='Macro'") _
      & vbCrLf & vbCrLf

'modules
strB = strB & "Modules (Standard/Class) : " & String(28 - Len("Modules (Standard/Class) : "), " ") & _
      DSum("ObjectCount", "qryDatabaseObjectCount", "Object='Module'") & vbCrLf

strB = strB & "Module Procedures : " & String(28 - Len("Module Procedures : "), " ") & CountProceduresInProject & vbCrLf
strB = strB & "Total Code Lines : " & String(28 - Len("Total Code Lines : "), " ") & TotalLinesInProject & vbCrLf & vbCrLf

'relationships
strB = strB & "Relationships : " & String(28 - Len("Relationships : "), " ") & _
      DSum("ObjectCount", "qryDatabaseObjectCount", "Object='Relationships'") & vbCrLf & vbCrLf

'calculate time taken in seconds
Finish = Timer
TimeTaken = Finish - Start

strB = strB & "Time taken : " & String(28 - Len("Time taken : "), " ") & TimeTaken & " seconds" & vbCrLf

'close message
N = Len("Path : " & Application.CurrentProject.FullName)
strB = strB & String(N, "=")

'print to immediate window
Debug.Print ""
Debug.Print strH
Debug.Print strB

'show mesaage box
MsgBox strH & vbCrLf & strB, vbInformation, "Database Statistics"

Exit_Handler:
      Exit Sub

Err_Handler:
MsgBox "Error " & Err.Number & " in GetDatabaseStatistics procedure : " & vbCrLf & _
      Err.description, vbCritical, "Program error"

      Resume Exit_Handler

End Sub




NOTE:
The code could easily be modified to save the data direct to a log text file as a further option.

To run the GetDatabaseStatistics procedure, you will need to copy all the following items to your own application.

     Table      - tblSysObjectTypes
     Queries  - qryDatabaseObjects, qryDatabaseObjectCount & (optionally) qryDatabaseObjectSummary
     Modules - modDatabaseStatistics & modVBECode

You will also need to add the VBA reference library: Microsoft Visual Basic for Applications Extensibility 5.3



Click to download:
      DatabaseStatistics       Approx 0.6 MB (zipped)





Colin Riddington             Mendip Data Systems            Last Updated 30 Jan 2022

Return to Code Samples Page Return to Top