Master 95 #1

home *** CD-ROM | disk | FTP | other *** search

/ Master 95 #1 / MASTER95_1.iso / microsof / vbasic4 / vb4-6.cab / relation.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1995-07-26 | 16.8 KB | 528 lines

VERSION 4.00 Begin VB.Form frmRelations BorderStyle = 3 'Fixed Dialog Caption = "Relations" ClientHeight = 4545 ClientLeft = 1080 ClientTop = 1515 ClientWidth = 8055 Height = 4950 HelpContextID = 2016087 Icon = "RELATION.frx":0000 Left = 1020 LinkTopic = "Form1" MaxButton = 0 'False MDIChild = -1 'True ScaleHeight = 4545 ScaleWidth = 8055 Top = 1170 Width = 8175 Begin VB.CommandButton cmdClose Caption = "&Close" Height = 375 Left = 5280 TabIndex = 17 Top = 4080 Width = 2175 End Begin VB.CommandButton cmdDelete Caption = "&Delete Relation" Height = 375 Left = 2880 TabIndex = 16 Top = 4080 Width = 2175 End Begin VB.CommandButton cmdAdd Caption = "&New Relation" Height = 375 Left = 480 TabIndex = 15 Top = 4080 Width = 2175 End Begin VB.PictureBox picJoinType BorderStyle = 0 'None Enabled = 0 'False Height = 855 Left = 120 ScaleHeight = 855 ScaleWidth = 7815 TabIndex = 21 TabStop = 0 'False Top = 3120 Width = 7815 Begin VB.OptionButton optJoinType Caption = "All records from foreign and only those from base where joined fields are equal." Height = 255 Index = 2 Left = 120 TabIndex = 14 Top = 560 Width = 6255 End Begin VB.OptionButton optJoinType Caption = "All records from base and only those from foreign where joined fields are equal." Height = 255 Index = 1 Left = 120 TabIndex = 13 Top = 300 Width = 6375 End Begin VB.OptionButton optJoinType Caption = "Only rows where joined fields from both tables are equal." Height = 255 Index = 0 Left = 120 TabIndex = 12 Top = 40 Width = 6255 End End Begin VB.PictureBox picProperties Appearance = 0 'Flat BorderStyle = 0 'None Enabled = 0 'False ForeColor = &H80000008& Height = 2895 Left = 2640 ScaleHeight = 2895 ScaleWidth = 5295 TabIndex = 19 TabStop = 0 'False Top = 0 Width = 5295 Begin VB.ComboBox cboBaseField Height = 300 ItemData = "RELATION.frx":030A Left = 3240 List = "RELATION.frx":0311 Style = 2 'Dropdown List TabIndex = 3 Top = 720 Width = 2055 End Begin VB.ComboBox cboForeignField Height = 300 ItemData = "RELATION.frx":0323 Left = 3240 List = "RELATION.frx":032A Style = 2 'Dropdown List TabIndex = 5 Top = 1080 Width = 2055 End Begin VB.ComboBox cboForeignTable Height = 300 Left = 840 Sorted = -1 'True Style = 2 'Dropdown List TabIndex = 4 Top = 1080 Width = 2295 End Begin VB.ComboBox cboBaseTable Height = 300 Left = 840 Sorted = -1 'True Style = 2 'Dropdown List TabIndex = 2 Top = 720 Width = 2295 End Begin VB.TextBox txtRelationName Height = 285 Left = 840 TabIndex = 1 Top = 120 Width = 4455 End Begin VB.CheckBox chkInherited Caption = "Inherited" Height = 255 Left = 120 TabIndex = 6 Top = 1560 Width = 3015 End Begin VB.CheckBox chkReferentialIntegrity Caption = "Enforce Referential Integrity" Height = 255 Left = 120 TabIndex = 7 Top = 1920 Width = 3015 End Begin VB.CheckBox chkCascadeUpdate Caption = "UpdateCascade" Enabled = 0 'False Height = 255 Left = 2760 TabIndex = 10 Top = 2280 Width = 1935 End Begin VB.CheckBox chkCascadeDelete Caption = "DeleteCascade" Enabled = 0 'False Height = 255 Left = 2760 TabIndex = 11 Top = 2640 Width = 1935 End Begin VB.OptionButton optOneToMany Caption = "One-To-Many" Enabled = 0 'False Height = 255 Left = 165 TabIndex = 9 Top = 2565 Width = 1455 End Begin VB.OptionButton optOneToOne Caption = "One-To-One" Enabled = 0 'False Height = 255 Left = 165 TabIndex = 8 Top = 2310 Width = 1455 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = "Table Name: " Height = 195 Index = 3 Left = 840 TabIndex = 26 Top = 480 Width = 960 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = " Foreign: " Height = 195 Index = 4 Left = 0 TabIndex = 25 Top = 1125 Width = 660 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = " Field Name: " Height = 195 Index = 6 Left = 3240 TabIndex = 24 Top = 480 Width = 975 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = " Base: " Height = 195 Index = 7 Left = 0 TabIndex = 23 Top = 765 Width = 495 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = " Name: " Height = 195 Index = 2 Left = 0 TabIndex = 22 Top = 165 Width = 555 End End Begin VB.ListBox lstRelations Height = 2205 Left = 120 TabIndex = 0 Top = 360 Width = 2415 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = " Join Type: " Height = 195 Index = 5 Left = 120 TabIndex = 20 Top = 2880 Width = 825 End Begin VB.Label lblLabels AutoSize = -1 'True Caption = " Relations: " Height = 195 Index = 0 Left = 120 TabIndex = 18 Top = 120 Width = 795 End Attribute VB_Name = "frmRelations" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Dim mrelFrmRel As Relation Sub cboBaseTable_Click() On Error GoTo BTErr If cboBaseTable.ItemData(cboBaseTable.ListIndex) = 0 Then 'its a table ListItemNames gdbCurrentDB.TableDefs(cboBaseTable.Text).Fields, cboBaseField, True Else 'its a querydef ListItemNames gdbCurrentDB.QueryDefs(cboBaseTable.Text).Fields, cboBaseField, True End If Exit Sub BTErr: ShowError Exit Sub End Sub Sub cboForeignTable_Click() On Error GoTo FTErr If cboForeignTable.ItemData(cboForeignTable.ListIndex) = 0 Then 'its a table ListItemNames gdbCurrentDB.TableDefs(cboForeignTable.Text).Fields, cboForeignField, True Else 'its a querydef ListItemNames gdbCurrentDB.QueryDefs(cboForeignTable.Text).Fields, cboForeignField, True End If Exit Sub FTErr: ShowError Exit Sub End Sub Sub chkReferentialIntegrity_Click() If chkReferentialIntegrity.Value = 1 Then optOneToOne.Enabled = True optOneToMany.Enabled = True chkCascadeUpdate.Enabled = True chkCascadeDelete.Enabled = True Else optOneToOne.Enabled = False optOneToMany.Enabled = False chkCascadeUpdate.Enabled = False chkCascadeDelete.Enabled = False End If End Sub Private Sub cmdAdd_Click() On Error GoTo AddErr Dim rel As Relation Dim fld As Field If cmdAdd.Caption = "&New Relation" Then 'enable the controls to add a new relation txtRelationName.Text = gsNULL_STR lstRelations.Enabled = False picProperties.Enabled = True picJoinType.Enabled = True cmdDelete.Caption = "&Don't Add Relation" cmdAdd.Caption = "&Add Relation" Me.Caption = "New Relation" txtRelationName.SetFocus Else 'add the new relation If Len(txtRelationName.Text) = 0 Or _ Len(cboBaseTable.Text) = 0 Or _ Len(cboBaseField.Text) = 0 Or _ Len(cboForeignTable.Text) = 0 Or _ Len(cboForeignField.Text) = 0 Then MsgBox "Some info was not filled in!", 48 txtRelationName.SetFocus Exit Sub End If Set rel = gdbCurrentDB.CreateRelation(txtRelationName.Text) With rel .TABLE = cboBaseTable.Text .ForeignTable = cboForeignTable.Text 'set the attributes If chkInherited.Value = 1 Then .Attributes = .Attributes Or dbRelationInherited End If If chkReferentialIntegrity.Value = 1 Then If optOneToOne.Value = True Then .Attributes = .Attributes Or dbRelationUnique End If If chkCascadeUpdate.Value = 1 Then .Attributes = .Attributes Or dbRelationUpdateCascade End If If chkCascadeDelete.Value = 1 Then .Attributes = .Attributes Or dbRelationDeleteCascade End If Else .Attributes = .Attributes Or dbRelationDontEnforce End If If optJoinType(2).Value = True Then .Attributes = .Attributes Or dbRelationRight ElseIf optJoinType(1).Value = True Then .Attributes = .Attributes Or dbRelationLeft End If End With 'add the fields Set fld = rel.CreateField(cboBaseField.Text) fld.ForeignName = cboForeignField.Text rel.Fields.Append fld 'add the relation to the database gdbCurrentDB.Relations.Append rel 'must have been successful so add it to the list lstRelations.AddItem txtRelationName.Text 'make the new one active lstRelations.ListIndex = lstRelations.NewIndex 'reset the controls lstRelations.Enabled = True picProperties.Enabled = False picJoinType.Enabled = False cmdDelete.Caption = "&Delete Relation" cmdAdd.Caption = "&New Relation" Me.Caption = "Relations" End If Exit Sub AddErr: ShowError Exit Sub End Sub Sub cmdClose_Click() Unload Me End Sub Private Sub cmdDelete_Click() On Error GoTo DELErr If cmdDelete.Caption = "&Delete Relation" Then If MsgBox("Delete '" & lstRelations.Text & "' Relation?", gnMSGBOX_TYPE) = gnMSGBOX_YES Then gdbCurrentDB.Relations.Delete lstRelations.Text lstRelations.RemoveItem lstRelations.ListIndex If lstRelations.ListCount > 0 Then lstRelations.ListIndex = 0 End If End If Else 'reset the controls lstRelations.Enabled = True picProperties.Enabled = False picJoinType.Enabled = False cmdDelete.Caption = "&Delete Relation" cmdAdd.Caption = "&New Relation" Me.Caption = "Relations" 'make the last active one active again 'this is needed on failures If lstRelations.ListCount > 0 Then lstRelations_Click End If End If Exit Sub DELErr: ShowError Exit Sub End Sub Sub Form_Load() On Error GoTo FLErr Dim i As Integer Dim tdf As TableDef Dim qdf As QueryDef Dim rln As Relation CenterMe Me, gnMDIFORM 'load tables and querydefs GetTableList cboBaseTable, True, False, True GetTableList cboForeignTable, True, False, True 'load relations ListItemNames gdbCurrentDB.Relations, lstRelations, False If lstRelations.ListCount > 0 Then lstRelations.ListIndex = 0 End If Screen.MousePointer = vbDefault Exit Sub FLErr: ShowError Exit Sub End Sub Sub lstRelations_Click() On Error GoTo LRErr Dim i As Integer Dim fld As Field Set mrelFrmRel = gdbCurrentDB.Relations(lstRelations.Text) 'set all the properties txtRelationName.Text = mrelFrmRel.Name 'clear out the lists cboBaseField.Clear cboForeignField.Clear For i = 0 To cboBaseTable.ListCount - 1 If mrelFrmRel.TABLE = cboBaseTable.List(i) Then cboBaseTable.ListIndex = i Exit For End If Next ListItemNames gdbCurrentDB.TableDefs(cboBaseTable.Text).Fields, cboBaseField, True 'set the list to the correct field For i = 0 To cboBaseField.ListCount - 1 If mrelFrmRel.Fields(0).Name = cboBaseField.List(i) Then cboBaseField.ListIndex = i Exit For End If Next For i = 0 To cboForeignTable.ListCount - 1 If mrelFrmRel.ForeignTable = cboForeignTable.List(i) Then cboForeignTable.ListIndex = i Exit For End If Next ListItemNames gdbCurrentDB.TableDefs(cboForeignTable.Text).Fields, cboForeignField, True 'set the list to the correct field For i = 0 To cboForeignField.ListCount - 1 If mrelFrmRel.Fields(0).ForeignName = cboForeignField.List(i) Then cboForeignField.ListIndex = i Exit For End If Next If (mrelFrmRel.Attributes And dbRelationInherited) = 0 Then chkInherited.Value = 0 Else chkInherited.Value = 1 End If If (mrelFrmRel.Attributes And dbRelationDontEnforce) = 0 Then chkReferentialIntegrity.Value = 1 Else chkReferentialIntegrity.Value = 0 End If If (mrelFrmRel.Attributes And dbRelationUnique) = 0 Then optOneToMany.Value = True Else optOneToOne.Value = True End If If (mrelFrmRel.Attributes And dbRelationUpdateCascade) = 0 Then chkCascadeUpdate.Value = 0 Else chkCascadeUpdate.Value = 1 End If If (mrelFrmRel.Attributes And dbRelationDeleteCascade) = 0 Then chkCascadeDelete.Value = 0 Else chkCascadeDelete.Value = 1 End If If (mrelFrmRel.Attributes And dbRelationRight) = dbRelationRight Then optJoinType(2).Value = True ElseIf (mrelFrmRel.Attributes And dbRelationLeft) = dbRelationLeft Then optJoinType(1).Value = True Else 'must be an inner join optJoinType(0).Value = True End If Exit Sub LRErr: ShowError Exit Sub End Sub Sub lstRelations_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single) If Button <> 2 Then Exit Sub If SetPropItem(lstRelations, Y) = False Then Exit Sub ShowProperties "Relation", gdbCurrentDB.Relations(lstRelations.Text) End Sub