clsmerge.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 = "clsMerge"
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.picBalloom.Picture
End Property

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

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

Private Sub ICommand_OnClick()
  Call 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.Merge"
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 Merge()
    ' Get the first layer in the map
    Dim pMxDoc As IMxDocument
    Set pMxDoc = pApp.Document
    Dim pLayer As ILayer
    Set pLayer = pMxDoc.FocusMap.Layer(0)
    Dim pFeatLayer As IFeatureLayer
    Set pFeatLayer = pLayer
    Dim pFirstFeatClass As IFeatureClass
    Set pFirstFeatClass = pFeatLayer.FeatureClass
    
    ' Get the first layer's table
    ' Use the Itable interface from the Layer (not from the FeatureClass)
    ' This table defines which fields are to be used in the output
    Dim pFirstTable As ITable
    Set pFirstTable = pLayer
    
    ' Get the second layer and its table
    ' Use the Itable interface from the Layer (not from the FeatureClass)
    Set pLayer = pMxDoc.FocusMap.Layer(1)
    Dim pSecondTable As ITable
    Set pSecondTable = pLayer
    
    ' Error checking
    If pFirstTable Is Nothing Then
        MsgBox "Table QI failed"
        Exit Sub
    End If
    
    If pSecondTable Is Nothing Then
        MsgBox "Table QI failed"
        Exit Sub
    End If
    
    ' Define the output feature class name and shape type
    Dim pFeatClassName As IFeatureClassName
    Set pFeatClassName = New FeatureClassName
    
    With pFeatClassName
        .FeatureType = esriFTSimple
        .ShapeFieldName = "Shape"
        .shapeType = pFirstFeatClass.shapeType
    End With
        
    ' Set the output location and feature class name
    Dim pNewWSName As IWorkspaceName
    Set pNewWSName = New WorkspaceName
    
    With pNewWSName
        .WorkspaceFactoryProgID = "esriCore.ShapefileWorkspaceFactory.1"
        .pathName = "e:\temp"
    End With
    
    Dim pDatasetName As IDatasetName
    Set pDatasetName = pFeatClassName
    pDatasetName.name = "Merge_result"
    
    Set pDatasetName.WorkspaceName = pNewWSName
    
    ' Build the input set/array - these are the layers to be merged
    Dim inputArray As IArray
    Set inputArray = New esriCore.Array
    inputArray.Add pFirstTable
    inputArray.Add pSecondTable
    
    ' Perform the merge
    Dim pBGP As IBasicGeoprocessor
    Set pBGP = New BasicGeoprocessor
    Dim pOutputFeatClass As IFeatureClass
    Set pOutputFeatClass = pBGP.Merge(inputArray, pFirstTable, pFeatClassName)
    
    ' Add the output to the map
    Dim pOutputFeatLayer As IFeatureLayer
    Set pOutputFeatLayer = New FeatureLayer
    Set pOutputFeatLayer.FeatureClass = pOutputFeatClass
    pOutputFeatLayer.name = pOutputFeatClass.AliasName
    pMxDoc.FocusMap.AddLayer pOutputFeatLayer

End Sub