clsfloodedarea.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 = "clsWaterRange"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

'************************************************************************************************
'*********************** To calculate the flooded area                    ***********************
'*********************** The result is raster cells                       ***********************
'*********************** ZHANG Wenjiang, 2004/02/17                       ***********************
'************************************************************************************************

Option Explicit

Dim m_pCommand As ICommand
Dim m_pTool As ITool
Dim m_pSketchTool As ISketchTool
Dim m_pApp As IApplication
Dim m_pEditor As IEditor
Implements ICommand

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

Private Property Get ICommand_Caption() As String
  ICommand_Caption = "洪水淹没范围"
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 = "洪水淹没范围"
End Property

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

Private Sub ICommand_OnClick()
''''''  With pSDEPropertySet
''''''        .SetProperty "Server", "foundway"
''''''        .SetProperty "Instance", "port:5150"
''''''        .SetProperty "Database", "mydb"              ' Ignored with ArcSDE for Oracle
''''''        .SetProperty "user", "sde"
''''''        .SetProperty "password", "lan811"
''''''        .SetProperty "version", "sde.DEFAULT"
''''''  End With
    Dim pFSdeWS As IFeatureWorkspace
    Set pFSdeWS = Nothing
    Set pFSdeWS = SDEConnect("foundway", "port:5150", "sde", "lan811", "myDB")
    Call FloodedRange(m_pApp, pFSdeWS) 'WaterDepth 'polygonSelect0 'NeighborhoodNotation 'pixelOp
End Sub

Private Sub ICommand_OnCreate(ByVal hook As Object)
On Error GoTo ErrorHandler:
  
    Set m_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, vbInformation + vbOKOnly, "提示信息"
    Exit Sub
End Sub

Private Property Get ICommand_Tooltip() As String
    ICommand_Tooltip = "洪水淹没范围"
End Property


'************************************************************************************************''''''''''''''
'''''FloodedRange计算洪水淹没范围
'************************************************************************************************''''''''''''''
Public Sub FloodedRange(pApp As IApplication, Optional ByRef pSdeFWS As IWorkspace = Nothing)
    
    On Error GoTo errHandle
     
    ' Declare the dataset objects
    Dim pWorkspaceFactory As IWorkspaceFactory, pFeatureWorkspace As IFeatureWorkspace
    Dim pFeaLyr As IFeatureLayer, pFloodFeatLyr As IFeatureLayer, pOutFeatLyr As IFeatureLayer, pWaterFeatLyr As IFeatureLayer
    Dim fs

    Dim strWaterPath As String, strFloodPath As String, strResultPath As String
    Dim strWaterFile As String, strFloodFile As String, strResultFile As String, strTemp As String
    frmFloodArea.Left = (Screen.Width - frmFloodArea.Width) / 2
    frmFloodArea.Top = (Screen.Height - frmFloodArea.Height) / 2
    frmFloodArea.strPathFlood = ""
    frmFloodArea.strPathResult = ""
    frmFloodArea.strPathWater = ""
    frmFloodArea.Show vbModal
    
    If frmFloodArea.flagOK Then

        Set fs = CreateObject("Scripting.FileSystemObject")

        strWaterFile = frmFloodArea.strPathWater & ".shp"
        strFloodFile = frmFloodArea.strPathFlood & ".shp"
        strResultFile = frmFloodArea.strPathResult

        If fs.FileExists(strResultFile) Then  '
            MsgBox strResultFile & "已存在，将被覆盖", vbInformation + vbOKOnly, "提示信息"
            fs.DeleteFile (strResultFile) '
        End If

        If fs.FileExists(Left(strResultFile, Len(strResultFile) - 4) + ".dbf") Then '
            fs.DeleteFile (Left(strResultFile, Len(strResultFile) - 4) + ".dbf") '
        End If

        Call SplitPath(strResultFile, strResultPath, strTemp)
        strResultFile = strTemp 'Left(strTemp, Len(strTemp) - 4)
        m_txtRangeSde = Left(strTemp, Len(strTemp) - 4)

    Else
        MsgBox "放弃淹没范围计算", vbInformation + vbOKOnly, "提示信息"
        Exit Sub
    End If

    Dim pMouseCursor As IMouseCursor
    Set pMouseCursor = New MouseCursor
    pMouseCursor.SetCursor 2

    Set pFloodFeatLyr = frmFloodArea.shpFloodLyr
    Set pWaterFeatLyr = frmFloodArea.shpWaterLyr
    Dim pSpaRef As ISpatialReference
    Set pSpaRef = GetLayerSourceSpatialRef(pFloodFeatLyr)                                            ' set CoordinateSystem for the new result shape file

    Set pWorkspaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strResultPath, 0)
    Dim pNewFeatClass As IFeatureClass
    Set pNewFeatClass = CreateShapefile(pFeatureWorkspace, strResultFile, pSpaRef)                ' create a null shape file for the flood range

    Call Difference(pFloodFeatLyr, pWaterFeatLyr, pNewFeatClass)   '''通过difference进行多边形的异处理，去除本体水体

    Dim pMxDoc As IMxDocument
    Set pMxDoc = pApp.Document
    Dim pFeatLyr As IFeatureLayer
    Set pFeatLyr = New FeatureLayer
    Set pFeatLyr.FeatureClass = pNewFeatClass
    pFeatLyr.name = "洪水淹没范围"
    Call setFeatureLayerRenderer(pFeatLyr, vbRed)
    
    pMxDoc.FocusMap.AddLayer pFeatLyr
    pMxDoc.ActiveView.Refresh

    Set pWorkspaceFactory = Nothing
    Set pFeatureWorkspace = Nothing
    Set pWaterFeatLyr = Nothing
    Set pFloodFeatLyr = Nothing
    Set pMxDoc = Nothing
    Set pFeatLyr = Nothing
    
    '将计算结果（矢量）上传到SDE库
    If Not pSdeFWS Is Nothing Then
        If pSdeFWS.Type = esriRemoteDatabaseWorkspace Then
            Dim strSdeName As String
            strSdeName = Left(strResultFile, Len(strResultFile) - 4)
            Dim sdeProperSet As IPropertySet
            Set sdeProperSet = pSdeFWS.connectionProperties
            Call LoadShpfileToSDE(strResultFile, strResultPath, strSdeName, sdeProperSet, pSdeFWS)
        End If
    End If
    
    MsgBox "完成淹没范围计算！", vbInformation + vbOKOnly, "提示信息"
    
    Set pMouseCursor = Nothing
    
    Exit Sub 'exit sub to avoid error handler

