clsdifference.cls

FloodEvaluation-程序是gis方面的程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDifference"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

'************************************************************************************************
'*********************** Difference operation                             ***********************
'*********************** To difference two input layers                   ***********************
'*********************** ZHANG Wenjiang, 2004/01/03                       ***********************
'************************************************************************************************

Option Explicit

Dim m_pCommand As ICommand
Dim m_pTool As ITool
Dim m_pSketchTool As ISketchTool
Dim pApp As IApplication
Dim m_pEditor As IEditor

Implements ICommand
Implements ISketchTool
Implements ITool

'ICommand''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE
  ICommand_Bitmap = frmResources.picCup.Picture
End Property

Private Property Get ICommand_Caption() As String
  ICommand_Caption = "Difference"
End Property

Private Property Get ICommand_Category() As String
  ICommand_Category = "洪损评估"
End Property

Private Property Get ICommand_Checked() As Boolean
  ICommand_Checked = False
End Property

Private Property Get ICommand_Enabled() As Boolean
  ICommand_Enabled = True
End Property

Private Property Get ICommand_HelpContextID() As Long

End Property

Private Property Get ICommand_HelpFile() As String

End Property

Private Property Get ICommand_Message() As String
    ICommand_Message = "Difference"
End Property

Private Property Get ICommand_Name() As String
    ICommand_Name = "CustomSketch.SketchTool"
End Property

Private Sub ICommand_OnClick()
    Call Difference
End Sub

Private Sub ICommand_OnCreate(ByVal hook As Object)
On Error GoTo ErrorHandler:
  
    Set pApp = hook
    Set m_pCommand = CreateObject("esricore.SketchTool")
    m_pCommand.OnCreate hook
    Set m_pTool = m_pCommand
    Set m_pSketchTool = m_pCommand
    Exit Sub
    
ErrorHandler:
    MsgBox "OnCreate - " & err.Description
    Exit Sub
End Sub

Private Property Get ICommand_Tooltip() As String
    ICommand_Tooltip = "Flood.Difference"
End Property

''ISketchTool''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub ISketchTool_AddPoint(ByVal Point As esriCore.IPoint, ByVal Clone As Boolean, ByVal allowUndo As Boolean)
    m_pSketchTool.AddPoint Point, Clone, True
End Sub

Private Property Get ISketchTool_Anchor() As esriCore.IPoint
    Set ISketchTool_Anchor = m_pSketchTool.Anchor
End Property

Private Property Let ISketchTool_AngleConstraint(ByVal RHS As Double)
    m_pSketchTool.AngleConstraint = RHS
End Property

Private Property Get ISketchTool_AngleConstraint() As Double
    ISketchTool_AngleConstraint = m_pSketchTool.AngleConstraint
End Property

Private Property Let ISketchTool_Constraint(ByVal RHS As esriCore.esriSketchConstraint)
    m_pSketchTool.Constraint = RHS
End Property

Private Property Get ISketchTool_Constraint() As esriCore.esriSketchConstraint
    ISketchTool_Constraint = m_pSketchTool.Constraint
End Property

Private Property Let ISketchTool_DistanceConstraint(ByVal RHS As Double)
    m_pSketchTool.DistanceConstraint = RHS
End Property

Private Property Get ISketchTool_DistanceConstraint() As Double
    ISketchTool_DistanceConstraint = m_pSketchTool.DistanceConstraint
End Property

Private Property Let ISketchTool_IsStreaming(ByVal RHS As Boolean)
    m_pSketchTool.IsStreaming = RHS
End Property

Private Property Get ISketchTool_IsStreaming() As Boolean
    ISketchTool_IsStreaming = m_pSketchTool.IsStreaming
End Property

Private Property Get ISketchTool_Location() As esriCore.IPoint
    Set ISketchTool_Location = m_pSketchTool.Location
End Property

''ITool'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Property Get ITool_Cursor() As esriCore.OLE_HANDLE

End Property

Private Function ITool_Deactivate() As Boolean
    ITool_Deactivate = True
End Function

Private Function ITool_OnContextMenu(ByVal x As Long, ByVal y As Long) As Boolean
    m_pTool.OnContextMenu x, y
    ITool_OnContextMenu = True
