YouTube | Facebook | Twitter  Feed

マップ トポロジーの利用

2016/9/1 (木)

'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

関連記事

  • この記事を書いた人

羽田 康祐

Esri認定インストラクター、GIS上級技術者、測量士補、潜水士。GISy / GISc とその関連分野である地理学・地図学について日々の出来事で学んだ記憶を記録するためにブログを書いています。行動原理は伊達と酔狂。好きな地形は圏谷。好きな地図投影法はパースクインカンシャル図法。呉市生まれ広島市出身。GIS を使った自己紹介はこちら

-プログラミング, ArcGIS
-,

© 2020 WINGFIELD since1981