' Copyright 2008 ESRI
'
' All rights reserved under the copyright laws of the United States
' and applicable international laws, treaties, and conventions.
'
' You may freely redistribute and use this sample code, with or
' without modification, provided you include the original copyright
' notice and use restrictions.
'
' See use restrictions at <your ArcGIS install location>/developerkit/userestrictions.txt.
'
Option Explicit
Public m_GxApp As IGxApplication
Private Sub UpdateRefenceGrid()
On Error GoTo ErrHand:
Dim sDomName As String, pEnumData As IEnumDataset, pDataset As IDataset
Dim pGxDatabase As IGxDatabase2, pFeatureClassContainer2 As IFeatureClassContainer
Dim pDataset2 As IDataset, pEnumDataset2 As IEnumDataset, pApp As IApplication
11: Me.MousePointer = vbHourglass
'Clear the reference grid
14: grdReferences.Rows = 1
'Get the domain name
17: sDomName = cmbDomains.List(cmbDomains.ListIndex)
'Loop through the datasets in the database
20: Set pApp = m_GxApp
21: Set pGxDatabase = m_GxApp.SelectedObject
22: Set pEnumData = pGxDatabase.Workspace.Datasets(esriDTAny)
23: pEnumData.Reset
24: Set pDataset = pEnumData.Next
25: Do While Not pDataset Is Nothing
26: If TypeOf pDataset Is IFeatureDataset Then
27: Set pFeatureClassContainer2 = pDataset
28: Set pEnumDataset2 = pFeatureClassContainer2.Classes
29: Set pDataset2 = pEnumDataset2.Next
30: Do Until pDataset2 Is Nothing
31: If TypeOf pDataset2 Is esriGeoDatabase.IObjectClass Then
32: pApp.StatusBar.Message(0) = "Checking " & pDataset2.Name & " . . . "
33: FindDomainRefs pDataset2, sDomName
34: End If
35: Set pDataset2 = pEnumDataset2.Next
36: Loop
37: Else
38: If TypeOf pDataset Is esriGeoDatabase.IObjectClass Then
39: pApp.StatusBar.Message(0) = "Checking " & pDataset.Name & " . . . "
40: FindDomainRefs pDataset, sDomName
41: End If
42: End If
44: Set pDataset = pEnumData.Next
45: Loop
47: grdReferences.Enabled = True
48: pApp.StatusBar.Message(0) = "Finished checking for domain references"
49: Me.MousePointer = vbNormal
Exit Sub
ErrHand:
53: Me.MousePointer = vbNormal
54: MsgBox "UpdateRefenceGrid - " & Erl & " - " & Err.Description
End Sub
Private Sub FindDomainRefs(pDataset As IDataset, sDomName As String)
On Error GoTo ErrHand:
Dim pFields As IFields, pField As IField, lLoop As Long
Dim pObjClass As IObjectClass, pSubs As ISubtypes, pEnumSubs As IEnumSubtype
Dim lSubCode As Long, sSubName As String, pDomain As IDomain
63: Set pObjClass = pDataset
'Begin by checking the fields for domain references
66: Set pFields = pObjClass.Fields
67: For lLoop = 0 To pFields.FieldCount - 1
68: Set pField = pFields.Field(lLoop)
69: If Not pField.Domain Is Nothing Then
70: If pField.Domain.Name = sDomName Then
71: grdReferences.AddItem pDataset.Name & vbTab & "<none>" & vbTab & pField.Name
72: End If
73: End If
74: Next lLoop
'Now check each subtype for the domain
77: Set pSubs = pObjClass
78: If pSubs.HasSubtype Then
79: Set pEnumSubs = pSubs.Subtypes
80: pEnumSubs.Reset
81: sSubName = pEnumSubs.Next(lSubCode)
82: Do Until sSubName = ""
83: For lLoop = 0 To pFields.FieldCount - 1
84: Set pField = pFields.Field(lLoop)
85: Set pDomain = pSubs.Domain(lSubCode, pField.Name)
86: If Not pDomain Is Nothing Then
87: If pDomain.Name = sDomName Then
88: grdReferences.AddItem pDataset.Name & vbTab & sSubName & vbTab & pField.Name
89: End If
90: End If
91: Next lLoop
93: sSubName = pEnumSubs.Next(lSubCode)
94: Loop
95: End If
Exit Sub
ErrHand:
99: Me.MousePointer = vbNormal
100: MsgBox "FindDomainRefs - " & Erl & " - " & Err.Description
End Sub
Private Sub cmbDomains_Click()
104: UpdateRefenceGrid
End Sub
Private Sub cmdAll_Click()
On Error GoTo ErrHand:
Dim lLoop As Long, pResp As VbMsgBoxResult
111: pResp = MsgBox("The selected references to the domain will be permanently removed." & vbCrLf & _
"Are you sure you want to continue??", vbOKCancel, "Remove reference to domain?")
If pResp = vbCancel Then Exit Sub
115: For lLoop = 1 To grdReferences.Rows - 1
116: RemoveReference lLoop
117: Next lLoop
'Reset the grid
120: UpdateRefenceGrid
Exit Sub
ErrHand:
124: MsgBox "cmdAll_Click - " & Erl & " - " & Err.Description
End Sub
Private Sub RemoveReference(lRow As Long)
On Error GoTo ErrHand:
Dim s1 As String, s2 As String, s3 As String
Dim pGxDatabase As IGxDatabase2, pFeatWork As IFeatureWorkspace
Dim pFClass As IFeatureClass, pFields As IFields, lIndex As Long, pFEdit As IFieldEdit
Dim pSubs As ISubtypes, lCode As Long, pEnumSubs As IEnumSubtype, sSub As String
'Get the parameters for the row
135: grdReferences.Row = lRow
136: grdReferences.Col = 0
137: s1 = grdReferences.Text
138: grdReferences.Col = 1
139: s2 = grdReferences.Text
140: grdReferences.Col = 2
141: s3 = grdReferences.Text
'Get the workspace and open the feature class
144: Set pGxDatabase = m_GxApp.SelectedObject
If Not TypeOf pGxDatabase.Workspace Is IFeatureWorkspace Then Exit Sub
147: Set pFeatWork = pGxDatabase.Workspace
148: Set pFClass = pFeatWork.OpenFeatureClass(s1)
149: If pFClass Is Nothing Then
150: MsgBox "Did you find feature class - " & s1
Exit Sub
152: End If
'Make sure we can find the field
155: Set pFields = pFClass.Fields
156: lIndex = pFields.FindField(s3)
157: If lIndex < 0 Then
158: MsgBox "Could not find field - " & s3
Exit Sub
160: End If
'Check for a Subtype and then remove the reference
163: If s2 = "<none>" Then
164: Set pFEdit = pFields.Field(lIndex)
165: Set pFEdit.Domain = Nothing
166: Else
167: Set pSubs = pFClass
'find the subtype code
169: Set pEnumSubs = pSubs.Subtypes
170: pEnumSubs.Reset
171: sSub = pEnumSubs.Next(lCode)
172: Do Until sSub = ""
173: If sSub = s2 Then Exit Do
175: sSub = pEnumSubs.Next(lCode)
176: Loop
178: If sSub <> "" Then
179: Set pSubs.Domain(lCode, s3) = Nothing
180: Else
181: MsgBox "Did not find subtype - " & s2
182: End If
183: End If
Exit Sub
ErrHand:
187: MsgBox "RemoveReference - " & Erl & " - " & Err.Description
End Sub
Private Sub cmdDismiss_Click()
191: Set m_GxApp = Nothing
193: Unload Me
End Sub
Private Sub cmdSelected_Click()
On Error GoTo ErrHand:
Dim lStart As Long, lEnd As Long, lLoop As Long
Dim s1 As String, s2 As String, s3 As String, pResp As VbMsgBoxResult
201: pResp = MsgBox("The selected references to the domain will be permanently removed." & vbCrLf & _
"Are you sure you want to continue??", vbOKCancel, "Remove reference to domain?")
If pResp = vbCancel Then Exit Sub
205: If grdReferences.Row > grdReferences.RowSel Then
206: lStart = grdReferences.RowSel
207: lEnd = grdReferences.Row
208: Else
209: lStart = grdReferences.Row
210: lEnd = grdReferences.RowSel
211: End If
213: For lLoop = lStart To lEnd
214: RemoveReference lLoop
215: Next lLoop
'Update the reference grid
218: UpdateRefenceGrid
Exit Sub
ErrHand:
222: MsgBox "cmdSelected_Click - " & Erl & " - " & Err.Description
End Sub
Private Sub Form_Load()
On Error GoTo ErrHand:
227: grdReferences.ColWidth(0) = 2200
228: grdReferences.ColWidth(1) = 2200
229: grdReferences.ColWidth(2) = 2200
230: grdReferences.Row = 0
231: grdReferences.Col = 0
232: grdReferences.Text = "Object Class"
233: grdReferences.Col = 1
234: grdReferences.Text = "Subtype"
235: grdReferences.Col = 2
236: grdReferences.Text = "Field"
' grdReferences.AddItem "Object Class" & vbTab & "Subtype" & vbTab & "Field"
'Populate the combo box with the domains for the selected database.
Dim pGxDatabase As IGxDatabase2, pWorkspaceDoms As IWorkspaceDomains
Dim pEnumDoms As IEnumDomain, pDom As IDomain
242: Set pGxDatabase = m_GxApp.SelectedObject
243: Set pWorkspaceDoms = pGxDatabase.Workspace
244: Set pEnumDoms = pWorkspaceDoms.Domains
245: pEnumDoms.Reset
246: Set pDom = pEnumDoms.Next
247: cmbDomains.Clear
248: Do While Not pDom Is Nothing
249: cmbDomains.AddItem pDom.Name
251: Set pDom = pEnumDoms.Next
252: Loop
' If cmbDomains.ListCount > 0 Then
' cmbDomains.ListIndex = 0
' End If
Exit Sub
ErrHand:
260: MsgBox "frmDomainFinder_Load - " & Erl & " - " & Err.Description
End Sub
Private Sub Form_Terminate()
264: Set m_GxApp = Nothing
End Sub
Private Sub Form_Unload(Cancel As Integer)
268: Set m_GxApp = Nothing
End Sub