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