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
記事
