マップ トポロジの利用

'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