始点から各点にラインを引く方法

Sub subCreateLine()

    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
    
    'ポイント
    Dim pFLayer0 As IFeatureLayer
    Set pFLayer0 = pMxDoc.FocusMap.Layer(0)
    
    Dim pFClass0 As IFeatureClass
    Set pFClass0 = pFLayer0.FeatureClass
    
    '作成ライン
    Dim pFLayer1 As IFeatureLayer
    Set pFLayer1 = pMxDoc.FocusMap.Layer(1)

    Dim pFClass1 As IFeatureClass
    Set pFClass1 = pFLayer1.FeatureClass
    
    
    'InsertCursor
    Dim pFeatureCursor As IFeatureCursor
Set pFeatureCursor = pFClass1.Insert(True)


    'フィーチャバッファを使用
    Dim pFeature1 As IFeature
    Set pFeature1 = pFClass1.CreateFeatureBuffer
    
    Dim i As Long   'ループ用
    Dim q As Long   'ObjectID
        
    
    Dim FromID As Long
    FromID = InputBox("中心点とするフィーチャIDを指定してください")
    
    '中心点用Feaeture取得
    Dim pCFeature As IFeature
    Set pCFeature = pFClass0.GetFeature(FromID)
    
    'ラインジオメトリ
    '始点
    Dim pFromPoint As IPoint
    
    '終点
    Dim pToPoint As IPoint
    
    'ライン
    Dim pLine As ILine
    
    Dim pPolyline As IPointCollection
    Dim pPolyCurve As IPolycurve
    
    
    Dim pFcursor0 As IFeatureCursor
    Set pFcursor0 = pFClass0.Search(Nothing, True)
    
    Dim pFeature0 As IFeature
    Set pFeature0 = pFcursor0.NextFeature
    
    Do Until pFeature0 Is Nothing
    
            If Not pFeature0.OID = FromID Then
            
            Set pFromPoint = pCFeature.Shape
            Set pToPoint = pFeature0.Shape
            
            pFromPoint.Project pMxDoc.FocusMap.SpatialReference
            pToPoint.Project pMxDoc.FocusMap.SpatialReference
            
            'ポリラインの作成
            Set pPolyline = New Polyline
            
            Set pPolyCurve = pPolyline
            pPolyCurve.Project pMxDoc.FocusMap.SpatialReference
            
            pPolyline.AddPoint pFromPoint
            pPolyline.AddPoint pToPoint

            
            pPolyCurve.Densify 1000, 0

            
            '属性情報の入力
            Set pFeature1.Shape = pPolyCurve
            
            'Featureの作成処理
            q = pFeatureCursor.InsertFeature(pFeature1)
    
    End If
    
    Set pFeature0 = pFcursor0.NextFeature
    
    Loop
    
    
    'フィーチャのフラッシュ

        pFeatureCursor.Flush
    
    
pMxDoc.ActiveView.Refresh

End Sub