📄 frmcreaterelation.frm
字号:
VERSION 5.00
Begin VB.Form frmCreateRelation
Caption = "Create Relation"
ClientHeight = 4800
ClientLeft = 1590
ClientTop = 2265
ClientWidth = 6705
ControlBox = 0 'False
LinkTopic = "Form1"
ScaleHeight = 4800
ScaleWidth = 6705
Begin VB.CommandButton cmd
Cancel = -1 'True
Caption = "Cancel"
Height = 465
Index = 1
Left = 5310
TabIndex = 18
Top = 4140
Width = 1185
End
Begin VB.CommandButton cmd
Caption = "OK"
Default = -1 'True
Height = 465
Index = 0
Left = 3870
TabIndex = 17
Top = 4140
Width = 1185
End
Begin VB.CheckBox chkRef
Caption = "Cascade Updates"
Height = 375
Index = 0
Left = 2700
TabIndex = 15
Top = 3240
Width = 1635
End
Begin VB.Frame fraRelation
Caption = "Relation"
Height = 2895
Left = 180
TabIndex = 4
Top = 990
Width = 6315
Begin VB.OptionButton optOneTo
Caption = "Many"
Height = 375
Index = 1
Left = 1260
TabIndex = 14
Top = 2250
Width = 1005
End
Begin VB.OptionButton optOneTo
Caption = "One"
Height = 375
Index = 0
Left = 180
TabIndex = 13
Top = 2250
Width = 915
End
Begin VB.CheckBox chkRef
Caption = "Cascade Deletes"
Height = 375
Index = 1
Left = 4320
TabIndex = 16
Top = 2250
Width = 1815
End
Begin VB.ComboBox cboForeignName
Height = 315
Left = 2520
Style = 2 'Dropdown List
TabIndex = 10
Top = 1260
Width = 2085
End
Begin VB.ComboBox cboFieldName
Height = 315
Left = 180
Style = 2 'Dropdown List
TabIndex = 8
Top = 1260
Width = 2085
End
Begin VB.TextBox txtRelationName
Height = 315
Left = 180
TabIndex = 6
Top = 540
Width = 2085
End
Begin VB.Line Line2
X1 = 2520
X2 = 6120
Y1 = 2160
Y2 = 2160
End
Begin VB.Label lblReferentialIntegrity
Caption = "Referential Integrity"
Height = 285
Left = 2520
TabIndex = 12
Top = 1890
Width = 3525
End
Begin VB.Line Line1
X1 = 180
X2 = 2250
Y1 = 2160
Y2 = 2160
End
Begin VB.Label lblOneTo
Caption = "One To:"
Height = 285
Left = 180
TabIndex = 11
Top = 1890
Width = 2085
End
Begin VB.Label lblForeignName
Caption = "Foreign Name"
Height = 285
Left = 2520
TabIndex = 9
Top = 990
Width = 1995
End
Begin VB.Label lblFieldName
Caption = "Field Name"
Height = 285
Left = 180
TabIndex = 7
Top = 990
Width = 2085
End
Begin VB.Label lblRelationName
Caption = "Relation Name"
Height = 285
Left = 180
TabIndex = 5
Top = 270
Width = 2085
End
End
Begin VB.ComboBox cboForeignTableDefName
Height = 315
Left = 2700
Style = 2 'Dropdown List
TabIndex = 3
Top = 450
Width = 2265
End
Begin VB.ComboBox cboTableDefName
Height = 315
Left = 180
Style = 2 'Dropdown List
TabIndex = 1
Top = 450
Width = 2265
End
Begin VB.Label lblForeignTableDefName
Caption = "Foreign Table"
Height = 285
Left = 2700
TabIndex = 2
Top = 180
Width = 2265
End
Begin VB.Label lblTableDefName
Caption = "Table"
Height = 285
Left = 180
TabIndex = 0
Top = 180
Width = 2175
End
End
Attribute VB_Name = "frmCreateRelation"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' database
Private mdb As Database
' table
Private mstrTableDefName As String
' foreign table
Private mstrForeignTableDefName As String
' relation name
Private mstrRelationName As String
' field name
Private mstrFieldName As String
' foreign name
Private mstrForeignName As String
' control array constants
Private Const optOneToOne = 0
Private Const optOneToMany = 1
Private Const chkRefCascadeUpdates = 0
Private Const chkRefCascadeDeletes = 1
Private Const cmdOK = 0
Private Const cmdCancel = 1
' Public Properties
Public Property Set Database(db As DAO.Database)
' set database object and setup form
' assign the database object
Set mdb = db
' populate the table combo boxes
GetTables cboTableDefName
GetTables cboForeignTableDefName
End Property
' Private Procedures
Private Sub EnableOK()
' to create a relation, you need the following
' a table name
' a foreign table name
' a relation name
' a field name
' a foreign name for the field
' additionally, CreateRelation will fail if the
' field data types do not match correctly
If mstrTableDefName = "" Or _
mstrForeignTableDefName = "" Or _
mstrRelationName = "" Or _
mstrFieldName = "" Or _
mstrForeignName = "" Then
cmd(cmdOK).Enabled = False
Else
cmd(cmdOK).Enabled = True
End If
End Sub
Private Sub EnableRelation()
' enable/disable the relation frame
If _
mstrTableDefName = "" Or _
mstrForeignTableDefName = "" _
Then
fraRelation.Enabled = False
Else
fraRelation.Enabled = True
End If
End Sub
Private Sub GetTables(cbo As ComboBox)
' fill the table list combo
Dim td As TableDef
With cbo
' clear what (if anything) is there
.Clear
For Each td In mdb.TableDefs
' check for system table
If (td.Attributes And dbSystemObject) = 0 Then
' not a system table, add it
.AddItem td.Name
End If
Next ' TableDef
End With
End Sub
Private Sub GetFields(cbo As ComboBox, strTableDefName As String)
' fill the field list combo
Dim fld As Field
With cbo
' clear it
.Clear
For Each fld In mdb.TableDefs(strTableDefName).Fields
' add it
.AddItem fld.Name
Next ' Field
End With
End Sub
Private Sub CreateRelation()
' create the relation
' called only from cmd(cmdOK) click event
Dim rel As Relation
Dim fld As Field
Dim lngAttributes As Long
' setup attributes
If optOneTo(optOneToOne) Then
lngAttributes = dbRelationUnique
End If
If chkRef(chkRefCascadeUpdates) Then
lngAttributes = lngAttributes Or dbRelationUpdateCascade
End If
If chkRef(chkRefCascadeDeletes) Then
lngAttributes = lngAttributes Or dbRelationDeleteCascade
End If
' create the relation
Set rel = mdb.CreateRelation( _
mstrRelationName, _
mstrTableDefName, _
mstrForeignTableDefName, _
lngAttributes)
Set fld = rel.CreateField(mstrFieldName)
' set the foreign name
fld.ForeignName = mstrForeignName
' append the field to the relation
rel.Fields.Append fld
' append the relation to the database
mdb.Relations.Append rel
End Sub
' Event Procedures
Private Sub Form_Load()
On Error GoTo ProcError
' disable the relations frame
fraRelation.Enabled = False
' disable the OK button
cmd(cmdOK).Enabled = False
ProcExit:
Exit Sub
ProcError:
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
Resume ProcExit
End Sub
Private Sub cmd_Click(Index As Integer)
' create the relation or unload
On Error GoTo ProcError
Screen.MousePointer = vbHourglass
Select Case Index
Case cmdOK
' create relation and unload
CreateRelation
Unload Me
Case cmdCancel
' just unload
Unload Me
End Select
ProcExit:
Screen.MousePointer = vbDefault
Exit Sub
ProcError:
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
Resume ProcExit
End Sub
Private Sub cboTableDefName_Click()
On Error GoTo ProcError
Screen.MousePointer = vbHourglass
mstrTableDefName = cboTableDefName.Text
If mstrTableDefName <> "" Then
GetFields cboFieldName, mstrTableDefName
End If
EnableOK
EnableRelation
ProcExit:
Screen.MousePointer = vbDefault
Exit Sub
ProcError:
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
Resume ProcExit
End Sub
Private Sub cboForeignTableDefName_Click()
On Error GoTo ProcError
Screen.MousePointer = vbHourglass
mstrForeignTableDefName = cboForeignTableDefName.Text
If mstrForeignTableDefName <> "" Then
GetFields cboForeignName, mstrForeignTableDefName
End If
EnableOK
EnableRelation
ProcExit:
Screen.MousePointer = vbDefault
Exit Sub
ProcError:
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
Resume ProcExit
End Sub
Private Sub cboFieldName_Click()
On Error GoTo ProcError
mstrFieldName = cboFieldName.Text
EnableOK
ProcExit:
Exit Sub
ProcError:
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
Resume ProcExit
End Sub
Private Sub cboForeignName_Click()
On Error GoTo ProcError
mstrForeignName = cboForeignName.Text
EnableOK
ProcExit:
Exit Sub
ProcError:
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
Resume ProcExit
End Sub
Private Sub txtRelationName_Change()
On Error GoTo ProcError
mstrRelationName = txtRelationName
EnableOK
ProcExit:
Exit Sub
ProcError:
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
Resume ProcExit
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -