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
Large database statistics
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
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
Download
Click to download: DatabaseStatistics Approx 0.6 MB (zipped)
Feedback
Please use the contact form below to let me know whether you found this article interesting/useful or if you have any questions/comments.
Also, do let me know if you find any bugs in the application.
Please also consider making a donation towards the costs of maintaining this website. Thank you
Colin Riddington Mendip Data Systems Last Updated 30 Jan 2022
|
Return to Code Samples Page
|
Return to Top
|