中心から指定した東西南北の地点を通る疑似楕円

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
    
    
    '作成する図形について
    'ケース1(楕円)
    '上(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)>>>>(4つの楕円の組み合わせ)
    '第1象限の部分の楕円
     '上(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
     '1つ目のカーブを追加する
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    '第2象限の部分の楕円
     '上(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
    '2つ目のカーブを追加する。
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    '第3象限の部分の楕円
     '上(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
    '3つ目のカーブを追加する。
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    '第4象限の部分の楕円
     '上(4m)、下(4m)、左(5m)、右(5m)>>>>(w = 10, H = 8)
    '第1点目を再利用するので新しい点は不要。
    
    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
    '4つ目のカーブを追加する。
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

    Set pFeature = pFeatureClass.CreateFeature
    Set pFeature.Shape = pSegmentCollection
    pFeature.Store
   
    pMxDocument.ActiveView.Refresh

End Sub