沿线批量内插点对象

最近碰到有一个数据处理的要求，需要针对线对象批量的内插生成点对象，本想自己写算法，后来发现AO中已提供接口实现，省事了

将点层放在第一层，在toc中选择要内插的线层，然后运行如下vba程序

该程序也适用于面对沿边线内插，关键接口IConstructMultipoint，方法ConstructDivideEqual 是指定个数，方法ConstructDivideEqual 是等距内插，自动计算内插个数。它支持等距内插和设定内插点个数两种方式，需要注意一点，起点和终点作为默认点，如果是设定内插点个数的，要在目标个数基础上减2，帮助中明确说是内部点个数作为输入参数

GetInterPointNum函数是自定义的，目的是获取需要内插点的个数

Public Sub CreatePointsAlongCurve()
    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
    Dim pMap As IMap
    Set pMap = pMxDoc.FocusMap
   
    Dim pInGeometry As IGeometry
    Dim pInLayer As ILayer
    Dim pInFLayer As IFeatureLayer
    Dim pOutFLayer As IFeatureLayer
    Dim pInFCursor As IFeatureCursor
    Dim pOutFCursor As IFeatureCursor
    Dim pOutFBuffer As IFeatureBuffer
    Dim pInFClass As IFeatureClass
    Dim pOutFClass As IFeatureClass
    Dim pSelSet As ISelectionSet
    Dim pFSelection As IFeatureSelection
    Dim pInFeature As IFeature
    Dim pCurve As ICurve
    Dim pPointCollection As IPointCollection
    Dim pConstructMultipoint As IConstructMultipoint
    Dim i As Long, lAID As Long
    Dim pPointDist As Double
    Dim pPolyline As IPolyline
    Dim dLength As Double
   
    Set pInLayer = pMxDoc.SelectedLayer
    If pInLayer Is Nothing Then
        MsgBox "请在TOC中选择要转换的图层", vbCritical, "错误提示"
        Exit Sub
    End If
    If TypeOf pInLayer Is IFeatureLayer Then
        Set pInFLayer = pMxDoc.SelectedLayer
    Else
        MsgBox "必须选择矢量要素类图层", vbCritical, "错误提示"
    Exit Sub
    End If
   
    Set pOutFLayer = pMap.Layer(0)
    Set pInFClass = pInFLayer.FeatureClass
    Set pOutFClass = pOutFLayer.FeatureClass
   
    If Not pOutFClass.ShapeType = esriGeometryPoint Then
        MsgBox "目标图层非点图层", vbCritical, "错误提示"
        Exit Sub
    End If
   
    Set pFSelection = pInFLayer
    Set pSelSet = pFSelection.SelectionSet
   
    Set pOutFBuffer = pOutFClass.CreateFeatureBuffer
    Set pOutFCursor = pOutFClass.Insert(True)
   
    Set pInFCursor = pInFLayer.Search(Nothing, False)
    Set pInFeature = pInFCursor.NextFeature
    Do While Not pInFeature Is Nothing
        Set pInGeometry = pInFeature.Shape
        lAID = pInFeature.Value(2)
        Set pCurve = pInGeometry
        dLength = pCurve.Length
       
        Set pConstructMultipoint = New Multipoint
        pConstructMultipoint.ConstructDivideEqual pCurve, GetInterPointNum(dLength, lAID) - 2
        Set pPointCollection = pConstructMultipoint
       
        For i = 0 To pPointCollection.PointCount - 1
            Set pOutFBuffer.Shape = pPointCollection.Point(i)
            pOutFCursor.InsertFeature pOutFBuffer
        Next i
       
        Set pInFeature = pInFCursor.NextFeature
    Loop
   
    pMxDoc.ActiveView.Refresh
    MsgBox "over"
    Exit Sub
End Sub