clsevaluatewizard.cls

FloodEvaluation-程序是gis方面的程序

    Dim ZoneArr(0 To 0) As Integer
    ZoneArr(0) = 0                                                                                     ' 用于边缘栅格shrink的控制值：0
    ZoneList = ZoneArr()

    Dim pRaster1 As IRaster, pRaster2 As IRaster, pOutputRaster As IRaster
    
    Set pZeroRaster = pMathOp.Minus(inputRaster, inputRaster)                                          ' 构造一个0栅格以便进行shrink操作
    Set pOutputRaster = pGeneralizeOp.Shrink(pZeroRaster, 1, ZoneList)                                 ' 得到对0值shrink后的0值图斑
    Set pRasterDepth = pMathOp.Plus(inputRaster, pOutputRaster)                                        ' 得到原栅格shrink后的图斑
    Set pRaster2 = pConditionalOp.Con(pLogicalOp.IsNull(pRasterDepth), pZeroRaster, pRasterDepth)      ' 将外围没有值NoData的象素设为0 value
    Set pRaster1 = pMathOp.Minus(inputRaster, pRaster2)                                                ' 相减得到边缘象素非0，内部为0
    Set pRasterDepth = pConditionalOp.Con(pLogicalOp.GreaterThan(pRaster1, pZeroRaster), inputRaster)  ' 只保留边界的象素to only keep the edge value
    
    Dim pRasterBandCollection As IRasterBandCollection
    Set pRasterBandCollection = pRasterDepth
    Dim pRasterBand As iRasterBand
    Set pRasterBand = pRasterBandCollection.Item(0)
    
    Set pRaster1 = pRMOp.MakeConstant(pRasterBand.Statistics.Mean, True)     ' For later convenience, the plus of 1 here should be removed later
    Set pRasterDepth = pMathOp.Minus(inputRaster, pRaster1)                  ' to get the depth

    Set pConditionalOp = Nothing
    Set pGeneralizeOp = Nothing
    Set pLogicalOp = Nothing
    Set pMathOp = Nothing
    Set pRMOp = Nothing
    Set pRaster1 = Nothing
    Set pRaster2 = Nothing
    Set pZeroRaster = Nothing
    Set pRasterBandCollection = Nothing
    Set pRasterBand = Nothing
    
    Exit Sub 'exit sub to avoid error handler

errHandle:
    MsgBox "水深计算失败1" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
 
End Sub



'************************************************************************************************
'''cropEvaluation
'************************************************************************************************
'************************************************************************************************'''
''''cropEvaluation进行作物损失评估，调用evaluateOneCrop实现
'************************************************************************************************'''
Public Function cropEvaluation(pApp As IApplication, _
                          strPassWd As String, _
                          Optional ByRef pSdeFWS As IWorkspace = Nothing, _
                          Optional ByRef adoCnn As ADODB.Connection = Nothing) As Boolean
    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.strPathDepth = ""
    frmEvaluateCrop.strPathLU = ""
    frmEvaluateCrop.strPathResult = ""
    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 & "已存在，将被覆盖", vbInformation + vbOKOnly, "提示信息"
            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)
        If Len(strResultFile) > 12 Then strResultFile = Left(strResultFile, 12)
        m_txtCropLossSde = strResultFile
    Else
        MsgBox "放弃指定评估文件，将退出", vbInformation + vbOKOnly, "提示信息"
        cropEvaluation = False
        Exit Function
    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 "放弃指定作物的洪水损失率，将退出", vbInformation + vbOKOnly, "提示信息"
            Exit Function

        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.CreateFromRaster pRasOutput 'Dataset displayRDS
''''    pRL.name = strResultFile 'strLayerName & "洪灾损失"
'''    pMxDoc.FocusMap.AddLayer pRL
'''    pMxDoc.ActiveView.Refresh
'''    Set pRL = Nothing

'''Dim districtLyr As IFeatureLayer
'''Set districtLyr = New FeatureLayer
'''Set districtLyr.FeatureClass = OpenShapeFile("C:\Program Files\BeijiangTemp", "政区人口.shp")
''''Dim cropRaster As IRaster
''''Set cropRaster = OpenRasterDataset(strResultPath, strResultFile).CreateDefaultRaster
'''Call addCropLossInfo(pRasOutput, districtLyr, adoCnn)
    '将计算结果（栅格）上传到SDE库
    If Not pSdeFWS Is Nothing Then
        If pSdeFWS.Type = esriRemoteDatabaseWorkspace Then
            Dim strSdeName As String
            strSdeName = strResultFile 'Left(strResultFile, Len(strResultFile) - 4)
            
            Dim sdeProperSet As IPropertySet
            Set sdeProperSet = pSdeFWS.connectionProperties
            Call LoadRasterToSDE(strResultFile, strResultPath, strSdeName, sdeProperSet, pSdeFWS, strPassWd)
        End If
    End If
       
    Set pRasterDepth = Nothing
    Set pRasterLU = Nothing
    Set pShpFloodRangeLyr = Nothing
    Set pWSF = Nothing
    Set pMathOp = Nothing
    Set pOrigin = Nothing
  '  MsgBox "完成作物洪损评估计算！", vbInformation + vbOKOnly, "提示信息"
    cropEvaluation = True
    
    Exit Function

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


