Public Sub Test_New()
'現在のドキュメントを取得
Dim pMxDocument As IMxDocument
Set pMxDocument = ThisDocument
'アクティブなデータフレームの取得
Dim pMap As IMap
Set pMap = pMxDocument.FocusMap
'レイヤを取得
Dim pLayer As ILayer
Set pLayer = pMap.Layer(0)
' Set pLayer = pMap.Layer(InputBox("Layer Index ?"))
'フィーチャレイヤを取得
Dim pFeatureLayer As IFeatureLayer
Set pFeatureLayer = pLayer
'フィーチャクラスを取得
Dim pFeatureClass As IFeatureClass
Set pFeatureClass = pFeatureLayer.FeatureClass
'フィールドのコレクションを取得
Dim pFields As IFields
Set pFields = pFeatureClass.Fields
'フィーチャを取得
Dim pFeature As IFeature
Set pFeature = pFeatureClass.CreateFeature
' Set pFeature = pFeatureClass.GetFeature(InputBox("ObjectID ?"))
Dim ppoint As IPoint
Set ppoint = New Point
Call ppoint.PutCoords(422480, 324767.31) '中心点
Dim pEnvelope As IEnvelope
Set pEnvelope = ppoint.Envelope
'作成する図形について
'ケース１（楕円）
'上（4m）、下（4m）、左（2m）、右（2m）の楕円形
pEnvelope.XMin = ppoint.X - 2 '楕円の左端
pEnvelope.XMax = ppoint.X + 2 '楕円の右端
pEnvelope.YMin = ppoint.Y - 4 '楕円の上端
pEnvelope.YMax = ppoint.Y + 4 '楕円の下端
Dim pConstructEllipticArc As IConstructEllipticArc
Set pConstructEllipticArc = New EllipticArc
Call pConstructEllipticArc.ConstructEnvelope(pEnvelope)
Dim pSegmentCollectionA As ISegmentCollection
Set pSegmentCollectionA = New Polygon
Call pSegmentCollectionA.AddSegment(pConstructEllipticArc)
Set pFeature.Shape = pSegmentCollectionA
pFeature.Store
pMxDocument.ActiveView.Refresh
'*****************************************************************************************
'*****************************************************************************************
Dim pSegmentCollection As ISegmentCollection
Set pSegmentCollection = New Polygon
'完成後のポリゴン
'作成する図形について
'上（4m）、下（2m）、左（5m）、右（2m）＞＞＞＞（４つの楕円の組み合わせ）
'第１象限の部分の楕円
'上（4m）、下（4m）、左（2m）、右（2m）＞＞＞＞（w = 4, H = 8）
Dim P1 As IPoint
Dim P2 As IPoint
Set P1 = New Point
Set P2 = New Point
P1.X = ppoint.X
P1.Y = ppoint.Y + 4
P2.X = ppoint.X + 2
P2.Y = ppoint.Y
Dim penv01 As IEnvelope
Set penv01 = P1.Envelope
penv01.XMin = ppoint.X - 2 '楕円の左端
penv01.XMax = ppoint.X + 2 '楕円の右端
penv01.YMin = ppoint.Y - 4 '楕円の上端
penv01.YMax = ppoint.Y + 4 '楕円の下端
Set pConstructEllipticArc = New EllipticArc
pConstructEllipticArc.ConstructTwoPointsEnvelope P1, P2, penv01, esriArcClockwise
pSegmentCollection.AddSegment pConstructEllipticArc
'１つ目のカーブを追加する
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'第２象限の部分の楕円
'上（2m）、下（2m）、左（2m）、右（2m）＞＞＞＞（w = 4, H = 4）
Dim P3 As IPoint
Set P3 = New Point
P3.X = ppoint.X
P3.Y = ppoint.Y - 2
Dim penv02 As IEnvelope
Set penv02 = P3.Envelope
penv02.XMin = ppoint.X - 2 '楕円の左端
penv02.XMax = ppoint.X + 2 '楕円の右端
penv02.YMin = ppoint.Y - 2 '楕円の上端
penv02.YMax = ppoint.Y + 2 '楕円の下端
Set pConstructEllipticArc = New EllipticArc
pConstructEllipticArc.ConstructTwoPointsEnvelope P2, P3, penv02, esriArcClockwise
pSegmentCollection.AddSegment pConstructEllipticArc
'２つ目のカーブを追加する。
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'第３象限の部分の楕円
'上（2m）、下（2m）、左（5m）、右（5m）＞＞＞＞（w = 10, H = 4）
Dim P4 As IPoint
Set P4 = New Point
P4.X = ppoint.X - 5
P4.Y = ppoint.Y
Dim penv03 As IEnvelope
Set penv03 = P3.Envelope
penv03.XMin = ppoint.X - 5 '楕円の左端
penv03.XMax = ppoint.X + 5 '楕円の右端
penv03.YMin = ppoint.Y - 2 '楕円の上端
penv03.YMax = ppoint.Y + 2 '楕円の下端
Set pConstructEllipticArc = New EllipticArc
pConstructEllipticArc.ConstructTwoPointsEnvelope P3, P4, penv03, esriArcClockwise
pSegmentCollection.AddSegment pConstructEllipticArc
'３つ目のカーブを追加する。
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'第4象限の部分の楕円
'上（4m）、下（4m）、左（5m）、右（5m）＞＞＞＞（w = 10, H = 8）
'第１点目を再利用するので新しい点は不要。
Dim penv04 As IEnvelope
Set penv04 = P1.Envelope
penv04.XMin = ppoint.X - 5 '楕円の左端
penv04.XMax = ppoint.X + 5 '楕円の右端
penv04.YMin = ppoint.Y - 4 '楕円の上端
penv04.YMax = ppoint.Y + 4 '楕円の下端
Set pConstructEllipticArc = New EllipticArc
pConstructEllipticArc.ConstructTwoPointsEnvelope P4, P1, penv04, esriArcClockwise
pSegmentCollection.AddSegment pConstructEllipticArc
'４つ目のカーブを追加する。
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Set pFeature = pFeatureClass.CreateFeature
Set pFeature.Shape = pSegmentCollection
pFeature.Store
pMxDocument.ActiveView.Refresh
End Sub
記事
