Let's start with the procedure (sub or function) that is showing the "break"
and identify the code step on which the break is occurring.
Ok. Here is the Function. The variables are declared up in the
Declarations section. References are:
VBA
Access 10 Object Library
OLE Automation
DAO 3.6
Office 10 Object Library
Look in the section labeled GetQueries:. I've put an asterisk on the
line that breaks. It actually gets through about 80 or 90 queries
before it breaks.
Function EnumObjects(mPath As String)
On Error GoTo ERH
'Get name of database
mPos = InStrRev(mPath, "\")
mLen = Len(mPath) - mPos
myDb = Right(mPath, mLen)
'Open databases without password ... causes error if password
required.
Set db1 = OpenDatabase(mPath, True)
Set db2 = CurrentDb()
GoTo GetTables
GotPassword: 'Open databases with password
pWord = InputBox("Enter password.", "Need Password")
Set db1 = OpenDatabase(mPath, True, True, "MS Access;PWD=" &
pWord)
Set db2 = CurrentDb()
GetTables:
sTag = "GetTables"
myOp = "Tables"
Set tdfs = db1.TableDefs
Set rs = db2.OpenRecordset("Tables", dbOpenDynaset)
If rs.RecordCount = 0 Then
n = 0
Else
rs.MoveLast
n = rs.Fields("idx")
End If
i = 0
For i = 0 To db1.TableDefs.Count - 1
If Left(tdfs(i).Name, 4) <> "mSys" Then
With rs
.AddNew
.Fields("idx") = n + 1
.Fields("Source_Db") = myDb
.Fields("Name") = tdfs(i).Name
.Update
n = n + 1
End With
End If
Next i
rs.Close
Set rs = Nothing
Set tdfs = Nothing
i = 0
n = 0
sTag = ""
GetQueries:
On Error Resume Next
sTag = "GetQueries"
myOp = myOp & ",Queries"
Set qdfs = db1.QueryDefs
Set rs = db2.OpenRecordset("Queries", dbOpenDynaset)
If rs.RecordCount = 0 Then
n = 0
Else
rs.MoveLast
n = rs.Fields("idx")
End If
i = 0
For i = 0 To db1.QueryDefs.Count - 1
With rs
.AddNew
.Fields("idx") = n + 1
.Fields("Source_Db") = myDb
.Fields("Name") = qdfs(i).Name
If Left(UCase(qdfs(i).SQL), 3) = "SEL" Then
.Fields("Type") = "S"
End If
If Left(qdfs(i).Name, 1) = "~" Then
.Fields("Desc") = "Support query."
Else
* .Fields("Desc") = qdfs(i).Properties("Description")
End If
.Fields("SQL") = qdfs(i).SQL
.Update
n = n + 1
End With
Next i
rs.Close
Set rs = Nothing
Set qdfs = Nothing
i = 0
n = 0
sTag = ""
GetForms:
On Error GoTo ERH
sTag = "GetForms"
myOp = myOp & ",Forms"
Set rs = db2.OpenRecordset("Forms", dbOpenDynaset)
If rs.RecordCount = 0 Then
n = 0
Else
rs.MoveLast
n = rs.Fields("idx")
End If
For Each frm In db1.Containers("Forms").Documents
With rs
.AddNew
.Fields("idx") = n + 1
.Fields("Source_Db") = myDb
.Fields("Name") = frm.Name
.Update
n = n + 1
End With
Next frm
rs.Close
Set rs = Nothing
n = 0
sTag = ""
GetReports:
sTag = "GetReports"
myOp = myOp & ",Reports"
Set rs = db2.OpenRecordset("Reports", dbOpenDynaset)
If rs.RecordCount = 0 Then
n = 0
Else
rs.MoveLast
n = rs.Fields("idx")
End If
For Each rpt In db1.Containers("Reports").Documents
With rs
.AddNew
.Fields("idx") = n + 1
.Fields("Source_Db") = myDb
.Fields("Name") = rpt.Name
.Update
n = n + 1
End With
Next rpt
rs.Close
Set rs = Nothing
n = 0
sTag = ""
GetMacros:
sTag = "GetMacros"
myOp = myOp & ",Macros"
Set rs = db2.OpenRecordset("Macros", dbOpenDynaset)
If rs.RecordCount = 0 Then
n = 0
Else
rs.MoveLast
n = rs.Fields("idx")
End If
For Each mcr In db1.Containers("Scripts").Documents
With rs
.AddNew
.Fields("idx") = n + 1
.Fields("Source_Db") = myDb
.Fields("Name") = mcr.Name
.Fields("Desc") = mcr.Properties("Description").Value
.Update
n = n + 1
End With
Next mcr
rs.Close
Set rs = Nothing
n = 0
sTag = ""
GetModules:
sTag = "GetModules"
myOp = myOp & ",Modules"
Set rs = db2.OpenRecordset("Modules", dbOpenDynaset)
If rs.RecordCount = 0 Then
n = 0
Else
rs.MoveLast
n = rs.Fields("idx")
End If
For Each mMod In db1.Containers("Modules").Documents
With rs
.AddNew
.Fields("idx") = n + 1
.Fields("Source_Db") = myDb
.Fields("Name") = mMod.Name
End With
Next mMod
rs.Close
Set rs = Nothing
n = 0
sTag = ""
ExitPoint:
Set db1 = Nothing
Set db2 = Nothing
Exit Function
ERH:
' Catch password error, redirect.
If Err.Number = 3031 Then
Err.Clear
GoTo GotPassword
End If
' Catch "No record" and "Property not found" errors.
If Err.Number = 3021 Then Resume Next
If Err.Number = 3270 Then Resume Next
'Unhandled errors.
str = MyError(sTag)
Select Case str
Case "Yes"
Resume Next
Case "No"
GoTo ExitPoint
Case "Cancel"
MyRollBack
GoTo ExitPoint
Case Else
End Select
GoTo ExitPoint
End Function