'************************************************************************************************'''
''''调用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)

On Error GoTo ERH

    Dim pWSF As IWorkspaceFactory
    Set pWSF = New RasterWorkspaceFactory
    If Not pWSF.IsWorkspace(strOutPath) Then GoTo ERH
    Dim pRWS As IRasterWorkspace2
    Set pRWS = pWSF.OpenFromFile(strOutPath, 0)
    
    Dim pDepthBandCol As IRasterBandCollection
    Set pDepthBandCol = pRasDepth 'pInputRasterDS
    Dim pDepthBand As iRasterBand
    Set pDepthBand = pDepthBandCol.Item(0)
    Dim pDepthRasProps As IRasterProps
    Set pDepthRasProps = pDepthBand

    Dim pLUBandCol As IRasterBandCollection
    Set pLUBandCol = pRasLU 'pInputRasterDS
    Dim pLUBand As iRasterBand
    Set pLUBand = pLUBandCol.Item(0)
    Dim pLURasProps As IRasterProps
    Set pLURasProps = pLUBand

    Dim pOrigin As IPoint
    Set pOrigin = New Point
    pOrigin.X = pDepthRasProps.Extent.XMin
    pOrigin.Y = pDepthRasProps.Extent.YMin
'    pOrigin.X = pLURasProps.Extent.XMin
'    pOrigin.Y = pLURasProps.Extent.YMin
    
    Dim pMouseCursor As IMouseCursor
    Set pMouseCursor = New MouseCursor
    pMouseCursor.SetCursor 2
                   
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FolderExists(strOutPath & "\" & strOutFile) Then  '
        fs.Deletefolder (strOutPath & "\" & strOutFile) '
    End If

    If fs.FileExists(strOutPath & "\" & strOutFile & ".aux") Then '
        fs.DeleteFile (strOutPath & "\" & strOutFile & ".aux") '
    End If
    
    Dim pOutputRasterDS As IRasterDataset
    
    Set pOutputRasterDS = pRWS.CreateRasterDataset(strOutFile, "GRID", pOrigin, _
                          pDepthRasProps.Width, pDepthRasProps.Height, pDepthRasProps.MeanCellSize.X, _
                          pDepthRasProps.MeanCellSize.Y, 1, PT_FLOAT, _
                          pDepthRasProps.SpatialReference, True)
    'Create a default raster from output raster dataset
    Dim pOutputRaster As IRaster
    Set pOutputRaster = pOutputRasterDS.CreateDefaultRaster
    
    Dim pOutputBandCol As IRasterBandCollection
    Set pOutputBandCol = pOutputRasterDS
    Dim pOutputBand As iRasterBand
    Set pOutputBand = pOutputBandCol.Item(0)
    
    Dim pOutputBandCol1 As IRasterBandCollection
    Set pOutputBandCol1 = pRasOutput
    Dim pOutputBand1 As iRasterBand
    Set pOutputBand1 = pOutputBandCol1.Item(0)
        
    Dim pDepthRawPixel As IRawPixels, pLURawPixel As IRawPixels, pOutputRawPixel As IRawPixels, pOutputRawPixel1 As IRawPixels
    Set pDepthRawPixel = pDepthBand
    Set pLURawPixel = pLUBand
    Set pOutputRawPixel = pOutputBand
    Set pOutputRawPixel1 = pOutputBand1
    
    'Create a DblPnt to hold the PixelBlock size
    Dim pPnt As IPnt
    Set pPnt = New DblPnt
    pPnt.SetCoords pLURasProps.Width, pLURasProps.Height  'pDepthRasProps.Width, pDepthRasProps.Height
    
    Dim pDepthBlock As IPixelBlock
    Set pDepthBlock = pDepthRawPixel.CreatePixelBlock(pPnt)
    
    pPnt.SetCoords pDepthRasProps.Width, pDepthRasProps.Height
    Dim pLUBlock As IPixelBlock
    Set pLUBlock = pLURawPixel.CreatePixelBlock(pPnt)
    Dim pOutputBlock As IPixelBlock
    Set pOutputBlock = pOutputRawPixel.CreatePixelBlock(pPnt)
    Dim pOutputBlock1 As IPixelBlock
    Set pOutputBlock1 = pOutputRawPixel1.CreatePixelBlock(pPnt)
    
    'Read input PixelBlock
    pPnt.X = 0
    pPnt.Y = 0
    pDepthRawPixel.Read pPnt, pDepthBlock
    pLURawPixel.Read pPnt, pLUBlock
    pOutputRawPixel1.Read pPnt, pOutputBlock1
    
    'Get the SafeArray associated with the first band of output
    Dim vSafeArray As Variant
    vSafeArray = pOutputBlock.SafeArray(0)
    Dim vSafeArray1 As Variant
    vSafeArray1 = pOutputBlock1.SafeArray(0)
    
    Dim i As Integer, j As Integer, k As Integer, numCount As Integer, depth As Single, selLossRate As Single
    Dim temp As Double, intTemp As Integer
    numCount = 0

    For i = 0 To pDepthRasProps.Width - 1 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''i
                                                                                                 'i
        For j = 0 To pDepthRasProps.Height - 1 '''''''''''''''''''''''''''''''''''''''''j'''''''''i