原文地址：http://blog.163.com/zhug_1970/blog/static/4298305320105109381862/
以下代码可以实现....
Public Sub ConvertPointToPolygon()
On Error GoTo errorHander
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Set pActiveView = pMap
Set pFeatureLayer = pMap.Layer(0)
Set pFeatureClass = pFeatureLayer.FeatureClass
'创建一个工作区，开始编辑
Set pDataSet = pFeatureClass
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pWorkspaceEdit = pWorkspaceFactory.OpenFromFile(pDataSet.Workspace.PathName, 0)
pWorkspaceEdit.StartEditOperation
pWorkspaceEdit.StartEditing True
Set pMultiLeft = New Multipoint
Set pMultiRight = New Multipoint
Set pGonColl = New Polygon
Set pMultiPoint = New Multipoint
Set pMultiPointSorted = New Multipoint
'得到所选择的图形集
Set pEnumFeature = pMxDoc.FocusMap.FeatureSelection
Set pFeature = pEnumFeature.Next
'增加点到MultiPoint
While Not pFeature Is Nothing
If pFeature.ShapeCopy.GeometryType = esriGeometryPoint Then
pMultiPoint.AddPoint pFeature.ShapeCopy
ElseIf pFeature.ShapeCopy.GeometryType = esriGeometryMultipoint Then
pMultiPoint.AddPointCollection pFeature.ShapeCopy
End If
Set pFeature = pEnumFeature.Next
Wend
If pMultiPoint.PointCount < 3 Then
MsgBox "Select a least 3 points !"
Exit Sub
End If
'创建第一个Polygon
pGonColl.AddPointCollection pMultiPoint
Set pTopoOp = pGonColl
'将Polygon是否是Simple设置成未知
pTopoOp.IsKnownSimple = False
'经判断，如果不是Simple，则经过以下处理，将其转换为Simple
If pTopoOp.IsSimple = False and pMultiPoint.PointCount>3 Then
lFlag = 1
Set pTopoOp = pMultiPoint
pTopoOp.IsKnownSimple = False
pTopoOp.Simplify
'将Multipoint进行排序
For i = 0 To pMultiPoint.PointCount - 1
For j = i + 1 To pMultiPoint.PointCount - 1
If pMultiPoint.Point(j).x < pMultiPoint.Point(i).x Or pMultiPoint.Point(j).x = _ pMultiPoint.Point(i).x And_ pMultiPoint.Point(j).y < pMultiPoint.Point(i).y Then
Set pClonei = pMultiPoint.Point(i)
Set pPointi = pClonei.Clone
'交换两点
pMultiPoint.ReplacePoints i, 1, 1, pMultiPoint.Point(j)
pMultiPoint.ReplacePoints j, 1, 1, pPointi
End If
Next
Next
Set ptMin = New Point
Set ptMax = New Point
'找出MultiPoint中的最大和最小点
pMultiPoint.QueryPoint 0, ptMin
pMultiPoint.QueryPoint pMultiPoint.PointCount - 1, ptMax
'创建一条线段
Set pBaseLine = New Line
pBaseLine.PutCoords ptMin, ptMax
Set pBaseCurve = pBaseLine
For i = 0 To pMultiPoint.PointCount - 1
Set pOutpoint = New Point
pBaseCurve.QueryPointAndDistance esriNoExtension, pMultiPoint.Point(i), False, pOutpoint, _ dDistAlong, dDistFrom, bIsRight
If bIsRight Then
pMultiRight.AddPoint pMultiPoint.Point(i)
Else
pMultiLeft.AddPoint pMultiPoint.Point(i)
End If
Next
Set pRingColl = New Ring
'将左边的线添加到Ring
For i = 0 To pMultiLeft.PointCount - 2
Set pLine = New Line
pLine.PutCoords pMultiLeft.Point(i), pMultiLeft.Point(i + 1)
pRingColl.AddSegment pLine
Next
'第一条线
Set pLine = New Line
pLine.PutCoords pMultiLeft.Point(pMultiLeft.PointCount - 1), pMultiRight.Point(0)
pRingColl.AddSegment pLine
'将右边的先添加到Ring
For i = (pMultiRight.PointCount - 1) To 1 Step -1
Set pLine = New Line
pLine.PutCoords pMultiRight.Point(i), pMultiRight.Point(i - 1)
pRingColl.AddSegment pLine
Next
'最后一条线
Set pLine = New Line
pLine.PutCoords pMultiRight.Point(0), pMultiLeft.Point(0)
pRingColl.AddSegment pLine
Set pRing = pRingColl
pRing.Close
Set pGonColl2 = New Polygon
pGonColl2.AddGeometry pRing
End If
If lFlag = 0 Then
Set pPolygon = pGonColl
Else
Set pPolygon = pGonColl2 'QI
End If
'画出Polygon
Set pFeatureLayer1 = pMap.Layer(1)
Set pFeatureClass1 = pFeatureLayer1.FeatureClass
Set pFeature1 = pFeatureClass1.CreateFeature
'把画的Polygon加到新建的Feature上
Set pFeature1.Shape = pPolygon
'保存Feature
pFeature1.Store
pMxDoc.ActiveView.Refresh
'停止编辑
pWorkspaceEdit.StopEditOperation
pWorkspaceEdit.StopEditing True
Exit Sub
ErrorHander:
pWorkspaceEdit.AbortEditOperation
MsgBox Err.Description
End Su