ESRI ArcGIS应用与开发 [帝国首发]ArcGIS开发教材,0830更新,提问前请先看||做专业的GIS技术交流论坛

zhqh

路人甲

注册日期2007-06-05
发帖数16
QQ
铜币145枚
威望0点
贡献值0点
银元0个

110楼^#

发布于：2008-06-23 16:14

如何将选中的点集转换成Polygon
本例要实现的功能是根据选中的Points创建一个Polygon，并且保存到Polygon类型的FeatureLayer中，要求被选择的Points最少为3个。 ● 要点 根据选择的点创建一个Polygon，首先要判断生成的Polygon是否是Simple,这里用到接口ITopologicalOperator2的属性IsSimple。如果不是,则要对做Polygon排序等处理。此外还用到了接口IPointCollection的方法ReplacePoints，进行点的交换。将排好序的点，按顺序创建Segment，运用实例化为Ring的ISegmentCollection接口方法AddSegment增加Segment。实例化为Polygon的IGeometryCollection接口方法AddGeometry增加Ring。这样，通过上面的方法便可以创建Polygon。 ●程序说明 
根据接口ITopologicalOperator2.IsSimple属性判断Polygon是否Simple。如果返回为False，就对Polygon上的点进行排序等处理，排好序后，找出X方向上值最大和最小的点，由这两点创建一条直线，将所有点分成在直线左边和右边两部分。 ●代码 Public Sub ConvertPointToPolygon() Dim pMxDoc As IMxDocument Dim pMap As IMap Dim pEnumFeature As IEnumFeature Dim pMultiPoint As IPointCollection Dim pMultiPointSorted As IPointCollection Dim pFeature As IFeature Dim pPointi As IPoint Dim pTopoOp As ITopologicalOperator2 Dim pLine As ILine Dim pGonColl As IPointCollection Dim pClonei As IClone Dim ptMin As IPoint Dim ptMax As IPoint Dim pBaseLine As ILine Dim pBaseCurve As ICurve Dim pOutpoint As IPoint Dim pMultiRight As IPointCollection Dim pMultiLeft As IPointCollection Dim pGonColl2 As IGeometryCollection Dim pPolygon As IPolygon Dim pRing As IRing Dim pFeatureClass As IFeatureClass Dim pFeatureLayer As IfeatureLayer Dim pFeature1 As IFeature Dim pFeatureClass1 As IFeatureClass Dim pFeatureLayer1 As IFeatureLayer Dim pDataSet As IDataset Dim pWorkspaceFactory As IWorkspaceFactory Dim pWorkspaceEdit As IWorkspaceEdit 
Dim pRingColl As ISegmentCollection Dim dDistAlong As Double Dim dDistFrom As Double Dim bIsRight As Boolean Dim i As Long Dim j As Long Dim lFlag As Long 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 Sub

举报回复喜欢评分

zhqh

路人甲

注册日期2007-06-05
发帖数16
QQ
铜币145枚
威望0点
贡献值0点
银元0个

加关注写私信

111楼^#

发布于：2008-06-23 16:20

如何将Multipoint转换成Points 本例要实现的功能是根据一个FeatureLayer中被选择一个或多个 MultiPoint，生成多个Point并把这些新生成的Point保存在一个Point类型的 Feature Layer上。 ●要点 本例将选择的Multipoints上的每个点都生成一个对应得Point，并用一个 接口IPointCollection的变量来接收。利用IPointCollection的方法 point(index),取出新生成的每个点,用来创建Point类型的Feature。 ●程序说明 
本例要求在ArcMap中添加两个层，最上面的是层Ｍultipoint，下面是层 wind。根据循环得到选择的每个Ｍultipoint的每个点，为wind层生成新的 Feature并保存 ●代码 Sub convertMultipointToPoints() Dim pMxDocument As IMxDocument Dim pMap As IMap Dim pActiveView As IActiveView Dim pEnumFeature As IEnumFeature Dim pFeature0 As IFeature Dim pFeatureLayer0 As IFeatureLayer Dim pFeatureClass0 As IFeatureClass Dim pFeature1 As IFeature Dim pFeatureLayer1 As IFeatureLayer Dim pFeatureClass1 As IFeatureClass Dim pPointCollection As IPointCollection Dim pDataSet As IDataset Dim pWorkspaceFactory As IWorkspaceFactory Dim pWorkspaceEdit As IWorkspaceEdit Dim lPointIndex As Long Dim lPointFieldIndex As Long On Error GoTo ErrorHanlder '得到当前层 Set pMxDocument = ThisDocument Set pMap = pMxDocument.FocusMap Set pActiveView = pMap '得到0层和1层的FeatureClass 
Set pFeatureLayer0 = pMxDocument.FocusMap.Layer(0) Set pFeatureClass0 = pFeatureLayer0.FeatureClass Set pFeatureLayer1 = pMxDocument.FocusMap.Layer(1) Set pFeatureClass1 = pFeatureLayer1.FeatureClass '建立编辑工作区 Set pDataSet = pFeatureClass1 Set pWorkspaceFactory = New ShapefileWorkspaceFactory Set pWorkspaceEdit = pWorkspaceFactory.OpenFromFile(pDataSet.Workspace.PathName,0) pWorkspaceEdit.StartEditOperation pWorkspaceEdit.StartEditing True '得到Feature Set pEnumFeature = pMxDocument.FocusMap.FeatureSelection Set pFeature0 = pEnumFeature.Next If pFeature0 Is Nothing Then MsgBox "Must have Select in Position 0" Exit Sub End If '循环,通过每个MultiPoint,在１图层上，生成以每个点为特征的Points While Not pFeature0 Is Nothing If pFeature0.ShapeCopy.GeometryType = esriGeometryMultipoint Then Set pPointCollection = pFeature0.ShapeCopy For nPointIndex = 0 To pPointCollection.PointCount - 1 Set pFeature1 = pFeatureClass1.CreateFeature '在pFeature1上生成Point Set pFeature1.Shape = pPointCollection.Point(nPointIndex) '如果两Feature的FieldCount相同，赋每个Field的值，ID, 
'TypeGeometry的Field除外 If pFeature1.Fields.FieldCount = pFeature0.Fields.FieldCount Then For lPointFieldIndex = 0 To pFeature1.Fields.FieldCount - 1 If Not pFeature1.Fields.Field(lPointFieldIndex).Type = _ 
esriFieldTypeGeometry And Not pFeature1.Fields. _ Field(lPointFieldIndex).Type = esriFieldTypeOID Then pFeature1.Value(lPointFieldIndex) = _ 
pFeature0.Value(lPointFieldIndex) End If Next End If '保存Feature pFeature1.Store Next Else MsgBox "Must have Multipoint in position 0" Exit Sub End If Set pFeature0 = pEnumFeature.Next Wend '停止编辑 pWorkspaceEdit.StopEditOperation pWorkspaceEdit.StopEditing True Exit Sub ErrorHanlder: pWorkspaceEdit. AbortEditOperation 
MsgBox Err.Description End Sub

举报回复喜欢评分

zhqh 路人甲注册日期2007-06-05 发帖数16 QQ 铜币145枚威望0点贡献值0点银元0个加关注写私信	112楼^# 发布于：2008-06-23 16:23 <P>我有PDF文件，谁要的话联系我吧。</P> <P>(不会上传）</P> <P>QQ:280246507</P>
	举报回复(0) 喜欢(0) 评分

liuwq05 路人甲注册日期2007-02-25 发帖数13 QQ 铜币158枚威望0点贡献值0点银元0个加关注写私信	113楼^# 发布于：2008-08-27 10:17 <P>是相当不错，老大能不能再提供点vb.net开发的东西。</P>
	举报回复(0) 喜欢(0) 评分

zsj1986 外卖仔注册日期2007-07-11 发帖数42 QQ 铜币221枚威望2点贡献值0点银元0个加关注写私信	114楼^# 发布于：2008-09-25 17:17 <img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em01.gif" />
	举报回复(0) 喜欢(0) 评分

JamLau 路人甲注册日期2007-05-16 发帖数14 QQ 铜币21枚威望0点贡献值0点银元0个加关注写私信	115楼^# 发布于：2008-10-04 15:58 我顶<img src="images/post/smile/dvbbs/em11.gif" /><img src="images/post/smile/dvbbs/em11.gif" />
	举报回复(0) 喜欢(0) 评分

100200y 路人甲注册日期2008-05-19 发帖数26 QQ 铜币146枚威望0点贡献值0点银元0个加关注写私信	116楼^# 发布于：2008-10-31 15:43 你好历害啊，佩服
	举报回复(0) 喜欢(0) 评分

您需要登录后才可以回帖，登录或者注册