zdmerger.vb

来自「基于ArcEngine用VB.net编写的地籍信息管理系统中实现宗地合并功能的相」· VB 代码 · 共 608 行 · 第 1/2 页

                        pFeat = pArrayFeat.Item(i)
                        pNewFeat.Shape = pFeat.ShapeCopy '//传递宗地的空间字段
                        m = pFeat.Fields.FindField(Consts.FieldsName.ZDH)
                        pRow = pReTab.CreateRow
                        pRow.Value(1) = pFeat.Value(m)
                        pRow.Value(2) = pFrm.ZDH          '//将宗地号传到关系表中
                        pRow.Value(3) = pFrm.AlterTime
                        pRow.Value(4) = pFrm.AlterPerson
                        pRow.Value(5) = "M"
                        pRow.Store()
                        For j = 0 To pNewFeat.Fields.FieldCount - 1  '//传递选中宗地的属性值到历史表中

                            If pNewFeat.Fields.Field(j).Editable And pNewFeat.Fields.Field(j).Type <> esriFieldType.esriFieldTypeGeometry Then
                                k = pFeat.Fields.FindFieldByAliasName(pNewFeat.Fields.Field(j).AliasName)
                                pNewFeat.Value(j) = pFeat.Value(k)
                            End If

                        Next
                        pNewFeat.Store()
                    Next

                    DelecteHighLight() '//删除高亮选择
                    Me.DelCommonEdges() '\\删除公共的界址线
                    pNewFeat = MergeZDFeature(pFrm.ZDH) '//合并宗地类,输入新宗地号
                    Me.DeleteCommonJZD(pNewFeat) '删除公共的界址点
                    pWorkSpaceEdit.StopEditOperation()
                    Return True
                End If
            Catch ex As System.Exception
                MessageBox.Show(ex.Message)
                pWorkSpaceEdit.StopEditOperation()
                pWorkSpaceEdit.UndoEditOperation() '出错,取消本次操作 
                Return False
            Finally
                'pFrm.Dispose()
                'pFrm = Nothing
            End Try

        End Function
        Private Function FindJZXFromZD(ByVal pZDFeat As IFeature, ByRef pJZXFeat As IFeature()) As Boolean
            '根据宗地要素查找与它相关的界址线集合，并检查拓扑关系匹配
            '如果匹配返回查找到的界址线要素集合，否则返回空值和FALSE
            '======================================================

            Dim pEnumTopologyEdge As IEnumTopologyEdge
            Dim pTopologyEdge As ITopologyEdge
            Dim pTopologyElement As ITopologyElement
            Dim pTopoEPerents As IEnumTopologyParent
            Dim pTopoPerent As esriTopologyParent
            Dim i As Integer, pFeatCount As Integer, j As Integer
            Dim pFeatID() As Integer
            '\\
            Dim pActiveView As IActiveView
            pActiveView = Me.m_pMap
            '\\
            pEnumTopologyEdge = Me.m_pTopologyGraph.GetParentEdges(m_pZDFeatCls, pZDFeat.OID)
            pTopologyEdge = pEnumTopologyEdge.Next

            pFeatCount = 0
            Do While Not pTopologyEdge Is Nothing
                '====================================
                pTopologyElement = pTopologyEdge
                pTopoEPerents = pTopologyElement.Parents

                For i = 0 To pTopoEPerents.Count - 1
                    pTopoPerent = pTopoEPerents.Next
                    If pTopoPerent.m_pFC Is Me.m_pJZXFeatCls Then
                        '==============查找是否有重复====================
                        For j = 0 To pFeatCount - 1
                            If pFeatID(j) = pTopoPerent.m_FID Then
                                Exit For 'J
                            End If
                        Next
                        If j = pFeatCount Then '没有重复
                            ReDim Preserve pFeatID(pFeatCount + 1)
                            pFeatID(pFeatCount) = pTopoPerent.m_FID
                            pFeatCount = pFeatCount + 1
                        End If
                        Exit For  '查找到界址线类,退出循环I
                    End If
                Next
                pTopologyEdge = pEnumTopologyEdge.Next
            Loop
            '=====================找到相应的要素====================
            Dim pJZXFeat1(pFeatCount - 1) As IFeature
            For i = 0 To pFeatCount - 1
                '===========================
                pJZXFeat1(i) = Me.m_pJZXFeatCls.GetFeature(pFeatID(i))
            Next
            pJZXFeat = pJZXFeat1
            Return True
        End Function
        Private Sub DelecteHighLight()
            Dim i As Integer
            Dim pGC As IGraphicsContainer
            Dim pAV As IActiveView
            pGC = m_pMap
            pAV = m_pMap

            For i = 0 To Me.m_pElements.Count - 1
                '================================
                pGC.DeleteElement(Me.m_pElements(i))
            Next

            Me.m_pElements.Clear() '//清空数组 
            SelectFeatNum = 0 '//清空被选要素数
            pAV.Refresh()

        End Sub
        Private Function MergeZDFeature(ByVal ZDHstr As String) As IFeature

            ' create a new feature to be the merge feature
            Dim pCurFeature As IFeature
            Dim pNewFeature As IFeature
            Dim lCount As Long
            Dim pWspEdit As IWorkspaceEdit
            Dim m As Integer
            '\\建立新的要素
            pNewFeature = m_pZDFeatCls.CreateFeature
            ' create the new geometry.
            Dim pGeom As IGeometry
            Dim pTmpGeom As IGeometry
            Dim pOutputGeometry As IGeometry
            Dim pTopoOperator As ITopologicalOperator
            Dim pGC2 As IGraphicsContainer
            '' initialize the default values for the new feature
            'Dim pOutRSType As IRowSubtypes
            'pOutRSType = pNewFeature
            'If lSCode <> 0 Then
            '    pOutRSType.SubtypeCode = lSCode
            'End If
            'pOutRSType.InitDefaultValues()

            ' get the first feature
            pCurFeature = pArrayFeat.Item(0)
            Dim pFlds As IFields
            pFlds = m_pZDFeatCls.Fields

            lCount = 1
            Do
                ' get the geometry
                pGeom = pCurFeature.ShapeCopy
                If lCount = 1 Then ' if its the first feature
                    pTmpGeom = pGeom
                Else ' merge the geometry of the features
                    pTopoOperator = pTmpGeom
                    pOutputGeometry = pTopoOperator.Union(pGeom)
                    pTmpGeom = pOutputGeometry
                End If

                pCurFeature.Delete() ' delete the feature
                If lCount = pArrayFeat.Count Then
                    Exit Do
                End If
                pCurFeature = pArrayFeat.Item(lCount)
                lCount = lCount + 1
            Loop
            'Loop Until pCurFeature Is Nothing
            pNewFeature.Shape = pOutputGeometry

            m = pNewFeature.Fields.FindField(Consts.FieldsName.ZDH) '//向新合并的宗地输入宗地号
            pNewFeature.Value(m) = ZDHstr
            pNewFeature.Store() '//保存

            'GetSelectFeatHighLight(pNewFeature) '//高亮显示新对象
            Return pNewFeature
            'pGC2 = m_pMap
            ''pGC2.DeleteElement()
            'pGC2.DeleteAllElements()
            'Dim pActive As IActiveView
            'pActive = m_pMap
            'pActive.PartialRefresh(esriViewDrawPhase.esriViewGraphics, Nothing, Nothing)

            '' select new feature
            'Dim pMap As IMap
            'pMap = m_pMap
            'pMap.ClearSelection()
            'pMap.SelectFeature(m_pZDLayer, pNewFeature)




        End Function
        '\\检查所选择的宗地是否有都有公共边
        Private Function CheckZD() As Boolean
            'Dim pZdBaseCls As New ZDBaseClass(Me.m_pMap) '使用宗地要素类
            Dim pFeatEdge As IFeature(), pFeatEdge2 As IFeature()
            Dim i, j, k, m As Integer

            Dim pFeat1 As IFeature, pFeat2 As IFeature
            Dim pHasCommon As Boolean
            For i = 0 To pArrayFeat.Count - 1
                If Me.FindJZXFromZD(pArrayFeat(i), pFeatEdge) Then
                    For j = 0 To pArrayFeat.Count - 1
                        If j <> i Then '不能为相同的宗地
                            If Me.FindJZXFromZD(pArrayFeat(j), pFeatEdge2) Then
                                '\\比较有没有公共边
                                k = 0
                                pHasCommon = False
                                Do While Not pHasCommon And k <= UBound(pFeatEdge)
                                    pFeat1 = pFeatEdge(k)
                                    For m = 0 To UBound(pFeatEdge2)
                                        pFeat2 = pFeatEdge2(m)
                                        If pFeat1.OID = pFeat2.OID Then '有公共边
                                            pHasCommon = True
                                            Exit For
                                        End If
                                    Next
                                    k = k + 1
                                Loop
                                '\\
                                If pHasCommon Then '说明此两个宗地有公共边
                                    Exit For 'j
                                End If
                            End If
                        End If
                    Next
                    '\\判断是否找到至少一个宗地与该宗地有公共边
                    If j = pArrayFeat.Count Then '没有公共边,说明有孤立的宗地,所以不能进行合并
                        Return False
                    End If
                End If
            Next
            Return True '所有宗地都与其余宗地至少有一条公共边
        End Function
        '\\删除所需合并的公共边
        Private Function DelCommonEdges() As Boolean
            'Dim pZdBaseCls As New ZDBaseClass(Me.m_pMap) '使用宗地要素类

            Dim pFeatEdge As IFeature(), pFeatEdge2 As IFeature()
            Dim pFeatEdgeArray As New ArrayList '存放各个宗地所检测出的所有边
            Dim pFeatRepeatArray As New ArrayList
            Dim pFeat1 As IFeature, pFeat2 As IFeature

            Dim i, j, k, m As Integer
            '\\查找所有宗地的边
            For i = 0 To pArrayFeat.Count - 1
                If Me.FindJZXFromZD(pArrayFeat(i), pFeatEdge) Then
                    pFeatEdgeArray.Add(pFeatEdge)
                End If
            Next
            '\\检查重复边并删除
            For i = 0 To pFeatEdgeArray.Count - 1
                pFeatEdge = pFeatEdgeArray(i)
                For j = i + 1 To pFeatEdgeArray.Count - 1
                    pFeatEdge2 = pFeatEdgeArray(j)
                    '\\检查重复边
                    For k = 0 To UBound(pFeatEdge)
                        pFeat1 = pFeatEdge(k)
                        For m = 0 To UBound(pFeatEdge2)
                            pFeat2 = pFeatEdge2(m)
                            If pFeat1.OID = pFeat2.OID Then
                                pFeatRepeatArray.Add(pFeat1) '检查到有重复边
                            End If
                        Next
                    Next
                Next
            Next
            '\\删除重复边
            '\\检查数组中有无重复的要素
            i = 0
            Do While i < pFeatRepeatArray.Count
                pFeat1 = pFeatRepeatArray(i)
                j = i + 1
                Do While j < pFeatRepeatArray.Count
                    pFeat2 = pFeatRepeatArray(j)
                    If pFeat1.OID = pFeat2.OID Then
                        pFeatRepeatArray.RemoveAt(j) '移除重复检测边,以免重复删除出错
                    End If
                    j = j + 1
                Loop

                '\\删除要素边(界址线)
                pFeat1.Delete()
                i = i + 1
            Loop
            Return True
        End Function
        Private Sub DeleteCommonJZD(ByVal pNewFeat As IFeature)
            '\\
            Dim pSFilter As ISpatialFilter
            Dim pQFilter As IQueryFilter
            Dim pCursor As IFeatureCursor
            Dim pFeat As IFeature
            '\\
            pSFilter = New SpatialFilter
            pSFilter.Geometry = pNewFeat.ShapeCopy
            pSFilter.SpatialRel = esriSpatialRelEnum.esriSpatialRelContains
            pSFilter.GeometryField = Me.m_pJZDFeatCls.ShapeFieldName
            pQFilter = pSFilter
            pCursor = Me.m_pJZDFeatCls.Search(pQFilter, False)
            '\\
            pFeat = pCursor.NextFeature
            Do While Not IsNothing(pFeat)
                pFeat.Delete()
                pFeat = pCursor.NextFeature
            Loop
        End Sub

    End Class

End Namespace