使用VBA在Access中自动创建表关系

Question

我正在尝试使用VBA自动创建数据库中的所有关系。

我已经成功找到了可以创建单个关系并通过CSV循环连接所有单个关系的代码。我遇到的问题是表中的一个字段需要链接到两个外部字段时。我看到我可以手动执行此操作，但是在定位对象中第二个关系的链接位置时遇到了麻烦。

awk -vstart_line=3 -vbuffer=2 'NR>=start_line && NR<=start_line+buffer' file

它将成功地循环通过一个字段到一个外部字段的任何关系，但是如果需要将同一字段链接到同一表中的第二个字段，则会失败。

Answer 1

这是最终为我工作的功能。可能不是最好的错误处理，但它确实成功创建了我在原始帖子中使用sub时所需的所有关系。

Public Function AddRelationship(strRelCount As String, strTable As String, strFTable As String, strField As String, strFField As String, Optional intAttribute As DAO.RelationAttributeEnum = 2)

    On Error GoTo ErrHandler

    Dim db As Database
    Dim Rel As DAO.Relation
    Dim errorCount

    Set db = CurrentDb
    Set Rel = db.CreateRelation(strField, strTable, strFTable, dbRelationDontEnforce)

    With Rel
        .Fields.Append .CreateField(strField)
        .Fields(strField).ForeignName = strFField
        .Attributes = intAttribute
        .Name = Trim(strRelCount + Left(strTable + strField + strFTable + strFField, 43))


    End With

    db.Relations.Append Rel

    Exit Function

ErrHandler:

    On Error GoTo NextError
    errorCount = 1

    strTable = strTable + "_" + Str(errorCount)

    Set db = CurrentDb
    Set Rel = db.CreateRelation(strField, strTable, strFTable, dbRelationDontEnforce)

    With Rel
        .Fields.Append .CreateField(strField)
        .Fields(strField).ForeignName = strFField
        .Attributes = intAttribute
        .Name = Trim(strRelCount + Left(strTable + strField + strFTable + strFField, 43))

    End With

    db.Relations.Append Rel

    Exit Function

NextError:
    errorCount = 2

    On Error GoTo FinalError

    strTable = strTable + "_" + Str(errorCount)

    Set db = CurrentDb
    Set Rel = db.CreateRelation(strField, strTable, strFTable, dbRelationDontEnforce)

    With Rel
        .Fields.Append .CreateField(strField)
        .Fields(strField).ForeignName = strFField
        .Attributes = intAttribute
        .Name = Trim(strRelCount + Left(strTable + strField + strFTable + strFField, 43))

    End With

    db.Relations.Append Rel

    Exit Function

FinalError:

    MsgBox Err.Description + " " + strTable + " " + strField + " " + strFTable + " " + strFField


End Function