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

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