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

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