zdmerger.vb

基于ArcEngine用VB.net编写的地籍信息管理系统中实现宗地合并功能的相关代码。在合并宗地的同时传递历史宗地记录到数据库中。

Imports ESRI.ArcGIS.ToolbarControl
Imports ESRI.ArcGIS.SystemUI
Imports ESRI.ArcGIS.Carto
Imports ESRI.ArcGIS.MapControl
Imports ESRI.ArcGIS.TOCControl
Imports ESRI.ArcGIS.esriSystem
Imports ESRI.ArcGIS.Display
Imports ESRI.ArcGIS.Geometry
Imports ESRI.ArcGIS.Geodatabase
Imports ESRI.ArcGIS.DataSourcesGDB
Imports ESRI.ArcGIS.DataSourcesFile

Imports Microsoft.VisualBasic
Imports System
Imports ESRI.ArcGIS.Geometry.esriGeometryType    '//添加类型

Imports System.Windows.Forms
Imports System.Data
Imports System.Runtime.InteropServices

Imports ESRI.ArcGIS.ControlCommands
Imports ESRI.ArcGIS.Utility.BaseClasses
Namespace myZDEditor
    Public Class ZDMerger
        Inherits BaseTool

        Private m_pHookHelper As IHookHelper
        Private m_pMap As IMap
        Private m_pWorkspace As IWorkspace
        Private m_pZDLayer As ILayer
        Private m_pZDFeatCls As IFeatureClass
        Private m_pJZDFeatCls As IFeatureClass
        Private m_pJZXFeatCls As IFeatureClass
        '\\
        Private pFeatArray() As IFeature
        Private pArrayFeat As ArrayList
        Private m_pElements As ArrayList '传入所编辑要素的图形要素,与FEAT要素是一一对应的
        Private m_pFillSymbol As ISimpleFillSymbol
        Private pFeatureWorkspace As IFeatureWorkspace
        Private SelectFeatNum As Integer
        '\\
        Private m_pTopology As ITopology2
        Private m_pTopologyGraph As ITopologyGraph


        Public Overrides Sub OnCreate(ByVal hook As Object)
            m_pHookHelper.Hook = hook
            m_pMap = m_pHookHelper.FocusMap
            Dim pLayer As ILayer
            Dim i As Integer
            Dim pFeatLyr As IFeatureLayer
            Dim pFeatCls As IFeatureClass
            Dim pTopologyLayer As ITopologyLayer

            For i = 0 To m_pMap.LayerCount - 1
                pLayer = m_pMap.Layer(i)
                If pLayer.Name = Consts.LayersName.zdLayerName And TypeOf (pLayer) Is IFeatureLayer Then '//找到宗地图层
                    m_pZDLayer = pLayer
                    pFeatLyr = pLayer
                    pFeatCls = pFeatLyr.FeatureClass
                    Me.m_pZDFeatCls = pFeatCls
                    Me.m_pWorkspace = pFeatCls.FeatureDataset.Workspace
                ElseIf pLayer.Name = Consts.LayersName.jzdLayerName And TypeOf (pLayer) Is IFeatureLayer Then '//找到宗地图层
                    pFeatLyr = pLayer
                    Me.m_pJZDFeatCls = pFeatLyr.FeatureClass
                ElseIf pLayer.Name = Consts.LayersName.jzxLayerName And TypeOf (pLayer) Is IFeatureLayer Then '//找到宗地图层
                    pFeatLyr = pLayer
                    Me.m_pJZXFeatCls = pFeatLyr.FeatureClass
                ElseIf pLayer.Name = Consts.LayersName.CurrentTopoName And TypeOf (pLayer) Is ITopologyLayer Then  '//找到宗地图层
                    pTopologyLayer = pLayer
                    Me.m_pTopology = pTopologyLayer.Topology
                End If
            Next
        End Sub
        Public Overrides ReadOnly Property Enabled() As Boolean
            Get
                '======================================
                If Me.m_pWorkspace Is Nothing Then Return False
                Dim pWsEdit As IWorkspaceEdit = Me.m_pWorkspace
                Return pWsEdit.IsBeingEdited
                '======================================

            End Get
        End Property
        Public Sub New()
            m_pHookHelper = New HookHelper
            MyBase.m_bitmap = New System.Drawing.Bitmap((GetType(ZDMerger).Assembly.GetManifestResourceStream("地籍管理信息系统.EditSelect.bmp")))
            MyBase.m_cursor = New System.windows.forms.Cursor((GetType(ZDMerger).Assembly.GetManifestResourceStream("地籍管理信息系统.myEditSelect.cur"))) '注意要将MYCURSOR.CUR的属性"生成"的值改为"嵌入的资源",否则会出错.
            SelectFeatNum = 0  '//初始化要素选择数
            pArrayFeat = New ArrayList '//新建要素类数组
            Me.m_pElements = New ArrayList '//初始化数组
        End Sub
        Public Overrides ReadOnly Property Tooltip() As String
            Get
                Return "宗地合并"
            End Get
        End Property

        Public Overrides ReadOnly Property Name() As String
            Get
                Return "宗地合并"
            End Get
        End Property

        Public Overrides ReadOnly Property Message() As String
            Get
                Return "宗地合并"
            End Get
        End Property

        Public Overrides ReadOnly Property Caption() As String
            Get
                Return "宗地合并"
            End Get
        End Property

        Public Overrides Sub OnMouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer)
            Dim pFeat As IFeature
            Dim s As Integer
            If IsNothing(Me.m_pWorkspace) Or Me.m_pZDFeatCls Is Nothing Or Me.m_pJZDFeatCls Is Nothing Or Me.m_pTopology Is Nothing Or Me.m_pJZXFeatCls Is Nothing Then
                Return
            End If
            Try
                'Dim FeatNum As Integer
                If Button = 2 Then
                    If MsgBox("确定要合并这" + CStr(SelectFeatNum) + "块宗地吗？", MsgBoxStyle.OKCancel) = MsgBoxResult.OK Then
                        If ZDMergeOperotion() Then '合并成功
                            MsgBox("合并成功！", MsgBoxStyle.OKOnly, "提示")
                            DelecteHighLight()
                            '\\清空选择数组和图形数组
                            pArrayFeat.Clear() '//新建要素类数组
                            Me.m_pElements.Clear() '//初始化数组
                            '\\
                        Else '合并失败
                            MsgBox("合并失败！", MsgBoxStyle.OKOnly, "提示")
                            DelecteHighLight()
                            '\\清空选择数组和图形数组
                            pArrayFeat.Clear() '//新建要素类数组
                            Me.m_pElements.Clear() '//初始化数组
                            '\\
                        End If
                    Else
                        DelecteHighLight()
                        '\\清空选择数组和图形数组
                        pArrayFeat.Clear() '//新建要素类数组
                        Me.m_pElements.Clear() '//初始化数组
                        '\\
                        Exit Sub
                    End If

                Else
                    pFeat = Me.SelectZDFeature(X, Y)
                    GetSelectFeatHighLight(pFeat)

                    If Not pFeat Is Nothing Then
                        pArrayFeat.Add(pFeat)
                        's = pArrayFeat.Count
                    End If

                End If
            Catch ex As System.Exception
                MessageBox.Show(ex.Message)
            End Try
        End Sub
        Private Sub GetSelectFeatHighLight(ByVal myFeat As IFeature)
            Dim ZDPolygon As IPolygon
            Dim pPolygonElt As IFillShapeElement
            Dim pColor As IRgbColor
            Dim pElt As IElement
            Dim pGC As IGraphicsContainer

            pColor = New RgbColor
            pColor.RGB = RGB(0, 255, 0)

            Dim pOutline As ILineSymbol
            pOutline = New SimpleLineSymbol
            pOutline.Width = 5
            pOutline.Color = pColor

            m_pFillSymbol = New SimpleFillSymbol
            m_pFillSymbol.Outline = pOutline
            m_pFillSymbol.Style = esriSimpleFillStyle.esriSFSHollow

            pElt = New PolygonElement

            pElt.Geometry = myFeat.ShapeCopy
            pPolygonElt = pElt
            pPolygonElt.Symbol = m_pFillSymbol

            pGC = m_pMap
            If Not pElt Is Nothing Then
                Me.m_pElements.Add(pElt)
            End If

            pGC.AddElement(Me.m_pElements(SelectFeatNum), SelectFeatNum)
            SelectFeatNum += 1

            Dim pActive As IActiveView
            pActive = m_pMap
            pActive.PartialRefresh(esriViewDrawPhase.esriViewGraphics, Nothing, Nothing)

            'pPolygonElt.Symbol = pPolygonSymbol


        End Sub
        Private Function SelectZDFeature(ByVal x As Integer, ByVal y As Integer) As IFeature
            Dim pPoint As IPoint
            Dim pDArray As IArray
            Dim pIdentify As IIdentify
            Dim pFeatureIdentifyObj As IFeatureIdentifyObj
            Dim pIdentifyObj As IIdentifyObj
            Dim pRowIdentifyObj As IRowIdentifyObject
            Dim pActiveView As IActiveView
            Dim pOperater As ITopologicalOperator
            Dim pGeom As IGeometry
            Dim pFeature As IFeature

            pIdentify = Me.m_pZDLayer

            pActiveView = Me.m_pMap
            pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)

            Dim length As Double = Me.ConvertPixelsToMapUnits(pActiveView, 4)
            pOperater = pPoint
            pGeom = pOperater.Buffer(length)     '//对屏幕上点击得到的点创建缓冲

            pDArray = pIdentify.Identify(pGeom)
            'Get the FeatureIdentifyObject
            If Not pDArray Is Nothing Then
                ''MsgBox(pIDArray.Count)

                pFeatureIdentifyObj = pDArray.Element(0)
                pIdentifyObj = pFeatureIdentifyObj
                'pIdentifyObj.Flash(pActiveView.ScreenDisplay)      '//闪烁显示对应的Feature 
                ''//不需要闪烁，只是加一个绿色的外框-bxd
                'Feature property of FeatureIdentifyObject has write only access   
                pRowIdentifyObj = pFeatureIdentifyObj
                pFeature = pRowIdentifyObj.Row '查到了一个要素类
                Return pFeature
            Else
                Return Nothing
            End If
        End Function
        Private Function ConvertPixelsToMapUnits(ByVal pActiveView As IActiveView, ByVal pixelUnits As Double) As Double
            ' Uses the ratio of the size of the map in pixels to map units to do the conversion
            Dim p1 As IPoint = pActiveView.ScreenDisplay.DisplayTransformation.VisibleBounds.UpperLeft
            Dim p2 As IPoint = pActiveView.ScreenDisplay.DisplayTransformation.VisibleBounds.UpperRight
            Dim x1 As Integer, x2 As Integer, y1 As Integer, y2 As Integer
            pActiveView.ScreenDisplay.DisplayTransformation.FromMapPoint(p1, x1, y1)
            pActiveView.ScreenDisplay.DisplayTransformation.FromMapPoint(p2, x2, y2)
            Dim pixelExtent As Double = x2 - x1
            Dim realWorldDisplayExtent As Double = pActiveView.ScreenDisplay.DisplayTransformation.VisibleBounds.Width
            Dim sizeOfOnePixel As Double = realWorldDisplayExtent / pixelExtent
            Return pixelUnits * sizeOfOnePixel
        End Function

        Private Function ZDMergeOperotion() As Boolean
            Dim pWorkSpaceEdit As IWorkspaceEdit
            Dim pDataset As IDataset
            Dim pws As IWorkspace
            Dim pEnumDSName As IEnumDatasetName
            Dim pSUbEDSName As IEnumDatasetName
            Dim pDatasetName As IDatasetName
            Dim pSubDsName As IDatasetName
            Dim pFeatureClass As IFeatureClass
            Dim pNewFeat As IFeature
            Dim pFeat As IFeature
            Dim pReTab As ITable
            Dim pRow As IRow
            Dim ZDHnew As String
            Dim i, j, k, m As Integer
            Dim pActiveView As IActiveView
            pActiveView = Me.m_pMap
            '\\
            m_pTopologyGraph = m_pTopology.Cache
            m_pTopologyGraph.Build(pActiveView.Extent, False)
            '\\首先检查是否有孤立宗地
            If Not Me.CheckZD() Then '存在孤立的宗地
                MsgBox("所选择的宗地中有孤立的宗地!", , "提示")
                Return False
            End If
            '//打开对话框，输入新宗地信息
            Dim pFrm As New ZDInfoInput
            If pFrm.ShowDialog() <> DialogResult.OK Then '退出操作
                Return False
            Else
                Application.DoEvents() '处理一些消息
            End If
            Try
                '//打开历史数据库
                pWorkSpaceEdit = Me.m_pWorkspace
                If pWorkSpaceEdit.IsBeingEdited Then
                    pWorkSpaceEdit.StartEditOperation()
                    '\\打开与历史相关的要素类
                    pFeatureWorkspace = Me.m_pWorkspace
                    pFeatureClass = pFeatureWorkspace.OpenFeatureClass(Consts.LayersName.zdHistoryFeatclsName) '//打开ZDHistory要素类
                    pReTab = pFeatureWorkspace.OpenTable(Consts.LayersName.zdRelationTableName) '//打开关系表
                    If IsNothing(pFeatureClass) Or IsNothing(pReTab) Then
                        MsgBox("数据库中没有建立存放历史数据所需的表或要素类!请查看数据库结构!", , "错误提示")
                        Return False
                    End If
                    '\\
                    For i = 0 To pArrayFeat.Count - 1
                        pNewFeat = pFeatureClass.CreateFeature