clsdissolve.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 = "clsDissolve"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

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

Implements ICommand
Implements ISketchTool
Implements ITool


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

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

Private Property Get ICommand_Caption() As String
  ICommand_Caption = "Dissolve"
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 = "Dissolve"
End Property

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

Private Sub ICommand_OnClick()
  Call Dissolve 'Merge ' Intersect
  ' m_pCommand.OnClick
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.Dissolve"
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)
  'MsgBox "hello from DLL"
  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 Dissolve()
  Dim pDoc As IMxDocument
  Set pDoc = pApp.Document
  Dim pMap As IMap
  Set pMap = pDoc.FocusMap

  ' Find the layer named STATES
  Dim pLayer As ILayer
  Dim pInputFeatLayer As IFeatureLayer
  Dim intCount As Integer
  
  Set pInputFeatLayer = pMap.Layer(0)
  
'  For intCount = 0 To pMap.LayerCount - 1
'    Set pLayer = pMap.Layer(intCount)
'    If TypeOf pLayer Is IFeatureLayer Then
'      If pLayer.Name = "New_Shapefile" Then
'        Set pInputFeatLayer = pLayer
'        Exit For
'      End If
'    End If
'  Next

  If pInputFeatLayer Is Nothing Then
    MsgBox "Fail to find the source layer!"
    Exit Sub
  End If

  ' Use the ITable interface from the FeatureLayer (not from the FeatureClass)
  Dim pInputTable As ITable
  Set pInputTable = pInputFeatLayer
  
  ' Error checking
  If pInputTable Is Nothing Then
    MsgBox "Table QI failed"
    Exit Sub
  End If
  
  ' Make sure there is a field called SUB_REGION in the input layer
'  If pInputTable.FindField("SUB_REGION") = -1 Then
'    MsgBox "There must be a field named SUB_REGION in STATES"
'    Exit Sub
'  End If
  
  ' Get the feature class properties needed for the output
  Dim pInputFeatCLass As IFeatureClass
  Set pInputFeatCLass = pInputFeatLayer.FeatureClass
  Dim pFeatClassName As IFeatureClassName
  Set pFeatClassName = New FeatureClassName
  With pFeatClassName
      .FeatureType = esriFTSimple
 '     .ShapeFieldName = "SUB_REGION"
      .shapeType = pInputFeatCLass.shapeType
  End With
    
  ' Set output location and output feature class name
  Dim pNewWSName As IWorkspaceName
  Set pNewWSName = New WorkspaceName
  pNewWSName.WorkspaceFactoryProgID = "esriCore.ShapefileWorkspaceFactory.1"
  pNewWSName.pathName = "e:\temp"
   
  Dim pDatasetName As IDatasetName
  Set pDatasetName = pFeatClassName
  pDatasetName.name = "Dissolve_result"
    
  Set pDatasetName.WorkspaceName = pNewWSName
  
  ' Perform the dissolve.
  ' Note the summary fields string (Dissolve.Shape, Minimum.state_name ...)
  ' below. This is a comma-delimited string that lists the generated summary
  ' fields. The syntax for the summaryFields argument is
  ' operation_code1.field_name1, operation_codeN.field_nameN
  ' Operation codes include: Dissolve, Count, Minimum, Maximum, Sum,
  ' Average, Variance and StdDev.
  '
  ' Since we are performing a spatial dissolve, we must use the operation code
  ' Dissolve on the Shape field.
  Dim iBGP As IBasicGeoprocessor
  Set iBGP = New BasicGeoprocessor
  Dim pOutputTable As ITable
  Set pOutputTable = iBGP.Dissolve(pInputTable, False, "Source", "Dissolve.Shape", pDatasetName)
'  Set pOutputTable = iBGP.Dissolve(pInputTable, False, "SUB_REGION", _
'    "Dissolve.Shape, Minimum.SUB_REGION, Count.SUB_REGION, Average.AREA", pDatasetName)

  ' Add the output to the map
  Dim pOutputFeatClass As IFeatureClass
  Set pOutputFeatClass = pOutputTable
    
  ' Error checking
  If pOutputFeatClass Is Nothing Then
      MsgBox "FeatureClass QI Failed"
      Exit Sub
  End If
    
  Dim pOutputFeatLayer As IFeatureLayer
  Set pOutputFeatLayer = New FeatureLayer
  Set pOutputFeatLayer.FeatureClass = pOutputFeatClass
  pOutputFeatLayer.name = pOutputFeatClass.AliasName
  pMap.AddLayer pOutputFeatLayer

End Sub