clscropevaluation.cls

FloodEvaluation-程序是gis方面的程序

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 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
                                                                                       'j         i
            If m_bSumResultFirst Then vSafeArray1(i, j) = 0 'initialize result raster  'j         i
                                                                                       'j         i
            depth = pDepthBlock.GetVal(0, i, j)
            If pLUBlock.GetVal(0, i, j) = cropTypeID Then  '该种作物的分类值            'j         i
                selLossRate = lossRate(1)                                              'j         i
                                                                                       'j         i
                For k = 1 To numBreak ''''''''''''''''''''''''''''''''''''''''''''k    'j         i
                    If depth >= depthBreak(k) Then                               'k    'j         i
                       selLossRate = lossRate(k + 1)                             'k    'j         i
                       Exit For                                                  'k    'j         i
                    End If                                                       'k    'j         i
                Next k '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''k    'j         i
                                                                                       'j         i
                vSafeArray(i, j) = CSng(selLossRate * cropPrice / 666.7)               'j         i
                vSafeArray1(i, j) = vSafeArray1(i, j) + vSafeArray(i, j)               'j         i
                                                                                       'j         i
            End If                                                                     'j         i
                                                                                       'j         i
        Next j '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''j         i
                                                                                                 'i
    Next i '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''i
    
    If m_bSumResultFirst Then m_bSumResultFirst = False

    ' Write out the result
    pOutputRawPixel.Write pPnt, pOutputBlock
    pOutputRawPixel1.Write pPnt, pOutputBlock1
        
    Set pWSF = Nothing
    Set pOrigin = Nothing
    Set pPnt = Nothing
    
    Exit Sub
    
ERH:
    MsgBox "作物损失单项评估失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"

End Sub


'************************************************************************************************''''''
'''CutRasByShp，用多边形提取栅格图斑

'************************************************************************************************''''''
Public Function CutRasByShp(strPolygonFile As String, strPolygonPath As String, rasLanduse As IRaster, strGRIDPath As String) As IRaster 'GeoDataset
    On Error GoTo ERH
    
    Dim pWorkspaceFactory As IWorkspaceFactory
    Dim pFeatureWorkspace As IFeatureWorkspace
    Dim pFeaLyr As IFeatureLayer
    
    Dim pWks As IRasterWorkspace
    Dim pWksF As IWorkspaceFactory
    Dim pRasLyr As IRasterLayer
    
    Dim pEnv As IRasterAnalysisEnvironment
    
    'Create a new ShapefileWorkspaceFactory object and open a shapefile folder
    Set pWorkspaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strPolygonPath, 0)
    Set pFeaLyr = New FeatureLayer
    Set pFeaLyr.FeatureClass = pFeatureWorkspace.OpenFeatureClass(strPolygonFile)
   
'    Dim inputRaster As IRaster
'    Set inputRaster = OpenRasterDataset(strGRIDPath, strGRIDFile).CreateDefaultRaster
'
    Dim pTempDS As IGeoDataset
    Set pTempDS = pFeaLyr.FeatureClass
    Dim pConOp As IConversionOp
    Set pConOp = New RasterConversionOp
    Set pEnv = pConOp
    Dim pProp As IRasterProps
    Set pProp = rasLanduse
    pEnv.SetCellSize esriRasterEnvValue, pProp.MeanCellSize.X
    
    ' Delete the existing file
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FolderExists(strGRIDPath + "\" + "CovTemp") Then                'FileExists
        fs.Deletefolder (strGRIDPath + "\" + "CovTemp")                   'Deletefile
    End If
                
'    Dim pWks As IWorkspace
    Set pWksF = New RasterWorkspaceFactory
    Set pWks = pWksF.OpenFromFile(strGRIDPath, 0)
    Dim pGeoDs As IRasterDataset
    Set pGeoDs = pConOp.ToRasterDataset(pTempDS, "GRID", pWks, "CovTemp") '转为栅格
    
    Dim pLogicalOp As ILogicalOp
    Dim pConditionalOp As IConditionalOp
    Set pLogicalOp = New RasterMathOps
    Set pConditionalOp = New RasterConditionalOp

    Dim pZeroRaster As IRaster
    Dim pMathOp As IMathSupportOp
    Set pMathOp = New RasterMathSupportOp
    
    Set pZeroRaster = pMathOp.Minus(pGeoDs, pGeoDs)
    Dim pOutRas1 As IRaster 'GeoDataset
    Set pOutRas1 = pConditionalOp.Con(pLogicalOp.GreaterThanEqual(pGeoDs, pZeroRaster), rasLanduse) '提取洪水范围内的LU

    Set CutRasByShp = pOutRas1
    
    Set pEnv = Nothing
    Set pWks = Nothing
    Set pWksF = Nothing
    Set pConOp = Nothing
    Set pFeaLyr = Nothing
    Set pTempDS = Nothing
    Set pMathOp = Nothing
    Set pLogicalOp = Nothing
    Set pConditionalOp = Nothing
    Set pWorkspaceFactory = Nothing
    Set pFeatureWorkspace = Nothing
    
    Exit Function
ERH:
    MsgBox ERR.Description
End Function