errHandle:
    MsgBox "计算淹没范围失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
 
 End Sub

'************************************************************************************************''''''''''''''
'''''Difference进行两个多边形图层间的叠加，剔除洪水水体中的平水期水体，得到真正淹没的范围

'************************************************************************************************''''''''''''''
Public Sub Difference(pSourceFeatLayer As IFeatureLayer, pFilterFeatLayer As IFeatureLayer, pOutFeatClass As IFeatureClass)
    On Error GoTo errHandle:
    
    Dim pFilter As IQueryFilter
    Dim pFeatCursor1 As IFeatureCursor
    Dim pFeatCursor2 As IFeatureCursor
    Set pFilter = New QueryFilter
    pFilter.WhereClause = ""
    
    Dim sourceFeat As IFeature, filterFeat As IFeature, resultFeat As IFeature
    Dim pGeoResult As IGeometry, pIntersect As IGeometry
    Dim pTopoOp As ITopologicalOperator
        
    Set pFeatCursor1 = pFilterFeatLayer.Search(pFilter, False)
    Set filterFeat = pFeatCursor1.NextFeature
    
   
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    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
            If Not pTopoOp.Intersect(filterFeat.Shape, esriGeometry2Dimension).IsEmpty Then  ' Skip creation if without the intersection of polygons is null
                Set pGeoResult = pTopoOp.Difference(filterFeat.Shape)
                Call CreateFeature(pOutFeatClass, pGeoResult)   '创建一个洪水淹没矢量图斑
            End If

            Set sourceFeat = pFeatCursor2.NextFeature

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

        Set filterFeat = pFeatCursor1.NextFeature

    Loop '''''''''''''''''''''''''''''''''''''''''''''''''''''''Do While Not filterFeat Is Nothing
        
   ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set pFilter = Nothing
    
    Exit Sub 'exit sub to avoid error handler
    
errHandle:
    MsgBox "提取洪水淹没范围失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
 
 End Sub

'************************************************************************************************''''''''''''''
'''CreateShapefile创建一个多边形文件

'************************************************************************************************''''''''''''''
Public Function CreateShapefile(pShapeWsF As IFeatureWorkspace, strShapeName As String, spatialRef As ISpatialReference) As IFeatureClass

    On Error GoTo Errhdr
    Const strShapeFieldName As String = "Shape"
    
    ' Set up a simple fields collection
    Dim pFields As IFields
    Dim pFieldsEdit As IFieldsEdit
    Set pFields = New esriCore.Fields
    Set pFieldsEdit = pFields
    
    Dim pField As IField
    Dim pFieldEdit As IFieldEdit
    
    ' Make the shape field
    ' it will need a geometry definition, with a spatial reference
    Set pField = New esriCore.Field
    Set pFieldEdit = pField
    pFieldEdit.name = strShapeFieldName
    pFieldEdit.Type = esriFieldTypeGeometry
    
    Dim pGeomDef As IGeometryDef
    Dim pGeomDefEdit As IGeometryDefEdit
    Set pGeomDef = New GeometryDef
    Set pGeomDefEdit = pGeomDef
    With pGeomDefEdit
      .GeometryType = esriGeometryPolygon
      Set .SpatialReference = spatialRef 'New UnknownCoordinateSystem
    End With
    
    Set pFieldEdit.GeometryDef = pGeomDef
    pFieldsEdit.AddField pField
    
    Set pField = New esriCore.Field
    Set pFieldEdit = pField
    With pFieldEdit
        .Length = 30
        .name = "MiscText"
        .Type = esriFieldTypeString
    End With
    pFieldsEdit.AddField pField
    
    ' Create the shapefile
    Dim pFeatClass As IFeatureClass
    Set pFeatClass = pShapeWsF.CreateFeatureClass(strShapeName, pFields, Nothing, _
                                             Nothing, esriFTSimple, strShapeFieldName, "")
                                             
    Set CreateShapefile = pFeatClass
    
    Set pFields = Nothing
    Set pField = Nothing
    Set pGeomDef = Nothing
    
    Exit Function
    
Errhdr:
    MsgBox "创建shape文件失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
    
End Function


'************************************************************************************************''''''''''''''
'''''CreateFeature根据给定几何体特征创建一个空间特征体

'************************************************************************************************''''''''''''''
Private Sub CreateFeature(pFeatureClass As IFeatureClass, pGeometry As IGeometry)
  Dim pFeature As IFeature
  Set pFeature = pFeatureClass.CreateFeature
  Set pFeature.Shape = pGeometry
  pFeature.Store
End Sub