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

'************************************************************************************************
'*********************** 作物洪水淹没损失评估                              ***********************
'*********************** The result is raster cells                       ***********************
'*********************** ZHANG Wenjiang, 2004/04/02                       ***********************
'************************************************************************************************

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
Dim m_bSumResultFirst As Boolean

Implements ICommand

Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE
  ICommand_Bitmap = frmResources.picCropEvaluation.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()
    Call cropEvaluation(m_pApp)  'NeighborhoodNotation '
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
    Exit Sub
End Sub

Private Property Get ICommand_Tooltip() As String
    ICommand_Tooltip = "受灾作物评估"
End Property


'************************************************************************************************'''
''''cropEvaluation进行作物损失评估，调用evaluateOneCrop实现

'************************************************************************************************'''
Public Sub cropEvaluation(pApp As IApplication)
    On Error GoTo errHandle
    
    Dim fs, numCropPrice As Integer
    Dim strResultPath As String, strResultFile As String, strTemp As String, cropName As String, cropFileName As String
    Dim pRasterDepth As IRaster, pRasterLU As IRaster, pShpFloodRangeLyr As IFeatureLayer
    
    frmEvaluateCrop.Left = (Screen.Width - frmEvaluateCrop.Width) / 2
    frmEvaluateCrop.Top = (Screen.Height - frmEvaluateCrop.Height) / 2
    frmEvaluateCrop.Show vbModal '''''''''''''''''''''''''''''''''''''指定作物洪水损失评估的数据
    
    If frmEvaluateCrop.flagOK Then
    
        Set fs = CreateObject("Scripting.FileSystemObject")
    
        Set pRasterDepth = frmEvaluateCrop.rasFloodDepthLyr.Raster   '传递由catalog打开的图层
        Set pRasterLU = frmEvaluateCrop.rasLanduseLyr.Raster
        
        strResultFile = frmEvaluateCrop.strPathResult
        
        If fs.FolderExists(Left(strResultFile, Len(strResultFile) - 4)) Then '
            MsgBox strResultFile & "已存在，将被覆盖"
            fs.Deletefolder (Left(strResultFile, Len(strResultFile) - 4)) '
        End If

        If fs.FileExists(strResultFile) Then '
            fs.DeleteFile (strResultFile) '
        End If

        Call SplitPath(strResultFile, strResultPath, strTemp)
        strResultFile = Left(strTemp, Len(strTemp) - 4)
    Else
        MsgBox "放弃指定评估文件，将退出"
        Exit Sub
    End If
               
    Dim pMathOp As IMathSupportOp
    Set pMathOp = New RasterMathSupportOp
    
    Dim pRasCutLU As IRaster
    Set pRasCutLU = pMathOp.Plus(pRasterDepth, pRasterLU)
    Set pRasCutLU = pMathOp.Minus(pRasCutLU, pRasterDepth)
       
    Dim pRasDepthProps As IRasterProps
    Set pRasDepthProps = pRasterDepth  'pRasZeroWhole
    Dim pOrigin As IPoint
    Set pOrigin = New Point
    pOrigin.X = pRasDepthProps.Extent.XMin
    pOrigin.Y = pRasDepthProps.Extent.YMin
    
    Dim pWSF As IWorkspaceFactory
    Set pWSF = New RasterWorkspaceFactory
    Dim pRWS As IRasterWorkspace2
    Set pRWS = pWSF.OpenFromFile(strResultPath, 0)
    
    Dim pOutputRasterDS As IRasterDataset
    Set pOutputRasterDS = pRWS.CreateRasterDataset(strResultFile, "GRID", pOrigin, _
                          pRasDepthProps.Width, pRasDepthProps.Height, pRasDepthProps.MeanCellSize.X, _
                          pRasDepthProps.MeanCellSize.Y, 1, PT_FLOAT, _
                          pRasDepthProps.SpatialReference, True)

     ' Create a default raster from output raster dataset
    Dim pRasOutput As IRaster
    Set pRasOutput = pOutputRasterDS.CreateDefaultRaster

    Call setLanduseIDs  '设置作物在土地利用中的类别ID
    m_bSumResultFirst = True
    
'''''''''''''''''''''''
    frmLossRateDetail.Left = (Screen.Width - frmLossRateDetail.Width) / 2
    frmLossRateDetail.Top = (Screen.Height - frmLossRateDetail.Height) / 2

    Dim bContinue As Boolean
    bContinue = True

    Do While bContinue
        frmLossRateDetail.Show vbModal  '''''''''''''''''''''''''''''''''''''''指定作物的洪水损失率
        If frmLossRateDetail.bOKFlag Or frmLossRateDetail.bContinueFlag Then

            cropName = frmLossRateDetail.strCropName
            cropFileName = frmLossRateDetail.strCropName
            numCropPrice = CInt(frmLossRateDetail.strRicePrice)
            bContinue = frmLossRateDetail.bContinueFlag

            Call evaluateOneCrop(strResultPath, cropFileName, cropName, pRasterDepth, pRasCutLU, _
            pRasOutput, m_numRateLevel, m_depthBreak, m_lossRate, numCropPrice, numRiceID)  '评估
        Else
            MsgBox "放弃指定作物的洪水损失率，将退出"
            Exit Sub

        End If
    Loop
        
    Dim displayRDS As IRasterDataset
    Set displayRDS = OpenRasterDataset(strResultPath, strResultFile)
    Dim pMxDoc As IMxDocument
    Set pMxDoc = pApp.Document
    Dim pRL As IRasterLayer
    Set pRL = New RasterLayer
    pRL.CreateFromDataset displayRDS
    pRL.name = strResultFile 'strLayerName & "洪灾损失"
    pMxDoc.FocusMap.AddLayer pRL
    pMxDoc.ActiveView.Refresh
    Set pRL = Nothing
   
    Set pRasterDepth = Nothing
    Set pRasterLU = Nothing
    Set pShpFloodRangeLyr = Nothing
    Set pWSF = Nothing
    Set pMathOp = Nothing
    Set pOrigin = Nothing

    MsgBox "完成作物洪损评估计算！"
    
    Exit Sub 'exit sub to avoid error handler

errHandle:
    MsgBox "作物洪损评估计算失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
End Sub


'************************************************************************************************'''
''''调用evaluateOneCrop，实现单种作物损失评估

'************************************************************************************************'''
Sub evaluateOneCrop(strOutPath As String, strOutFile As String, strLayerName As String, _
pRasDepth As IRaster, pRasLU As IRaster, pRasOutput As IRaster, numBreak As Integer, _
depthBreak() As Single, lossRate() As Single, cropPrice As Integer, cropTypeID As Integer)