I am trying to establish a one to many relationship between tblCompany 1

[polnichek]

I am using the following code to establish a relationship between tblCompany and MainTable. tblCompany is on the "One" side with a primary key called Comp_Id and MainTable is on the "many" side and has fk_Comp_Id as its linking field. When I run this code I get the error message "User defined type not defined". This is my first attempt using the ADOX model so any help would be appreciated.


Private Sub Command1_Click()



Dim tbl As ADOX.Table
Dim fk As ADOX.Key

Dim cat As ADOX.Catalog
Set cat = New ADOX.Catalog

cat.ActiveConnection = CurrentProject.Connection


Set tbl = cat.Tables("tblCompany")


Set fk = New ADOX.Key


With fk
.Name = "Comp_Id"
.Type = adKeyForeign
.RelatedTable = "MainTable"
.Columns.Append "fk_Comp_Id"
.Columns("fk_Comp_Id").RelatedColumn = "fk_Comp_Id"
End With

tbl.Keys.Append fk

Set cat = Nothing
Set tbl = Nothing
Set fk = Nothing


End Sub

 

[polnichek]

Update to previous post:

I discovered a missing library by opening a code module and selecting references from the Tools menu. I clicked on the reference "ADO Ext.2.x for DDL and Security..." This resolved my initial problem (I hope!) and I no longer get the error message "User defined type not defined" but instead I get the the error message "Run Time Error...Index already Exists" with the compiler stopping at the following line:

tbl.Keys.Append fk


Once again any suggestions or help would be greatly appreciated.

Polnichek

 

[Zion7]

you can't receate an index, a table or a control,
or a constraint, or a field etc...

It appears your index has already been created, probably
right after you made your reference, and ran your code.

...you can't run it again, without an error handler.

Private Sub Command1_Click()

On Error GoTo xxx

Dim tbl As ADOX.Table
Dim fk As ADOX.Key

Dim cat As ADOX.Catalog
Set cat = New ADOX.Catalog

cat.ActiveConnection = CurrentProject.Connection


Set tbl = cat.Tables("tblCompany")


Set fk = New ADOX.Key


With fk
.Name = "Comp_Id"
.Type = adKeyForeign
.RelatedTable = "MainTable"
.Columns.Append "fk_Comp_Id"
.Columns("fk_Comp_Id").RelatedColumn = "fk_Comp_Id"
End With

tbl.Keys.Append fk

xx:
Set cat = Nothing
Set tbl = Nothing
Set fk = Nothing
Exit Sub
xxx:
If err <> -214007291 Then 'object already exists
MsgBox err & vbcrlf & Error$
End If
Resume xx


End Sub

I KNOW MY ERR NUMBER IS WRONG, FIX IT

 

[polnichek]

Thank you Zion for posting this hint. I will give this a try and see if I can get it to work.

Polnichek

Polnichek

 

[polnichek]

I tried Zion's fix of adding the error handler to my code but I still do not get the desired result. I am able to keep the prgram from crashing but I wind up in and endless loop of error messages (the error handlers msg box statements). Perhaps I should give a full account of what I am attempting to do. I have two databases, the first one has the current year data, at the end of the fiscal year I export the data to a second database which serves as an archive. This process involves the export of two tables using the Transfer Database method, and the tables are called tblCompany, and MainTable. The data in the archive must be available for review and the occasional update so I have re-establish the relationship programmatically. Both tables have primary keys with the primary key of tblCompany serving as the foreign key in MainTable. Is there an easier way of archiving a current fiscal year?

Any suggestions would be greatly appreciated.

Polnichek

Polnichek

 

[Zion7]

Polnichek, why is the code not achieving your objective?
Outside of the error loop, are you creating as relationship?

The error loop, is coming from the Set statements.
When it tries to exit(xx), one of the clean-up
Set ... = Nothing statements are causing an endless error. It shouldn't though?
What err message keeps recurring?

 

[polnichek]

Thank you again for replying Zion your help is greatly appreciated! I ran my old code once again to find the error handler number to replace the one you said I had to fix. I tried your error handler again but in a new form and the error messages disappeared. The problem now is it does not appear to be creating the relationship between the two tables. I am new to using recordsets so I do not understand the concept fully. I was hoping that it would establish the relationships in the same manner as if you used the drag method in the Relationships window and then I would be able to use microsoft access QBE queries. Is it actually establishing the relationships but it just does not show up when you use the query design view? Will it only work with embedded SQL?

