マップ トポロジーの利用

'This example demonstrates how to hook up to the Maptopology
 
Sub HookUpToMapTopology()
Dim bTopoExSuccessed As Boolean, pMapTopology As IMapTopology, sPath As String, pWFactory As IWorkspaceFactory
Dim pFWorkspace As IFeatureWorkspace, pfc0 As IFeatureClass, pTopologyGraph As ITopologyGraph
Dim pgdset As IGeoDataset, pTopologyExtension As ITopologyExtension, peditor As IEditor, pws As IWorkspace
 
Set peditor = GetEditorExtension
Set pTopologyExtension = GetTopoExtension
 
If pTopologyExtension Is Nothing Then Exit Sub
 
Set pMapTopology = pTopologyExtension.MapTopology
Set pWFactory = New ShapefileWorkspaceFactory
 
sPath = "D:\WorkSpace\Archives\Export_Output_2"
 
Set pFWorkspace = pWFactory.OpenFromFile(sPath, 0)
Set pws = pFWorkspace
Set pfc0 = pFWorkspace.OpenFeatureClass("Export_Output_4.shp")
 
If Not AddFeatureClassesToMap(pfc0) Then Exit Sub
 
If Not peditor.EditState = esriStateEditing Then peditor.StartEditing pws
pMapTopology.ClearClasses
pMapTopology.AddClass pfc0
Debug.Print pMapTopology.ClassCount
 
Set pTopologyGraph = pMapTopology.Cache
Set pgdset = pfc0
 
 
 
pTopologyGraph.Build pgdset.Extent, False
 
 
 
Debug.Print pTopologyGraph.Nodes.Count
'pMapTopology.ClearClasses
 
 
 
Dim pDocument As IDocument
Set pDocument = ThisDocument
 
Dim pMxDocument As IMxDocument
Set pMxDocument = pDocument
 
'pMxDocument.FocusMap.Layer(0).Visible = False
 
pMxDocument.UpdateContents
pMxDocument.ActiveView.Refresh
 
 
Dim pCommandBars As ICommandBars
Set pCommandBars = pDocument.CommandBars
 
  Dim pUID As New UID
  Dim pCmdItem As ICommandItem
  ' Use the CLSID of the Save command
'  pUID.Value = "{DC12D55A-EC2D-4F01-8C75-B407EC0959E5}"
  pUID.Value = "{7953D111-120A-4CFA-86D5-4DD93F171B55}"
  ' or you can use the ProgID
  'pUID.Value = "esriArcMapUI.MxFileMenuItem" pUID.SubType = 3
  Set pCmdItem = pCommandBars.Find(pUID)
   
'  pCmdItem.Execute
   
 
'Dim pLayer As ILayer
'Set pLayer = pMxDocument.FocusMap.Layer(0)
'
'pLayer.Visible = False
'pMxDocument.UpdateContents
'
'pLayer.Visible = True
'pMxDocument.UpdateContents
 
End Sub
 
Private Function GetTopoExtension() As ITopologyExtension
On Error GoTo errhand
Dim pTopoEx As ITopologyExtension, pUID As UID, pApp As IApplication
Set pApp = Application
Set pUID = New UID
pUID.Value = "esriEditorExt.topologyextension"
Set pTopoEx = pApp.FindExtensionByCLSID(pUID)
Set GetTopoExtension = pTopoEx
Exit Function
errhand:
Set GetTopoExtension = Nothing
End Function
 
  
 
Private Function GetEditorExtension() As IEditor
 
On Error GoTo errhand
 
Dim peditor As IEditor, pUID As UID, pApp As IApplication
Set pApp = Application
Set pUID = New UID
pUID.Value = "esriEditor.editor"
 
Set peditor = pApp.FindExtensionByCLSID(pUID)
Set GetEditorExtension = peditor
 
Exit Function
 
errhand:
Set GetEditorExtension = Nothing
End Function
 
Public Function AddFeatureClassesToMap(FCArr As IFeatureClass) As Boolean
 
  Dim pFeatureLayer As IFeatureLayer, pMap As IMap, pMxDoc As IMxDocument, pFeatureclass As IFeatureClass, i As Integer
   
  On Error GoTo errhand
   
  Set pFeatureclass = FCArr
  Set pFeatureLayer = New FeatureLayer
  Set pFeatureLayer.FeatureClass = pFeatureclass
  pFeatureLayer.Name = pFeatureclass.AliasName
   
  Set pMxDoc = ThisDocument
  Set pMap = pMxDoc.FocusMap
   
  pMap.AddLayer pFeatureLayer
  AddFeatureClassesToMap = True
   
  Set pMap = Nothing
  Set pMxDoc = Nothing
  Set pFeatureLayer = Nothing
  Set pFeatureclass = Nothing
   
  Exit Function
errhand:
  AddFeatureClassesToMap = False
  Set pMap = Nothing
  Set pMxDoc = Nothing
  Set pFeatureLayer = Nothing
  Set pFeatureclass = Nothing
End Function