Multipart polyline to single part lines

最新推荐文章于 2019-07-03 07:43:16 发布

转载最新推荐文章于 2019-07-03 07:43:16 发布 · 113 阅读

本教程介绍如何在ArcGIS中使用VBA代码将多部分折线分解为单个线段。通过使用IGeometryCollection接口而非ISegmentCollection，可以避免创建过多的线段。代码示例展示了如何遍历选定的折线特征，将其分解，并存储为新的单一部分折线。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

Breaking Up Polylines

http://forums.esri.com/Thread.asp?c=93&f=987&t=74554&mc=4#msgid197545

It appears as though IGeometryCollection is the way to go here, rather than ISegmentCollection. I noticed that the "ISegmentCollection" version created 905 line segments (from 15 polylines). ISegmentCollection created a line for every Single PAIR of vertices - 905 straight, two vertex lines.

There is no way I could have put this thing together at this point. Thanks for getting the ball rolling.

Hopefully, this can be useful to other users. Multipart lines can be a huge pain when you don't want them.

Sub ExplodePolyLines()

' From the original by Kirk Kuykendall.

Dim pUID As New UID

pUID.Value = "esricore.Editor"

Dim pEditor As IEditor

Set pEditor = Application.FindExtensionByCLSID(pUID)

If pEditor.EditState <> esriStateEditing Then

MsgBox "Make a shapefile editable."

Exit Sub

End If

Dim pEditlayers As IEditLayers

Set pEditlayers = pEditor

If pEditlayers.CurrentLayer.FeatureClass.ShapeType <> esriGeometryPolyline Then

Exit Sub

End If

Dim pFSel As IFeatureSelection

Set pFSel = pEditlayers.CurrentLayer

If pFSel.SelectionSet.Count = 0 Then

MsgBox "Select features to be broken up."

Exit Sub

End If

Dim pFCur As IFeatureCursor

pFSel.SelectionSet.Search Nothing, False, pFCur

pEditor.StartOperation

Dim pFeat As IFeature

Set pFeat = pFCur.NextFeature

Do Until pFeat Is Nothing

Dim pInGeomColl As IGeometryCollection

''' Dim pInSegColl As ISegmentCollection

''' Set pInSegColl = pFeat.ShapeCopy

Set pInGeomColl = pFeat.ShapeCopy

Application.StatusBar.Message(0) = "Exploding " & pFeat.OID

Dim l As Long

''' For l = 0 To pInSegColl.SegmentCount - 1

For l = 0 To pInGeomColl.GeometryCount - 1

''' Dim pOutSegColl As ISegmentCollection

''' Set pOutSegColl = New Polyline

Dim pOutGeomColl As IGeometryCollection

Set pOutGeomColl = New Polyline

''' pOutSegColl.AddSegment pInSegColl.Segment(l)

pOutGeomColl.AddGeometry pInGeomColl.Geometry(l)

Dim pOutFeat As IFeature

Set pOutFeat = pEditlayers.CurrentLayer.FeatureClass.CreateFeature

Dim k As Long

For k = 0 To pOutFeat.Fields.FieldCount - 1

If pOutFeat.Fields.Field(k).Editable Then

If pOutFeat.Fields.Field(k).Type <> esriFieldTypeGeometry Then

pOutFeat.Value(k) = pFeat.Value(k)

End If

Next k

''' Set pOutFeat.Shape = pOutSegColl

Set pOutFeat.Shape = pOutGeomColl

pOutFeat.Store

Next l

pFeat.Delete

Set pFeat = pFCur.NextFeature

Loop

pEditor.StopOperation "Explode"

Dim pMxDoc As IMxDocument

Set pMxDoc = pEditor.Parent.Document

Dim pAV As IActiveView

Set pAV = pMxDoc.FocusMap

Dim lCacheID As Long

lCacheID = pAV.ScreenCacheID(esriViewGeoSelection, Nothing)

pAV.ScreenDisplay.Invalidate Nothing, True, lCacheID

MsgBox "Done"

End Sub