' 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
Private Const MODULE_NAME As String = "modImportExport.bas"
'==================================================================================
'-----------------
' EXPORT - DOMAIN
'-----------------
Public Function ExportDomain(ByRef pApplication As esriFramework.IApplication) As MSXML2.DOMDocument
On Error GoTo ErrorHandler
'
Dim pGxApplication As esriCatalogUI.IGxApplication
Dim pStatusBar As esriSystem.IStatusBar
'
Dim pGxObject As esriCatalog.IGxObject
Dim pGxDatabase As esriCatalog.IGxDatabase
Dim pWorkspace As esriGeoDatabase.IWorkspace
Dim pWorkspaceDomains As esriGeoDatabase.IWorkspaceDomains
Dim pEnumDomain As esriGeoDatabase.IEnumDomain
Dim pDomain As esriGeoDatabase.IDomain
Dim pRangeDomain As esriGeoDatabase.IRangeDomain
Dim pCodedValueDomain As esriGeoDatabase.ICodedValueDomain
Dim pDataset As esriGeoDatabase.IDataset
Dim pEnumDataset As esriGeoDatabase.IEnumDataset
'
Dim pDataset2 As esriGeoDatabase.IDataset
Dim pEnumDataset2 As esriGeoDatabase.IEnumDataset
Dim pFeatureClassContainer2 As esriGeoDatabase.IFeatureClassContainer
'
Dim pIndexMember As Long
Dim pDOMDocument As MSXML2.DOMDocument
'
Dim pXMLDOMNodeGeodatabaseDesigner As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeDomain As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeMember As MSXML2.IXMLDOMNode
'---------------------------------
' Set GxApplication and StatusBar
'---------------------------------
Set pGxApplication = pApplication
Set pStatusBar = pApplication.StatusBar
'-------------------------
' Get Workspace Interface
'-------------------------
Set pGxObject = pGxApplication.SelectedObject
If TypeOf pGxObject Is esriCatalog.IGxDatabase Then
Set pGxDatabase = pGxObject
Set pWorkspace = pGxDatabase.Workspace
If pWorkspace.Type = esriFileSystemWorkspace Then
MsgBox "Please select a Geodatabase", vbExclamation, App.FileDescription
Exit Function
End If
Else
MsgBox "Please select a Geodatabase", vbExclamation, App.FileDescription
Exit Function
End If
'----------------------------------
' Get new XML Document (in memory)
'----------------------------------
Set pDOMDocument = modCommon.NewXMLDocument
'------------------------
' Add header to XML file
'------------------------
Call modCommon.WriteGeodatabaseDesignerHeader(pDOMDocument, pWorkspace)
'------------------------------
' Get GeodatabaseDesigner Node
'------------------------------
Set pXMLDOMNodeGeodatabaseDesigner = pDOMDocument.getElementsByTagName("geodatabaseDesigner").nextNode
'------------------------
' Get Domains Enumerator
'------------------------
Set pWorkspaceDomains = pWorkspace
Set pEnumDomain = pWorkspaceDomains.Domains
If pEnumDomain Is Nothing Then
Set ExportDomain = pDOMDocument
Exit Function
End If
'----------------------
' Loop for each Domain
'----------------------
Set pDomain = pEnumDomain.Next
Do Until pDomain Is Nothing
'--------------------------
' Update StatusBar Message
'--------------------------
pStatusBar.Message(0) = "Exporting Domain: " & pDomain.Name
'------------------------
' Create new Domain Node
'------------------------
Set pXMLDOMNodeDomain = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "domain", "")
Set pXMLDOMNodeDomain = pXMLDOMNodeGeodatabaseDesigner.appendChild(pXMLDOMNodeDomain)
'-----------------------
' Add Domain Attributes
'-----------------------
Call modCommon.AddNodeAttribute(pXMLDOMNodeDomain, "name", pDomain.Name)
Call modCommon.AddNodeAttribute(pXMLDOMNodeDomain, "description", pDomain.Description)
Call modCommon.AddNodeAttribute(pXMLDOMNodeDomain, "owner", pDomain.Owner)
Call modCommon.AddNodeAttribute(pXMLDOMNodeDomain, "esriDomainType", CStr(pDomain.Type))
Call modCommon.AddNodeAttribute(pXMLDOMNodeDomain, "esriFieldType", CStr(pDomain.FieldType))
Call modCommon.AddNodeAttribute(pXMLDOMNodeDomain, "esriMergePolicyType", CStr(pDomain.MergePolicy))
Call modCommon.AddNodeAttribute(pXMLDOMNodeDomain, "esriSplitPolicyType", CStr(pDomain.SplitPolicy))
Select Case pDomain.Type
Case esriDTCodedValue
'----------------------------------
' Add CodedValue Domain Attributes
'----------------------------------
Set pCodedValueDomain = pDomain
For pIndexMember = 0 To pCodedValueDomain.CodeCount - 1 Step 1
Set pXMLDOMNodeMember = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "member", "")
Set pXMLDOMNodeMember = pXMLDOMNodeDomain.appendChild(pXMLDOMNodeMember)
Call modCommon.AddNodeAttribute(pXMLDOMNodeMember, "name", pCodedValueDomain.Name(pIndexMember))
Call modCommon.AddNodeAttribute(pXMLDOMNodeMember, "value", CStr(pCodedValueDomain.Value(pIndexMember)))
Next pIndexMember
Case esriDTRange
'-----------------------------
' Add Range Domain Attributes
'-----------------------------
Set pRangeDomain = pDomain
Set pXMLDOMNodeMember = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "member", "")
Set pXMLDOMNodeMember = pXMLDOMNodeDomain.appendChild(pXMLDOMNodeMember)
Call modCommon.AddNodeAttribute(pXMLDOMNodeMember, "minValue", CStr(pRangeDomain.MinValue))
Call modCommon.AddNodeAttribute(pXMLDOMNodeMember, "maxValue", CStr(pRangeDomain.MaxValue))
Case esriDTString
'--------------------------------------
' Not Supported - What is this anyway?
'--------------------------------------
End Select
Set pDomain = pEnumDomain.Next
Loop
'
If mDMExportOCAssocation Then
'-----------------------------
' Add all domain dependancies
'-----------------------------
Set pEnumDataset = pWorkspace.Datasets(esriDTAny)
Set pDataset = pEnumDataset.Next
'
Do Until pDataset Is Nothing
If TypeOf pDataset Is IFeatureDataset Then
Set pFeatureClassContainer2 = pDataset
Set pEnumDataset2 = pFeatureClassContainer2.Classes
Set pDataset2 = pEnumDataset2.Next
Do Until pDataset2 Is Nothing
If TypeOf pDataset2 Is esriGeoDatabase.IObjectClass Then
pStatusBar.Message(0) = "Exporting Domain Assocations From: " & pDataset2.Name
Call ExportObjectClassAssociation(pDOMDocument, pDataset2)
End If
Set pDataset2 = pEnumDataset2.Next
Loop
Else
If TypeOf pDataset Is esriGeoDatabase.IObjectClass Then
pStatusBar.Message(0) = "Exporting Domain Assocations From: " & pDataset.Name
Call ExportObjectClassAssociation(pDOMDocument, pDataset)
End If
End If
Set pDataset = pEnumDataset.Next
Loop
Else
'---------------------------
' Dependancies not exported
'---------------------------
End If
'-----------------
' Clear StatusBar
'-----------------
pStatusBar.Message(0) = ""
'------------------
' Save XML to file
'------------------
Set ExportDomain = pDOMDocument
'
Exit Function
ErrorHandler:
Call HandleError(False, "ExportDomain " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Private Sub ExportObjectClassAssociation(ByRef pDOMDocument As MSXML2.DOMDocument, _
ByRef pObjectClass As esriGeoDatabase.IObjectClass)
On Error GoTo ErrorHandler
'
Dim pDataset As esriGeoDatabase.IDataset
Dim pSubtypes As esriGeoDatabase.ISubtypes
Dim pSQLSyntax As esriGeoDatabase.ISQLSyntax
Dim pDomain As esriGeoDatabase.IDomain
Dim pEnumSubtype As esriGeoDatabase.IEnumSubtype
Dim pFields As esriGeoDatabase.IFields
Dim pField As esriGeoDatabase.IField
Dim pDatabaseName As String
Dim pOwnerName As String
Dim pTableName As String
Dim pSubtypeName As String
Dim pSubtypeCode As Long
Dim pIndexField As Long
'-------------------------------------------
' Interate throught each subtytpe and field
'-------------------------------------------
Set pDataset = pObjectClass
Set pSQLSyntax = pDataset.Workspace
Set pSubtypes = pObjectClass
Set pFields = pObjectClass.Fields
'
Call pSQLSyntax.ParseTableName(CStr(pDataset.Name), pDatabaseName, pOwnerName, pTableName)
'
If pSubtypes.HasSubtype Then
'-----------------------------
' ObjectClasses with Subtypes
'-----------------------------
Set pEnumSubtype = pSubtypes.Subtypes
pSubtypeName = pEnumSubtype.Next(pSubtypeCode)
Do Until pSubtypeName = ""
For pIndexField = 0 To pFields.FieldCount - 1 Step 1
Set pField = pFields.Field(pIndexField)
Set pDomain = pSubtypes.Domain(pSubtypeCode, pField.Name)
If pDomain Is Nothing Then
'--------------------------
' This field has no Domain
'--------------------------
Else
Call ExportObjectClassAssociationNode(pDOMDocument, pDatabaseName, pOwnerName, pTableName, pSubtypeName, pField.Name, pDomain.Name)
End If
Next pIndexField
pSubtypeName = pEnumSubtype.Next(pSubtypeCode)
Loop
Else
'--------------------------------
' ObjectClasses without Subtypes
'--------------------------------
For pIndexField = 0 To pFields.FieldCount - 1 Step 1
Set pField = pFields.Field(pIndexField)
Set pDomain = pField.Domain
If pDomain Is Nothing Then
'---------------------
' Field has no domain
'---------------------
Else
Call ExportObjectClassAssociationNode(pDOMDocument, pDatabaseName, pOwnerName, pTableName, "", pField.Name, pDomain.Name)
End If
Next pIndexField
End If
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ExportObjectClassAssociation " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ExportObjectClassAssociationNode(ByRef pDOMDocument As MSXML2.DOMDocument, _
ByRef pDatabaseName As String, _
ByRef pOwnerName As String, _
ByRef pTableName As String, _
ByRef pSubtypeName As String, _
ByRef pFieldName As String, _
ByRef pDomainName As String)
On Error GoTo ErrorHandler
'
Dim pXMLDOMNodeGeodatabaseDesigner As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeDomain As MSXML2.IXMLDOMNode
'
Dim pXMLDOMNode As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeParent As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeList As MSXML2.IXMLDOMNodeList
'----------------------------
' Get Domain Collection Node
'----------------------------
Set pXMLDOMNodeGeodatabaseDesigner = pDOMDocument.getElementsByTagName("geodatabaseDesigner").nextNode
'--------------------------------------------
' Get Domain Node from DomainCollection Node
' <domain name="" ...>
'--------------------------------------------
Set pXMLDOMNodeDomain = pXMLDOMNodeGeodatabaseDesigner.selectNodes("domain[@name='" & pDomainName & "']").nextNode
'------------------------------------------------
' Get Child FeatureClass
' <domain name="" ...>
' <objectClass database="" owner="" table="">
'-------------------------------------------------
Set pXMLDOMNodeList = pXMLDOMNodeDomain.selectNodes("objectClass[@database='" & pDatabaseName & "'" & _
" and @owner='" & pOwnerName & "'" & _
" and @table='" & pTableName & "']")
If pXMLDOMNodeList.length = 0 Then
'--------------
' Add New Node
'--------------
Set pXMLDOMNode = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "objectClass", "")
Set pXMLDOMNode = pXMLDOMNodeDomain.appendChild(pXMLDOMNode)
'
Call modCommon.AddNodeAttribute(pXMLDOMNode, "database", pDatabaseName)
Call modCommon.AddNodeAttribute(pXMLDOMNode, "owner", pOwnerName)
Call modCommon.AddNodeAttribute(pXMLDOMNode, "table", pTableName)
'
Set pXMLDOMNodeParent = pXMLDOMNode
Else
Set pXMLDOMNodeParent = pXMLDOMNodeList.nextNode
End If
'------------------------------------------------
' Get Child Subtype
' <domain name="" ...>
' <objectClass database="" owner="" table="">
' <subtype name="">
'------------------------------------------------
Set pXMLDOMNodeList = pXMLDOMNodeParent.selectNodes("subtype[@name='" & pSubtypeName & "']")
If pXMLDOMNodeList.length = 0 Then
'--------------
' Add New Node
'--------------
Set pXMLDOMNode = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "subtype", "")
Set pXMLDOMNode = pXMLDOMNodeParent.appendChild(pXMLDOMNode)
'
Call modCommon.AddNodeAttribute(pXMLDOMNode, "name", pSubtypeName)
'
Set pXMLDOMNodeParent = pXMLDOMNode
Else
Set pXMLDOMNodeParent = pXMLDOMNodeList.nextNode
End If
'------------------------------------------------
' Get Child Field
' <domain name="" ...>
' <objectClass database="" owner="" table="">
' <subtype name="">
' <field name="">
'------------------------------------------------
'--------------
' Add New Node
'--------------
Set pXMLDOMNode = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "field", "")
Set pXMLDOMNode = pXMLDOMNodeParent.appendChild(pXMLDOMNode)
'
Call modCommon.AddNodeAttribute(pXMLDOMNode, "name", pFieldName)
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ExportObjectClassAssociationNode " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
'==================================================================================
'--------------------
' ObjectClass Import
'--------------------
Public Sub ImportGDB(ByRef pApplication As esriFramework.IApplication)
On Error GoTo ErrorHandler
'
Dim pGxApplication As esriCatalogUI.IGxApplication
Dim pStatusBar As esriSystem.IStatusBar
Dim pMouseCursor As esriFramework.IMouseCursor
'
Dim pDOMDocument As MSXML2.DOMDocument
Dim pXMLDOMNodeGeodatabaseDesigner As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeListDataset As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeDataset As MSXML2.IXMLDOMNode
'
Dim pGxObject As esriCatalog.IGxObject
Dim pGxDatabase As esriCatalog.IGxDatabase
Dim pWorkspace As esriGeoDatabase.IWorkspace
'
Dim pIndex As Long
'---------------------------------
' Set GxApplication and StatusBar
'---------------------------------
Set pGxApplication = pApplication
Set pStatusBar = pApplication.StatusBar
'-------------------------
' Get Workspace Interface
'-------------------------
Set pGxObject = pGxApplication.SelectedObject
If TypeOf pGxObject Is esriCatalog.IGxDatabase Then
Set pGxDatabase = pGxObject
Set pWorkspace = pGxDatabase.Workspace
If pWorkspace.Type = esriFileSystemWorkspace Then
MsgBox "Please select a Geodatabase", vbExclamation, App.FileDescription
Exit Sub
End If
Else
MsgBox "Please select a Geodatabase", vbExclamation, App.FileDescription
Exit Sub
End If
'----------------------------------------------
' Prompt for and open the source XML document.
'----------------------------------------------
Set pDOMDocument = modCommon.GetXMLDocument
If pDOMDocument Is Nothing Then
Exit Sub
End If
'---------------------
' Change Mouse Cursor
'---------------------
Set pMouseCursor = New esriFramework.MouseCursor
Call pMouseCursor.SetCursor(2)
'-----------------------------------------------
' Get GeodatabaseDesigner Node and Dataset list
'-----------------------------------------------
Set pXMLDOMNodeGeodatabaseDesigner = pDOMDocument.getElementsByTagName("geodatabaseDesigner").nextNode
Set pXMLDOMNodeListDataset = pXMLDOMNodeGeodatabaseDesigner.childNodes
'-------------------------------------------------------
' Launch procedure for each type of dataset encountered
'-------------------------------------------------------
For pIndex = 0 To pXMLDOMNodeListDataset.length - 1 Step 1
Set pXMLDOMNodeDataset = pXMLDOMNodeListDataset.Item(pIndex)
Select Case UCase(pXMLDOMNodeDataset.baseName)
Case "METADATA"
'------------
' Do Nothing
'------------
Case "FEATUREDATASET"
'----------------------------------------
' Create FeatureDataset and sub-datasets
'----------------------------------------
Call ImportGDB_FeatureDataset(pXMLDOMNodeDataset, pWorkspace, pStatusBar)
Case "OBJECTCLASS"
'---------------------------
' Create Table/FeatureClass
'---------------------------
pStatusBar.Message(0) = "Import ObjectClass: Creating " & pXMLDOMNodeDataset.Attributes.getNamedItem("table").Text
Call ImportGDB_ObjectClass(pXMLDOMNodeDataset, Nothing, pWorkspace)
Case Else
'------------
' Do Nothing
'------------
End Select
Next pIndex
'-----------------
' Clear StatusBar
'-----------------
pStatusBar.Message(0) = ""
'--------------------------------------
' Refresh ArcCatalog Table of Contents
'--------------------------------------
Call pGxApplication.Refresh(pGxApplication.SelectedObject.FullName)
'---------------------
' Restore MouseCursor
'---------------------
Set pMouseCursor = Nothing
'
Set pWorkspace = Nothing
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ImportGDB " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ImportGDB_FeatureDataset(ByRef pXMLDOMNodeFeatureDataset As MSXML2.IXMLDOMNode, _
ByRef pWorkspace As esriGeoDatabase.IWorkspace, _
ByRef pStatusBar As esriSystem.IStatusBar)
On Error GoTo ErrorHandler
'----------------------------------------
' <featureDataset name="">
'----------------------------------------
Dim pXMLDOMNodeSpatialReference As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeObjectClass As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeObjectClassList As MSXML2.IXMLDOMNodeList
'
Dim pFeatureWorkspace As esriGeoDatabase.IFeatureWorkspace
Dim pFeatureDataset As esriGeoDatabase.IFeatureDataset
Dim pSpatialReference As esriGeometry.ISpatialReference
Dim pIndex As Long
'----------------------
' Get SpatialReference
'----------------------
Set pXMLDOMNodeSpatialReference = pXMLDOMNodeFeatureDataset.selectNodes("spatialReference").nextNode
Set pSpatialReference = ImportGDB_SpatialReference(pXMLDOMNodeSpatialReference)
'-----------------------
' Create FeatureDataset
'-----------------------
Set pFeatureWorkspace = pWorkspace
Set pFeatureDataset = pFeatureWorkspace.CreateFeatureDataset(pXMLDOMNodeFeatureDataset.Attributes.getNamedItem("table").Text, pSpatialReference)
'----------------------------------
' Create Underlying FeatureClasses
'----------------------------------
Set pXMLDOMNodeObjectClassList = pXMLDOMNodeFeatureDataset.selectNodes("objectClass")
For pIndex = 0 To pXMLDOMNodeObjectClassList.length - 1 Step 1
Set pXMLDOMNodeObjectClass = pXMLDOMNodeObjectClassList.Item(pIndex)
pStatusBar.Message(0) = "Import ObjectClass: Creating " & pXMLDOMNodeObjectClass.Attributes.getNamedItem("table").Text
Call ImportGDB_ObjectClass(pXMLDOMNodeObjectClass, pFeatureDataset, pWorkspace)
Next pIndex
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ImportGDB_FeatureDataset " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ImportGDB_ObjectClass(ByRef pXMLDOMNodeObjectClass As MSXML2.IXMLDOMNode, _
ByRef pFeatureDataset As esriGeoDatabase.IFeatureDataset, _
ByRef pWorkspace As esriGeoDatabase.IWorkspace)
On Error GoTo ErrorHandler
'----------------------------------------
' <objectClass database="" owner="" table=""
' aliasName=""
' esriDatasetType=""
' esriFeatureType=""
' oidField=""
' shapeField=""
' subtypeField=""
' defaultSubtypeCode=""
' modelName=""
' configKeyword="">
'----------------------------------------
Dim pXMLDOMNodeFeatureClassExtension As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeIndexList As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeIndex As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeFieldList As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeField As MSXML2.IXMLDOMNode
'
Dim pFeatureWorkspace As esriGeoDatabase.IFeatureWorkspace
Dim pFields As esriGeoDatabase.IFields
Dim pFeatureClass As esriGeoDatabase.IFeatureClass
Dim pTable As esriGeoDatabase.ITable
Dim pObjectClass As esriGeoDatabase.IObjectClass
Dim pClassSchemaEdit As esriGeoDatabase.IClassSchemaEdit
Dim pAnnoClassAdmin As esriCarto.IAnnoClassAdmin
Dim pDimensionClassExtension As esriCarto.IDimensionClassExtension
Dim pIndex As esriGeoDatabase.IIndex
Dim pIndexEdit As esriGeoDatabase.IIndexEdit
Dim pFieldsEdit As esriGeoDatabase.IFieldsEdit
Dim pField As esriGeoDatabase.IField
'
Dim pName As String
Dim pAliasName As String
Dim pEsriFeatureType As Long
Dim pEsriDatasetType As Long
Dim pShapeFieldName As String
Dim pSubtypeFieldName As String
Dim pDefaultSubtypeCode As Long
Dim pConfigKeyword As String
Dim pModelName As String
'
Dim pIndexIndex As Long
Dim pIndexField As Long
Dim pFieldName As String
Dim pFieldIndex As Long
Dim pIndexName As String
'
Dim pCLSID As UID
Dim pEXTCLSID As UID
'
Dim pFieldChecker As IFieldChecker
Dim pEnumFieldError As IEnumFieldError
Dim pFixedFields As IFields
Dim pFixedTableName As String
Dim pFieldError As IFieldError
Dim pMessage As String
Dim pEsriTableNameErrorType As esriTableNameErrorType
'
Set pFeatureWorkspace = pWorkspace
'---------------------------------------------
' Extract the ObjectClass properties from XML
'---------------------------------------------
pName = CStr(pXMLDOMNodeObjectClass.Attributes.getNamedItem("table").Text)
pConfigKeyword = CStr(pXMLDOMNodeObjectClass.Attributes.getNamedItem("configKeyword").Text)
pShapeFieldName = CStr(pXMLDOMNodeObjectClass.Attributes.getNamedItem("shapeField").Text)
pEsriDatasetType = CLng(pXMLDOMNodeObjectClass.Attributes.getNamedItem("esriDatasetType").Text)
'----------------------------------------
' Test if the ObjectClass already exists
'----------------------------------------
' TODO
'--------------------------------------------------------
' Validation Input Table Name against target Geodatabase
'--------------------------------------------------------
Set pFieldChecker = New FieldChecker
Set pFieldChecker.ValidateWorkspace = pWorkspace
pEsriTableNameErrorType = pFieldChecker.ValidateTableName(pName, pFixedTableName)
If pEsriTableNameErrorType < 1 Then
'-----------------
' Table Name Pass
'-----------------
Else
pMessage = "Table Error encountered in " & pName & vbCrLf
pMessage = pMessage & "Error: " & ReturnTableErrorText(pEsriTableNameErrorType) & vbCrLf
pMessage = pMessage & "ObjectClass Creation Skipped"
Call MsgBox(pMessage, vbCritical, App.ProductName)
'----------------------------------
' Bail out of ObjectClass creation
'----------------------------------
Exit Sub
End If
'---------------------------
' Create the Fields Object.
'---------------------------
Set pFields = ImportGDB_Field(pXMLDOMNodeObjectClass.selectNodes("field"))
'--------------------------------------------------
' Validate Input Fields against target Geodatabase
'--------------------------------------------------
Call pFieldChecker.Validate(pFields, pEnumFieldError, pFixedFields)
If pEnumFieldError Is Nothing Then
'------------------------
' Fields Pass Validation
'------------------------
Else
'------------------------------------
' Iterate through the error messages
'------------------------------------
pMessage = "Field Error(s) encountered in " & pName & vbCrLf
pEnumFieldError.Reset
Set pFieldError = pEnumFieldError.Next
Do Until pFieldError Is Nothing
pMessage = pMessage & "[FieldName(" & pFields.Field(pFieldError.FieldIndex).Name & ") " & _
"Error(" & ReturnFieldErrorText(pFieldError.FieldError) & ")]" & _
vbCrLf
Set pFieldError = pEnumFieldError.Next
Loop
pMessage = pMessage & "ObjectClass Creation Skipped"
Call MsgBox(pMessage, vbCritical, App.ProductName)
'----------------------------------
' Bail out of ObjectClass creation
'----------------------------------
Exit Sub
End If
'--------------
' Assign GUIDs
'--------------
Set pCLSID = New UID
Set pEXTCLSID = New UID
'
Select Case pEsriDatasetType
Case esriGeoDatabase.esriDatasetType.esriDTTable
'---------------------
' Table (no EXTCLSID)
'---------------------
pCLSID.Value = GUID_TABLE_CLSID
Set pEXTCLSID = Nothing
Case esriGeoDatabase.esriDatasetType.esriDTFeatureClass
'-------------
' FeatureCass
'-------------
pEsriFeatureType = CLng(pXMLDOMNodeObjectClass.Attributes.getNamedItem("esriFeatureType").Text)
'
Select Case pEsriFeatureType
Case esriGeoDatabase.esriFeatureType.esriFTAnnotation
'-------------------------------------
' Set Annotation Class Extension GUID
'-------------------------------------
pCLSID.Value = GUID_ANNOTATION_CLSID
pEXTCLSID.Value = GUID_ANNOTATION_EXTCLSID
Case esriGeoDatabase.esriFeatureType.esriFTDimension
'------------------------------------
' Set Dimension Class Extension GUID
'------------------------------------
pCLSID.Value = GUID_DIMENSION_CLSID
pEXTCLSID.Value = GUID_DIMENSION_EXTCLSID
Case esriGeoDatabase.esriFeatureType.esriFTComplexEdge, esriGeoDatabase.esriFeatureType.esriFTComplexJunction, esriGeoDatabase.esriFeatureType.esriFTSimpleEdge, esriGeoDatabase.esriFeatureType.esriFTSimpleJunction
'--------------------------------------------------
' Downgrade Simple/Complex Edge/Junction to Simple
'--------------------------------------------------
pEsriFeatureType = esriGeoDatabase.esriFeatureType.esriFTSimple
pCLSID.Value = GUID_FEATURECLASS_CLSID
Set pEXTCLSID = Nothing
Case esriGeoDatabase.esriFeatureType.esriFTSimple
'---------------------
' Simple FeatureClass
'---------------------
pCLSID.Value = GUID_FEATURECLASS_CLSID
Set pEXTCLSID = Nothing
End Select
End Select
'
Select Case pEsriDatasetType
Case esriGeoDatabase.esriDatasetType.esriDTTable
'------------------
' Create the Table
'------------------
Set pTable = pFeatureWorkspace.CreateTable(pName, pFields, pCLSID, pEXTCLSID, pConfigKeyword)
Set pObjectClass = pTable
Case esriGeoDatabase.esriDatasetType.esriDTFeatureClass
'-------------------------
' Create the FeatureClass
'-------------------------
If pFeatureDataset Is Nothing Then
'-------------------------
' Standalone FeatureClass
'-------------------------
Set pFeatureClass = pFeatureWorkspace.CreateFeatureClass(pName, pFields, pCLSID, pEXTCLSID, pEsriFeatureType, pShapeFieldName, pConfigKeyword)
Else
'----------------------------------------------
' FeatureClass is a subset of a FeatureDataset
'----------------------------------------------
Set pFeatureClass = pFeatureDataset.CreateFeatureClass(pName, pFields, pCLSID, pEXTCLSID, pEsriFeatureType, pShapeFieldName, pConfigKeyword)
End If
'--------------------------------------------------
' Set Annotation and Dimension Specific Properties
'--------------------------------------------------
Select Case pEsriFeatureType
Case esriGeoDatabase.esriFeatureType.esriFTAnnotation
'---------------------------------------------
' <annotation referenceScale="" esriUnits="">
'---------------------------------------------
Set pXMLDOMNodeFeatureClassExtension = pXMLDOMNodeObjectClass.selectNodes("annotation").nextNode
Set pAnnoClassAdmin = pFeatureClass.Extension
pAnnoClassAdmin.ReferenceScale = CDbl(pXMLDOMNodeFeatureClassExtension.Attributes.getNamedItem("referenceScale").Text)
pAnnoClassAdmin.ReferenceScaleUnits = CLng(pXMLDOMNodeFeatureClassExtension.Attributes.getNamedItem("esriUnits").Text)
Case esriGeoDatabase.esriFeatureType.esriFTDimension
'---------------------------------------------
' <dimension referenceScale="" esriUnits="">
'---------------------------------------------
Set pXMLDOMNodeFeatureClassExtension = pXMLDOMNodeObjectClass.selectNodes("dimension").nextNode
Set pDimensionClassExtension = pFeatureClass.Extension
pDimensionClassExtension.ReferenceScale = CDbl(pXMLDOMNodeFeatureClassExtension.Attributes.getNamedItem("referenceScale").Text)
pDimensionClassExtension.ReferenceScaleUnits = CLng(pXMLDOMNodeFeatureClassExtension.Attributes.getNamedItem("esriUnits").Text)
End Select
'-------------------------------------------------------------
' Set the IObjectClass interface for downstream compatiablity
'-------------------------------------------------------------
Set pObjectClass = pFeatureClass
End Select
'------------
' AliasName
'------------
Set pClassSchemaEdit = pObjectClass
pAliasName = CStr(pXMLDOMNodeObjectClass.Attributes.getNamedItem("aliasName").Text)
Call pClassSchemaEdit.AlterAliasName(pAliasName)
'-----------
' ModelInfo
'-----------
pModelName = CStr(pXMLDOMNodeObjectClass.Attributes.getNamedItem("modelName").Text)
Call pClassSchemaEdit.AlterModelName(pModelName)
'-----------
' Subtytpes
'-----------
pSubtypeFieldName = CStr(pXMLDOMNodeObjectClass.Attributes.getNamedItem("subtypeField").Text)
pDefaultSubtypeCode = CLng(pXMLDOMNodeObjectClass.Attributes.getNamedItem("defaultSubtypeCode").Text)
'
Call ImportGDB_Subtype(pXMLDOMNodeObjectClass.selectNodes("subtype"), _
pObjectClass, _
pSubtypeFieldName, _
pDefaultSubtypeCode)
'-------------------
' Add Field Indexes
'-------------------
If mOCImportFieldIndex Then
Set pXMLDOMNodeIndexList = pXMLDOMNodeObjectClass.selectNodes("index")
'
If pXMLDOMNodeIndexList.length > 0 Then
For pIndexIndex = 0 To pXMLDOMNodeIndexList.length - 1 Step 1
Set pXMLDOMNodeIndex = pXMLDOMNodeIndexList(pIndexIndex)
'
pIndexName = CStr(pXMLDOMNodeIndex.Attributes.getNamedItem("name").Text)
'
If IndexExist(pObjectClass, pIndexName) Then
'----------------------------
' Index Already Exists! Skip
'----------------------------
Else
'---------------------------
' Index Does Not Exist. Add
'---------------------------
Set pXMLDOMNodeFieldList = pXMLDOMNodeIndex.selectNodes("field")
If pXMLDOMNodeFieldList.length > 0 Then
'--------------------------------------------
' Only Add Indexes with one or field assigned
'--------------------------------------------
Set pFields = New esriGeoDatabase.Fields
Set pFieldsEdit = pFields
pFieldsEdit.FieldCount = pXMLDOMNodeFieldList.length
'
For pIndexField = 0 To pXMLDOMNodeFieldList.length - 1 Step 1
Set pXMLDOMNodeField = pXMLDOMNodeFieldList.Item(pIndexField)
pFieldName = CStr(pXMLDOMNodeField.Attributes.getNamedItem("name").Text)
pFieldIndex = pObjectClass.FindField(pFieldName)
If pFieldIndex = -1 Then
'-------------------------
' ERROR Cannot Find Field
'-------------------------
Set pFields = Nothing
Exit For
Else
Set pField = pObjectClass.Fields.Field(pFieldIndex)
Select Case CLng(pField.Type)
Case esriGeoDatabase.esriFieldType.esriFieldTypeGeometry, esriGeoDatabase.esriFieldType.esriFieldTypeOID, esriGeoDatabase.esriFieldType.esriFieldTypeBlob
'------------------------------------------------------------------------
' ERROR: Cannot create an index of using a OID, Shape or Blob field type
'------------------------------------------------------------------------
Set pFields = Nothing
Exit For
Case Else
'---------------------
' Add Field to Fields
'---------------------
Set pFieldsEdit.Field(pIndexField) = pField
End Select
End If
Next pIndexField
'
If pFields Is Nothing Then
'----------------------------------
' Error Occurred, do not add index
'----------------------------------
Else
Set pIndex = New esriGeoDatabase.Index
Set pIndexEdit = pIndex
Set pIndexEdit.Fields = pFields
pIndexEdit.Name = pIndexName
pIndexEdit.IsAscending = CBool(pXMLDOMNodeIndex.Attributes.getNamedItem("isAscending").Text)
pIndexEdit.IsUnique = CBool(pXMLDOMNodeIndex.Attributes.getNamedItem("isUnique").Text)
'
Call pObjectClass.AddIndex(pIndex)
End If
End If
End If
Next pIndexIndex
End If
End If
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ImportGDB_ObjectClass " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Function IndexExist(ByRef pObjectClass As esriGeoDatabase.IObjectClass, ByRef pIndexName As String) As Boolean
On Error GoTo ErrorHandler
'
Dim pIndexes As esriGeoDatabase.IIndexes
Dim pIndex As esriGeoDatabase.IIndex
'
Dim pIndexIndex As Long
Dim pIndexExist As Boolean
'
pIndexExist = False
'
Set pIndexes = pObjectClass.Indexes
'
For pIndexIndex = 0 To pIndexes.IndexCount - 1 Step 1
Set pIndex = pIndexes.Index(pIndexIndex)
If UCase(pIndex.Name) = UCase(pIndexName) Then
pIndexExist = True
Exit For
End If
Next pIndexIndex
'
IndexExist = pIndexExist
'
Exit Function
ErrorHandler:
Call HandleError(False, "FindIndexPosition " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Private Function ImportGDB_Field(ByRef pXMLDOMNodeListField As MSXML2.IXMLDOMNodeList) As esriGeoDatabase.IFields
On Error GoTo ErrorHandler
'-----------------------------------------
' <field name=""
' aliasName=""
' domainFixed = ""
' editable = ""
' isNullable = ""
' length = ""
' precision = ""
' required = ""
' scale=""
' esriFieldType = ""
' modelName=""/>
'-----------------------------------------
Dim pXMLDOMNodeField As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeGeometryDef As MSXML2.IXMLDOMNode
'
Dim pFields As esriGeoDatabase.IFields
Dim pFieldsEdit As esriGeoDatabase.IFieldsEdit
Dim pField As esriGeoDatabase.IField
Dim pIndex As Long
'
Set pFields = New esriGeoDatabase.Fields
Set pFieldsEdit = pFields
'
pFieldsEdit.FieldCount = pXMLDOMNodeListField.length
'
For pIndex = 0 To pXMLDOMNodeListField.length - 1 Step 1
'----------------
' Get Field Node
'----------------
Set pXMLDOMNodeField = pXMLDOMNodeListField.Item(pIndex)
'-------------------
' Create new IField
'-------------------
Set pField = modImportExport.MakeField(pXMLDOMNodeField)
'------------------------------------
' Add Field to the Fields Collection
'------------------------------------
Set pFieldsEdit.Field(pIndex) = pField
Next pIndex
'
Set ImportGDB_Field = pFields
'
Exit Function
ErrorHandler:
Call HandleError(False, "ImportGDB_Field " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Private Sub ImportGDB_Subtype(ByRef pXMLDOMNodeListSubtype As MSXML2.IXMLDOMNodeList, _
ByRef pObjectClass As esriGeoDatabase.IObjectClass, _
ByRef pSubtypeFieldName As String, _
ByRef pSubtypeDefaultCode As Long)
On Error GoTo ErrorHandler
'-----------------------------------------------------------
' <subtype name="" code="">
' <field name="" defaultValue="" domain=""/>
' </subtype>
'-----------------------------------------------------------
Dim pXMLDOMNodeSubtype As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeField As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeListField As MSXML2.IXMLDOMNodeList
'
Dim pIndexSubtype As Long
Dim pIndexField As Long
Dim pSubtypes As esriGeoDatabase.ISubtypes
Dim pDataset As esriGeoDatabase.IDataset
Dim pWorkspaceDomain As esriGeoDatabase.IWorkspaceDomains
Dim pDomain As esriGeoDatabase.IDomain
Dim pField As esriGeoDatabase.IField
Dim pFieldEdit As esriGeoDatabase.IFieldEdit
Dim pFieldIndex As Long
Dim pDomainFixed As Boolean
'
Dim pSubtypeCode As Long
Dim pFieldName As String
Dim pDefaultValue As Variant
Dim pDomainName As String
'
Set pDataset = pObjectClass
Set pSubtypes = pObjectClass
Set pWorkspaceDomain = pDataset.Workspace
'----------------------
' Assign Subtype Field
'----------------------
If pSubtypeFieldName <> "" Then
pSubtypes.SubtypeFieldName = pSubtypeFieldName
End If
'----------------------------
' Loop for each Subtype Node
'----------------------------
For pIndexSubtype = 0 To pXMLDOMNodeListSubtype.length - 1 Step 1
Set pXMLDOMNodeSubtype = pXMLDOMNodeListSubtype.Item(pIndexSubtype)
If pSubtypeFieldName <> "" Then
'-----------------
' Add new Subtype
'-----------------
Call pSubtypes.AddSubtype(CLng(pXMLDOMNodeSubtype.Attributes.getNamedItem("code").Text), _
CStr(pXMLDOMNodeSubtype.Attributes.getNamedItem("name").Text))
End If
Set pXMLDOMNodeListField = pXMLDOMNodeSubtype.selectNodes("field")
'--------------------------
' Loop for each Field Node
'--------------------------
For pIndexField = 0 To pXMLDOMNodeListField.length - 1 Step 1
Set pXMLDOMNodeField = pXMLDOMNodeListField.Item(pIndexField)
'
pSubtypeCode = CLng(pXMLDOMNodeSubtype.Attributes.getNamedItem("code").Text)
pFieldName = CStr(pXMLDOMNodeField.Attributes.getNamedItem("name").Text)
pDefaultValue = CVar(pXMLDOMNodeField.Attributes.getNamedItem("defaultValue").Text)
pDomainName = CStr(pXMLDOMNodeField.Attributes.getNamedItem("domain").Text)
'----------------------
' Get the Field Object
'----------------------
pFieldIndex = pObjectClass.FindField(pFieldName)
Set pField = pObjectClass.Fields.Field(pFieldIndex)
Set pFieldEdit = pField
'---------------
' Assign Domain
'---------------
Set pDomain = Nothing
If pDomainName <> "" Then
'------------
' Get Domain
'------------
Set pDomain = pWorkspaceDomain.DomainByName(pDomainName)
If Not (pDomain Is Nothing) Then
'-------------------------
' De-Activate DOMAINFIXED
'-------------------------
pDomainFixed = False
If pField.DomainFixed Then
pFieldEdit.DomainFixed = False
pDomainFixed = True
End If
'-------------------------------------------
' Assign Domain to Field (or Subtype/Field)
'-------------------------------------------
If pSubtypeFieldName = "" Then
Set pFieldEdit.Domain = pDomain
Else
Set pSubtypes.Domain(pSubtypeCode, pFieldName) = pDomain
End If
'-------------------------
' Re-Activate DOMAINFIXED
'-------------------------
If pDomainFixed Then
pFieldEdit.DomainFixed = True
End If
End If
End If
'----------------------
' Assign Default Value
'----------------------
If CStr(pXMLDOMNodeField.Attributes.getNamedItem("defaultValue").Text) <> "" Then
Select Case pField.Type
Case esriFieldTypeDate
If IsDate(pDefaultValue) Then
If pDomain Is Nothing Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CDate(pDefaultValue)
Else
If pDomain.MemberOf(CDate(pDefaultValue)) Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CDate(pDefaultValue)
End If
End If
End If
Case esriFieldTypeDouble
If IsNumeric(pDefaultValue) Then
If pDomain Is Nothing Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CDbl(pDefaultValue)
Else
If pDomain.MemberOf(CDbl(pDefaultValue)) Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CDbl(pDefaultValue)
End If
End If
End If
Case esriFieldTypeInteger
If IsNumeric(pDefaultValue) Then
If pDomain Is Nothing Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CLng(pDefaultValue)
Else
If pDomain.MemberOf(CLng(pDefaultValue)) Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CLng(pDefaultValue)
End If
End If
End If
Case esriFieldTypeSingle
If IsNumeric(pDefaultValue) Then
If pDomain Is Nothing Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CSng(pDefaultValue)
Else
If pDomain.MemberOf(CSng(pDefaultValue)) Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CSng(pDefaultValue)
End If
End If
End If
Case esriFieldTypeSmallInteger
If IsNumeric(pDefaultValue) Then
If pDomain Is Nothing Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CInt(pDefaultValue)
Else
If pDomain.MemberOf(CInt(pDefaultValue)) Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CInt(pDefaultValue)
End If
End If
End If
Case esriFieldTypeString
If pDomain Is Nothing Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CStr(pDefaultValue)
Else
If pDomain.MemberOf(CStr(pDefaultValue)) Then
pSubtypes.DefaultValue(pSubtypeCode, pFieldName) = CStr(pDefaultValue)
End If
End If
End Select
End If
Next pIndexField
Next pIndexSubtype
'--------------------------
' Set Default Subtype Code
'--------------------------
If pSubtypeFieldName <> "" Then
pSubtypes.DefaultSubtypeCode = pSubtypeDefaultCode
End If
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ImportGDB_Subtype " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Function ImportGDB_GeometryDef(ByRef pXMLDOMNodeGeometryDef As MSXML2.IXMLDOMNode) As esriGeoDatabase.IGeometryDef
On Error GoTo ErrorHandler
'--------------------------------------------
' <geometryDef esriGeometryType = ""
' avgNumPoints = ""
' gridCount = ""
' gridSize[0-n] = ""
' hasM=""
' hasZ=""/>
'--------------------------------------------
Dim pXMLDOMNodeFeatureDataset As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeSpatialReference As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeListGrid As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeGrid As MSXML2.IXMLDOMNode
'
Dim pSpatialReference As esriGeometry.ISpatialReference
Dim pGeometryDef As esriGeoDatabase.IGeometryDef
Dim pGeometryDefEdit As esriGeoDatabase.IGeometryDefEdit
Dim pIndex As Long
'
Set pGeometryDef = New GeometryDef
Set pGeometryDefEdit = pGeometryDef
pGeometryDefEdit.AvgNumPoints = CLng(pXMLDOMNodeGeometryDef.Attributes.getNamedItem("avgNumPoints").Text)
pGeometryDefEdit.GeometryType = CLng(pXMLDOMNodeGeometryDef.Attributes.getNamedItem("esriGeometryType").Text)
pGeometryDefEdit.HasM = CBool(pXMLDOMNodeGeometryDef.Attributes.getNamedItem("hasM").Text)
pGeometryDefEdit.HasZ = CBool(pXMLDOMNodeGeometryDef.Attributes.getNamedItem("hasZ").Text)
'
Set pXMLDOMNodeListGrid = pXMLDOMNodeGeometryDef.selectNodes("grid")
pGeometryDefEdit.GridCount = pXMLDOMNodeListGrid.length
For pIndex = 0 To pXMLDOMNodeListGrid.length - 1 Step 1
pGeometryDefEdit.GridSize(pIndex) = CLng(pXMLDOMNodeListGrid.Item(pIndex).Attributes.getNamedItem("size").Text)
Next pIndex
'----------------------------------------------------------
' If there is a child "spatialReference" node then add it.
'----------------------------------------------------------
If pXMLDOMNodeGeometryDef.selectNodes("spatialReference").length = 1 Then
'--------------------------------------
' Get SpatialReference from child node
'--------------------------------------
Set pXMLDOMNodeSpatialReference = pXMLDOMNodeGeometryDef.selectNodes("spatialReference").nextNode
Else
'-------------------------------------------------
' Get SpatialReference from parent FeatureDataset
'-------------------------------------------------
Set pXMLDOMNodeFeatureDataset = pXMLDOMNodeGeometryDef.parentNode.parentNode.parentNode
Set pXMLDOMNodeSpatialReference = pXMLDOMNodeFeatureDataset.selectNodes("spatialReference").nextNode
End If
Set pSpatialReference = ImportGDB_SpatialReference(pXMLDOMNodeSpatialReference)
Set pGeometryDefEdit.SpatialReference = pSpatialReference
'----------------------------
' Return Geometry Definition
'----------------------------
Set ImportGDB_GeometryDef = pGeometryDef
'
Exit Function
ErrorHandler:
Call HandleError(False, "ImportGDB_GeometryDef " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Private Function ImportGDB_SpatialReference(ByRef pXMLDOMNodeSpatialReference As MSXML2.IXMLDOMNode) As esriGeometry.ISpatialReference
On Error GoTo ErrorHandler
'---------------------------------------------------------------------
' <spatialReference minX="" minY="" precisionXY=""
' minM="" precisionM=""
' minZ="" precisionZ=""
' coordinateSystemDescription=""/>
'---------------------------------------------------------------------
Dim pSpatialReference As esriGeometry.ISpatialReference
Dim pESRISpatialReference As esriGeometry.IESRISpatialReference
Dim pSpatialReferenceFactory As ISpatialReferenceFactory
Dim pCoordinateSystemDescription As String
' Minimum
Dim pXMin As Double
Dim pYMin As Double
Dim pMMin As Double
Dim pZMin As Double
' Precision
Dim pXYPrecision As Double
Dim pMPrecision As Double
Dim pZPrecision As Double
Dim pBytes As Long
'---------------------------------
' Get CoordinateSystemDescription
'---------------------------------
pCoordinateSystemDescription = pXMLDOMNodeSpatialReference.Attributes.getNamedItem("coordinateSystemDescription").Text
If pCoordinateSystemDescription = "" Then
Set pSpatialReference = New esriGeometry.UnknownCoordinateSystem
Else
Set pSpatialReferenceFactory = New esriGeometry.SpatialReferenceEnvironment
Call pSpatialReferenceFactory.CreateESRISpatialReference(pCoordinateSystemDescription, pSpatialReference, pBytes)
End If
'------------------
' Import XY Domain
'------------------
pXMin = CDbl(pXMLDOMNodeSpatialReference.Attributes.getNamedItem("minX").Text)
pYMin = CDbl(pXMLDOMNodeSpatialReference.Attributes.getNamedItem("minY").Text)
pXYPrecision = CDbl(pXMLDOMNodeSpatialReference.Attributes.getNamedItem("precisionXY").Text)
'If pXMin <> 0 And pYMin <> 0 And pXYPrecision <> 0 Then
If pXYPrecision <> 0 Then
Call pSpatialReference.SetFalseOriginAndUnits(pXMin, pYMin, pXYPrecision)
End If
'-----------------
' Import M Domain
'-----------------
If pXMLDOMNodeSpatialReference.Attributes.getNamedItem("minM").Text = "" Or _
pXMLDOMNodeSpatialReference.Attributes.getNamedItem("precisionM").Text = "" Then
'-------------------------
' M Domain is Blank. Skip
'-------------------------
Else
pMMin = CDbl(pXMLDOMNodeSpatialReference.Attributes.getNamedItem("minM").Text)
pMPrecision = CDbl(pXMLDOMNodeSpatialReference.Attributes.getNamedItem("precisionM").Text)
'If pMMin <> 0 And pMPrecision <> 0 Then
If pMPrecision <> 0 Then
Call pSpatialReference.SetMFalseOriginAndUnits(pMMin, pMPrecision)
End If
End If
'-----------------
' Import Z Domain
'-----------------
If pXMLDOMNodeSpatialReference.Attributes.getNamedItem("minZ").Text = "" Or _
pXMLDOMNodeSpatialReference.Attributes.getNamedItem("precisionZ").Text = "" Then
'-------------------
' Z Domain is blank
'-------------------
Else
pZMin = CDbl(pXMLDOMNodeSpatialReference.Attributes.getNamedItem("minZ").Text)
pZPrecision = CDbl(pXMLDOMNodeSpatialReference.Attributes.getNamedItem("precisionZ").Text)
'If pZMin <> 0 And pZPrecision <> 0 Then
If pZPrecision <> 0 Then
Call pSpatialReference.SetZFalseOriginAndUnits(pZMin, pZPrecision)
End If
End If
'---------------------------
' Return Spatial Reference
'--------------------------
Set ImportGDB_SpatialReference = pSpatialReference
'
Exit Function
ErrorHandler:
Call HandleError(False, "ImportGDB_SpatialReference " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Private Function MakeField(ByRef pXMLDOMNodeField As MSXML2.IXMLDOMNode) As esriGeoDatabase.IField
On Error GoTo ErrorHandler
'
Dim pXMLDOMNodeGeometryDef As MSXML2.IXMLDOMNode
Dim pField As esriGeoDatabase.IField
Dim pFieldEdit As esriGeoDatabase.IFieldEdit
Dim pModelInfo As esriGeoDatabase.IModelInfo
'--------------------
' Create a new field
'--------------------
Set pField = New esriGeoDatabase.Field
Set pFieldEdit = pField
Set pModelInfo = pField
'------------------------------
' Edit Common Field Attributes
'------------------------------
With pFieldEdit
.Name = CStr(pXMLDOMNodeField.Attributes.getNamedItem("name").Text)
.AliasName = CStr(pXMLDOMNodeField.Attributes.getNamedItem("aliasName").Text)
.Type = CLng(pXMLDOMNodeField.Attributes.getNamedItem("esriFieldType").Text)
.IsNullable = CBool(pXMLDOMNodeField.Attributes.getNamedItem("isNullable").Text)
.Required = CBool(pXMLDOMNodeField.Attributes.getNamedItem("required").Text)
.Editable = CBool(pXMLDOMNodeField.Attributes.getNamedItem("editable").Text)
End With
'-------------------------------------
' Edit Field-Type specific properties
'-------------------------------------
Select Case pField.Type
Case esriFieldTypeGeometry
'-------------------------
' Set Geometry Definition
'-------------------------
Set pXMLDOMNodeGeometryDef = pXMLDOMNodeField.childNodes.nextNode
Set pFieldEdit.GeometryDef = ImportGDB_GeometryDef(pXMLDOMNodeGeometryDef)
Case esriFieldTypeOID
'
Case esriFieldTypeBlob
With pFieldEdit
.length = CLng(pXMLDOMNodeField.Attributes.getNamedItem("length").Text)
End With
Case esriFieldTypeDate
With pFieldEdit
.DomainFixed = CBool(pXMLDOMNodeField.Attributes.getNamedItem("domainFixed").Text)
End With
Case esriFieldTypeDouble
With pFieldEdit
.Precision = CLng(pXMLDOMNodeField.Attributes.getNamedItem("precision").Text)
.Scale = CLng(pXMLDOMNodeField.Attributes.getNamedItem("scale").Text)
.DomainFixed = CBool(pXMLDOMNodeField.Attributes.getNamedItem("domainFixed").Text)
End With
Case esriFieldTypeInteger
With pFieldEdit
.Precision = CLng(pXMLDOMNodeField.Attributes.getNamedItem("precision").Text)
.DomainFixed = CBool(pXMLDOMNodeField.Attributes.getNamedItem("domainFixed").Text)
End With
Case esriFieldTypeSingle
With pFieldEdit
.Precision = CLng(pXMLDOMNodeField.Attributes.getNamedItem("precision").Text)
.Scale = CLng(pXMLDOMNodeField.Attributes.getNamedItem("scale").Text)
.DomainFixed = CBool(pXMLDOMNodeField.Attributes.getNamedItem("domainFixed").Text)
End With
Case esriFieldTypeSmallInteger
With pFieldEdit
.Precision = CLng(pXMLDOMNodeField.Attributes.getNamedItem("precision").Text)
.DomainFixed = CBool(pXMLDOMNodeField.Attributes.getNamedItem("domainFixed").Text)
End With
Case esriFieldTypeString
With pFieldEdit
.length = CLng(pXMLDOMNodeField.Attributes.getNamedItem("length").Text)
.DomainFixed = CBool(pXMLDOMNodeField.Attributes.getNamedItem("domainFixed").Text)
End With
End Select
'----------------
' Set Model Name
'----------------
pModelInfo.ModelName = CStr(pXMLDOMNodeField.Attributes.getNamedItem("modelName").Text)
'--------------------------------
' Return reference to new IField
'--------------------------------
Set MakeField = pField
'
Exit Function
ErrorHandler:
Call HandleError(False, "MakeField " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
'==================================================================================
'-----------------------
' RELATIONSHIP - Import
'-----------------------
Public Sub ImportRelationship(ByRef pApplication As esriFramework.IApplication)
On Error GoTo ErrorHandler
'
Dim pGxApplication As esriCatalogUI.IGxApplication
Dim pStatusBar As esriSystem.IStatusBar
Dim pMouseCursor As esriFramework.IMouseCursor
'
Dim pDOMDocument As MSXML2.DOMDocument
Dim pXMLDOMNodeListRelationship As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeListField As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeListRule As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeGeodatabaseDesigner As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeRelationship As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeFeatureDataset As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeOrigin As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeDestination As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeField As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeRule As MSXML2.IXMLDOMNode
'
Dim pGxObject As esriCatalog.IGxObject
Dim pGxDatabase As esriCatalog.IGxDatabase
Dim pWorkspace As esriGeoDatabase.IWorkspace
Dim pFeatureDataset As esriGeoDatabase.IFeatureDataset
Dim pOriginObjectClass As esriGeoDatabase.IObjectClass
Dim pDestinationObjectClass As esriGeoDatabase.IObjectClass
'
Dim pName As String
Dim pFeatureDatasetName As String
Dim pOriginObjectClassName As String
Dim pDestinationObjectClassName As String
Dim pForwardLabel As String
Dim pBackwardLabel As String
Dim pEsriRelCardinality As Long
Dim pEsriRelNotification As Long
Dim pIsComposite As Boolean
Dim pIsAttributed As Boolean
Dim pOriginPrimaryKey As String
Dim pOriginForeignKey As String
Dim pDestinationPrimaryKey As String
Dim pDestinationForeignKey As String
'
Dim pFeatureWorkspace As esriGeoDatabase.IFeatureWorkspace
Dim pRelationshipClassContainer As esriGeoDatabase.IRelationshipClassContainer
Dim pRelationshipClass As esriGeoDatabase.IRelationshipClass
Dim pRelationshipRule As IRelationshipRule
Dim pTable As esriGeoDatabase.ITable
Dim pField As esriGeoDatabase.IField
'
Dim pIndexRelationship As Long
Dim pIndexField As Long
Dim pIndexRule As Long
'---------------------------------
' Set GxApplication and StatusBar
'---------------------------------
Set pGxApplication = pApplication
Set pStatusBar = pApplication.StatusBar
'-------------------------
' Get Workspace Interface
'-------------------------
Set pGxObject = pGxApplication.SelectedObject
If TypeOf pGxObject Is esriCatalog.IGxDatabase Then
Set pGxDatabase = pGxObject
Set pWorkspace = pGxDatabase.Workspace
If pWorkspace.Type = esriFileSystemWorkspace Then
MsgBox "Please select a Geodatabase", vbExclamation, App.FileDescription
Exit Sub
End If
Else
MsgBox "Please select a Geodatabase", vbExclamation, App.FileDescription
Exit Sub
End If
'----------------------------------------------
' Prompt for and open the source XML document.
'----------------------------------------------
Set pDOMDocument = modCommon.GetXMLDocument
If pDOMDocument Is Nothing Then
Exit Sub
End If
'---------------------
' Change Mouse Cursor
'---------------------
Set pMouseCursor = New esriFramework.MouseCursor
Call pMouseCursor.SetCursor(2)
'-----------------------------------------------
' Get GeodatabaseDesigner Node and Dataset list
'-----------------------------------------------
Set pXMLDOMNodeGeodatabaseDesigner = pDOMDocument.getElementsByTagName("geodatabaseDesigner").nextNode
Set pXMLDOMNodeListRelationship = pXMLDOMNodeGeodatabaseDesigner.selectNodes("relationshipClass")
'-------------------------------------------------------
' Launch procedure for each type of dataset encountered
'-------------------------------------------------------
For pIndexRelationship = 0 To pXMLDOMNodeListRelationship.length - 1 Step 1
Set pXMLDOMNodeRelationship = pXMLDOMNodeListRelationship.Item(pIndexRelationship)
Set pXMLDOMNodeFeatureDataset = pXMLDOMNodeRelationship.selectSingleNode("featureDataset")
Set pXMLDOMNodeOrigin = pXMLDOMNodeRelationship.selectSingleNode("origin")
Set pXMLDOMNodeDestination = pXMLDOMNodeRelationship.selectSingleNode("destination")
'----------------------------------------------------------------------------
' <relationshipClass database="" owner="" table="" esriRelCardinality="" esriRelNotification="" isComposite="" isAttributed="" originPrimaryKey="" destinationPrimaryKey="" originForeignKey="" destinationForeignKey="">
' <featureDataset database="" owner="" table="" />
' <origin database="" owner="" table="" label="" />
' <destination database="" owner="" table="" label="" />
' <!-- Relationship Attribute Fields -->
' <field />
' <!-- Relationship Rules -->
' <rule destinationSubtype="" destinationMinimum="" destinationMaximum="" originSubtype="" originMinimum="" originMaximum="" />
' </relationshipClass>
'----------------------------------------------------------------------------
' CreateRelationshipClass (in relClassName: String,
' in OriginClass: IObjectClass,
' in DestinationClass: IObjectClass,
' in forwardLabel: String,
' in backwardLabel: String,
' in Cardinality: esriRelCardinality,
' in Notification: esriRelNotification,
' in IsComposite: Boolean,
' in IsAttributed: Boolean,
' in relAttrFields: IFields,
' in OriginPrimaryKey: String,
' in destPrimaryKey: String,
' in OriginForeignKey: String,
' in destForeignKey: String): IRelationshipClass
'----------------------------------------------------------------------------
'------------------------------------------------
' Get Relationship Propertied from the XML Node.
'------------------------------------------------
pName = CStr(pXMLDOMNodeRelationship.Attributes.getNamedItem("table").Text)
'
pEsriRelCardinality = CLng(pXMLDOMNodeRelationship.Attributes.getNamedItem("esriRelCardinality").Text)
pEsriRelNotification = CLng(pXMLDOMNodeRelationship.Attributes.getNamedItem("esriRelNotification").Text)
pIsComposite = CBool(pXMLDOMNodeRelationship.Attributes.getNamedItem("isComposite").Text)
pIsAttributed = CBool(pXMLDOMNodeRelationship.Attributes.getNamedItem("isAttributed").Text)
pOriginPrimaryKey = CStr(pXMLDOMNodeRelationship.Attributes.getNamedItem("originPrimaryKey").Text)
pOriginForeignKey = CStr(pXMLDOMNodeRelationship.Attributes.getNamedItem("originForeignKey").Text)
pDestinationPrimaryKey = CStr(pXMLDOMNodeRelationship.Attributes.getNamedItem("destinationPrimaryKey").Text)
pDestinationForeignKey = CStr(pXMLDOMNodeRelationship.Attributes.getNamedItem("destinationForeignKey").Text)
'
pFeatureDatasetName = CStr(pXMLDOMNodeFeatureDataset.Attributes.getNamedItem("table").Text)
'
pOriginObjectClassName = CStr(pXMLDOMNodeOrigin.Attributes.getNamedItem("table").Text)
pBackwardLabel = CStr(pXMLDOMNodeOrigin.Attributes.getNamedItem("label").Text)
'
pDestinationObjectClassName = CStr(pXMLDOMNodeDestination.Attributes.getNamedItem("table").Text)
pForwardLabel = CStr(pXMLDOMNodeDestination.Attributes.getNamedItem("label").Text)
'------------------
' Update StatusBar
'------------------
pStatusBar.Message(0) = "Import Relationship: Creating " & pName
'
Set pFeatureWorkspace = pWorkspace
Set pOriginObjectClass = pFeatureWorkspace.OpenTable(pOriginObjectClassName)
Set pDestinationObjectClass = pFeatureWorkspace.OpenTable(pDestinationObjectClassName)
'-------------------------
' Create the Relationship
'-------------------------
Set pRelationshipClass = pFeatureWorkspace.CreateRelationshipClass(pName, _
pOriginObjectClass, _
pDestinationObjectClass, _
pForwardLabel, _
pBackwardLabel, _
pEsriRelCardinality, _
pEsriRelNotification, _
pIsComposite, _
pIsAttributed, _
Nothing, _
pOriginPrimaryKey, _
pDestinationPrimaryKey, _
pOriginForeignKey, _
pDestinationForeignKey)
'----------------------------------------------------------------------------
' Transfer ownership of Relationship to a FeatureDataset (if not standalone)
'----------------------------------------------------------------------------
If pFeatureDatasetName <> "" Then
Set pRelationshipClassContainer = pFeatureWorkspace.OpenFeatureDataset(pFeatureDatasetName)
Call pRelationshipClassContainer.AddRelationshipClass(pRelationshipClass)
End If
'---------------------------------------
' Add non-key attribute fields (if any)
'---------------------------------------
Set pXMLDOMNodeListField = pXMLDOMNodeRelationship.selectNodes("field")
If pXMLDOMNodeListField.length > 0 Then
'------------------------
' QI to ITable Interface
'------------------------
Set pTable = pRelationshipClass
For pIndexField = 0 To pXMLDOMNodeListField.length - 1 Step 1
'----------------
' Get Field Node
'----------------
Set pXMLDOMNodeField = pXMLDOMNodeListField.Item(pIndexField)
'---------------------
' Create a new IField
'---------------------
Set pField = modImportExport.MakeField(pXMLDOMNodeField)
'-----------------------------------------------
' Add Field to the Relationship Attribute Table
'-----------------------------------------------
Call pTable.AddField(pField)
Next pIndexField
End If
'----------------------------------------
' Add Rules to the Relationship (if any)
' <rule destinationSubtype=""
' destinationMinimum=""
' destinationMaximum=""
' originSubtype=""
' originMinimum=""
' originMaximum=""/>
'----------------------------------------
Set pXMLDOMNodeListRule = pXMLDOMNodeRelationship.selectNodes("rule")
If pXMLDOMNodeListRule.length > 0 Then
'
For pIndexRule = 0 To pXMLDOMNodeListRule.length - 1 Step 1
'---------------
' Get Rule Node
'---------------
Set pXMLDOMNodeRule = pXMLDOMNodeListRule.Item(pIndexRule)
'------------------------
' Create new Rule Object
'------------------------
Set pRelationshipRule = New RelationshipRule
With pRelationshipRule
.DestinationClassID = pDestinationObjectClass.ObjectClassID
.DestinationSubtypeCode = GetSubtypeCodeFromName(pDestinationObjectClass, _
CStr(pXMLDOMNodeRule.Attributes.getNamedItem("destinationSubtype").Text))
.DestinationMaximumCardinality = CLng(pXMLDOMNodeRule.Attributes.getNamedItem("destinationMaximum").Text)
.DestinationMinimumCardinality = CLng(pXMLDOMNodeRule.Attributes.getNamedItem("destinationMinimum").Text)
.OriginClassID = pOriginObjectClass.ObjectClassID
.OriginSubtypeCode = GetSubtypeCodeFromName(pOriginObjectClass, _
CStr(pXMLDOMNodeRule.Attributes.getNamedItem("originSubtype").Text))
.OriginMaximumCardinality = CLng(pXMLDOMNodeRule.Attributes.getNamedItem("originMaximum").Text)
.OriginMinimumCardinality = CLng(pXMLDOMNodeRule.Attributes.getNamedItem("originMinimum").Text)
End With
'
Call pRelationshipClass.AddRelationshipRule(pRelationshipRule)
Next pIndexRule
End If
'
Next pIndexRelationship
'-----------------
' Clear StatusBar
'-----------------
pStatusBar.Message(0) = ""
'--------------------------------------
' Refresh ArcCatalog Table of Contents
'--------------------------------------
Call pGxApplication.Refresh(pGxApplication.SelectedObject.FullName)
'---------------------
' Restore MouseCursor
'---------------------
Set pMouseCursor = Nothing
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ImportRelationship " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Public Function GetSubtypeCodeFromName(ByRef pSubtypes As esriGeoDatabase.ISubtypes, _
ByRef pSubtypeNameIn As String) As Long
On Error GoTo ErrorHandler
'
Dim pEnumSubtype As esriGeoDatabase.IEnumSubtype
Dim pSubtypeNameOut As String
Dim pSubtypeCodeOut As Long
'
pSubtypeCodeOut = 0
'
Set pEnumSubtype = pSubtypes.Subtypes
pSubtypeNameOut = pEnumSubtype.Next(pSubtypeCodeOut)
Do Until pSubtypeNameOut = ""
If UCase(pSubtypeNameOut) = UCase(pSubtypeNameIn) Then
Exit Do
End If
pSubtypeNameOut = pEnumSubtype.Next(pSubtypeCodeOut)
Loop
'
GetSubtypeCodeFromName = pSubtypeCodeOut
'
Exit Function
ErrorHandler:
Call HandleError(False, "GetSubtypeCodeFromName " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
'==================================================================================
'-----------------------
' EXPORT - RELATIONSHIP
'-----------------------
Public Function ExportRelationship(ByRef pApplication As esriFramework.IApplication) As MSXML2.DOMDocument
On Error GoTo ErrorHandler
'
Dim pGxApplication As esriCatalogUI.IGxApplication
Dim pStatusBar As esriSystem.IStatusBar
'
Dim pGxObject As esriCatalog.IGxObject
Dim pGxDatabase As esriCatalog.IGxDatabase
Dim pWorkspace As esriGeoDatabase.IWorkspace
Dim pEnumDataset As esriGeoDatabase.IEnumDataset
Dim pDataset As esriGeoDatabase.IDataset
Dim pDatasetRelationship As esriGeoDatabase.IDataset
Dim pRelationshipClassContainer As esriGeoDatabase.IRelationshipClassContainer
Dim pEnumRelationshipClass As esriGeoDatabase.IEnumRelationshipClass
Dim pRelationshipClass As esriGeoDatabase.IRelationshipClass
'
Dim pDOMDocument As MSXML2.DOMDocument
Dim pXMLDOMNodeGeodatabaseDesigner As MSXML2.IXMLDOMNode
'---------------------------------
' Set GxApplication and StatusBar
'---------------------------------
Set pGxApplication = pApplication
Set pStatusBar = pApplication.StatusBar
'-------------------------
' Get Workspace Interface
'-------------------------
Set pGxObject = pGxApplication.SelectedObject
If TypeOf pGxObject Is esriCatalog.IGxDatabase Then
Set pGxDatabase = pGxObject
Set pWorkspace = pGxDatabase.Workspace
If pWorkspace.Type = esriFileSystemWorkspace Then
MsgBox "Please select a Geodatabase", vbExclamation, App.FileDescription
Exit Function
End If
Else
MsgBox "Please select a Geodatabase", vbExclamation, App.FileDescription
Exit Function
End If
'----------------------------------
' Get new XML Document (in memory)
'----------------------------------
Set pDOMDocument = modCommon.NewXMLDocument
'------------------------
' Add header to XML file
'------------------------
Call modCommon.WriteGeodatabaseDesignerHeader(pDOMDocument, pWorkspace)
'----------------------------
' Get GeodatabaseDesigner Node
'------------------------------
Set pXMLDOMNodeGeodatabaseDesigner = pDOMDocument.getElementsByTagName("geodatabaseDesigner").nextNode
'------------------------------------------------
' Iterate through each IDataset under IWorkspace
'------------------------------------------------
Set pEnumDataset = pWorkspace.Datasets(esriDTAny)
Set pDataset = pEnumDataset.Next
Do Until pDataset Is Nothing
Select Case pDataset.Type
Case esriGeoDatabase.esriDatasetType.esriDTFeatureDataset
'-----------------------------
' Document the FeatureDataset
'-----------------------------
Set pRelationshipClassContainer = pDataset
Set pEnumRelationshipClass = pRelationshipClassContainer.RelationshipClasses
Set pRelationshipClass = pEnumRelationshipClass.Next
Set pDatasetRelationship = pRelationshipClass
Do Until pRelationshipClass Is Nothing
pStatusBar.Message(0) = "Exporting Relationship: " & pDatasetRelationship.Name
Call ExportRelationship2(pXMLDOMNodeGeodatabaseDesigner, pRelationshipClass)
Set pRelationshipClass = pEnumRelationshipClass.Next
Loop
Case esriGeoDatabase.esriDatasetType.esriDTRelationshipClass
'--------------------------------
' Export Standalone Relationship
'--------------------------------
pStatusBar.Message(0) = "Exporting Relationship: " & pDataset.Name
Call ExportRelationship2(pXMLDOMNodeGeodatabaseDesigner, pDataset)
End Select
'
Set pDataset = pEnumDataset.Next
Loop
'-----------------
' Clear StatusBar
'-----------------
pStatusBar.Message(0) = ""
'---------------------
' Return XML Document
'---------------------
Set ExportRelationship = pDOMDocument
'
Exit Function
ErrorHandler:
Call HandleError(False, "ExportRelationship " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Private Sub ExportRelationship2(ByRef pXMLDOMNodeGeodatabaseDesigner As MSXML2.IXMLDOMNode, _
ByRef pRelationshipClass As esriGeoDatabase.IRelationshipClass)
On Error GoTo ErrorHandler
'-----------------------------------------------------
' <relationshipClass database=""
' owner=""
' table=""
' esriRelCardinality=""
' esriRelNotification=""
' isComposite=""
' isAttributed=""
' originPrimaryKey=""
' destinationPrimaryKey=""
' originForeignKey=""
' destinationForeignKey="">
' <featureDataset database="" owner="" table="" />
' <origin database="" owner="" table="" label="" />
' <destination database="" owner="" table="" label="" />
' <field />
' <rule destinationSubtype=""
' destinationMinimum=""
' destinationMaximum=""
' originSubtype=""
' originMinimum=""
' originMaximum=""/>
' </relationshipClass>
'----------------------------------------------------
Dim pXMLDOMNodeRelationshipClass As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeFeatureDataset As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeOrigin As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeDestination As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeField As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeRule As MSXML2.IXMLDOMNode
'
Dim pDataset As esriGeoDatabase.IDataset
Dim pTable As esriGeoDatabase.ITable
Dim pField As esriGeoDatabase.IField
Dim pModelInfo As esriGeoDatabase.IModelInfo
Dim pEnumRule As esriGeoDatabase.IEnumRule
Dim pRelationshipRule As esriGeoDatabase.IRelationshipRule
Dim pDatasetDestination As esriGeoDatabase.IDataset
Dim pDatasetOrigin As esriGeoDatabase.IDataset
Dim pSubtypesDestination As esriGeoDatabase.ISubtypes
Dim pSubtypesOrigin As esriGeoDatabase.ISubtypes
'
Dim pIndex As Long
'
Set pDataset = pRelationshipClass
'---------------------------
' Add new Relationship Node
'---------------------------
Set pXMLDOMNodeRelationshipClass = pXMLDOMNodeGeodatabaseDesigner.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "relationshipClass", "")
Set pXMLDOMNodeRelationshipClass = pXMLDOMNodeGeodatabaseDesigner.appendChild(pXMLDOMNodeRelationshipClass)
'-----------------------------
' Add Relationship properties
'-----------------------------
Set pDatasetOrigin = pRelationshipClass.OriginClass
Set pDatasetDestination = pRelationshipClass.DestinationClass
'
Call AddQualifiedTableNameParts(pXMLDOMNodeRelationshipClass, pDataset)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "esriRelCardinality", CStr(pRelationshipClass.Cardinality))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "esriRelNotification", CStr(pRelationshipClass.Notification))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "isComposite", CStr(pRelationshipClass.IsComposite))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "isAttributed", CStr(pRelationshipClass.IsAttributed))
If pRelationshipClass.IsAttributed Then
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "originPrimaryKey", CStr(pRelationshipClass.OriginPrimaryKey))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "originForeignKey", CStr(pRelationshipClass.OriginForeignKey))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "destinationPrimaryKey", CStr(pRelationshipClass.DestinationPrimaryKey))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "destinationForeignKey", CStr(pRelationshipClass.DestinationForeignKey))
Else
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "originPrimaryKey", CStr(pRelationshipClass.OriginPrimaryKey))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "originForeignKey", CStr(pRelationshipClass.OriginForeignKey))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "destinationPrimaryKey", "")
Call modCommon.AddNodeAttribute(pXMLDOMNodeRelationshipClass, "destinationForeignKey", "")
End If
'-------------------------
' Add FeatureDataset Node
'-------------------------
Set pXMLDOMNodeFeatureDataset = pXMLDOMNodeRelationshipClass.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "featureDataset", "")
Set pXMLDOMNodeFeatureDataset = pXMLDOMNodeRelationshipClass.appendChild(pXMLDOMNodeFeatureDataset)
'
If pRelationshipClass.FeatureDataset Is Nothing Then
Call AddQualifiedTableNameParts(pXMLDOMNodeFeatureDataset, Nothing)
Else
Call AddQualifiedTableNameParts(pXMLDOMNodeFeatureDataset, pRelationshipClass.FeatureDataset)
End If
'-----------------
' Add Origin Node
'-----------------
Set pXMLDOMNodeOrigin = pXMLDOMNodeRelationshipClass.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "origin", "")
Set pXMLDOMNodeOrigin = pXMLDOMNodeRelationshipClass.appendChild(pXMLDOMNodeOrigin)
'
Call AddQualifiedTableNameParts(pXMLDOMNodeOrigin, pDatasetOrigin)
Call modCommon.AddNodeAttribute(pXMLDOMNodeOrigin, "label", CStr(pRelationshipClass.BackwardPathLabel))
'----------------------
' Add Destination Node
'----------------------
Set pXMLDOMNodeDestination = pXMLDOMNodeRelationshipClass.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "destination", "")
Set pXMLDOMNodeDestination = pXMLDOMNodeRelationshipClass.appendChild(pXMLDOMNodeDestination)
'
Call AddQualifiedTableNameParts(pXMLDOMNodeDestination, pDatasetDestination)
Call modCommon.AddNodeAttribute(pXMLDOMNodeDestination, "label", CStr(pRelationshipClass.ForwardPathLabel))
'--------------------------------------------------------
' Add non-key fields in Attributed Relationship (if any)
'--------------------------------------------------------
If pRelationshipClass.IsAttributed Then
Set pTable = pRelationshipClass
For pIndex = 0 To pTable.Fields.FieldCount - 1 Step 1
Set pField = pTable.Fields.Field(pIndex)
If UCase(pField.Name) <> UCase(pRelationshipClass.OriginForeignKey) And _
UCase(pField.Name) <> UCase(pRelationshipClass.DestinationForeignKey) And _
pField.Type <> esriFieldTypeOID Then
'----------------
' Add Field Node
'----------------
Set pModelInfo = pField
Set pXMLDOMNodeField = pXMLDOMNodeRelationshipClass.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "field", "")
Set pXMLDOMNodeField = pXMLDOMNodeRelationshipClass.appendChild(pXMLDOMNodeField)
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "name", CStr(pField.Name))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "aliasName", CStr(pField.AliasName))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "esriFieldType", CStr(pField.Type))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "length", CStr(pField.length))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "precision", CStr(pField.Precision))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "required", CStr(pField.Required))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "scale", CStr(pField.Scale))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "domainFixed", CStr(pField.DomainFixed))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "editable", CStr(pField.Editable))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "isNullable", CStr(pField.IsNullable))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "modelName", CStr(pModelInfo.ModelName))
End If
Next pIndex
End If
'------------------------
' Add Relationship Rules
'------------------------
Set pSubtypesDestination = pDatasetDestination
Set pSubtypesOrigin = pDatasetOrigin
Set pEnumRule = pRelationshipClass.RelationshipRules
Set pRelationshipRule = pEnumRule.Next
Do Until pRelationshipRule Is Nothing
'------------------------------------
' <rule destinationSubtype=""
' destinationMinimum=""
' destinationMaximum=""
' originSubtype=""
' originMinimum=""
' originMaximum=""/>
'------------------------------------
If IsSubtypeCodeValid(pSubtypesOrigin, pRelationshipRule.OriginSubtypeCode) Then
If IsSubtypeCodeValid(pSubtypesDestination, pRelationshipRule.DestinationSubtypeCode) Then
Set pXMLDOMNodeRule = pXMLDOMNodeRelationshipClass.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "rule", "")
Set pXMLDOMNodeRule = pXMLDOMNodeRelationshipClass.appendChild(pXMLDOMNodeRule)
Call modCommon.AddNodeAttribute(pXMLDOMNodeRule, "originSubtype", CStr(pSubtypesOrigin.SubtypeName(pRelationshipRule.OriginSubtypeCode)))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRule, "destinationSubtype", CStr(pSubtypesDestination.SubtypeName(pRelationshipRule.DestinationSubtypeCode)))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRule, "originMinimum", CStr(pRelationshipRule.OriginMinimumCardinality))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRule, "originMaximum", CStr(pRelationshipRule.OriginMaximumCardinality))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRule, "destinationMinimum", CStr(pRelationshipRule.DestinationMinimumCardinality))
Call modCommon.AddNodeAttribute(pXMLDOMNodeRule, "destinationMaximum", CStr(pRelationshipRule.DestinationMaximumCardinality))
Else
' ************ Destination Subtype Code is Invalid **************
End If
Else
' ************ Origin Subtype Code is Invalid **************
End If
'
Set pRelationshipRule = pEnumRule.Next
Loop
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ExportRelationship " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Function IsSubtypeCodeValid(ByRef pSubtypes As esriGeoDatabase.ISubtypes, _
ByRef pSubtypeCodeIn As Long) As Boolean
On Error GoTo ErrorHandler
'
Dim pEnumSubtype As esriGeoDatabase.IEnumSubtype
Dim pSubtypeName As String
Dim pSubtypeCodeOut As Long
Dim pValidateSubtypeCode As Boolean
'
pValidateSubtypeCode = False
'
Set pEnumSubtype = pSubtypes.Subtypes
pSubtypeName = pEnumSubtype.Next(pSubtypeCodeOut)
Do Until pSubtypeName = ""
If pSubtypeCodeIn = pSubtypeCodeOut Then
pValidateSubtypeCode = True
Exit Do
End If
pSubtypeName = pEnumSubtype.Next(pSubtypeCodeOut)
Loop
'
IsSubtypeCodeValid = pValidateSubtypeCode
'
Exit Function
ErrorHandler:
Call HandleError(False, "IsSubtypeCodeValid " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
'=====================================================================
'-------------------------
' Export GeometricNetwork
'-------------------------
Public Function ExportGeometricNework(ByRef pApplication As esriFramework.IApplication) As MSXML2.DOMDocument
On Error GoTo ErrorHandler
'---------------------------------------------------------------------------
' This routine will export both the GeometricNetwork and Connectivity Rules
'---------------------------------------------------------------------------
Dim pGxApplication As esriCatalogUI.IGxApplication
Dim pStatusBar As esriSystem.IStatusBar
'
Dim pDOMDocument As MSXML2.DOMDocument
'
Dim pXMLDOMNodeGeodatabaseDesigner As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeGeometricNetwork As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeJunctionConnRule As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeEdgeConnRule As MSXML2.IXMLDOMNode
'
Dim pXMLDOMNodeChild As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeParent As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeParent2 As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeList As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeWeight As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeWeightAssociation As MSXML2.IXMLDOMNode
'
Dim pIndexWeight As Long
Dim pNetwork As esriGeoDatabase.INetwork
Dim pNetSchema As esriGeoDatabase.INetSchema
Dim pNetWeight As esriGeoDatabase.INetWeight
Dim pNetWeightAssociation As esriGeoDatabase.INetWeightAssociation
Dim pEnumNetWeightAssociation As esriGeoDatabase.IEnumNetWeightAssociation
'
Dim pGxObject As esriCatalog.IGxObject
Dim pGxDataset As esriCatalog.IGxDataset
Dim pDataset As esriGeoDatabase.IDataset
Dim pGeometricNetwork As esriGeoDatabase.IGeometricNetwork
Dim pWorkspace As esriGeoDatabase.IWorkspace
Dim pFeatureWorkspace As esriGeoDatabase.IFeatureWorkspace
'
Dim pEnumRule As esriGeoDatabase.IEnumRule
Dim pRule As IRule
Dim pJunctionConnectivityRule2 As esriGeoDatabase.IJunctionConnectivityRule2
Dim pFeatureClassContainer As esriGeoDatabase.IFeatureClassContainer
'
Dim pFeatureClassEdge As esriGeoDatabase.IFeatureClass
Dim pDatasetEdge As esriGeoDatabase.IDataset
Dim pSubtypesEdge As esriGeoDatabase.ISubtypes
Dim pSubtypeNameEdge As String
'
Dim pFeatureClassJunction As esriGeoDatabase.IFeatureClass
Dim pDatasetJunction As esriGeoDatabase.IDataset
Dim pSubtypesJunction As esriGeoDatabase.ISubtypes
Dim pSubtypeNameJunction As String
'
Dim pEdgeConnectivityRule As esriGeoDatabase.IEdgeConnectivityRule
Dim pFeatureClassEdge1 As esriGeoDatabase.IFeatureClass
Dim pFeatureClassEdge2 As esriGeoDatabase.IFeatureClass
Dim pDatasetEdge1 As esriGeoDatabase.IDataset
Dim pDatasetEdge2 As esriGeoDatabase.IDataset
Dim pSubtypesEdge1 As esriGeoDatabase.ISubtypes
Dim pSubtypesEdge2 As esriGeoDatabase.ISubtypes
Dim pSubtypeEdgeName1 As String
Dim pSubtypeEdgeName2 As String
Dim pSubtypeJunctionName As String
Dim pJunctionCounter As Long
Dim pSQLSyntax As esriGeoDatabase.ISQLSyntax
Dim pDatabaseName As String
Dim pOwnerName As String
Dim pTableName As String
'---------------------------------
' Set GxApplication and StatusBar
'---------------------------------
Set pGxApplication = pApplication
Set pStatusBar = pApplication.StatusBar
'-----------------------
' Get GeometricNetwork.
'-----------------------
Set pGxObject = pGxApplication.SelectedObject
Set pGxDataset = pGxObject
Set pDataset = pGxDataset.Dataset
Set pWorkspace = pDataset.Workspace
Set pFeatureWorkspace = pWorkspace
Set pGeometricNetwork = pDataset
'----------------------------------
' Get new XML Document (in memory)
'----------------------------------
Set pDOMDocument = modCommon.NewXMLDocument
'------------------------
' Add header to XML file
'------------------------
Call modCommon.WriteGeodatabaseDesignerHeader(pDOMDocument, pWorkspace)
'--------------------------------------------------------------------
' Add GeometricNetwork to XML
' <geometricNetwork database="" owner="" table="" esriNetworkType=""
'--------------------------------------------------------------------
Set pXMLDOMNodeGeodatabaseDesigner = pDOMDocument.getElementsByTagName("geodatabaseDesigner").nextNode
Set pXMLDOMNodeGeometricNetwork = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "geometricNetwork", "")
Set pXMLDOMNodeGeometricNetwork = pXMLDOMNodeGeodatabaseDesigner.appendChild(pXMLDOMNodeGeometricNetwork)
Call AddQualifiedTableNameParts(pXMLDOMNodeGeometricNetwork, pDataset)
Call modCommon.AddNodeAttribute(pXMLDOMNodeGeometricNetwork, "esriNetworkType", CStr(pGeometricNetwork.NetworkType))
'----------------------------------------------------------------------------------------------------
' Add GN FeatureClasses to XML
' <featureClass database="" owner="" table="" esriFeatureType="" esriNetworkClassAncillaryRole="" />
'----------------------------------------------------------------------------------------------------
If mGNExportFeatureClass Then
pStatusBar.Message(0) = "Export GeometricNetwork: Writing Simple Junctions"
Call WriteNetworkClassToXML(pXMLDOMNodeGeometricNetwork, pGeometricNetwork, esriFTSimpleJunction)
pStatusBar.Message(0) = "Export GeometricNetwork: Writing Simple Edges"
Call WriteNetworkClassToXML(pXMLDOMNodeGeometricNetwork, pGeometricNetwork, esriFTSimpleEdge)
pStatusBar.Message(0) = "Export GeometricNetwork: Writing Complex Edges"
Call WriteNetworkClassToXML(pXMLDOMNodeGeometricNetwork, pGeometricNetwork, esriFTComplexEdge)
End If
'-----------------------------------------------------------
' Add all GeometricNetwork Weights
' <weight name="" esriweighttype="" bitGateSize="">
' <association database="" owner="" table="" field="" />
' </weight>
'-----------------------------------------------------------
Set pNetwork = pGeometricNetwork.Network
Set pNetSchema = pNetwork
'----------------------------------
' Loop through all Network Weights
'-----------------------------------
For pIndexWeight = 0 To pNetSchema.WeightCount - 1 Step 1
pStatusBar.Message(0) = "Export GeometricNetwork: Writing Weights " & CStr(pIndexWeight)
Set pNetWeight = pNetSchema.Weight(pIndexWeight)
'---------------------------------------------------
' Add Weight Node and Attributes
' <weight name="" esriweighttype="" bitGateSize="">
'---------------------------------------------------
Set pXMLDOMNodeWeight = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "weight", "")
Set pXMLDOMNodeWeight = pXMLDOMNodeGeometricNetwork.appendChild(pXMLDOMNodeWeight)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeWeight, "name", CStr(pNetWeight.WeightName))
Call modCommon.AddNodeAttribute(pXMLDOMNodeWeight, "esriWeightType", CStr(pNetWeight.WeightType))
If pNetWeight.WeightType = esriGeoDatabase.esriWeightType.esriWTBitGate Then
Call modCommon.AddNodeAttribute(pXMLDOMNodeWeight, "bitGateSize", CStr(pNetWeight.BitGateSize))
Else
Call modCommon.AddNodeAttribute(pXMLDOMNodeWeight, "bitGateSize", "")
End If
'--------------------------------------
' Loop through all Weight Associations
'--------------------------------------
Set pEnumNetWeightAssociation = pNetSchema.WeightAssociations(pIndexWeight)
Set pNetWeightAssociation = pEnumNetWeightAssociation.Next
Do Until pNetWeightAssociation Is Nothing
'-------------------------------------------------------
' Add WeightAssociation
' <association database="" owner="" table="" field=""/>
'-------------------------------------------------------
Set pXMLDOMNodeWeightAssociation = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "association", "")
Set pXMLDOMNodeWeightAssociation = pXMLDOMNodeWeight.appendChild(pXMLDOMNodeWeightAssociation)
'Call modCommon.AddNodeAttribute(pXMLDOMNodeWeightAssociation, "featureClass", pNetWeightAssociation.TableName)
Call AddQualifiedTableNameParts(pXMLDOMNodeWeightAssociation, pFeatureWorkspace.OpenFeatureClass(pNetWeightAssociation.TableName))
Call modCommon.AddNodeAttribute(pXMLDOMNodeWeightAssociation, "field", pNetWeightAssociation.FieldName)
'
Set pNetWeightAssociation = pEnumNetWeightAssociation.Next
Loop
Next pIndexWeight
'-----------------------------------------------------
' Add ALL Connectivity Rules
' <junctionConnectivityRule> & <edgeConnectivityRule>
'-----------------------------------------------------
Set pXMLDOMNodeJunctionConnRule = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "junctionConnectivityRule", "")
Set pXMLDOMNodeJunctionConnRule = pXMLDOMNodeGeometricNetwork.appendChild(pXMLDOMNodeJunctionConnRule)
Set pXMLDOMNodeEdgeConnRule = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "edgeConnectivityRule", "")
Set pXMLDOMNodeEdgeConnRule = pXMLDOMNodeGeometricNetwork.appendChild(pXMLDOMNodeEdgeConnRule)
'
Set pEnumRule = pGeometricNetwork.Rules
Set pRule = pEnumRule.Next
Set pFeatureClassContainer = pGeometricNetwork
'
pStatusBar.Message(0) = "Export GeometricNetwork: Writing Connectivity Rules"
'
Do Until pRule Is Nothing
If TypeOf pRule Is esriGeoDatabase.IJunctionConnectivityRule Then
If mGNExportJunctionConnRule Then
'-----------------------------
' Junction Connectivity Rules
'-----------------------------
Set pJunctionConnectivityRule2 = pRule
'---------------------
' Get Rule Properties
'---------------------
Set pFeatureClassEdge = pFeatureClassContainer.ClassByID(pJunctionConnectivityRule2.EdgeClassID)
Set pDatasetEdge = pFeatureClassEdge
Set pSubtypesEdge = pDatasetEdge
If pSubtypesEdge.HasSubtype Then
pSubtypeNameEdge = pSubtypesEdge.SubtypeName(pJunctionConnectivityRule2.EdgeSubtypeCode)
Else
pSubtypeNameEdge = ""
End If
'
Set pFeatureClassJunction = pFeatureClassContainer.ClassByID(pJunctionConnectivityRule2.JunctionClassID)
Set pDatasetJunction = pFeatureClassJunction
Set pSubtypesJunction = pDatasetJunction
If pSubtypesJunction.HasSubtype Then
pSubtypeNameJunction = pSubtypesJunction.SubtypeName(pJunctionConnectivityRule2.JunctionSubtypeCode)
Else
pSubtypeNameJunction = ""
End If
'----------------------------------------------
' Edge FC <edge database="" owner="" table="">
'----------------------------------------------
Set pSQLSyntax = pDatasetEdge.Workspace
Call pSQLSyntax.ParseTableName(CStr(pDatasetEdge.Name), pDatabaseName, pOwnerName, pTableName)
Set pXMLDOMNodeList = pXMLDOMNodeJunctionConnRule.selectNodes("edge[@database='" & pDatabaseName & "'" & _
" and @owner='" & pOwnerName & "'" & _
" and @table='" & pTableName & "']")
If pXMLDOMNodeList.length = 0 Then
'--------------
' Add New Node
'--------------
Set pXMLDOMNodeChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "edge", "")
Set pXMLDOMNodeChild = pXMLDOMNodeJunctionConnRule.appendChild(pXMLDOMNodeChild)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "database", pDatabaseName)
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "owner", pOwnerName)
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "table", pTableName)
'
Set pXMLDOMNodeParent = pXMLDOMNodeChild
Else
Set pXMLDOMNodeParent = pXMLDOMNodeList.nextNode
End If
'--------------------------------
' Edge Subtype <subtype name="">
'--------------------------------
Set pXMLDOMNodeList = pXMLDOMNodeParent.selectNodes("subtype[@name='" & CStr(pSubtypeNameEdge) & "']")
If pXMLDOMNodeList.length = 0 Then
'--------------
' Add New Node
'--------------
Set pXMLDOMNodeChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "subtype", "")
Set pXMLDOMNodeChild = pXMLDOMNodeParent.appendChild(pXMLDOMNodeChild)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "name", pSubtypeNameEdge)
'
Set pXMLDOMNodeParent = pXMLDOMNodeChild
Else
Set pXMLDOMNodeParent = pXMLDOMNodeList.nextNode
End If
'------------------------------------------------------
' Junction FC <junction database="" owner="" table="">
'------------------------------------------------------
Set pSQLSyntax = pDatasetJunction.Workspace
Call pSQLSyntax.ParseTableName(CStr(pDatasetJunction.Name), pDatabaseName, pOwnerName, pTableName)
Set pXMLDOMNodeList = pXMLDOMNodeJunctionConnRule.selectNodes("junction[@database='" & pDatabaseName & "'" & _
" and @owner='" & pOwnerName & "'" & _
" and @table='" & pTableName & "']")
If pXMLDOMNodeList.length = 0 Then
'--------------
' Add New Node
'--------------
Set pXMLDOMNodeChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "junction", "")
Set pXMLDOMNodeChild = pXMLDOMNodeParent.appendChild(pXMLDOMNodeChild)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "database", pDatabaseName)
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "owner", pOwnerName)
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "table", pTableName)
'
Set pXMLDOMNodeParent = pXMLDOMNodeChild
Else
Set pXMLDOMNodeParent = pXMLDOMNodeList.nextNode
End If
'----------------------------------------------------------------------------------
' Junction Subytype <subtype name="" eMin="" eMax="" jMin="" jMax="" default="" />
' Duplication not possible, hence no test.
'----------------------------------------------------------------------------------
Set pXMLDOMNodeChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "subtype", "")
Set pXMLDOMNodeChild = pXMLDOMNodeParent.appendChild(pXMLDOMNodeChild)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "name", pSubtypeNameJunction)
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "eMin", CStr(pJunctionConnectivityRule2.EdgeMinimumCardinality))
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "eMax", CStr(pJunctionConnectivityRule2.EdgeMaximumCardinality))
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "jMin", CStr(pJunctionConnectivityRule2.JunctionMinimumCardinality))
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "jMax", CStr(pJunctionConnectivityRule2.JunctionMaximumCardinality))
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "default", CStr(pJunctionConnectivityRule2.DefaultJunction))
End If
Else
If TypeOf pRule Is esriGeoDatabase.IEdgeConnectivityRule Then
If mGNExportEdgeConnRule Then
'-------------------------
' Edge Connectivity Rules
'-------------------------
Set pEdgeConnectivityRule = pRule
'---------------------
' Get Rule Properties
'---------------------
Set pFeatureClassEdge1 = pFeatureClassContainer.ClassByID(pEdgeConnectivityRule.FromEdgeClassID)
Set pFeatureClassEdge2 = pFeatureClassContainer.ClassByID(pEdgeConnectivityRule.ToEdgeClassID)
Set pDatasetEdge1 = pFeatureClassEdge1
Set pDatasetEdge2 = pFeatureClassEdge2
Set pSubtypesEdge1 = pFeatureClassEdge1
Set pSubtypesEdge2 = pFeatureClassEdge2
If pSubtypesEdge1.HasSubtype Then
pSubtypeEdgeName1 = pSubtypesEdge1.SubtypeName(pEdgeConnectivityRule.FromEdgeSubtypeCode)
Else
pSubtypeEdgeName1 = ""
End If
If pSubtypesEdge2.HasSubtype Then
pSubtypeEdgeName2 = pSubtypesEdge2.SubtypeName(pEdgeConnectivityRule.ToEdgeSubtypeCode)
Else
pSubtypeEdgeName2 = ""
End If
'--------------------------------------
' Add FROM Edge FC
' <edge database="" owner="" table="">
'--------------------------------------
Set pSQLSyntax = pDatasetEdge1.Workspace
Call pSQLSyntax.ParseTableName(CStr(pDatasetEdge1.Name), pDatabaseName, pOwnerName, pTableName)
Set pXMLDOMNodeList = pXMLDOMNodeJunctionConnRule.selectNodes("edge[@database='" & pDatabaseName & "'" & _
" and @owner='" & pOwnerName & "'" & _
" and @table='" & pTableName & "']")
If pXMLDOMNodeList.length = 0 Then
'--------------
' Add New Node
'--------------
Set pXMLDOMNodeChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "edge", "")
Set pXMLDOMNodeChild = pXMLDOMNodeEdgeConnRule.appendChild(pXMLDOMNodeChild)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "database", pDatabaseName)
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "owner", pOwnerName)
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "table", pTableName)
'
Set pXMLDOMNodeParent = pXMLDOMNodeChild
Else
Set pXMLDOMNodeParent = pXMLDOMNodeList.nextNode
End If
'---------------------------
' Add FROM Edge Subtype
' <subtype name="">
'---------------------------
Set pXMLDOMNodeList = pXMLDOMNodeParent.selectNodes("subtype[@name='" & CStr(pSubtypeEdgeName1) & "']")
If pXMLDOMNodeList.length = 0 Then
'--------------
' Add New Node
'--------------
Set pXMLDOMNodeChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "subtype", "")
Set pXMLDOMNodeChild = pXMLDOMNodeParent.appendChild(pXMLDOMNodeChild)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "name", pSubtypeEdgeName1)
'
Set pXMLDOMNodeParent = pXMLDOMNodeChild
Else
Set pXMLDOMNodeParent = pXMLDOMNodeList.nextNode
End If
'--------------------------------------
' Add TO Edge FC
' <edge database="" owner="" table="">
'--------------------------------------
Set pSQLSyntax = pDatasetEdge2.Workspace
Call pSQLSyntax.ParseTableName(CStr(pDatasetEdge2.Name), pDatabaseName, pOwnerName, pTableName)
Set pXMLDOMNodeList = pXMLDOMNodeJunctionConnRule.selectNodes("edge[@database='" & pDatabaseName & "'" & _
" and @owner='" & pOwnerName & "'" & _
" and @table='" & pTableName & "']")
If pXMLDOMNodeList.length = 0 Then
'--------------
' Add New Node
'--------------
Set pXMLDOMNodeChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "edge", "")
Set pXMLDOMNodeChild = pXMLDOMNodeParent.appendChild(pXMLDOMNodeChild)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "database", pDatabaseName)
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "owner", pOwnerName)
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "table", pTableName)
'
Set pXMLDOMNodeParent = pXMLDOMNodeChild
Else
Set pXMLDOMNodeParent = pXMLDOMNodeList.nextNode
End If
'---------------------------
' Add TO Edge Subtype
' <subtype name="">
'---------------------------
Set pXMLDOMNodeChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "subtype", "")
Set pXMLDOMNodeChild = pXMLDOMNodeParent.appendChild(pXMLDOMNodeChild)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "name", pSubtypeEdgeName2)
'
Set pXMLDOMNodeParent = pXMLDOMNodeChild
'----------------------------------
' Loop Through ALL Valid Junctions
'----------------------------------
For pJunctionCounter = 0 To pEdgeConnectivityRule.JunctionCount - 1 Step 1
Set pFeatureClassJunction = pFeatureClassContainer.ClassByID(pEdgeConnectivityRule.JunctionClassID(pJunctionCounter))
Set pDatasetJunction = pFeatureClassJunction
Set pSubtypesJunction = pFeatureClassJunction
pSubtypeJunctionName = pSubtypesJunction.SubtypeName(pEdgeConnectivityRule.JunctionSubtypeCode(pJunctionCounter))
'------------------------------------------
' Add VIA Junction FC
' <junction database="" owner="" table="">
'------------------------------------------
Set pSQLSyntax = pDatasetJunction.Workspace
Call pSQLSyntax.ParseTableName(CStr(pDatasetJunction.Name), pDatabaseName, pOwnerName, pTableName)
Set pXMLDOMNodeList = pXMLDOMNodeJunctionConnRule.selectNodes("junction[@database='" & pDatabaseName & "'" & _
" and @owner='" & pOwnerName & "'" & _
" and @table='" & pTableName & "']")
If pXMLDOMNodeList.length = 0 Then
'--------------
' Add New Node
'--------------
Set pXMLDOMNodeChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "junction", "")
Set pXMLDOMNodeChild = pXMLDOMNodeParent.appendChild(pXMLDOMNodeChild)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "database", pDatabaseName)
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "owner", pOwnerName)
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "table", pTableName)
'
Set pXMLDOMNodeParent2 = pXMLDOMNodeChild
Else
Set pXMLDOMNodeParent2 = pXMLDOMNodeList.nextNode
End If
'----------------------------------------
' Add VIA Junction Subtype
' <subtype name="" default="" />
'----------------------------------------
Set pXMLDOMNodeChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "subtype", "")
Set pXMLDOMNodeChild = pXMLDOMNodeParent2.appendChild(pXMLDOMNodeChild)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "name", pSubtypeJunctionName)
If pEdgeConnectivityRule.JunctionClassID(pJunctionCounter) = pEdgeConnectivityRule.DefaultJunctionClassID And _
pEdgeConnectivityRule.JunctionSubtypeCode(pJunctionCounter) = pEdgeConnectivityRule.DefaultJunctionSubtypeCode Then
'--------------------------
' Default Junction/Subtype
'--------------------------
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "default", "True")
Else
Call modCommon.AddNodeAttribute(pXMLDOMNodeChild, "default", "False")
End If
Next pJunctionCounter
End If
Else
' ===>>> ERROR <<<===
End If
End If
Set pRule = pEnumRule.Next
Loop
'-----------------
' Clear StatusBar
'-----------------
pStatusBar.Message(0) = ""
'---------------------
' Return XML Document
'---------------------
Set ExportGeometricNework = pDOMDocument
'
Exit Function
ErrorHandler:
Call HandleError(False, "ExportGeometricNework " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Private Sub WriteNetworkClassToXML(ByRef pXMLDOMNodeGeometricNetwork As MSXML2.IXMLDOMNode, _
ByRef pGeometricNetwork As esriGeoDatabase.IGeometricNetwork, _
ByRef pEsriFeatureType As esriGeoDatabase.esriFeatureType)
On Error GoTo ErrorHandler
'
Dim pEnumFeatureClass As esriGeoDatabase.IEnumFeatureClass
Dim pNetworkClass As esriGeoDatabase.INetworkClass
Dim pDataset As esriGeoDatabase.IDataset
Dim pXMLDOMNodeFeatureClass As MSXML2.IXMLDOMNode
'
Set pEnumFeatureClass = pGeometricNetwork.ClassesByType(pEsriFeatureType)
Set pNetworkClass = pEnumFeatureClass.Next
'
Do Until pNetworkClass Is Nothing
'------------------------------------------------------------------------------
' Add GN FeatureClasses to XML
' <featureClass name="" esriFeatureType="" esriNetworkClassAncillaryRole="" />
'------------------------------------------------------------------------------
If pNetworkClass.FeatureClassID = pGeometricNetwork.OrphanJunctionFeatureClass.FeatureClassID Then
'----------------------------------
' Skip Writing Orphan FeatureClass
'----------------------------------
Else
Set pXMLDOMNodeFeatureClass = pXMLDOMNodeGeometricNetwork.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "featureClass", "")
Set pXMLDOMNodeFeatureClass = pXMLDOMNodeGeometricNetwork.appendChild(pXMLDOMNodeFeatureClass)
Set pDataset = pNetworkClass
Call AddQualifiedTableNameParts(pXMLDOMNodeFeatureClass, pDataset)
Call modCommon.AddNodeAttribute(pXMLDOMNodeFeatureClass, "esriFeatureType", CStr(pEsriFeatureType))
If pEsriFeatureType = esriFTSimpleJunction Then
Call modCommon.AddNodeAttribute(pXMLDOMNodeFeatureClass, "esriNetworkClassAncillaryRole", CStr(pNetworkClass.NetworkAncillaryRole))
Else
Call modCommon.AddNodeAttribute(pXMLDOMNodeFeatureClass, "esriNetworkClassAncillaryRole", "")
End If
End If
'
Set pNetworkClass = pEnumFeatureClass.Next
Loop
'
Exit Sub
ErrorHandler:
Call HandleError(False, "WriteNetworkClassToXML " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
'==================================================================================
'----------------------------
' IMPORT - GEOMETRIC NETWORK
'----------------------------
Public Sub ImportGeometricNetwork(ByRef pApplication As esriFramework.IApplication)
On Error GoTo ErrorHandler
'------------------------------------------------------------------------
' Main Routine. This routine is called when the user clicks "Import GN"
' If a FeatureDataset is selected: (1) Create NEW GeometricNetwork
' (2) Add NEW Connectivity Rules
' If a GeometricNetwork is selected: (1) Add NEW Connectivity Rules
'------------------------------------------------------------------------
Dim pGxApplication As esriCatalogUI.IGxApplication
Dim pStatusBar As esriSystem.IStatusBar
Dim pMouseCursor As esriFramework.IMouseCursor
'
Dim pDOMDocument As MSXML2.DOMDocument
'
Dim pGxObject As esriCatalog.IGxObject
Dim pGxDataset As esriCatalog.IGxDataset
Dim pGeometricNetwork As esriGeoDatabase.IGeometricNetwork
Dim pDataset As esriGeoDatabase.IDataset
Dim pFeatureDataset As esriGeoDatabase.IFeatureDataset
'---------------------------------
' Set GxApplication and StatusBar
'---------------------------------
Set pGxApplication = pApplication
Set pStatusBar = pApplication.StatusBar
Set pGxObject = pGxApplication.SelectedObject
Set pGxDataset = pGxObject
Set pDataset = pGxDataset.Dataset
'----------------------------------------------
' Prompt for and open the source XML document.
'----------------------------------------------
Set pDOMDocument = modCommon.GetXMLDocument
If pDOMDocument Is Nothing Then
Exit Sub
End If
'---------------------
' Change Mouse Cursor
'---------------------
Set pMouseCursor = New esriFramework.MouseCursor
Call pMouseCursor.SetCursor(2)
'
Select Case pDataset.Type
Case esriDTFeatureDataset
'-------------------------------------------
' FeatureDataset Selected in ArcCatalog TOC
'-------------------------------------------
Set pFeatureDataset = pDataset
pStatusBar.Message(0) = "Creating New GeometricNetwork"
Set pGeometricNetwork = CreateGeometricNetwork(pDOMDocument, pFeatureDataset)
If pGeometricNetwork Is Nothing Then
MsgBox "GeometricNetwork Unsuccessful", vbCritical, App.FileDescription
Else
pStatusBar.Message(0) = "Importing Connectivity Rules"
Call ImportGeometricNetworkConnectivityRules(pDOMDocument, pGeometricNetwork)
pStatusBar.Message(0) = "Importing Network Weights"
Call ImportGeometricNetworkWeights(pDOMDocument, pGeometricNetwork)
End If
Case esriDTGeometricNetwork
'---------------------------------------------
' GeometricNetwork Selected in ArcCatalog TOC
'---------------------------------------------
Set pGeometricNetwork = pDataset
pStatusBar.Message(0) = "Importing Connectivity Rules"
Call ImportGeometricNetworkConnectivityRules(pDOMDocument, pGeometricNetwork)
End Select
'--------------------------------------
' Refresh ArcCatalog Table of Contents
'--------------------------------------
Call pGxApplication.Refresh(pGxApplication.SelectedObject.FullName)
'---------------------
' Restore MouseCursor
'---------------------
Set pMouseCursor = Nothing
'-----------------
' Clear StatusBar
'-----------------
pStatusBar.Message(0) = ""
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ImportGeometricNetwork " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Function CreateGeometricNetwork(ByRef pDOMDocument As MSXML2.DOMDocument, _
ByRef pFeatureDataset As esriGeoDatabase.IFeatureDataset) As esriGeoDatabase.IGeometricNetwork
On Error GoTo ErrorHandler
'----------------------------------------------------------
' Creates a NEW GeometricNetwork inside the FeatureDataset
'----------------------------------------------------------
Dim pNetworkLoader As esriNetworkAnalysis.INetworkLoader
Dim pNetworkLoader2 As esriNetworkAnalysis.INetworkLoader2
Dim pNetworkLoaderProps As esriNetworkAnalysis.INetworkLoaderProps
'
Dim pGeometricNetwork As esriGeoDatabase.IGeometricNetwork
Dim pNetworkCollection As esriGeoDatabase.INetworkCollection
Dim pFeatureClassContainer As esriGeoDatabase.IFeatureClassContainer
Dim pFeatureDatasetName As esriGeoDatabase.IFeatureDatasetName
Dim pFeatureClass As esriGeoDatabase.IFeatureClass
Dim pDataset As esriGeoDatabase.IDataset
'
Dim pUIDComplexEdge As esriSystem.UID
Dim pUIDSimpleEdge As esriSystem.UID
Dim pUIDSimpleJunction As esriSystem.UID
'
Dim pXMLDOMNodeGeometricNetwork As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeFeatureClass As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeListFeatureClass As MSXML2.IXMLDOMNodeList
'
Dim pIndex As Long
'----------------
' Set Interfaces
'----------------
Set pGeometricNetwork = Nothing
Set pNetworkCollection = pFeatureDataset
Set pFeatureClassContainer = pFeatureDataset
'---------------------------------------------
' Check if GN by the same name already exists
'---------------------------------------------
Set pXMLDOMNodeGeometricNetwork = pDOMDocument.getElementsByTagName("geometricNetwork").nextNode
For pIndex = 0 To pNetworkCollection.GeometricNetworkCount - 1 Step 1
If UCase(pXMLDOMNodeGeometricNetwork.Attributes.getNamedItem("table").Text) = _
UCase(modCommon.GetDataset(pNetworkCollection.GeometricNetwork(pIndex)).Name) Then
Select Case MsgBox("The GeometricNetwork already exists!" & vbCrLf & "Continue to load Connectivity Rules?", vbYesNoCancel, App.FileDescription)
Case vbYes
'----------------------------------------------------------------------
' Return GeometricNetwork to parent routine. Add Conn Rules to that GN
'----------------------------------------------------------------------
Set CreateGeometricNetwork = pNetworkCollection.GeometricNetwork(pIndex)
Exit Function
Case vbNo, vbCancel
'----------------------------------------------------------------------------------------
' User wants to backout completely. Return to parent routine with empty GeometricNetwork
'----------------------------------------------------------------------------------------
Exit Function
End Select
End If
Next pIndex
'----------------------
' Create a new network
'----------------------
Set pNetworkLoader = New NetworkLoader
Set pNetworkLoader2 = pNetworkLoader
Set pNetworkLoaderProps = pNetworkLoader
Set pFeatureDatasetName = pFeatureDataset.FullName
Set pNetworkLoader.FeatureDatasetName = pFeatureDatasetName
pNetworkLoader.NetworkName = CStr(pXMLDOMNodeGeometricNetwork.Attributes.getNamedItem("table").Text)
pNetworkLoader.NetworkType = CLng(pXMLDOMNodeGeometricNetwork.Attributes.getNamedItem("esriNetworkType").Text)
'-----------------------
' Create new Class ID's
'-----------------------
Set pUIDComplexEdge = New esriSystem.UID
Set pUIDSimpleEdge = New esriSystem.UID
Set pUIDSimpleJunction = New esriSystem.UID
pUIDComplexEdge.Value = CStr(GUID_COMPLEXEDGE_CLSID)
pUIDSimpleEdge.Value = CStr(GUID_SIMPLEEDGE_CLSID)
pUIDSimpleJunction.Value = CStr(GUID_SIMPLEJUNCTION_CLSID)
'----------------------------------
' Set snapping tolerance (if used)
'----------------------------------
Select Case mGNImportSnapping
Case -1
pNetworkLoader.SnapTolerance = pNetworkLoader2.MinSnapTolerance
Case 0
pNetworkLoader.SnapTolerance = pNetworkLoader2.MinSnapTolerance
Case Else
pNetworkLoader.SnapTolerance = mGNImportSnapping
End Select
'--------------------------------
' Loop through each FeatureClass
'--------------------------------
Set pXMLDOMNodeListFeatureClass = pXMLDOMNodeGeometricNetwork.selectNodes("featureClass")
For pIndex = 0 To pXMLDOMNodeListFeatureClass.length - 1 Step 1
'-------------------------
' Get Source FeatureClass
'-------------------------
Set pXMLDOMNodeFeatureClass = pXMLDOMNodeListFeatureClass.Item(pIndex)
Set pFeatureClass = pFeatureClassContainer.ClassByName(pXMLDOMNodeFeatureClass.Attributes.getNamedItem("table").Text)
Set pDataset = pFeatureClass
'-----------------------------------
' Check if FeatureClass is suitable
'-----------------------------------
Select Case CLng(pNetworkLoader2.CanUseFeatureClass(pDataset.Name))
Case esriNetworkAnalysis.esriNetworkLoaderFeatureClassCheck.esriNLFCCCannotOpen
MsgBox pDataset.Name & " cannot be opened.", vbCritical, App.FileDescription
Exit Function
Case esriNetworkAnalysis.esriNetworkLoaderFeatureClassCheck.esriNLFCCInAnotherNetwork
MsgBox pDataset.Name & " is already in another network.", vbCritical, App.FileDescription
Exit Function
Case esriNetworkAnalysis.esriNetworkLoaderFeatureClassCheck.esriNLFCCInvalidFeatureType
MsgBox pDataset.Name & " has invalid type.", vbCritical, App.FileDescription
Exit Function
Case esriNetworkAnalysis.esriNetworkLoaderFeatureClassCheck.esriNLFCCInvalidShapeType
MsgBox pDataset.Name & " does not have point or line geometry.", vbCritical, App.FileDescription
Exit Function
Case esriNetworkAnalysis.esriNetworkLoaderFeatureClassCheck.esriNLFCCRegisteredAsVersioned
MsgBox pDataset.Name & " is registered as versioned.", vbCritical, App.FileDescription
Exit Function
Case esriNetworkAnalysis.esriNetworkLoaderFeatureClassCheck.esriNLFCCUnknownError
MsgBox pDataset.Name & ": An unknown error was encountered.", vbCritical, App.FileDescription
Exit Function
Case esriNetworkAnalysis.esriNetworkLoaderFeatureClassCheck.esriNLFCCValid
'-------------------------------------------------------
' The given feature class can participate in a network.
'-------------------------------------------------------
Case Else
' <<<---- XML ERROR?
End Select
'--------------------------------------------------
' Check if FeatureClass has a valid Enabled Field.
'--------------------------------------------------
Select Case pNetworkLoader2.CheckEnabledDisabledField(pDataset.Name, pNetworkLoaderProps.DefaultEnabledField)
Case esriNLFCValid
'----------------------------------------------------
' Enabled field found and is OK: Action not required
'----------------------------------------------------
Case esriNLFCNotFound
'-------------------------------------------------
' Enabled field not found. Safe to add the field.
'-------------------------------------------------
Call pNetworkLoader.PutEnabledDisabledFieldName(pDataset.Name, pNetworkLoaderProps.DefaultAncillaryRoleField)
Case esriNLFCInvalidType
MsgBox pDataset.Name & ": The ENABLED field has invalid type.", vbCritical, App.FileDescription
Exit Function
Case esriNLFCInvalidDomain
MsgBox pDataset.Name & ": The ENABLED field has invalid domain.", vbCritical, App.FileDescription
Exit Function
Case esriNLFCUnknownError
MsgBox pDataset.Name & ": (ENABLED Field)- An unknown error was encountered.", vbCritical, App.FileDescription
Exit Function
Case Else
' <<<---- XML ERROR?
End Select
'--------------------------------------------------------------------
' Check if Junctions FeatureClasses have an existing Ancillary Field
'--------------------------------------------------------------------
Select Case CLng(pXMLDOMNodeFeatureClass.Attributes.getNamedItem("esriFeatureType").Text)
Case esriFTSimpleJunction
Select Case CLng(pXMLDOMNodeFeatureClass.Attributes.getNamedItem("esriNetworkClassAncillaryRole").Text)
Case esriNCARNone
'--------------------------------------------
' This Junction FC will not be a Source/Sink
'--------------------------------------------
Case esriNCARSourceSink
'------------------------------------------------
' Check if Junction FC already has a ROLE field.
'------------------------------------------------
Select Case pNetworkLoader2.CheckAncillaryRoleField(pDataset.Name, pNetworkLoaderProps.DefaultAncillaryRoleField)
Case esriNLFCValid
'----------------------------------------------------
' Enabled field found and is OK: Action not required
'----------------------------------------------------
Case esriNLFCNotFound
'-------------------------------------------------
' Enabled field not found. Safe to add the field.
'-------------------------------------------------
Call pNetworkLoader.PutAncillaryRole(pDataset.Name, _
esriNCARSourceSink, _
pNetworkLoaderProps.DefaultAncillaryRoleField)
Case esriNLFCInvalidType
MsgBox pDataset.Name & ": The ROLE field has invalid type.", vbCritical, App.FileDescription
Exit Function
Case esriNLFCInvalidDomain
MsgBox pDataset.Name & ": The ROLE field has invalid domain.", vbCritical, App.FileDescription
Exit Function
Case esriNLFCUnknownError
MsgBox pDataset.Name & ": (ROLE Field)- An unknown error was encountered.", vbCritical, App.FileDescription
Exit Function
Case Else
' <<<---- XML ERROR?
End Select
Case Else
' <<<---- XML ERROR?
End Select
Case esriFTSimpleEdge, esriFTComplexEdge
'--------------------
' No Action Required
'--------------------
Case Else
' <<<---- XML ERROR?
End Select
'-------------------------------------------------------
' Add FeatureClass to GeometricNetwork
' FeatureClasses will snap if (mGNImportSnapping <> -1)
'-------------------------------------------------------
Select Case CLng(pXMLDOMNodeFeatureClass.Attributes.getNamedItem("esriFeatureType").Text)
Case esriFTSimpleJunction
Call pNetworkLoader.AddFeatureClass(pDataset.Name, esriFTSimpleJunction, pUIDSimpleJunction, CBool(mGNImportSnapping <> -1))
Case esriFTSimpleEdge
Call pNetworkLoader.AddFeatureClass(pDataset.Name, esriFTSimpleEdge, pUIDSimpleEdge, CBool(mGNImportSnapping <> -1))
Case esriFTComplexEdge
Call pNetworkLoader.AddFeatureClass(pDataset.Name, esriFTComplexEdge, pUIDComplexEdge, CBool(mGNImportSnapping <> -1))
Case Else
'--------------------------------------------
' Not possible. Error already trapped above.
'--------------------------------------------
End Select
Next pIndex
'------------------------------------------
' If already then preserve existing values
'------------------------------------------
pNetworkLoader2.PreserveEnabledValues = mGNImportPreserveEnabledValue
'----------------------------
' OK, Lets load then Network
'----------------------------
pNetworkLoader.LoadNetwork
'---------------------------------
' Return the NEW GeometricNetwork
'---------------------------------
Set CreateGeometricNetwork = pNetworkCollection.GeometricNetworkByName(pXMLDOMNodeGeometricNetwork.Attributes.getNamedItem("table").Text)
'-----------------
' Clear Variables
'-----------------
Set pNetworkLoader = Nothing
Set pNetworkLoader2 = Nothing
Set pNetworkLoaderProps = Nothing
'
Set pGeometricNetwork = Nothing
Set pNetworkCollection = Nothing
Set pFeatureClassContainer = Nothing
Set pFeatureDatasetName = Nothing
Set pFeatureClass = Nothing
Set pDataset = Nothing
'
Set pUIDComplexEdge = Nothing
Set pUIDSimpleEdge = Nothing
Set pUIDSimpleJunction = Nothing
'
Set pXMLDOMNodeGeometricNetwork = Nothing
Set pXMLDOMNodeFeatureClass = Nothing
Set pXMLDOMNodeListFeatureClass = Nothing
'
Exit Function
ErrorHandler:
Call HandleError(False, "CreateGeometricNetwork " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Private Sub ImportGeometricNetworkConnectivityRules(ByRef pDOMDocument As MSXML2.DOMDocument, _
ByRef pGeometricNetwork As esriGeoDatabase.IGeometricNetwork)
On Error GoTo ErrorHandler
'------------------------------------------------------------------------------------------
' This Routine will recreate a GeometricNetwork (and Connectivity Rules) from an XML file.
'------------------------------------------------------------------------------------------
Dim pJunctionConnectivityRule2 As esriGeoDatabase.IJunctionConnectivityRule2
Dim pEdgeConnectivityRule As esriGeoDatabase.IEdgeConnectivityRule
Dim pFeatureClassContainer As esriGeoDatabase.IFeatureClassContainer
Dim pFeatureClass As esriGeoDatabase.IFeatureClass
'
Dim pXMLDOMNodeEdgeList As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeEdgeSubtypeList As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeJunctionList As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeJunctionSubtypeList As MSXML2.IXMLDOMNodeList
'
Dim pXMLDOMNodeGNRules As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeEdge As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeEdgeSubtype As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeJunction As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeJunctionSubtype As MSXML2.IXMLDOMNode
'
Dim pXMLDOMNodeEdge1 As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeEdge2 As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeEdgeSubtype1 As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeEdgeSubtype2 As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeEdgeList1 As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeEdgeList2 As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeEdgeSubtypeList1 As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeEdgeSubtypeList2 As MSXML2.IXMLDOMNodeList
'
Dim pIndexEdge As Long
Dim pIndexEdgeSubtype As Long
Dim pIndexJunction As Long
Dim pIndexJunctionSubtype As Long
'
Dim pIndexEdge1 As Long
Dim pIndexEdge2 As Long
Dim pIndexEdgeSubtype1 As Long
Dim pIndexEdgeSubtype2 As Long
'----------------------------------------
' Delete all existing Connectivity Rules
'----------------------------------------
If mGNImportClearConnRule Then
Call RemoveConnectivityRules(pGeometricNetwork)
End If
'------------------------------------------------------------------------------------------------------
' QI to IFeatureClassContainer. This will be used to get the ObjectClass ID from the FeatureClass name
'------------------------------------------------------------------------------------------------------
Set pFeatureClassContainer = pGeometricNetwork
'-------------------------------------
' Junction Connectivity Rules
' Get <junctionConnectivityRule> Node
'-------------------------------------
Set pXMLDOMNodeGNRules = pDOMDocument.getElementsByTagName("junctionConnectivityRule").nextNode
Set pXMLDOMNodeEdgeList = pXMLDOMNodeGNRules.childNodes
'--------------------------------------
' Loop through each EDGE
' <edge database="" owner="" table="">
'--------------------------------------
For pIndexEdge = 0 To pXMLDOMNodeEdgeList.length - 1 Step 1
Set pXMLDOMNodeEdge = pXMLDOMNodeEdgeList.Item(pIndexEdge)
Set pXMLDOMNodeEdgeSubtypeList = pXMLDOMNodeEdge.childNodes
'--------------------------------
' Loop through each EDGE SUBTYPE
' <subtype name="Cable TV Line">
'--------------------------------
For pIndexEdgeSubtype = 0 To pXMLDOMNodeEdgeSubtypeList.length - 1 Step 1
Set pXMLDOMNodeEdgeSubtype = pXMLDOMNodeEdgeSubtypeList.Item(pIndexEdgeSubtype)
Set pXMLDOMNodeJunctionList = pXMLDOMNodeEdgeSubtype.childNodes
'------------------------------------------
' Loop through each JUNCTION
' <junction database="" owner="" table="">
'------------------------------------------
For pIndexJunction = 0 To pXMLDOMNodeJunctionList.length - 1 Step 1
Set pXMLDOMNodeJunction = pXMLDOMNodeJunctionList.Item(pIndexJunction)
Set pXMLDOMNodeJunctionSubtypeList = pXMLDOMNodeJunction.childNodes
'------------------------------------------------------------
' Loop through each JUNCTION SUBTYPE
' <subtype name="Service Pillar"
' eMin="-1" eMax="-1" jMin="-1" jMax="-1" default="True" />
'------------------------------------------------------------
For pIndexJunctionSubtype = 0 To pXMLDOMNodeJunctionSubtypeList.length - 1 Step 1
Set pXMLDOMNodeJunctionSubtype = pXMLDOMNodeJunctionSubtypeList.Item(pIndexJunctionSubtype)
'----------------------------------------------------
' Add Junction Connectivity Rule to GeometricNetwork
'----------------------------------------------------
Set pJunctionConnectivityRule2 = New JunctionConnectivityRule
'-----------------------------------
' Set Edge FeatureClass and Subtype
'-----------------------------------
Set pFeatureClass = pFeatureClassContainer.ClassByName(pXMLDOMNodeEdge.Attributes.getNamedItem("table").Text)
pJunctionConnectivityRule2.EdgeClassID = pFeatureClass.FeatureClassID
pJunctionConnectivityRule2.EdgeSubtypeCode = GetSubtypeCodeFromName(pFeatureClass, pXMLDOMNodeEdgeSubtype.Attributes.getNamedItem("name").Text)
'---------------------------------------
' Set Junction FeatureClass and Subtype
'---------------------------------------
Set pFeatureClass = pFeatureClassContainer.ClassByName(pXMLDOMNodeJunction.Attributes.getNamedItem("table").Text)
pJunctionConnectivityRule2.JunctionClassID = pFeatureClass.FeatureClassID
pJunctionConnectivityRule2.JunctionSubtypeCode = GetSubtypeCodeFromName(pFeatureClass, pXMLDOMNodeJunctionSubtype.Attributes.getNamedItem("name").Text)
'-----------------------------------
' Set Edge and Junction Cardinality
'-----------------------------------
pJunctionConnectivityRule2.EdgeMinimumCardinality = CLng(pXMLDOMNodeJunctionSubtype.Attributes.getNamedItem("eMin").Text)
pJunctionConnectivityRule2.EdgeMaximumCardinality = CLng(pXMLDOMNodeJunctionSubtype.Attributes.getNamedItem("eMax").Text)
pJunctionConnectivityRule2.JunctionMinimumCardinality = CLng(pXMLDOMNodeJunctionSubtype.Attributes.getNamedItem("jMin").Text)
pJunctionConnectivityRule2.JunctionMaximumCardinality = CLng(pXMLDOMNodeJunctionSubtype.Attributes.getNamedItem("jMax").Text)
'----------------------
' Set Default Junction
'----------------------
If CBool(pXMLDOMNodeJunctionSubtype.Attributes.getNamedItem("default").Text) Then
pJunctionConnectivityRule2.DefaultJunction = True
End If
'------------------------------
' Add Rule to GeometricNetwork
'------------------------------
Call pGeometricNetwork.AddRule(pJunctionConnectivityRule2)
Next pIndexJunctionSubtype
Next pIndexJunction
Next pIndexEdgeSubtype
Next pIndexEdge
'-------------------------
' Edge Connectivity Rules
' <edgeConnectivityRule>
'-------------------------
Set pXMLDOMNodeGNRules = pDOMDocument.getElementsByTagName("edgeConnectivityRule").nextNode
Set pXMLDOMNodeEdgeList1 = pXMLDOMNodeGNRules.childNodes
'--------------------------------------
' Loop through each FROM EDGE 1
' <edge database="" owner="" table="">
'--------------------------------------
For pIndexEdge1 = 0 To pXMLDOMNodeEdgeList1.length - 1 Step 1
Set pXMLDOMNodeEdge1 = pXMLDOMNodeEdgeList1.Item(pIndexEdge1)
Set pXMLDOMNodeEdgeSubtypeList1 = pXMLDOMNodeEdge1.childNodes
'----------------------------------
' Loop through each EDGE SUBTYPE 1
' <subtype name="Cable TV Line">
'----------------------------------
For pIndexEdgeSubtype1 = 0 To pXMLDOMNodeEdgeSubtypeList1.length - 1 Step 1
Set pXMLDOMNodeEdgeSubtype1 = pXMLDOMNodeEdgeSubtypeList1.Item(pIndexEdgeSubtype1)
Set pXMLDOMNodeEdgeList2 = pXMLDOMNodeEdgeSubtype1.childNodes
'------------------------------------------
' Loop through each EDGE 2
' <junction database="" owner="" table="">
'------------------------------------------
For pIndexEdge2 = 0 To pXMLDOMNodeEdgeList2.length - 1 Step 1
Set pXMLDOMNodeEdge2 = pXMLDOMNodeEdgeList2.Item(pIndexEdge2)
Set pXMLDOMNodeEdgeSubtypeList2 = pXMLDOMNodeEdge2.childNodes
'----------------------------------
' Loop through each EDGE SUBTYPE 2
' <subtype name="Cable TV Line">
'----------------------------------
For pIndexEdgeSubtype2 = 0 To pXMLDOMNodeEdgeSubtypeList2.length - 1 Step 1
Set pXMLDOMNodeEdgeSubtype2 = pXMLDOMNodeEdgeSubtypeList2.Item(pIndexEdgeSubtype2)
Set pXMLDOMNodeJunctionList = pXMLDOMNodeEdgeSubtype2.childNodes
'-------------------------------------------------------------
' Create a NEW Edge Connectivity Rule - Add FROM and TO Edges
'-------------------------------------------------------------
Set pEdgeConnectivityRule = New esriGeoDatabase.EdgeConnectivityRule
'----------------------------------------
' Set From Edge FeatureClass and Subtype
'----------------------------------------
Set pFeatureClass = pFeatureClassContainer.ClassByName(pXMLDOMNodeEdge1.Attributes.getNamedItem("table").Text)
pEdgeConnectivityRule.FromEdgeClassID = pFeatureClass.FeatureClassID
pEdgeConnectivityRule.FromEdgeSubtypeCode = GetSubtypeCodeFromName(pFeatureClass, pXMLDOMNodeEdgeSubtype1.Attributes.getNamedItem("name").Text)
'--------------------------------------
' Set To Edge FeatureClass and Subtype
'--------------------------------------
Set pFeatureClass = pFeatureClassContainer.ClassByName(pXMLDOMNodeEdge2.Attributes.getNamedItem("table").Text)
pEdgeConnectivityRule.ToEdgeClassID = pFeatureClass.FeatureClassID
pEdgeConnectivityRule.ToEdgeSubtypeCode = GetSubtypeCodeFromName(pFeatureClass, pXMLDOMNodeEdgeSubtype2.Attributes.getNamedItem("name").Text)
'-----------------------------------------------
' Loop through each JUNCTION
' <junction database="" owner="" table="">
'-----------------------------------------------
For pIndexJunction = 0 To pXMLDOMNodeJunctionList.length - 1 Step 1
Set pXMLDOMNodeJunction = pXMLDOMNodeJunctionList.Item(pIndexJunction)
Set pXMLDOMNodeJunctionSubtypeList = pXMLDOMNodeJunction.childNodes
Set pFeatureClass = pFeatureClassContainer.ClassByName(pXMLDOMNodeJunction.Attributes.getNamedItem("table").Text)
'------------------------------------------------------
' Loop through each JUNCTION SUBTYPE
' <subtype name="EF_DetailedDrawing" default="True" />
'------------------------------------------------------
For pIndexJunctionSubtype = 0 To pXMLDOMNodeJunctionSubtypeList.length - 1 Step 1
Set pXMLDOMNodeJunctionSubtype = pXMLDOMNodeJunctionSubtypeList.Item(pIndexJunctionSubtype)
'
Call pEdgeConnectivityRule.AddJunction(pFeatureClass.FeatureClassID, _
GetSubtypeCodeFromName(pFeatureClass, pXMLDOMNodeJunctionSubtype.Attributes.getNamedItem("name").Text))
If CBool(pXMLDOMNodeJunctionSubtype.Attributes.getNamedItem("default").Text) Then
pEdgeConnectivityRule.DefaultJunctionClassID = pFeatureClass.FeatureClassID
pEdgeConnectivityRule.DefaultJunctionSubtypeCode = GetSubtypeCodeFromName(pFeatureClass, pXMLDOMNodeJunctionSubtype.Attributes.getNamedItem("name").Text)
End If
Next pIndexJunctionSubtype
Next pIndexJunction
'------------------------------------------------
' Add Edge Connectivity Rule to GeometricNetwork
'------------------------------------------------
Call pGeometricNetwork.AddRule(pEdgeConnectivityRule)
Next pIndexEdgeSubtype2
Next pIndexEdge2
Next pIndexEdgeSubtype1
Next pIndexEdge1
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ImportGeometricNetworkConnectivityRules " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ImportGeometricNetworkWeights(ByRef pDOMDocument As MSXML2.DOMDocument, _
ByRef pGeometricNetwork As esriGeoDatabase.IGeometricNetwork)
On Error GoTo ErrorHandler
'
'-------------------------------------------------------
' This Routine will add Weights to the GeometricNetwork
'-------------------------------------------------------
Dim pNetwork As esriGeoDatabase.INetwork
Dim pNetSchema As esriGeoDatabase.INetSchema
Dim pNetSchemaEdit As esriGeoDatabase.INetSchemaEdit
Dim pNetWeight As esriGeoDatabase.INetWeight
Dim pNetWeightEdit As esriGeoDatabase.INetWeightEdit
Dim pNetWeightAssociation As INetWeightAssociation
Dim pNetWeightAssociationEdit As INetWeightAssociationEdit
Dim pNetworkUpdate As INetworkUpdate
'
Dim pXMLDOMNodeGeometricNetwork As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeListWeight As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeListWeightAssociation As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeWeight As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeWeightAssociation As MSXML2.IXMLDOMNode
'
Dim pIndexWeight As Long
Dim pIndexWeightAssociation As Long
'
Set pNetwork = pGeometricNetwork.Network
Set pNetworkUpdate = pNetwork
Set pNetSchema = pNetwork
Set pNetSchemaEdit = pNetSchema
'-----------------------
' Start Schema Updating
'-----------------------
pNetworkUpdate.StartSchemaUpdating
'
Set pXMLDOMNodeGeometricNetwork = pDOMDocument.getElementsByTagName("geometricNetwork").nextNode
Set pXMLDOMNodeListWeight = pXMLDOMNodeGeometricNetwork.selectNodes("weight")
'---------------------------------------------------
' Loop through all WEIGHTS in the XML file.
' <weight name="" esriWeightType="" bitGateSize="">
'---------------------------------------------------
For pIndexWeight = 0 To pXMLDOMNodeListWeight.length - 1 Step 1
Set pXMLDOMNodeWeight = pXMLDOMNodeListWeight(pIndexWeight)
'
Set pNetWeight = New NetWeight
Set pNetWeightEdit = pNetWeight
pNetWeightEdit.WeightName = CStr(pXMLDOMNodeWeight.Attributes.getNamedItem("name").Text)
pNetWeightEdit.WeightType = CLng(pXMLDOMNodeWeight.Attributes.getNamedItem("esriWeightType").Text)
If pNetWeight.WeightType = esriGeoDatabase.esriWeightType.esriWTBitGate Then
pNetWeightEdit.BitGateSize = CLng(pXMLDOMNodeWeight.Attributes.getNamedItem("bitGateSize").Text)
End If
'------------
' Add WEIGHT
'------------
Call pNetSchemaEdit.AddWeight(pNetWeight)
'-------------------------------------------------
' Loop through all WEIGHT ASSOCIATIONS
' <association featureClass="" field=""/>
'-------------------------------------------------
Set pXMLDOMNodeListWeightAssociation = pXMLDOMNodeWeight.selectNodes("association")
For pIndexWeightAssociation = 0 To pXMLDOMNodeListWeightAssociation.length - 1 Step 1
Set pXMLDOMNodeWeightAssociation = pXMLDOMNodeListWeightAssociation.Item(pIndexWeightAssociation)
'
Set pNetWeightAssociation = New NetWeightAssociation
Set pNetWeightAssociationEdit = pNetWeightAssociation
pNetWeightAssociationEdit.WeightID = pNetWeight.WeightID
pNetWeightAssociationEdit.TableName = CStr(pXMLDOMNodeWeightAssociation.Attributes.getNamedItem("table").Text)
pNetWeightAssociationEdit.FieldName = CStr(pXMLDOMNodeWeightAssociation.Attributes.getNamedItem("field").Text)
'------------------------
' Add WEIGHT ASSOCIATION
'------------------------
Call pNetSchemaEdit.AddWeightAssociation(pNetWeightAssociation)
Next pIndexWeightAssociation
Next pIndexWeight
'----------------------
' Stop Schema Updating
'----------------------
pNetworkUpdate.StopSchemaUpdating
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ImportGeometricNetworkWeights " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
'==================================================================================
'------------------------------------
' EXPORT - Geodatabase ObjectClasses
'------------------------------------
Public Function ExportGDB(ByRef pApplication As esriFramework.IApplication) As MSXML2.DOMDocument
On Error GoTo ErrorHandler
'
Dim pGxApplication As esriCatalogUI.IGxApplication
Dim pStatusBar As esriSystem.IStatusBar
'
Dim pGxObject As esriCatalog.IGxObject
Dim pGxDatabase As esriCatalog.IGxDatabase
Dim pWorkspace As esriGeoDatabase.IWorkspace
Dim pEnumDataset As esriGeoDatabase.IEnumDataset
Dim pDataset As esriGeoDatabase.IDataset
'
Dim pDOMDocument As MSXML2.DOMDocument
Dim pXMLDOMNodeGeodatabaseDesigner As MSXML2.IXMLDOMNode
'---------------------------------
' Set GxApplication and StatusBar
'---------------------------------
Set pGxApplication = pApplication
Set pStatusBar = pApplication.StatusBar
'-------------------------
' Get Workspace Interface
'-------------------------
Set pGxObject = pGxApplication.SelectedObject
If TypeOf pGxObject Is esriCatalog.IGxDatabase Then
Set pGxDatabase = pGxObject
Set pWorkspace = pGxDatabase.Workspace
If pWorkspace.Type = esriFileSystemWorkspace Then
MsgBox "Please select a Geodatabase", vbExclamation, App.FileDescription
Exit Function
End If
Else
MsgBox "Please select a Geodatabase", vbExclamation, App.FileDescription
Exit Function
End If
'----------------------------------
' Get new XML Document (in memory)
'----------------------------------
Set pDOMDocument = modCommon.NewXMLDocument
'------------------------
' Add header to XML file
'------------------------
Call modCommon.WriteGeodatabaseDesignerHeader(pDOMDocument, pWorkspace)
'----------------------------
' Get GeodatabaseDesigner Node
'------------------------------
Set pXMLDOMNodeGeodatabaseDesigner = pDOMDocument.getElementsByTagName("geodatabaseDesigner").nextNode
'------------------------------------------------
' Iterate through each IDataset under IWorkspace
'------------------------------------------------
Set pEnumDataset = pWorkspace.Datasets(esriDTAny)
Set pDataset = pEnumDataset.Next
Do Until pDataset Is Nothing
Select Case pDataset.Type
Case esriGeoDatabase.esriDatasetType.esriDTFeatureDataset
'-----------------------------
' Document the FeatureDataset
'-----------------------------
Call ExportGDB_FeatureDataset(pXMLDOMNodeGeodatabaseDesigner, pDataset, pStatusBar)
Case esriGeoDatabase.esriDatasetType.esriDTFeatureClass, esriGeoDatabase.esriDatasetType.esriDTTable
'--------------------------
' Document the ObjectClass
'--------------------------
pStatusBar.Message(0) = "Exporting ObjectClass: " & pDataset.Name
Call ExportGDB_ObjectClass(pXMLDOMNodeGeodatabaseDesigner, pDataset)
End Select
'
Set pDataset = pEnumDataset.Next
Loop
'-----------------
' Clear StatusBar
'-----------------
pStatusBar.Message(0) = ""
'---------------------
' Return XML Document
'---------------------
Set ExportGDB = pDOMDocument
'
Exit Function
ErrorHandler:
Call HandleError(False, "ExportGDB " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Private Sub ExportGDB_FeatureDataset(ByRef pXMLDOMNodeParent As MSXML2.IXMLDOMNode, _
ByRef pFeatureDataset As esriGeoDatabase.IFeatureDataset, _
ByRef pStatusBar As esriSystem.IStatusBar)
On Error GoTo ErrorHandler
'------------------------------------------------
' <featureDataset database="" owner="" table="">
'------------------------------------------------
Dim pFeatureClassContainer As esriGeoDatabase.IFeatureClassContainer
Dim pEnumFeatureClass As esriGeoDatabase.IEnumFeatureClass
Dim pFeatureClass As esriGeoDatabase.IFeatureClass
Dim pGeoDataset As esriGeoDatabase.IGeoDataset
Dim pDatasetFeatureClass As esriGeoDatabase.IDataset
'
Dim pXMLDOMNodeFeatureDataset As MSXML2.IXMLDOMNode
'------------------------------
' ADD the FeatureDataset Node
'------------------------------
Set pXMLDOMNodeFeatureDataset = pXMLDOMNodeParent.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "featureDataset", "")
Set pXMLDOMNodeFeatureDataset = pXMLDOMNodeParent.appendChild(pXMLDOMNodeFeatureDataset)
Call AddQualifiedTableNameParts(pXMLDOMNodeFeatureDataset, pFeatureDataset)
'-----------------------------------------------
' Export the FeatureDataset's Spatial Reference
'-----------------------------------------------
Set pGeoDataset = pFeatureDataset
Call ExportGDB_SpatialReference(pXMLDOMNodeFeatureDataset, pGeoDataset.SpatialReference)
'-----------------------------------------
' Iterate through each child FeatureClass
'-----------------------------------------
Set pFeatureClassContainer = pFeatureDataset
Set pEnumFeatureClass = pFeatureClassContainer.Classes
Set pFeatureClass = pEnumFeatureClass.Next
Set pDatasetFeatureClass = pFeatureClass
'
Do Until pFeatureClass Is Nothing
pStatusBar.Message(0) = "Exporting ObjectClass: " & pDatasetFeatureClass.Name
Call ExportGDB_ObjectClass(pXMLDOMNodeFeatureDataset, pFeatureClass)
'
Set pFeatureClass = pEnumFeatureClass.Next
Loop
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ExportGDB_FeatureDataset " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ExportGDB_SpatialReference(ByRef pXMLDOMNodeParent As MSXML2.IXMLDOMNode, _
ByRef pSpatialReference As esriGeometry.ISpatialReference)
On Error GoTo ErrorHandler
'---------------------------------------------------------------------
' <spatialReference minX="" minY="" maxX="" maxY="" precisionXY=""
' minM="" maxM="" precisionM=""
' minZ="" maxZ="" precisionZ=""
' coordinateSystemDescription=""/>
'---------------------------------------------------------------------
Dim pXMLDOMNodeSpatialReference As MSXML2.IXMLDOMNode
Dim pBuffer As String * 2048
Dim pBytes As Long
Dim pESRISpatialReference As esriGeometry.IESRISpatialReference
' Minimum
Dim pXMin As Double
Dim pYMin As Double
Dim pMMin As Double
Dim pZMin As Double
' Maximum
Dim pXMax As Double
Dim pYMax As Double
Dim pMMax As Double
Dim pZMax As Double
' Precision
Dim pXYPrecision As Double
Dim pMPrecision As Double
Dim pZPrecision As Double
' False Origin
Dim pXFalse As Double
Dim pYFalse As Double
Dim pMFalse As Double
Dim pZFalse As Double
'----------------------------
' Add Spatial Reference Node
'----------------------------
Set pXMLDOMNodeSpatialReference = pXMLDOMNodeParent.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "spatialReference", "")
Set pXMLDOMNodeSpatialReference = pXMLDOMNodeParent.appendChild(pXMLDOMNodeSpatialReference)
'------------------------------------------------
' Write "X" & "Y"
' minX="" minY="" precisionXY=""
'------------------------------------------------
If pSpatialReference.HasXYPrecision Then
Call pSpatialReference.GetDomain(pXMin, pXMax, pYMin, pYMax)
Call pSpatialReference.GetFalseOriginAndUnits(pXFalse, pYFalse, pXYPrecision)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "minX", CStr(pXMin))
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "minY", CStr(pYMin))
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "precisionXY", CStr(pXYPrecision))
Else
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "minX", "")
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "minY", "")
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "precisionXY", "")
End If
'--------------------------------
' Write "M"
' minM="" precisionM=""
'--------------------------------
If pSpatialReference.HasMPrecision Then
Call pSpatialReference.GetMDomain(pMMin, pMMax)
Call pSpatialReference.GetMFalseOriginAndUnits(pMFalse, pMPrecision)
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "minM", CStr(pMMin))
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "precisionM", CStr(pMPrecision))
Else
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "minM", "")
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "precisionM", "")
End If
'-------------------------------
' Write "Z"
' minZ="" precisionZ=""
'-------------------------------
If pSpatialReference.HasZPrecision Then
Call pSpatialReference.GetZDomain(pZMin, pZMax)
Call pSpatialReference.GetZFalseOriginAndUnits(pZFalse, pZPrecision)
'
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "minZ", CStr(pZMin))
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "precisionZ", CStr(pZPrecision))
Else
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "minZ", "")
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "precisionZ", "")
End If
'--------------------------------
' Coordinate System Description
' coordinateSystemDescription=""
'--------------------------------
If TypeOf pSpatialReference Is esriGeometry.IUnknownCoordinateSystem Then
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "coordinateSystemDescription", "")
Else
Set pESRISpatialReference = pSpatialReference
Call pESRISpatialReference.ExportToESRISpatialReference(pBuffer, pBytes)
Call modCommon.AddNodeAttribute(pXMLDOMNodeSpatialReference, "coordinateSystemDescription", CStr(Left(pBuffer, InStr(1, pBuffer, Chr(0)) - 1)))
End If
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ExportGDB_SpatialReference " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ExportGDB_ObjectClass(ByRef pXMLDOMNodeParent As MSXML2.IXMLDOMNode, _
ByRef pObjectClass As esriGeoDatabase.IObjectClass)
On Error GoTo ErrorHandler
'--------------------------------------
' <objectClass database=""
' owner=""
' table=""
' aliasName=""
' esriDatasetType=""
' esriFeatureType=""
' oidField=""
' shapeField=""
' subtypeField=""
' defaultSubtypeCode=""
' modelName=""
' configKeyword="">
'--------------------------------------
Dim pXMLDOMNodeObjectClass As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeFeatureClassExtension As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeIndex As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeField As MSXML2.IXMLDOMNode
'
Dim pDataset As esriGeoDatabase.IDataset
Dim pFeatureClass As esriGeoDatabase.IFeatureClass
Dim pModelInfo As esriGeoDatabase.IModelInfo
Dim pSubtypes As esriGeoDatabase.ISubtypes
Dim pEnumSubtype As esriGeoDatabase.IEnumSubtype
Dim pAnnoClass As esriCarto.IAnnoClass
Dim pDimensionClassExtension As esriCarto.IDimensionClassExtension
Dim pIndexes As esriGeoDatabase.IIndexes
Dim pIndex As esriGeoDatabase.IIndex
Dim pFields As esriGeoDatabase.IFields
Dim pField As esriGeoDatabase.IField
'
Dim pSubtypeCode As Long
Dim pSubtypeName As String
Dim pIndexField As Long
Dim pIndexIndex As Long
'
Dim pNetworkClass As esriGeoDatabase.INetworkClass
Dim pGeometricNetwork As esriGeoDatabase.IGeometricNetwork
'----------------------------------------------------
' Do not export GeometricNetwork Orphan FeatureClass
'----------------------------------------------------
If TypeOf pObjectClass Is esriGeoDatabase.IFeatureClass Then
Set pFeatureClass = pObjectClass
Select Case pFeatureClass.FeatureType
Case esriFTComplexEdge, esriFTSimpleEdge, esriFTSimpleJunction
Set pNetworkClass = pFeatureClass
Set pGeometricNetwork = pNetworkClass.GeometricNetwork
If Not (pGeometricNetwork Is Nothing) Then
If pFeatureClass.ObjectClassID = pGeometricNetwork.OrphanJunctionFeatureClass.ObjectClassID Then
Exit Sub
End If
End If
Case Else
'
End Select
End If
'--------------------------
' ADD the ObjectClass Node
'--------------------------
Set pXMLDOMNodeObjectClass = pXMLDOMNodeParent.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "objectClass", "")
Set pXMLDOMNodeObjectClass = pXMLDOMNodeParent.appendChild(pXMLDOMNodeObjectClass)
'
Set pDataset = pObjectClass
Set pModelInfo = pObjectClass
Set pSubtypes = pObjectClass
'
Call AddQualifiedTableNameParts(pXMLDOMNodeObjectClass, pDataset)
Call modCommon.AddNodeAttribute(pXMLDOMNodeObjectClass, "aliasName", CStr(pObjectClass.AliasName))
Call modCommon.AddNodeAttribute(pXMLDOMNodeObjectClass, "oidField", CStr(pObjectClass.OIDFieldName))
Call modCommon.AddNodeAttribute(pXMLDOMNodeObjectClass, "esriDatasetType", CStr(pDataset.Type))
If pDataset.Type = esriDTFeatureClass Then
Set pFeatureClass = pObjectClass
Call modCommon.AddNodeAttribute(pXMLDOMNodeObjectClass, "esriFeatureType", CStr(pFeatureClass.FeatureType))
Call modCommon.AddNodeAttribute(pXMLDOMNodeObjectClass, "shapeField", CStr(pFeatureClass.ShapeFieldName))
Else
Call modCommon.AddNodeAttribute(pXMLDOMNodeObjectClass, "esriFeatureType", "")
Call modCommon.AddNodeAttribute(pXMLDOMNodeObjectClass, "shapeField", "")
End If
Call modCommon.AddNodeAttribute(pXMLDOMNodeObjectClass, "subtypeField", CStr(pSubtypes.SubtypeFieldName))
Call modCommon.AddNodeAttribute(pXMLDOMNodeObjectClass, "defaultSubtypeCode", CStr(pSubtypes.DefaultSubtypeCode))
Call modCommon.AddNodeAttribute(pXMLDOMNodeObjectClass, "modelName", CStr(pModelInfo.ModelName))
Call modCommon.AddNodeAttribute(pXMLDOMNodeObjectClass, "configKeyword", "")
'-----------------
' Add Field Nodes
'-----------------
Call ExportGDB_Field(pXMLDOMNodeObjectClass, pObjectClass)
'--------------------
' Add Subtype Nodes
'-------------------
If pSubtypes.HasSubtype Then
'-----------------------------
' ObjectClasses with Subtypes
'-----------------------------
Set pEnumSubtype = pSubtypes.Subtypes
pSubtypeName = pEnumSubtype.Next(pSubtypeCode)
Do Until pSubtypeName = ""
Call ExportGDB_Subtype(pXMLDOMNodeObjectClass, pObjectClass, pSubtypeCode)
pSubtypeName = pEnumSubtype.Next(pSubtypeCode)
Loop
Else
'--------------------------------
' ObjectClasses without Subtypes
'--------------------------------
Call ExportGDB_Subtype(pXMLDOMNodeObjectClass, pObjectClass, 0)
End If
'--------------------------------------------------------
' Add additional information for FeatureClass Extensions
'--------------------------------------------------------
If pDataset.Type = esriDTFeatureClass Then
Select Case pFeatureClass.FeatureType
Case esriFTAnnotation
'---------------------------------------------
' <annotation referenceScale="" esriUnits="">
'---------------------------------------------
Set pAnnoClass = pFeatureClass.Extension
Set pXMLDOMNodeFeatureClassExtension = pXMLDOMNodeObjectClass.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "annotation", "")
Set pXMLDOMNodeFeatureClassExtension = pXMLDOMNodeObjectClass.appendChild(pXMLDOMNodeFeatureClassExtension)
Call modCommon.AddNodeAttribute(pXMLDOMNodeFeatureClassExtension, "referenceScale", CStr(pAnnoClass.ReferenceScale))
Call modCommon.AddNodeAttribute(pXMLDOMNodeFeatureClassExtension, "esriUnits", CStr(pAnnoClass.ReferenceScaleUnits))
Case esriFTDimension
'---------------------------------------------
' <dimension referenceScale="" esriUnits="">
'---------------------------------------------
Set pDimensionClassExtension = pFeatureClass.Extension
Set pXMLDOMNodeFeatureClassExtension = pXMLDOMNodeObjectClass.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "dimension", "")
Set pXMLDOMNodeFeatureClassExtension = pXMLDOMNodeObjectClass.appendChild(pXMLDOMNodeFeatureClassExtension)
Call modCommon.AddNodeAttribute(pXMLDOMNodeFeatureClassExtension, "referenceScale", CStr(pDimensionClassExtension.ReferenceScale))
Call modCommon.AddNodeAttribute(pXMLDOMNodeFeatureClassExtension, "esriUnits", CStr(pDimensionClassExtension.ReferenceScaleUnits))
End Select
End If
'----------------------------------------------
' Export Field Indexes
' <index name="" isAscending="" isUnique="">
' <field name=""/>
' </index>
'-----------------------------------------------
If mOCExportFieldIndex Then
Set pIndexes = pObjectClass.Indexes
If pIndexes.IndexCount > 0 Then
For pIndexIndex = 0 To pIndexes.IndexCount - 1 Step 1
Set pIndex = pIndexes.Index(pIndexIndex)
'
Set pXMLDOMNodeIndex = pXMLDOMNodeObjectClass.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "index", "")
Set pXMLDOMNodeIndex = pXMLDOMNodeObjectClass.appendChild(pXMLDOMNodeIndex)
Call modCommon.AddNodeAttribute(pXMLDOMNodeIndex, "name", CStr(pIndex.Name))
Call modCommon.AddNodeAttribute(pXMLDOMNodeIndex, "isAscending", CStr(pIndex.IsAscending))
Call modCommon.AddNodeAttribute(pXMLDOMNodeIndex, "isUnique", CStr(pIndex.IsUnique))
'
Set pFields = pIndex.Fields
If pFields.FieldCount > 0 Then
For pIndexField = 0 To pFields.FieldCount - 1 Step 1
Set pField = pFields.Field(pIndexField)
'
Set pXMLDOMNodeField = pXMLDOMNodeIndex.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "field", "")
Set pXMLDOMNodeField = pXMLDOMNodeIndex.appendChild(pXMLDOMNodeField)
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "name", CStr(pField.Name))
Next pIndexField
End If
Next pIndexIndex
End If
End If
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ExportGDB_ObjectClass " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ExportGDB_Field(ByRef pXMLDOMNodeParent As MSXML2.IXMLDOMNode, _
ByRef pObjectClass As esriGeoDatabase.IObjectClass)
On Error GoTo ErrorHandler
'-----------------------------------------
' <field name=""
' aliasName=""
' DomainFixed = ""
' Editable = ""
' IsNullable = ""
' Length = ""
' Precision = ""
' Required = ""
' scale=""
' esriFieldType = ""
' modelName=""/>
'-----------------------------------------
Dim pIndexField As Long
Dim pField As esriGeoDatabase.IField
Dim pFields As esriGeoDatabase.IFields
Dim pFeatureClass As esriGeoDatabase.IFeatureClass
Dim pModelInfo As esriGeoDatabase.IModelInfo
Dim pXMLDOMNodeField As MSXML2.IXMLDOMNode
Dim pField_Length As String
Dim pField_Area As String
'
If TypeOf pObjectClass Is esriGeoDatabase.IFeatureClass Then
Set pFeatureClass = pObjectClass
'-----------------------
' Get Length Field Name
'-----------------------
Set pField = pFeatureClass.LengthField
If pField Is Nothing Then
pField_Length = ""
Else
pField_Length = pField.Name
End If
'---------------------
' Get Area Field Name
'---------------------
Set pField = pFeatureClass.AreaField
If pField Is Nothing Then
pField_Area = ""
Else
pField_Area = pField.Name
End If
Else
pField_Length = ""
pField_Area = ""
End If
'
Set pFields = pObjectClass.Fields
For pIndexField = 0 To pFields.FieldCount - 1 Step 1
Set pField = pFields.Field(pIndexField)
Set pModelInfo = pField
If pField.Name = pField_Length Or pField.Name = pField_Area Then
'---------------------------------------------
' Skip "Shape_Area" and "Shape_Length" fields
'---------------------------------------------
Else
'---------------------------------
' Add Field Node (and attributes)
'---------------------------------
Set pXMLDOMNodeField = pXMLDOMNodeParent.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "field", "")
Set pXMLDOMNodeField = pXMLDOMNodeParent.appendChild(pXMLDOMNodeField)
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "name", CStr(pField.Name))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "aliasName", CStr(pField.AliasName))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "esriFieldType", CStr(pField.Type))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "length", CStr(pField.length))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "precision", CStr(pField.Precision))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "required", CStr(pField.Required))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "scale", CStr(pField.Scale))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "domainFixed", CStr(pField.DomainFixed))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "editable", CStr(pField.Editable))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "isNullable", CStr(pField.IsNullable))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "modelName", CStr(pModelInfo.ModelName))
'-------------------------------------------------------------
' If Geometry field then parse field to GeometryDef procedure
'-------------------------------------------------------------
If pField.Type = esriFieldTypeGeometry Then
Call ExportGDB_GeometryDef(pXMLDOMNodeField, pField.GeometryDef, CBool(pFeatureClass.FeatureDataset Is Nothing))
End If
End If
Next pIndexField
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ExportGDB_Field " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ExportGDB_GeometryDef(ByRef pXMLDOMNodeParent As MSXML2.IXMLDOMNode, _
ByRef pGeometryDef As esriGeoDatabase.IGeometryDef, _
ByRef pStandAlone As Boolean)
On Error GoTo ErrorHandler
'--------------------------------------------
' <geometryDef esriGeometryType = ""
' AvgNumPoints = ""
' GridCount = ""
' GridSize = ""
' HasM=""
' HasZ=""/>
'--------------------------------------------
Dim pXMLDOMNodeGeometryDef As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeGrid As MSXML2.IXMLDOMNode
Dim pIndexGrid As Long
'---------------------------------------
' Add GeometryDef Node (and attributes)
'---------------------------------------
Set pXMLDOMNodeGeometryDef = pXMLDOMNodeParent.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "geometryDef", "")
Set pXMLDOMNodeGeometryDef = pXMLDOMNodeParent.appendChild(pXMLDOMNodeGeometryDef)
Call modCommon.AddNodeAttribute(pXMLDOMNodeGeometryDef, "esriGeometryType", CStr(pGeometryDef.GeometryType))
Call modCommon.AddNodeAttribute(pXMLDOMNodeGeometryDef, "avgNumPoints", CStr(pGeometryDef.AvgNumPoints))
Call modCommon.AddNodeAttribute(pXMLDOMNodeGeometryDef, "hasM", CStr(pGeometryDef.HasM))
Call modCommon.AddNodeAttribute(pXMLDOMNodeGeometryDef, "hasZ", CStr(pGeometryDef.HasZ))
'--------------------
' Add Grid Sub-Nodes
'--------------------
For pIndexGrid = 0 To pGeometryDef.GridCount - 1 Step 1
Set pXMLDOMNodeGrid = pXMLDOMNodeGeometryDef.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "grid", "")
Set pXMLDOMNodeGrid = pXMLDOMNodeGeometryDef.appendChild(pXMLDOMNodeGrid)
Call modCommon.AddNodeAttribute(pXMLDOMNodeGrid, "size", CStr(pGeometryDef.GridSize(pIndexGrid)))
Next pIndexGrid
'
If pStandAlone Then
Call ExportGDB_SpatialReference(pXMLDOMNodeGeometryDef, pGeometryDef.SpatialReference)
End If
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ExportGDB_GeometryDef " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ExportGDB_Subtype(ByRef pXMLDOMNodeParent As MSXML2.IXMLDOMNode, _
ByRef pObjectClass As esriGeoDatabase.IObjectClass, _
ByRef pSubtypeCode As Long)
On Error GoTo ErrorHandler
'-----------------------------------------------------------
' <subtype name="" code="" default="">
' <field name="" defaultValue="" domain=""/>
' </subtype>
'-----------------------------------------------------------
Dim pXMLDOMNodeSubtype As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeField As MSXML2.IXMLDOMNode
'
Dim pSubtypes As esriGeoDatabase.ISubtypes
Dim pFields As esriGeoDatabase.IFields
Dim pField As esriGeoDatabase.IField
Dim pDomain As esriGeoDatabase.IDomain
Dim pDefaultValue As String
Dim pDomainName As String
Dim pIndexField As Long
'---------------
' Get ISubtypes
'---------------
Set pSubtypes = pObjectClass
Set pFields = pObjectClass.Fields
'-----------------------------------
' Add Subtype Node (and attributes)
'-----------------------------------
Set pXMLDOMNodeSubtype = pXMLDOMNodeParent.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "subtype", "")
Set pXMLDOMNodeSubtype = pXMLDOMNodeParent.appendChild(pXMLDOMNodeSubtype)
If pSubtypes.HasSubtype Then
Call modCommon.AddNodeAttribute(pXMLDOMNodeSubtype, "name", CStr(pSubtypes.SubtypeName(pSubtypeCode)))
Else
Call modCommon.AddNodeAttribute(pXMLDOMNodeSubtype, "name", "")
End If
Call modCommon.AddNodeAttribute(pXMLDOMNodeSubtype, "code", CStr(pSubtypeCode))
'------------------
' Add Fields Nodes
'------------------
For pIndexField = 0 To pFields.FieldCount - 1 Step 1
Set pField = pFields.Field(pIndexField)
If pField.Name <> pSubtypes.SubtypeFieldName Then
pDefaultValue = ""
pDomainName = ""
Set pDomain = pSubtypes.Domain(pSubtypeCode, pField.Name)
If Not IsNull(pSubtypes.DefaultValue(pSubtypeCode, pField.Name)) Then
pDefaultValue = CStr(pSubtypes.DefaultValue(pSubtypeCode, pField.Name))
End If
If Not (pDomain Is Nothing) Then
pDomainName = CStr(pDomain.Name)
End If
If pDefaultValue = "" And pDomainName = "" Then
'------------------------------
' Skip adding this field node.
'------------------------------
Else
Set pXMLDOMNodeField = pXMLDOMNodeSubtype.ownerDocument.createNode(MSXML2.NODE_ELEMENT, "field", "")
Set pXMLDOMNodeField = pXMLDOMNodeSubtype.appendChild(pXMLDOMNodeField)
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "name", CStr(pField.Name))
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "defaultValue", pDefaultValue)
Call modCommon.AddNodeAttribute(pXMLDOMNodeField, "domain", pDomainName)
End If
End If
Next pIndexField
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ExportGDB_Subtype " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub AddQualifiedTableNameParts(ByRef pXMLDOMNode As MSXML2.IXMLDOMNode, _
ByRef pDataset As esriGeoDatabase.IDataset)
On Error GoTo ErrorHandler
'
Dim pSQLSyntax As esriGeoDatabase.ISQLSyntax
Dim pDatabaseName As String
Dim pOwnerName As String
Dim pTableName As String
'
If pDataset Is Nothing Then
Call modCommon.AddNodeAttribute(pXMLDOMNode, "database", "")
Call modCommon.AddNodeAttribute(pXMLDOMNode, "owner", "")
Call modCommon.AddNodeAttribute(pXMLDOMNode, "table", "")
Else
Set pSQLSyntax = pDataset.Workspace
'---------------------------------------------
' Parse Dataset Name - Split into RDBMS parts
'---------------------------------------------
Call pSQLSyntax.ParseTableName(CStr(pDataset.Name), pDatabaseName, pOwnerName, pTableName)
'--------------------------
' Add parts to parsed node
'--------------------------
Call modCommon.AddNodeAttribute(pXMLDOMNode, "database", CStr(pDatabaseName))
Call modCommon.AddNodeAttribute(pXMLDOMNode, "owner", CStr(pOwnerName))
Call modCommon.AddNodeAttribute(pXMLDOMNode, "table", CStr(pTableName))
End If
'
Exit Sub
ErrorHandler:
Call HandleError(False, "AddQualifiedTableNameParts " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Public Function GetQualifiedTableNameSimple(ByRef pXMLDOMNode As MSXML2.IXMLDOMNode) As String
On Error GoTo ErrorHandler
'
Dim pDatabaseName As String
Dim pOwnerName As String
Dim pTableName As String
'
pDatabaseName = CStr(pXMLDOMNode.Attributes.getNamedItem("database").Text)
pOwnerName = CStr(pXMLDOMNode.Attributes.getNamedItem("owner").Text)
pTableName = CStr(pXMLDOMNode.Attributes.getNamedItem("table").Text)
'
If pDatabaseName = "" And pOwnerName = "" And pTableName <> "" Then
GetQualifiedTableNameSimple = pTableName
Else
If pDatabaseName = "" And pOwnerName <> "" And pTableName <> "" Then
GetQualifiedTableNameSimple = pOwnerName & "." & pTableName
Else
If pDatabaseName <> "" And pOwnerName <> "" And pTableName <> "" Then
GetQualifiedTableNameSimple = pDatabaseName & "." & pOwnerName & "." & pTableName
Else
GetQualifiedTableNameSimple = "??"
End If
End If
End If
'
Exit Function
ErrorHandler:
Call HandleError(False, "GetQualifiedTableNameSimple " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Sub RemoveConnectivityRules(ByRef pGeometricNetwork As esriGeoDatabase.IGeometricNetwork)
On Error GoTo ErrorHandler
'-----------------------------------------------------------------
' Removes all Connectivity Rules from the parsed GeometricNetwork
'-----------------------------------------------------------------
Dim pRule As esriGeoDatabase.IRule
Set pRule = pGeometricNetwork.Rules.Next
'
Do Until pRule Is Nothing
If TypeOf pRule Is esriGeoDatabase.IConnectivityRule Then
Call pGeometricNetwork.DeleteRule(pRule)
End If
Set pRule = pGeometricNetwork.Rules.Next
Loop
'
Exit Sub
ErrorHandler:
Call HandleError(False, "RemoveConnectivityRules " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub RemoveTopologyRules(ByRef pTopology As esriGeoDatabase.ITopology)
On Error GoTo ErrorHandler
'-----------------------------------------------------------------
' Removes all Connectivity Rules from the parsed GeometricNetwork
'-----------------------------------------------------------------
Dim pTopologyRuleContainer As esriGeoDatabase.ITopologyRuleContainer
Dim pTopologyRule As esriGeoDatabase.IRule
'
Set pTopologyRuleContainer = pTopology
Set pTopologyRule = pTopologyRuleContainer.Rules.Next
'
Do Until pTopologyRule Is Nothing
Call pTopologyRuleContainer.DeleteRule(pTopologyRule)
'
Set pTopologyRule = pTopologyRuleContainer.Rules.Next
Loop
'
Exit Sub
ErrorHandler:
Call HandleError(False, "RemoveTopologyRules " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Function ReturnFieldErrorText(eFieldNameErrorType As esriFieldNameErrorType) As String
Select Case eFieldNameErrorType
Case esriDuplicatedFieldName
ReturnFieldErrorText = "Field name is a duplicate of another field name."
Case esriInvalidCharacter
ReturnFieldErrorText = "Field name containes invalid character."
Case esriInvalidFieldNameLength
ReturnFieldErrorText = "Field name is too long."
Case esriNoFieldError
ReturnFieldErrorText = "No field error."
Case esriSQLReservedWord
ReturnFieldErrorText = "Field name is a SQL Reserved word."
Case Else
ReturnFieldErrorText = "unknownErrorType" & ":" & eFieldNameErrorType
End Select
End Function
Private Function ReturnTableErrorText(pEsriTableNameErrorType As esriTableNameErrorType) As String
Select Case pEsriTableNameErrorType
Case esriIsSQLReservedWord
ReturnTableErrorText = "Table name is a SQL reserved word."
Case esriHasInvalidCharacter
ReturnTableErrorText = "Table name contains an Invalid Character."
Case esriHasInvalidStartingCharacter
ReturnTableErrorText = "Table name has an invalid starting character."
Case Else
ReturnTableErrorText = "unknownErrorType" & ":" & pEsriTableNameErrorType
End Select
End Function
Public Function ExportTopology(ByRef pApplication As esriFramework.IApplication) As MSXML2.DOMDocument
On Error GoTo ErrorHandler
'---------------------------------------------------------------------------
' This routine will export both the Topology Dataset and Topology Rules
'---------------------------------------------------------------------------
Dim pGxApplication As esriCatalogUI.IGxApplication
Dim pGxObject As esriCatalog.IGxObject
Dim pStatusBar As esriSystem.IStatusBar
Dim pGxDataset As esriCatalog.IGxDataset
Dim pDataset As esriGeoDatabase.IDataset
Dim pWorkspace As esriGeoDatabase.IWorkspace
Dim pTopology As esriGeoDatabase.ITopology2
Dim pTopologyProperties As esriGeoDatabase.ITopologyProperties
Dim pEnumFeatureClass As esriGeoDatabase.IEnumFeatureClass
Dim pFeatureClass As esriGeoDatabase.IFeatureClass
Dim pDatasetFC As esriGeoDatabase.IDataset
Dim pTopologyClass As esriGeoDatabase.ITopologyClass
Dim pEnumRule As esriGeoDatabase.IEnumRule
Dim pRule As esriGeoDatabase.IRule
Dim pTopologyRule As esriGeoDatabase.ITopologyRule
Dim pTopologyRuleContainer As esriGeoDatabase.ITopologyRuleContainer
Dim pFeatureClassContainer As esriGeoDatabase.IFeatureClassContainer
Dim pDatasetOrigin As esriGeoDatabase.IDataset
Dim pDatasetDestination As esriGeoDatabase.IDataset
Dim pSubtypesOrigin As esriGeoDatabase.ISubtypes
Dim pSubtypesDestination As esriGeoDatabase.ISubtypes
Dim pSubtypeNameOrigin As String
Dim pSubtypeNameDestination As String
'
Dim pDOMDocument As MSXML2.DOMDocument
'
Dim pXMLDOMNodeGeodatabaseDesigner As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeTopology As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeFeatureClass As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeTopologyRule As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeOrigin As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeDestination As MSXML2.IXMLDOMNode
'---------------------------------
' Set GxApplication and StatusBar
'---------------------------------
Set pGxApplication = pApplication
Set pStatusBar = pApplication.StatusBar
'-----------------------
' Get Topology.
'-----------------------
Set pGxObject = pGxApplication.SelectedObject
Set pGxDataset = pGxObject
Set pDataset = pGxDataset.Dataset
Set pWorkspace = pDataset.Workspace
Set pTopology = pDataset
'----------------------------------
' Get new XML Document (in memory)
'----------------------------------
Set pDOMDocument = modCommon.NewXMLDocument
'------------------------
' Add header to XML file
'------------------------
pStatusBar.Message(0) = "Export Topology: Writing XML Header"
Call modCommon.WriteGeodatabaseDesignerHeader(pDOMDocument, pWorkspace)
'--------------------------------------------------------------------
'<topology database="" owner="" table=""
' clusterTolerance=""
' maxGeneratedErrorCount=""
' nothingTrusted=""
' esriTopologyState=""
' configurationKeywork="">
'</topology>
'--------------------------------------------------------------------
pStatusBar.Message(0) = "Export Topology: Writing Topology Node"
Set pXMLDOMNodeGeodatabaseDesigner = pDOMDocument.getElementsByTagName("geodatabaseDesigner").nextNode
Set pXMLDOMNodeTopology = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "topology", "")
Set pXMLDOMNodeTopology = pXMLDOMNodeGeodatabaseDesigner.appendChild(pXMLDOMNodeTopology)
Call AddQualifiedTableNameParts(pXMLDOMNodeTopology, pDataset)
Call modCommon.AddNodeAttribute(pXMLDOMNodeTopology, "clusterTolerance", CStr(pTopology.ClusterTolerance))
Call modCommon.AddNodeAttribute(pXMLDOMNodeTopology, "zclusterTolerance", CStr(pTopology.ZClusterTolerance))
Call modCommon.AddNodeAttribute(pXMLDOMNodeTopology, "maxGeneratedErrorCount", CStr(pTopology.MaximumGeneratedErrorCount))
Call modCommon.AddNodeAttribute(pXMLDOMNodeTopology, "esriTopologyState", CStr(pTopology.State))
Call modCommon.AddNodeAttribute(pXMLDOMNodeTopology, "configurationKeyword", "")
'----------------------------------------------------
' Write Topology FeatureClasses
' <featureClass database="" owner="" table=""
' weight=""
' xyRank=""
' zRank=""
' eventNotificationOnValidate="" />
'----------------------------------------------------
pStatusBar.Message(0) = "Export Topology: Writing Topology Class's"
Set pTopologyProperties = pTopology
Set pEnumFeatureClass = pTopologyProperties.Classes
Set pFeatureClass = pEnumFeatureClass.Next
Do Until pFeatureClass Is Nothing
Set pDatasetFC = pFeatureClass
Set pTopologyClass = pFeatureClass
'
pStatusBar.Message(0) = "Export Topology: Adding FeatureClass " & pDatasetFC.Name
Set pXMLDOMNodeFeatureClass = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "featureClass", "")
Set pXMLDOMNodeFeatureClass = pXMLDOMNodeTopology.appendChild(pXMLDOMNodeFeatureClass)
Call AddQualifiedTableNameParts(pXMLDOMNodeFeatureClass, pDatasetFC)
Call modCommon.AddNodeAttribute(pXMLDOMNodeFeatureClass, "weight", CStr(pTopologyClass.Weight))
Call modCommon.AddNodeAttribute(pXMLDOMNodeFeatureClass, "xyRank", CStr(pTopologyClass.XYRank))
Call modCommon.AddNodeAttribute(pXMLDOMNodeFeatureClass, "zRank", CStr(pTopologyClass.ZRank))
Call modCommon.AddNodeAttribute(pXMLDOMNodeFeatureClass, "eventNotificationOnValidate", CStr(pTopologyClass.EventNotificationOnValidate))
'
Set pFeatureClass = pEnumFeatureClass.Next
Loop
'------------------------------------------------------------------
' Write Topology Rules
' <rule name=""
' allOriginSubtypes=""
' allDestinationSubtypes=""
' guid=""
' esriTopologyRuleType=""
' triggerErrorEvents="">
' <origin database="" owner="" table="" subtype="" />
' <destination database="" owner="" table="" subtype="" />
' </rule>
'------------------------------------------------------------------
Set pFeatureClassContainer = pTopology
Set pTopologyRuleContainer = pTopology
Set pEnumRule = pTopologyRuleContainer.Rules
Set pRule = pEnumRule.Next
Do Until pRule Is Nothing
If TypeOf pRule Is esriGeoDatabase.ITopologyRule Then
pStatusBar.Message(0) = "Export Topology: Adding Topology Rule [" & pRule.ID & "]"
'
Set pTopologyRule = pRule
'---------------
' Add Rule Node
'---------------
Set pXMLDOMNodeTopologyRule = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "rule", "")
Set pXMLDOMNodeTopologyRule = pXMLDOMNodeTopology.appendChild(pXMLDOMNodeTopologyRule)
Call modCommon.AddNodeAttribute(pXMLDOMNodeTopologyRule, "name", CStr(pTopologyRule.Name))
Call modCommon.AddNodeAttribute(pXMLDOMNodeTopologyRule, "allOriginSubtypes", CStr(pTopologyRule.AllOriginSubtypes))
Call modCommon.AddNodeAttribute(pXMLDOMNodeTopologyRule, "allDestinationSubtypes", CStr(pTopologyRule.AllDestinationSubtypes))
Call modCommon.AddNodeAttribute(pXMLDOMNodeTopologyRule, "guid", CStr(pTopologyRule.Guid))
Call modCommon.AddNodeAttribute(pXMLDOMNodeTopologyRule, "esriTopologyRuleType", CStr(pTopologyRule.TopologyRuleType))
Call modCommon.AddNodeAttribute(pXMLDOMNodeTopologyRule, "triggerErrorEvents", CStr(pTopologyRule.TriggerErrorEvents))
'---------------------------------
' Add Origin and Destination Node
'---------------------------------
Set pDatasetOrigin = pFeatureClassContainer.ClassByID(pTopologyRule.OriginClassID)
Set pSubtypesOrigin = pDatasetOrigin
Set pXMLDOMNodeOrigin = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "origin", "")
Set pXMLDOMNodeOrigin = pXMLDOMNodeTopologyRule.appendChild(pXMLDOMNodeOrigin)
Call AddQualifiedTableNameParts(pXMLDOMNodeOrigin, pDatasetOrigin)
If pTopologyRule.AllOriginSubtypes Then
pSubtypeNameOrigin = ""
Else
pSubtypeNameOrigin = pSubtypesOrigin.SubtypeName(pTopologyRule.OriginSubtype)
End If
Call modCommon.AddNodeAttribute(pXMLDOMNodeOrigin, "subtype", pSubtypeNameOrigin)
'
Set pDatasetDestination = pFeatureClassContainer.ClassByID(pTopologyRule.DestinationClassID)
Set pSubtypesDestination = pDatasetDestination
Set pXMLDOMNodeDestination = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "destination", "")
Set pXMLDOMNodeDestination = pXMLDOMNodeTopologyRule.appendChild(pXMLDOMNodeDestination)
Call AddQualifiedTableNameParts(pXMLDOMNodeDestination, pDatasetDestination)
If pTopologyRule.AllDestinationSubtypes Then
pSubtypeNameDestination = ""
Else
pSubtypeNameDestination = pSubtypesDestination.SubtypeName(pTopologyRule.DestinationSubtype)
End If
Call modCommon.AddNodeAttribute(pXMLDOMNodeDestination, "subtype", pSubtypeNameDestination)
End If
'
Set pRule = pEnumRule.Next
Loop
'-----------------
' Clear StatusBar
'-----------------
pStatusBar.Message(0) = ""
'---------------------
' Return XML Document
'---------------------
Set ExportTopology = pDOMDocument
'
Exit Function
ErrorHandler:
Call HandleError(False, "ExportTopology " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Sub ImportTopology(ByRef pApplication As esriFramework.IApplication)
On Error GoTo ErrorHandler
'------------------------------------------------------------------------
' Main Routine. This routine is called when the user clicks "Import Topology"
' If a FeatureDataset is selected: (1) Create NEW Topology Dataset
' (2) Add NEW Topology Rules
' If a TopologyDataset is selected: (1) Add NEW Topology Rules
'------------------------------------------------------------------------
Dim pGxApplication As esriCatalogUI.IGxApplication
Dim pStatusBar As esriSystem.IStatusBar
Dim pMouseCursor As esriFramework.IMouseCursor
'
Dim pDOMDocument As MSXML2.DOMDocument
'
Dim pGxObject As esriCatalog.IGxObject
Dim pGxDataset As esriCatalog.IGxDataset
Dim pDataset As esriGeoDatabase.IDataset
Dim pFeatureDataset As esriGeoDatabase.IFeatureDataset
Dim pGeodatabaseRelease As IGeodatabaseRelease
Dim pDatasetTopology As esriGeoDatabase.IDataset
'---------------------------------
' Set GxApplication and StatusBar
'---------------------------------
Set pGxApplication = pApplication
Set pStatusBar = pApplication.StatusBar
Set pGxObject = pGxApplication.SelectedObject
Set pGxDataset = pGxObject
Set pDataset = pGxDataset.Dataset
'---------------------------
' Check Geodatabase Version
'---------------------------
Set pGeodatabaseRelease = pDataset.Workspace
Select Case pGeodatabaseRelease.MajorVersion
Case 0
'------------------
' Geodatabase 8.0x
'------------------
MsgBox "This commands requires an 8.3+ Geodatabase", vbExclamation, App.ProductName
Exit Sub
Case 1
'---------------------------
' Geodatabase 8.1, 8.2, 8.3
'---------------------------
If pGeodatabaseRelease.MinorVersion >= 3 Then
'--------------------------
' OK (Geodatabase is 8.3+)
'--------------------------
Else
MsgBox "This commands requires an 8.3+ Geodatabase", vbExclamation, App.ProductName
Exit Sub
End If
Case Else
'----------------------
' OK (Geodatabase 9.x)
'----------------------
End Select
'----------------------------------------------
' Prompt for and open the source XML document.
'----------------------------------------------
Set pDOMDocument = modCommon.GetXMLDocument
If pDOMDocument Is Nothing Then
Exit Sub
End If
'---------------------
' Change Mouse Cursor
'---------------------
Set pMouseCursor = New esriFramework.MouseCursor
Call pMouseCursor.SetCursor(2)
'
Select Case pDataset.Type
Case esriDTFeatureDataset
'-------------------------------------------
' FeatureDataset Selected in ArcCatalog TOC
'-------------------------------------------
Set pFeatureDataset = pDataset
pStatusBar.Message(0) = "Creating New Topology"
Set pDatasetTopology = CreateTopology(pDOMDocument, pFeatureDataset)
If pDatasetTopology Is Nothing Then
MsgBox "Toplogy Creation Unsuccessful", vbCritical, App.FileDescription
Else
pStatusBar.Message(0) = "Importing Topology Rules"
Call ImportTopologyRules(pDOMDocument, pDatasetTopology)
End If
Case 8 ' esriDTTopology
'---------------------------------------------
' Topology Selected in ArcCatalog TOC
'---------------------------------------------
Set pDatasetTopology = pDataset
pStatusBar.Message(0) = "Importing Topology Rules"
Call ImportTopologyRules(pDOMDocument, pDatasetTopology)
End Select
'--------------------------------------
' Refresh ArcCatalog Table of Contents
'--------------------------------------
Call pGxApplication.Refresh(pGxApplication.SelectedObject.FullName)
'---------------------
' Restore MouseCursor
'---------------------
Set pMouseCursor = Nothing
'-----------------
' Clear StatusBar
'-----------------
pStatusBar.Message(0) = ""
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ImportTopology " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Function CreateTopology(ByRef pDOMDocument As MSXML2.DOMDocument, _
ByRef pFeatureDataset As esriGeoDatabase.IFeatureDataset) As esriGeoDatabase.ITopology
On Error GoTo ErrorHandler
'----------------------------------------------------------
' Creates a NEW Topology inside the FeatureDataset
'----------------------------------------------------------
Dim pTopology As esriGeoDatabase.ITopology2
Dim pTopologyContainer As esriGeoDatabase.ITopologyContainer2
Dim pFeatureClassContainer As IFeatureClassContainer
Dim pFeatureClass As IFeatureClass
'
Dim pXMLDOMNodeTopology As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeFeatureClass As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeListFeatureClass As MSXML2.IXMLDOMNodeList
Dim pIndex As Long
Dim pName As String
Dim pClusterTolerance As String
Dim pZClusterTolerance As String
Dim pMaxGeneratedErrorCount As Long
Dim pConfigurationKeyword As String
Dim pWeight As Double
Dim pXYRank As Long
Dim pZRank As Long
Dim pEventNotificationOnValidate As Boolean
'----------------
' Set Interfaces
'----------------
Set pTopology = Nothing
Set pTopologyContainer = pFeatureDataset
Set pFeatureClassContainer = pFeatureDataset
'-------------------------
' Get Topology properties
'-------------------------
Set pXMLDOMNodeTopology = pDOMDocument.getElementsByTagName("topology").nextNode
pName = CStr(pXMLDOMNodeTopology.Attributes.getNamedItem("table").Text)
pClusterTolerance = CStr(pXMLDOMNodeTopology.Attributes.getNamedItem("clusterTolerance").Text)
pZClusterTolerance = CStr(pXMLDOMNodeTopology.Attributes.getNamedItem("zclusterTolerance").Text)
pMaxGeneratedErrorCount = CLng(pXMLDOMNodeTopology.Attributes.getNamedItem("maxGeneratedErrorCount").Text)
pConfigurationKeyword = CStr(pXMLDOMNodeTopology.Attributes.getNamedItem("configurationKeyword").Text)
'---------------------------------------------------
' Check if Topology by the same name already exists
'---------------------------------------------------
For pIndex = 0 To pTopologyContainer.TopologyCount - 1 Step 1
If UCase(pName) = _
UCase(modCommon.GetDataset(pTopologyContainer.Topology(pIndex)).Name) Then
Select Case MsgBox("The Topology already exists!" & vbCrLf & "Continue to load Topology Rules?", vbYesNoCancel, App.FileDescription)
Case vbYes
'----------------------------------------------------------------------
' Return Topology to parent routine. Add Conn Rules to that GN
'----------------------------------------------------------------------
Set CreateTopology = pTopologyContainer.Topology(pIndex)
Exit Function
Case vbNo, vbCancel
'----------------------------------------------------------------------------------------
' User wants to backout completely. Return to parent routine with empty GeometricNetwork
'----------------------------------------------------------------------------------------
Exit Function
End Select
End If
Next pIndex
'-----------------------------
' Create new Topology Dataset
'-----------------------------
Set pTopology = pTopologyContainer.CreateTopologyEx(pName, pClusterTolerance, pZClusterTolerance, pMaxGeneratedErrorCount, pConfigurationKeyword)
'-------------------------------------------------------------
' Add FeatureClasses (ITopologyClass) to the Topology Dataset
'-------------------------------------------------------------
Set pXMLDOMNodeListFeatureClass = pXMLDOMNodeTopology.selectNodes("featureClass")
For pIndex = 0 To pXMLDOMNodeListFeatureClass.length - 1 Step 1
Set pXMLDOMNodeFeatureClass = pXMLDOMNodeListFeatureClass.Item(pIndex)
pName = CStr(pXMLDOMNodeFeatureClass.Attributes.getNamedItem("table").Text)
pWeight = CDbl(pXMLDOMNodeFeatureClass.Attributes.getNamedItem("weight").Text)
pXYRank = CLng(pXMLDOMNodeFeatureClass.Attributes.getNamedItem("xyRank").Text)
pZRank = CLng(pXMLDOMNodeFeatureClass.Attributes.getNamedItem("zRank").Text)
pEventNotificationOnValidate = CStr(pXMLDOMNodeFeatureClass.Attributes.getNamedItem("eventNotificationOnValidate").Text)
Set pFeatureClass = pFeatureClassContainer.ClassByName(pName)
Call pTopology.AddClass(pFeatureClass, pWeight, pXYRank, pZRank, pEventNotificationOnValidate)
Next pIndex
'---------------------
' Return New Topology
'---------------------
Set CreateTopology = pTopology
'
Exit Function
ErrorHandler:
Call HandleError(False, "CreateTopology " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Private Sub ImportTopologyRules(ByRef pDOMDocument As MSXML2.DOMDocument, _
ByRef pTopology As esriGeoDatabase.ITopology)
On Error GoTo ErrorHandler
'-------------------------------------------------------------
' This Routine will recreate Topology Rules from an XML file.
'-------------------------------------------------------------
Dim pXMLDOMNodeTopology As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeListRule As MSXML2.IXMLDOMNodeList
Dim pXMLDOMNodeRule As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeOrigin As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeDestination As MSXML2.IXMLDOMNode
'
Dim pFeatureClassContainer As esriGeoDatabase.IFeatureClassContainer
Dim pFeatureClass As esriGeoDatabase.IFeatureClass
Dim pTopologyRuleContainer As esriGeoDatabase.ITopologyRuleContainer
Dim pTopologyRule As esriGeoDatabase.ITopologyRule
'
Dim pName As String
Dim pEsriTopologyRuleType As Long
Dim pTriggerErrorEvents As Boolean
Dim pAllDestinationSubtypes As Boolean
Dim pAllOriginSubtypes As Boolean
Dim pDestinationClassName As String
Dim pDestinationSubtypeName As String
Dim pOriginClassName As String
Dim pOriginSubtypeName As String
'
Dim pIndex As Long
'----------------------------------------------------
' <rule name=""
' allDestinationSubtypes=""
' allOriginSubtypes=""
' guid=""
' esriTopologyRuleType=""
' triggerErrorEvents="">
' <origin database="" owner="" subtype="" />
' <destination database="" owner="" subtype="" />
' </rule>
'----------------------------------------------------
Set pTopologyRuleContainer = pTopology
Set pFeatureClassContainer = pTopology
'------------------------------------------
' First Delete all existing Topology Rules
'------------------------------------------
Call RemoveTopologyRules(pTopology)
'
Set pXMLDOMNodeTopology = pDOMDocument.getElementsByTagName("topology").nextNode
Set pXMLDOMNodeListRule = pXMLDOMNodeTopology.selectNodes("rule")
'
For pIndex = 0 To pXMLDOMNodeListRule.length - 1 Step 1
Set pXMLDOMNodeRule = pXMLDOMNodeListRule.Item(pIndex)
Set pXMLDOMNodeOrigin = pXMLDOMNodeRule.selectSingleNode("origin")
Set pXMLDOMNodeDestination = pXMLDOMNodeRule.selectSingleNode("destination")
'
pName = CStr(pXMLDOMNodeRule.Attributes.getNamedItem("name").Text)
pEsriTopologyRuleType = CLng(pXMLDOMNodeRule.Attributes.getNamedItem("esriTopologyRuleType").Text)
pTriggerErrorEvents = CBool(pXMLDOMNodeRule.Attributes.getNamedItem("triggerErrorEvents").Text)
pAllDestinationSubtypes = CBool(pXMLDOMNodeRule.Attributes.getNamedItem("allDestinationSubtypes").Text)
pAllOriginSubtypes = CBool(pXMLDOMNodeRule.Attributes.getNamedItem("allOriginSubtypes").Text)
pDestinationClassName = CStr(pXMLDOMNodeDestination.Attributes.getNamedItem("table").Text)
pDestinationSubtypeName = CStr(pXMLDOMNodeDestination.Attributes.getNamedItem("subtype").Text)
pOriginClassName = CStr(pXMLDOMNodeOrigin.Attributes.getNamedItem("table").Text)
pOriginSubtypeName = CStr(pXMLDOMNodeOrigin.Attributes.getNamedItem("subtype").Text)
'
Set pTopologyRule = New esriGeoDatabase.TopologyRule
pTopologyRule.Name = pName
pTopologyRule.TopologyRuleType = pEsriTopologyRuleType
pTopologyRule.AllDestinationSubtypes = pAllDestinationSubtypes
pTopologyRule.AllOriginSubtypes = pAllOriginSubtypes
pTopologyRule.DestinationClassID = pFeatureClassContainer.ClassByName(pDestinationClassName).FeatureClassID
pTopologyRule.OriginClassID = pFeatureClassContainer.ClassByName(pOriginClassName).FeatureClassID
'
If Not pAllDestinationSubtypes Then
pTopologyRule.DestinationSubtype = GetSubtypeCodeFromName(pFeatureClassContainer.ClassByName(pDestinationClassName), pDestinationSubtypeName)
End If
If Not pAllOriginSubtypes Then
pTopologyRule.OriginSubtype = GetSubtypeCodeFromName(pFeatureClassContainer.ClassByName(pOriginClassName), pOriginSubtypeName)
End If
'
Call pTopologyRuleContainer.AddRule(pTopologyRule)
Next pIndex
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ImportTopologyRules " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub