تعديل VBA Code لتحويل المضلعات إلى نقاط
تحية طيبة وبعد
كنت قد وجدت الكود التالي الذي يقوم بتحويل المضلعات إلى نقاط
Sub PolyToPoints()
Dim pEditor As IEditor
Dim pUID As New UID
Dim pEnumFeature As IEnumFeature
Dim pFeature As IFeature
Dim pFeatureLayer As IFeatureLayer
Dim pEditLayers As IEditLayers
Dim pPointCollection As IPointCollection
Dim pPolygon As IPolygon
Dim I As Long
Dim pNewFeat As IFeature
Dim pActiveView As IActiveView
On Error GoTo ErrHand
'get the editor
pUID = "EsriEditor.Editor"
Set pEditor = Application.FindExtensionByCLSID(pUID)
If Not pEditor Is Nothing Then
If pEditor.EditState = esriStateEditing Then
'get the the target layer
Set pEditLayers = pEditor
Set pFeatureLayer = pEditLayers.CurrentLayer
'check if its a point layer
If pFeatureLayer.FeatureClass.ShapeType = esriGeometryPoint Then
pEditor.StartOperation
'get selected features
Set pEnumFeature = pEditor.EditSelection
pEnumFeature.Reset
Set pFeature = pEnumFeature.Next
Do While Not pFeature Is Nothing
'check if feature is a polygon
If pFeature.Shape.GeometryType = esriGeometryPolygon Then
Set pPolygon = pFeature.Shape 'get the polygon
Set pPointCollection = pPolygon 'get its vertices
For I = 0 To pPointCollection.PointCount - 1 'loop thru all vertices
'create new point of the vertice
Set pNewFeat = pFeatureLayer.FeatureClass.CreateFeature
Set pNewFeat.Shape = pPointCollection.Point(I)
pNewFeat.Store
Next I
End If
Set pFeature = pEnumFeature.Next
Loop
pEditor.StopOperation "Done"
'refresh the map
Set pActiveView = pEditor.Map
pActiveView.Refresh
End If
Else
MsgBox "No edit session!", vbExclamation
End If
End If
Exit Sub
ErrHand:
MsgBox Err.Description, vbExclamation
End Sub
ولكن برزت لدي المشكلة التالية وهي انه في حال وجود مضلعين متجاورين ولديهما line مشترك فإن هذا الكود يقوم بتحويل المضلع الأول إلى نقاط ومن ثم المضلع الثاني إلى نقاط و بالتالي نحصل على نقاط مكررة
فهل أستطيع تعديل الكود بحيث احصل على نقاط غير مكررة
مع جزيل الشكر
[fot1]...[/fot1]العلم يحرسك وأنت تحرس المال
[fot1].....[/fot1]هلك خزان الأموال و العلماء باقون ما بقي الدهر