No objections. But snip out all the non relevant portions. Just give
us the open, looping and write/put statements.
OK, I will, unfortunately, the writes aren't concentrated, they're
spread all over the code. Right now, on my test DB, this generates
5,900 lines of output and the slowdown seems to happen right at the
end - in the last 100 lines.
I'd also appreciate suggestions on how I could have done this code
better.
Option Compare Database
Option Explicit
Dim intLineCounter As Integer
Sub MapDAO()
Dim intNestLvl As Long
intNestLvl = 0
intLineCounter = 0
Debug.Print "Hello Mike. Today is " & Now()
Open "VBA_Trace.txt" For Output As #1
prStr intNestLvl, "Report date " & Now()
prStr intNestLvl, "Enumerate DBEngine:" & DBEngine.Version()
ListDbeProperties intNestLvl, "DBEngine", DBEngine
MapErrors intNestLvl, DBEngine
MapWorkspaces intNestLvl, DBEngine
Close 1
Debug.Print "End Run. " & intLineCounter & " lines output."
End Sub
Sub MapErrors(ByVal intNestLvl As Long, _
ByVal dbe As DAO.DBEngine)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of Errors: " & dbe.Errors.Count()
Dim ctr As Integer
ctr = 0
Dim err As DAO.Error
intNestLvl = intNestLvl + 1
For Each err In dbe.Errors
ctr = ctr + 1
prStr intNestLvl, "Error " & ctr & ": " & err.Description()
prStr intNestLvl + 1, "ErrorNumber: " & err.Number()
prStr intNestLvl + 1, "Errorsource: " & err.Source()
Next err
End Sub
Sub MapWorkspaces(ByVal intNestLvl As Long, _
ByVal dbe As DAO.DBEngine)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of Workspaces: " & _
DBEngine.Workspaces.Count()
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim wkspc As DAO.Workspace
For Each wkspc In dbe.Workspaces
ctr = ctr + 1
prStr intNestLvl, "Workspace " & ctr & ": " & wkspc.name
ListWkspcProperties intNestLvl, wkspc.name(), wkspc
MapDatabases intNestLvl, wkspc
MapGroups intNestLvl, wkspc
MapUsers intNestLvl, wkspc
Next wkspc
End Sub
Sub MapDatabases(ByVal intNestLvl As Long, _
ByVal wkspc As DAO.Workspace)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of Databases in " & wkspc.name() & _
": " & _
wkspc.Databases.Count()
Dim ctr As Integer
ctr = 0
Dim entity As DAO.Database
Dim FullPath As String
Dim DBName As String
Dim CurrentPath As String
intNestLvl = intNestLvl + 1
For Each entity In wkspc.Databases
ctr = ctr + 1
prStr intNestLvl, "Database " & ctr & ": " & entity.name()
FullPath = entity.name
DBName = Mid(FullPath, InStrRev(FullPath, "\", ,
vbBinaryCompare) + 1)
CurrentPath = Left$(FullPath, InStrRev(FullPath, "\", _
, vbBinaryCompare) - 1)
prStr intNestLvl + 1, "DBName: " & DBName
prStr intNestLvl + 1, "CurrentPath: " & CurrentPath
ListDbProperties intNestLvl, DBName, entity
MapContainers intNestLvl, DBName, entity
MapQueryDefs intNestLvl, DBName, entity
MapRecordSets intNestLvl, DBName, entity
MapRelations intNestLvl, DBName, entity
MapTableDefs intNestLvl, DBName, entity
Next entity
End Sub
Sub MapContainers(ByVal intNestLvl As Long, _
ByVal DBName As String, _
ByVal db As DAO.Database)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of Containers in " & DBName & _
": " & _
db.Containers.Count()
Dim ctr As Integer
ctr = 0
Dim entity As DAO.Container
intNestLvl = intNestLvl + 1
For Each entity In db.Containers
ctr = ctr + 1
prStr intNestLvl, "Container " & ctr & ": " & entity.name()
ListContainerProperties intNestLvl, entity.name(), entity
MapDocuments intNestLvl, entity.name(), entity
Next entity
End Sub
Sub MapDocuments(ByVal intNestLvl As Long, _
ByVal name As String, _
ByVal cntnr As DAO.Container)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of Documents in " & name & _
": " & _
cntnr.Documents.Count()
Dim ctr As Integer
ctr = 0
Dim entity As DAO.Document
intNestLvl = intNestLvl + 1
For Each entity In cntnr.Documents
ctr = ctr + 1
prStr intNestLvl, "Document " & ctr & ": " & entity.name()
ListDocumentProperties intNestLvl, entity.name(), entity
Next entity
End Sub
Sub MapQueryDefs(ByVal intNestLvl As Long, _
ByVal DBName As String, _
ByVal db As DAO.Database)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of QueryDefs in " & DBName & _
": " & _
db.QueryDefs.Count()
Dim ctr As Integer
ctr = 0
Dim entity As DAO.QueryDef
intNestLvl = intNestLvl + 1
For Each entity In db.QueryDefs
ctr = ctr + 1
prStr intNestLvl, "QueryDef " & ctr & ": " & entity.name()
ListQueryDefProperties intNestLvl, entity.name(), entity
MapQDFields intNestLvl, entity.name(), entity
Next entity
End Sub
Sub MapQDFields(ByVal intNestLvl As Long, _
ByVal QDName As String, _
ByVal qdf As DAO.QueryDef)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of QD Fields in " & QDName & _
": " & _
qdf.Fields.Count()
Dim ctr As Integer
ctr = 0
Dim entity As DAO.Field
intNestLvl = intNestLvl + 1
For Each entity In qdf.Fields
ctr = ctr + 1
prStr intNestLvl, "QueryDef " & ctr & ": " & entity.name()
ListQDFieldProperties intNestLvl, entity.name(), entity
Next entity
End Sub
Sub MapRecordSets(ByVal intNestLvl As Long, _
ByVal DBName As String, _
ByVal db As DAO.Database)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of RecordSets in " & DBName & _
": " & _
db.Recordsets.Count()
Dim ctr As Integer
ctr = 0
Dim entity As DAO.Recordset
intNestLvl = intNestLvl + 1
For Each entity In db.Recordsets
ctr = ctr + 1
prStr intNestLvl, "RecordDef " & ctr & ": " & entity.name()
ListRecordSetProperties intNestLvl, entity.name(), entity
Next entity
End Sub
Sub MapRelations(ByVal intNestLvl As Long, _
ByVal DBName As String, _
ByVal db As DAO.Database)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of Relations in " & DBName & _
": " & _
db.Relations.Count()
Dim ctr As Integer
ctr = 0
Dim entity As DAO.Relation
intNestLvl = intNestLvl + 1
For Each entity In db.Relations
ctr = ctr + 1
prStr intNestLvl, "Relation " & ctr & ": " & entity.name()
ListRelationProperties intNestLvl, entity.name(), entity
Next entity
End Sub
Sub MapTableDefs(ByVal intNestLvl As Long, _
ByVal DBName As String, _
ByVal db As DAO.Database)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of TableDefs in " & DBName & _
": " & _
db.TableDefs.Count()
Dim ctr As Integer
ctr = 0
Dim entity As DAO.TableDef
intNestLvl = intNestLvl + 1
For Each entity In db.TableDefs
ctr = ctr + 1
prStr intNestLvl, "Relation " & ctr & ": " & entity.name()
ListTableDefProperties intNestLvl, entity.name(), entity
Next entity
End Sub
Sub MapGroups(ByVal intNestLvl As Long, _
ByVal wkspc As DAO.Workspace)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of Groups in " & wkspc.name() & _
": " & _
wkspc.Groups.Count()
Dim ctr As Integer
ctr = 0
Dim entity As DAO.Group
intNestLvl = intNestLvl + 1
For Each entity In wkspc.Groups
ctr = ctr + 1
prStr intNestLvl, "Group " & ctr & ": " & entity.name()
ListGrpProperties intNestLvl, entity.name(), entity
Next entity
End Sub
Sub MapUsers(ByVal intNestLvl As Long, _
ByVal wkspc As DAO.Workspace)
intNestLvl = intNestLvl + 1
prStr intNestLvl, "Number of Users in " & wkspc.name() & _
": " & _
wkspc.Users.Count()
Dim ctr As Integer
ctr = 0
Dim entity As DAO.User
intNestLvl = intNestLvl + 1
For Each entity In wkspc.Users
ctr = ctr + 1
prStr intNestLvl, "User " & ctr & ": " & entity.name()
ListUsrProperties intNestLvl, entity.name(), entity
Next entity
End Sub
Sub ListDbeProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal dbe As DAO.DBEngine)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid DBEngine properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In dbe.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub ListWkspcProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal wkspc As DAO.Workspace)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid Workspace properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In wkspc.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub ListDbProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal entity As DAO.Database)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid Database properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In entity.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub ListContainerProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal entity As DAO.Container)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid Container properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In entity.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub ListDocumentProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal entity As DAO.Document)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid Document properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In entity.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub ListQueryDefProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal entity As DAO.QueryDef)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid QueryDef properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In entity.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub ListQDFieldProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal entity As DAO.Field)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid QDField properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In entity.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub ListRecordSetProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal entity As DAO.Recordset)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid RecordSet properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In entity.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub ListRelationProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal entity As DAO.Relation)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid Relation properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In entity.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub ListTableDefProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal entity As DAO.TableDef)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid TableDef properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In entity.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub ListGrpProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal entity As DAO.Group)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid Group properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In entity.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub ListUsrProperties(ByVal intNestLvl As Long, _
ByVal strTemp As String, _
ByVal entity As DAO.User)
intNestLvl = intNestLvl + 1
Dim ctr As Integer
ctr = 0
Dim prpLoop As DAO.Property
prStr intNestLvl, "Valid User properties in " & strTemp
intNestLvl = intNestLvl + 1
For Each prpLoop In entity.Properties
ctr = ctr + 1
On Error GoTo propertyError
prStr intNestLvl, strTemp & " property " & ctr & " " & _
prpLoop.name & " = " & prpLoop.Value
On Error GoTo 0
nextLoop:
Next prpLoop
Exit Sub
propertyError:
prStr intNestLvl, strTemp & " property " & ctr & " cannot be
listed."
Resume nextLoop
End Sub
Sub prStr(ByVal dots As Long, ByVal str As String)
intLineCounter = intLineCounter + 1
Print #1, String(dots, ".") & str
If (intLineCounter Mod 100) = 0 Then
Debug.Print "Printing line " & intLineCounter & " at " & Now()
End If
End Sub