2 点間のライン作成

Attribute VB_Name = "Module1"
Option Explicit

Sub test()

Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument

'始点ポイント(GPS)(1番目レイヤ)
Dim pFLayer0 As IFeatureLayer
Set pFLayer0 = pMxDoc.FocusMap.Layer(0)

Dim pFClass0 As IFeatureClass
Set pFClass0 = pFLayer0.FeatureClass


'終点ポイント(アドレスマッチング)(2番目レイヤ)
Dim pFLayer1 As IFeatureLayer
Set pFLayer1 = pMxDoc.FocusMap.Layer(1)

Dim pFClass1 As IFeatureClass
Set pFClass1 = pFLayer1.FeatureClass


'ライン(3番目レイヤ)
Dim pFLayer2 As IFeatureLayer
Set pFLayer2 = pMxDoc.FocusMap.Layer(2)

Dim pFClass2 As IFeatureClass
Set pFClass2 = pFLayer2.FeatureClass


'始点ポイントの取得
Dim pFCursor0 As IFeatureCursor
Set pFCursor0 = pFClass0.Search(Nothing, True)


'終点ポイント取得用検索条件
Dim pQFilter0 As IQueryFilter
Dim pFCursor1 As IFeatureCursor
Dim pFeature1 As IFeature
Dim pPCollection As IPointCollection    'ラインレイヤに挿入するジオメトリ


'Insertカーソルの作成
Dim pFCursor2 As IFeatureCursor
Set pFCursor2 = pFClass2.Insert(True)

'フィーチャバッファを使用
Dim pFeature2 As IFeature
Set pFeature2 = pFClass2.CreateFeatureBuffer

Dim i As Long   'ループ用
Dim q As Long   'ObjectID
Dim c As Long   'フィーチャ フラッシュ用
c = 0


'ベースポイント(1番目のレイヤ)の数だけループ
Dim pFeature0 As IFeature
Set pFeature0 = pFCursor0.NextFeature

Do Until pFeature0 Is Nothing
    
    '検索実行
    Set pQFilter0 = New QueryFilter
    pQFilter0.WhereClause = " ""基地局管理"" =  '" & pFeature0.Value(pFeature0.Fields.FindField("baseid")) & "'"
    
    Set pFCursor1 = pFClass1.Search(pQFilter0, True)
    Set pFeature1 = pFCursor1.NextFeature
    
    '検索によってひっかかった対応ポイント(2番目のレイヤ)
    If Not pFeature1 Is Nothing Then
                
        'ラインジオメトリの作成
        Set pPCollection = New Polyline
        
        pPCollection.AddPoint pFeature0.Shape
        pPCollection.AddPoint pFeature1.Shape
        
        '属性の入力
        Set pFeature2.Shape = pPCollection  'ジオメトリ
        pFeature2.Value(pFeature2.Fields.FindField("基地局管理")) = pFeature0.Value(pFeature0.Fields.FindField("baseid"))   '属性
        
        'Featureの作成処理
        q = pFCursor2.InsertFeature(pFeature2)
        c = c + 1
        
        'フィーチャのフラッシュ
        If c = 1000 Then
            pFCursor2.Flush
            c = 0
        End If
        
        
    End If
        
    Set pFeature0 = pFCursor0.NextFeature
    

Loop
    
    'フィーチャのフラッシュ
    pFCursor2.Flush
    
    MsgBox "end"

End Sub