Error 3251 using ADO & VBA to drop a table!
- From: Darizotas <dario.borreguero@xxxxxxxxxx(donotspam)>
- Date: Wed, 5 Jul 2006 23:58:02 -0700
Hello,
I have a MDE file that contains its own model and I am trying to link their
tables to a MDB file. I am trying to do this using ADO 2.8.
The method that I am following is to traverse ADOX.Tables Collection of the
MDE data model and replacing each one with the corresponding table at the MDB
file. But after replacing several tables I found the runtime error 3251 -
OPERATION IS NOT SUPPORTED FOR THIS TYPE OF OBJECT.
This error arises after the following algorithm:
For each table in Tables (from my Catalog)
1. Create a Link (lnk)
2. Tables.Append lnk
3. Catch the error: -2147217857 (Element already exists)
3.1 Remove the table: Tables.Delete table.name
3.2 Catch the error: -2147467259 (Table is involved in a relationship)
3.2.1 Then, I delete all relations that contains as foreign key and when
I ask for the Collection ADOX.Keys it throws the mentioned error. GoTo Step
3.1
Next table
I don't understand why this error happens after replacing several tables
from my model. Can someone tell me if there is something wrong on my
algorithm? Or ADO has any problems with collections??I have also read that
ADO is not prepared to deal with not enforced relationships, is this related
with my problem??
Thanks in advance,
Dario.
PS. Here it is the piece of code that performs the linking. I hope this helps.
Option Explicit
Public Function LinkDataBase(newOrigin As String, force As Boolean) As Boolean
Dim newCat As New ADOX.Catalog
Dim tbl As ADOX.table
'Return value.
LinkDataBase = False
On Error GoTo LinkDataBase_Err
newCat.ActiveConnection = "Provider='Microsoft.Jet.OLEDB.4.0';Data
Source=" & newOrigin
For Each tbl In newCat.Tables
'For each table.
If tbl.Type = "TABLE" Then
If Not LinkTable(newOrigin, tbl.name, force) Then
GoTo LinkDataBase_Exit
End If
End If
Next
LinkDataBase = True
LinkDataBase_Exit:
Set tbl = Nothing
Set newCat = Nothing
Exit Function
LinkDataBase_Err:
'Origin does not exist. Err.Number = '-2147467259'
MiscUtils.ShowError Err.Description
Resume LinkDataBase_Exit
End Function
Public Function LinkTable(origin As String, tbl As String, _
Optional force As Boolean = False) As Boolean
Dim cat As New ADOX.Catalog, tblLink As ADOX.table
On Error GoTo LinkTable_Err
cat.ActiveConnection = CurrentProject.Connection
Set tblLink = CreateLink(cat, origin, tbl)
LinkTable_Exe:
cat.Tables.Append tblLink
LinkTable = True
LinkTable_Exit:
Set cat = Nothing
Set tblLink = Nothing
Exit Function
LinkTable_Err:
'Origin element does not exist.
If Err.Number = -2147217860 Then
MiscUtils.ShowError "Table " & tbl & " does not exist in the origin: " & _
vbCrLf & origin
'Element already exists in the current database.
ElseIf Err.Number = -2147217857 Then
If force Then
RemoveTable tbl, True
Resume LinkTable_Exe
End If
Else
MiscUtils.ShowError Err.Number & " - " & Err.Description
End If
LinkTable = False
Resume LinkTable_Exit
End Function
Private Function CreateLink(catDB As ADOX.Catalog, ByVal origin As String, _
ByVal name As String) As ADOX.table
Dim tblLink As New ADOX.table
With tblLink
.name = name
Set .parentCatalog = catDB
.Properties("Jet OLEDB:Create Link") = True
.Properties("Jet OLEDB:Link Datasource") = origin
.Properties("Jet OLEDB:Remote Table Name") = .name
End With
Set CreateLink = tblLink
Set tblLink = Nothing
End Function
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/odeopg/html/deovrcreatingrelationshipsintegrityconstraints.asp
Public Function RemoveTable(ByVal tbl As String, _
Optional force As Boolean = False) As Boolean
Dim cat As New ADOX.Catalog
On Error GoTo RemoveTable_Err
cat.ActiveConnection = CurrentProject.Connection
RemoveTable_Exe:
cat.Tables.Delete tbl
RemoveTable = True
RemoveTable_Exit:
Set cat = Nothing
Exit Function
RemoveTable_Err:
'Nothing to delete, it does not exist in the current model.
If Err.Number = 3265 Then
Resume RemoveTable_Exit
'It is involved in some relationship.
ElseIf Err.Number = -2147467259 Then
If force Then
RemoveRelationships cat, tbl
Resume RemoveTable_Exe
End If
Else
MiscUtils.ShowError Err.Number & " - " & Err.Description
End If
RemoveTable = False
Resume RemoveTable_Exit
End Function
Private Sub RemoveRelationships(cat As ADOX.Catalog, foreignTbl As String)
Dim tbl As ADOX.table
On Error GoTo RemoveRelationships_Err
For Each tbl In cat.Tables
If tbl.Type = "TABLE" Then
If tbl.name <> foreignTbl Then
RemoveRelation tbl, foreignTbl
End If
End If
Next
RemoveRelationships_Exit:
Set tbl = Nothing
Exit Sub
RemoveRelationships_Err:
MiscUtils.ShowError Err.Number & " - " & Err.Description
End Sub
Private Sub RemoveRelation(tbl As ADOX.table, foreignTbl As String)
If foreignTbl = "" Then
Exit Sub
End If
Dim i As Integer
Dim key As ADOX.key, keys As New Collection
On Error GoTo RemoveRelation_Err
For Each key In tbl.keys 'Here starts the problem!! the object keys seems
to disappear
If key.RelatedTable = foreignTbl Then
keys.Add key.name, key.name
End If
Next
Dim kName As Variant
For Each kName In keys
tbl.keys.Delete kName
Next
RemoveRelation_Exit:
Set key = Nothing
Set keys = Nothing
Exit Sub
RemoveRelation_Err:
MiscUtils.ShowError Err.Number & " - " & Err.Description
Resume RemoveRelation_Exit
End Sub
.
- Follow-Ups:
- Re: Error 3251 using ADO & VBA to drop a table!
- From: Bob Barrows [MVP]
- Re: Error 3251 using ADO & VBA to drop a table!
- Prev by Date: Re: Getting a cell value in a DataGridView
- Next by Date: Re: Error 3251 using ADO & VBA to drop a table!
- Previous by thread: Getting a cell value in a DataGridView
- Next by thread: Re: Error 3251 using ADO & VBA to drop a table!
- Index(es):
Relevant Pages
|
|
