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