clsoverlay.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 = "clsOverlay"
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.picBell.Picture
End Property

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

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

Private Sub ICommand_OnClick()
  Call Intersect   'selectFeatureLayer ' selectAllFeature '
  ' 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.Overlay"
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
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


''''''''''''''''''''''''''FROM AO Help File
Public Sub Intersect()
    ' Get the input layer and feature class
    Dim pMxDoc As IMxDocument
    Set pMxDoc = pApp.Document  ' ThisDocument
    Dim pLayer As ILayer
    
    If pMxDoc.FocusMap.Layer(0) Is Nothing Then
        MsgBox "Please set the layers first!"
        Exit Sub
    End If
      
    Set pLayer = pMxDoc.FocusMap.Layer(0)
    'MsgBox pLayer.Name
    'Exit Sub
    
    Dim pInputFeatLayer As IFeatureLayer
    Set pInputFeatLayer = pLayer
    
    ' Use the Itable interface from the Layer (not from the FeatureClass)
    Dim pInputTable As ITable
    Set pInputTable = pLayer
    
    ' Get the input feature class.
    ' The Input feature class properties, such as shape type,
    ' will be needed for the output
    Dim pInputFeatCLass As IFeatureClass
    Set pInputFeatCLass = pInputFeatLayer.FeatureClass
      
    ' Get the overlay layer
    ' Use the Itable interface from the Layer (not from the FeatureClass)
    Set pLayer = pMxDoc.FocusMap.Layer(1)
    Dim pOverlayTable As ITable
    Set pOverlayTable = pLayer
    
    ' Error checking
    If pInputTable Is Nothing Then
        MsgBox "Table QI failed"
        Exit Sub
    End If
      
    If pOverlayTable Is Nothing Then
        MsgBox "Table QI failed"
        Exit Sub
    End If
    
    ' Define the output feature class name and shape type (taken from the
    ' properties of the input feature class)
    Dim pFeatClassName As IFeatureClassName
    Set pFeatClassName = New FeatureClassName
    With pFeatClassName                        '''''''''''''''''''''''''''''' To Construct the new table
        .FeatureType = esriFTSimple
        .ShapeFieldName = "Shape"
        .shapeType = pInputFeatCLass.shapeType
    End With
          
    ' Set output location and 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 = "Intersect_result"
    
    Set pDatasetName.WorkspaceName = pNewWSName
      
    ' Set the tolerance.  Passing 0.0 causes the default tolerance to be used.
    ' The default tolerance is 1/10,000 of the extent of the data frame's spatial domain
    Dim tol As Double
    tol = 0#
      
    ' Perform the intersect
    Dim pBGP As IBasicGeoprocessor
    Set pBGP = New BasicGeoprocessor
    Dim pOutputFeatClass As IFeatureClass
    Set pOutputFeatClass = pBGP.Intersect(pInputTable, False, pOverlayTable, False, tol, pFeatClassName)
      
    ' Add the output layer to the map