End Function

Private Sub ITool_OnDblClick()
    m_pTool.OnDblClick
End Sub

Private Sub ITool_OnKeyDown(ByVal keyCode As Long, ByVal Shift As Long)
    m_pTool.OnKeyDown keyCode, Shift
End Sub

Private Sub ITool_OnKeyUp(ByVal keyCode As Long, ByVal Shift As Long)
    m_pTool.OnKeyUp keyCode, Shift
End Sub

Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
    m_pTool.OnMouseDown Button, Shift, x, y
End Sub

Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
    m_pTool.OnMouseMove Button, Shift, x, y
End Sub

Private Sub ITool_OnMouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
    m_pTool.OnMouseUp Button, Shift, x, y
End Sub

Private Sub ITool_Refresh(ByVal hDC As esriCore.OLE_HANDLE)
    m_pTool.Refresh hDC
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub Difference()
    'On Error GoTo errHandle:
    
    ' Get the input layer and feature class
    Dim pMxDoc As IMxDocument
    Dim pLayer As ILayer
    Dim pSourceFeatLayer As IFeatureLayer
    Dim pFilterFeatLayer As IFeatureLayer
    
    Set pMxDoc = pApp.Document  ' ThisDocument
    
    If pMxDoc.FocusMap.Layer(0) Is Nothing Then
        MsgBox "Please set the layers first!"
        Exit Sub
    End If
    
    Set pSourceFeatLayer = pMxDoc.FocusMap.Layer(0)  '<----------------------To be changed here for selection
    Set pFilterFeatLayer = pMxDoc.FocusMap.Layer(1)
    
    ' Error checking
    If pSourceFeatLayer Is Nothing Then
        MsgBox "Source Layer failed"
        Exit Sub
    End If
    
    If pFilterFeatLayer Is Nothing Then
        MsgBox "Filter Layer failed"
        Exit Sub
    End If
    
    If Not pSourceFeatLayer.FeatureClass.shapeType = esriGeometryPolygon And _
    Not pFilterFeatLayer.FeatureClass.shapeType = esriGeometryPolygon Then
        MsgBox "Polygon layers are required in difference operation!"
        Exit Sub
    End If
    
    Dim pFilter As IQueryFilter
    Dim pFeatCursor1 As IFeatureCursor
    Dim pFeatCursor2 As IFeatureCursor
    Dim pFeatCursor3 As IFeatureCursor
    Set pFilter = New QueryFilter
    pFilter.WhereClause = ""
    
    Dim sourceFeat As IFeature
    Dim filterFeat As IFeature
    Dim resultFeat As IFeature
    Dim pTopoOp As ITopologicalOperator
    Dim pGeoResult As IGeometry
    Dim pIntersect As IGeometry
        
    Set pFeatCursor1 = pFilterFeatLayer.Search(pFilter, False)
    Set filterFeat = pFeatCursor1.NextFeature
    
'    Set frmSelectLayer.pMap = pMxDoc.FocusMap
'    frmSelectLayer.Show
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Do While Not filterFeat Is Nothing

        Set pFeatCursor2 = pSourceFeatLayer.Search(pFilter, False)
        Set sourceFeat = pFeatCursor2.NextFeature

        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Do While Not sourceFeat Is Nothing

            Set pTopoOp = sourceFeat.Shape
            'To do the symmetrical difference operaiton
            Set pGeoResult = pTopoOp.Difference(filterFeat.Shape)
            Set sourceFeat.Shape = pGeoResult
            sourceFeat.Store

            Set sourceFeat = pFeatCursor2.NextFeature

        Loop '''''''''''''''''''''''''''''''''''''''''''''''''''Do While Not sourceFeat Is Nothing

        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Set filterFeat = pFeatCursor1.NextFeature

   Loop ''''''''''''''''''''''''''''''''''''''''''''''''''''''''Do While Not filterFeat Is Nothing
        
   ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   MsgBox "Finished extraction"
   Exit Sub 'exit sub to avoid error handler
    
errHandle:
    MsgBox "Difference failed," & Chr(13) & "Please check the layers!", vbInformation + vbOKOnly, "提示信息"
 
 End Sub