I hope this is clear, and if there is an easier way to do this archiving stuff I would love to hear it.
The code I am using is as follows (same as before but with the midfications you suggested:

Private Sub Command0_Click()

On Error GoTo xxx

Dim tbl As ADOX.Table
Dim fk As ADOX.Key

Dim cat As ADOX.Catalog
Set cat = New ADOX.Catalog

cat.ActiveConnection = CurrentProject.Connection


Set tbl = cat.Tables("tblCompany")


Set fk = New ADOX.Key


With fk
.Name = "Comp_Id"
.Type = adKeyForeign
.RelatedTable = "MainTable"
.Columns.Append "fk_Comp_Id"
.Columns("fk_Comp_Id").RelatedColumn = "fk_Comp_Id"
End With

tbl.Keys.Append fk

xx:
Set cat = Nothing
Set tbl = Nothing
Set fk = Nothing
Exit Sub
xxx:
If Err <> -2147467259 Then 'object already exists
MsgBox Err & vbCrLf & Error$
End If
Resume xx

Polnichek

 

[Zion7]

Possibly, you need to refresh the relationship window.
there's an icon called "Show All Relationships".
All relationships, don't always show unless you click that icon.

Also, as an aside, from the query pane, you can create exclusive relationships, by dragging & dropping as from
the relationships window. these relationships, will only
remain within the query, you creatre it with.

outside of that, at a quick glance, your code looks fine
at a quick glance?

 

[polnichek]

I tried the Show all relationships and it does not show any unfortunately. I can make your Query suggestion work so I may go that way and just base all of my reports on the query's, since being an archived database the records will be Read Only therefore Referential Integrity will ot be as big an issue. Another idea I had was to create a temp table, rename the archived table to "MainTableTemp" and since the name of the table is known in advance I can run an append query using a previously created query into an existing set of tables with an established relationship. I still do not know why I can't get the code to establish the relationship programmatically. Thanks for all your help and if you have any insights as to why this did not work I would love to hear it since it is still my preferred method to solve my archiving issue.

Polnichek

 

[Zion7]

Is it possible, that you have a relationship between
2 other tables, with the same name, "Comp_Id"?

Maybe try this, to find out (even it was created or not)?


Sub ADOXRelationships()
Dim cat As New ADOX.Catalog
Dim idx As ADOX.Index, tbl As ADOX.Table
Set cat.ActiveConnection = CurrentProject.Connection

For Each tbl In cat.Tables
Debug.Print tbl.Name & ", " & tbl.Type
If tbl.Type = "TABLE" Then
For Each idx In tbl.Indexes
Debug.Print idx.Name '& ", " & idx.
Next idx
End If
Next

Set cat = Nothing
Set tbl = Nothing
Set idx = Nothing
End Sub

 

[polnichek]

Thank you Zion I will try that and let you know how it works.

Polnichek

 

[polnichek]

Thank you for sending that very useful bit of code that displays the relationships in the immediate window. I tested the application using your code and I had the following results:

Before link code is run:

2004_2005Company, TABLE
CompanyName
PrimaryKey
Comp_Id
2004_2005MainTable, TABLE
MainTable, TABLE
MSysAccessObjects, ACCESS TABLE
MSysAccessXML, ACCESS TABLE
MSysACEs, SYSTEM TABLE
MSysObjects, SYSTEM TABLE
MSysQueries, SYSTEM TABLE
MSysRelationships, SYSTEM TABLE
Switchboard Items, TABLE
PrimaryKey
tblCompany, TABLE
CompanyName
PrimaryKey
Comp_Id


After Link code is run:

2004_2005Company, TABLE
CompanyName
PrimaryKey
Comp_Id
2004_2005MainTable, TABLE
MainTable, TABLE
MSysAccessObjects, ACCESS TABLE
MSysAccessXML, ACCESS TABLE
MSysACEs, SYSTEM TABLE
MSysObjects, SYSTEM TABLE
MSysQueries, SYSTEM TABLE
MSysRelationships, SYSTEM TABLE
Switchboard Items, TABLE
PrimaryKey
tblCompany, TABLE
CompanyName
PrimaryKey
Comp_Id

I tested your code in another unrelated database to see what the results would be if there was an established relationship and of course the word "Link" is displayed on the same line as the field that participates in the relationship. So judging from the results that I posted here I would say the relationship is not being established and there are no previously established relationships between the two tables. I am wondering about the libraries, I only turned one library on to get the ADOX object declaration past the compiler (ADO Ext.2.x for DDL and Security...) is there another library I should have turned on beside this one?

Polnichek

 

[Zion7]

No need to check libraries, your code wouldn't compile,
if you were missing one!

It appears, you already have an index "Comp_Id".

That's your problem.

Change the nasme of your relationship,
something more meaningfull, that denotes both tables.

...
With fk
.Name = "tblCompanytblMain"
.Type = adKeyForeign
.RelatedTable = "MainTable"
...

 

[polnichek]

Thank you Zion! It finally works! You were right there was a problem with the name of the relationship, I had misunderstood this part of the code, I had thought it should be a table name for some reason. There was also a foreign key/primary key mixup too. The odd part is I expected the Relationships window to update and show the new relationship after you click on "Show All" but it still does not. When you go to build a query in design view it does show the relationship when you add the tables into the QBE window. This poses another problem for me since if I build the query ahead of time it does not update to show the relationship when I run the code. This is not really a problem since I can use embedded SQL inside VBA instead. The following is the code that worked:

On Error GoTo xxx

Dim tbl As ADOX.Table
Dim fk As ADOX.Key

Dim cat As ADOX.Catalog
Set cat = New ADOX.Catalog

cat.ActiveConnection = CurrentProject.Connection


Set tbl = cat.Tables("tblOneSide")


Set fk = New ADOX.Key


With fk
.Name = "tblCompanytblMain"
.Type = adKeyForeign
.RelatedTable = "tblManySide"
.Columns.Append "Comp_Id"
.Columns("Comp_Id").RelatedColumn = "Comp_Id"
End With

tbl.Keys.Append fk

xx:
Set cat = Nothing
Set tbl = Nothing
Set fk = Nothing
Exit Sub
xxx:
If Err <> -2147467259 Then 'object already exists
MsgBox Err & vbCrLf & Error$
End If
Resume xx


End Sub


Thanks again for all of your help.

Polnichek