modutilities.bas

FloodEvaluation-程序是gis方面的程序

Attribute VB_Name = "modUtilities"

''''''传递设置的农作物洪损率参数''''''''''''''''''''''''''''''''
Public numCottonRate As Integer, depthCottonBreak(7) As Single, rateCotton(8) As Single, _
numCottonPrice As Integer, numCottonID As Integer

Public numFlowerRate As Integer, depthFlowerBreak(7) As Single, rateFlower(8) As Single, _
numFlowerPrice As Integer, numFlowerID As Integer

Public numLicheeRate As Integer, depthLicheeBreak(7) As Single, rateLichee(8) As Single, _
numLicheePrice As Integer, numLicheeID As Integer

Public numOrangeRate As Integer, depthOrangeBreak(7) As Single, rateOrange(8) As Single, _
numOrangePrice As Integer, numOrangeID As Integer

Public numPotatoRate As Integer, depthPotatoBreak(7) As Single, ratePotato(8) As Single, _
numPotatoPrice As Integer, numPotatoID As Integer

Public numWheatRate As Integer, depthWheatBreak(7) As Single, rateWheat(8) As Single, _
numWheatPrice As Integer, numWheatID As Integer

Public numRiceRate As Integer, depthRiceBreak(7) As Single, rateRice(8) As Single, _
numRicePrice As Integer, numRiceID As Integer

Public numCornRate As Integer, depthCornBreak(7) As Single, rateCorn(8) As Single, _
numCornPrice As Integer, numCornID As Integer

Public m_depthBreak(7) As Single, m_lossRate(8) As Single, m_numRateLevel As Integer


'************************************************************************************************''''
Public numItemRate As Integer, depthItemBreak(7) As Single, rateItem(8) As Single, _
numItemPrice As Integer, numItemID As Integer


''土地利用类型ID''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''    Const waterField As Integer = 11
'''    Const aridField As Integer = 12
'''
'''    Const numCottonID As Integer = 12
'''    Const numCornID As Integer = 12
'''    Const numFlowerID As Integer = 12
'''    Const numLicheeID As Integer = 12
'''    Const numOrangeID As Integer = 12
'''    Const numPotatoID As Integer = 12
'''    Const numRiceID As Integer = 11
'''    Const numWheatID As Integer = 12
'''
'''    Const highTree As Integer = 21
'''    Const shrub As Integer = 22
'''    Const lowTree As Integer = 23
'''
'''    Const highGrass As Integer = 31
'''    Const middleGrass As Integer = 32
'''    Const lowGrass As Integer = 33
'''
'''    Const ditch As Integer = 41
'''    Const lake As Integer = 42
'''    Const reservior As Integer = 43
'''    Const glacier As Integer = 44
'''    Const beach As Integer = 45
'''    Const shoal As Integer = 46
'''
'''    Const townField As Integer = 51
'''    Const village As Integer = 52
'''    Const buildField As Integer = 53
'''
'''    Const sands As Integer = 61
'''    Const desert As Integer = 62
'''    Const salina As Integer = 63
'''    Const swamp As Integer = 64
'''    Const unPlant As Integer = 65
'''    Const gravel As Integer = 66
'''    Const other As Integer = 67
''土地利用ID''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'************************************************************************************************'''
''''setLanduseIDs设置土地利用ID

'************************************************************************************************'''
Public Sub setLanduseIDs()
    waterField = 11
    aridField = 12
    
    numCottonID = 12
    numCornID = 12
    numFlowerID = 12
    numLicheeID = 12
    numOrangeID = 12
    numPotatoID = 12
    numRiceID = 11
    numWheatID = 12
    
    highTree = 21
    shrub = 22
    lowTree = 23
    
    highGrass = 31
    middleGrass = 32
    lowGrass = 33
    
    ditch = 41
    lake = 42
    reservior = 43
    glacier = 44
    beach = 45
    shoal = 46
    
    townField = 51
    village = 52
    buildField = 53
    
    sands = 61
    desert = 62
    salina = 63
    swamp = 64
    unPlant = 65
    gravel = 66
    other = 67
End Sub



'************************************************************************************************'''
''''' SplitPath - splits a path into dir name and filename w/out extension

'************************************************************************************************'''
Public Sub SplitPath(pathName As String, dirName As String, FileName As String)
  ' find the last occurance of a file separator
  ' in the path
    nCurPos = 0
    Do
        nLastPos = nCurPos
        nCurPos = InStr(nCurPos + 1, pathName, "\")
    Loop Until nCurPos = 0
    
    If nLastPos = 0 Then Exit Sub
    
    dirName = Left(pathName, nLastPos - 1)
    FileName = Right(pathName, Len(pathName) - nLastPos)
    'filename = Left(fName, Len(fName) - 4)
End Sub



'************************************************************************************************'''
'''''OpenTableFromFile

'************************************************************************************************'''
Public Function OpenTableFromFile(sPath As String, sFileName As String) As ITable
   ' Returns RasterDataset object given a file name and its directory
    ' sPath: directory where dataset resides
    ' sFileName: name of the raster dataset
    On Error GoTo ErrorHandler
    
    ' Create RasterWorkSpaceFactory
    Dim pWSF As IWorkspaceFactory
    Set pWSF = New ShapefileWorkspaceFactory
    
    ' Get RasterWorkspace
    Dim pFeatws As IFeatureWorkspace
    If pWSF.IsWorkspace(sPath) Then
        Set pFeatws = pWSF.OpenFromFile(sPath, 0)
        Set OpenTableFromFile = pFeatws.OpenTable(sFileName)
    End If
    
    ' Release memeory
    Set pFeatws = Nothing
    Set pWSF = Nothing
    Exit Function
    
ErrorHandler:
    Set OpenTableFromFile = Nothing
  MsgBox "Fail to open table, " & ERR.Description
End Function



'************************************************************************************************'''
''''PlusRaster

'************************************************************************************************'''
Sub PlusRaster(pRasInput As IRaster, pRasResult As IRaster)
    
    On Error GoTo ERH
    
    Dim pInputBandCol As IRasterBandCollection
    Set pInputBandCol = pRasInput
    Dim pInputBand As iRasterBand
    Set pInputBand = pInputBandCol.Item(0)
    Dim pInputRasProps As IRasterProps
    Set pInputRasProps = pInputBand
    
    Dim pOutputBandCol As IRasterBandCollection
    Set pOutputBandCol = pRasResult
    Dim pOutputBand As iRasterBand
    Set pOutputBand = pOutputBandCol.Item(0)
        
    Dim pOrigin As IPoint
    Set pOrigin = New Point
    pOrigin.X = pInputRasProps.Extent.XMin
    pOrigin.Y = pInputRasProps.Extent.YMin
    
    Dim pInputRawPixel As IRawPixels
    Set pInputRawPixel = pInputBand
    Dim pOutputRawPixel As IRawPixels
    Set pOutputRawPixel = pOutputBand
      
    ' Create a DblPnt to hold the PixelBlock size
    Dim pPnt As IPnt
    Set pPnt = New DblPnt
    pPnt.SetCoords pInputRasProps.Width, pInputRasProps.Height
    Dim pInputBlock As IPixelBlock
    Set pInputBlock = pInputRawPixel.CreatePixelBlock(pPnt)
    Dim pOutputBlock As IPixelBlock
    Set pOutputBlock = pOutputRawPixel.CreatePixelBlock(pPnt)
      
    pPnt.X = 0
    pPnt.Y = 0
    pInputRawPixel.Read pPnt, pInputBlock
    pOutputRawPixel.Read pPnt, pOutputBlock
     
    ' Get the SafeArray associated with the first band of output
    Dim vSafeArray As Variant
    vSafeArray = pOutputBlock.SafeArray(0)
    MsgBox "OK here"
         
    ' Loop through the SafeArray and calculate each pixel value using equation given above
    Dim i, j As Long
    For i = 0 To pInputRasProps.Width - 1
        For j = 0 To pInputRasProps.Height - 1
            vSafeArray(i, j) = vSafeArray(i, j) + pInputBlock.GetVal(0, i, j)
        Next j
    Next i
      
    ' Write out the result
    pOutputRawPixel.Write pPnt, pOutputBlock
      
    Set pOrigin = Nothing
    Set pPnt = Nothing

    Exit Sub
    
ERH:
    MsgBox "栅格图层相加失败" & ERR.Description
End Sub



'************************************************************************************************'''
''''rasterSum，统计栅格图斑的面积

'************************************************************************************************'''
Public Sub rasterSum(pRasInput As IRaster, numResult As Double)

    On Error GoTo ERH
    
    Dim pInputBandCol As IRasterBandCollection
    Set pInputBandCol = pRasInput
    Dim pInputBand As iRasterBand
    Set pInputBand = pInputBandCol.Item(0)
    Dim pInputRasProps As IRasterProps
    Set pInputRasProps = pInputBand
    Dim pInputRawPixel As IRawPixels
    Set pInputRawPixel = pInputBand
    
    ' Create a DblPnt to hold the PixelBlock size
    Dim pPnt As IPnt
    Set pPnt = New DblPnt
    pPnt.SetCoords pInputRasProps.Width, pInputRasProps.Height
    
    Dim pInputBlock As IPixelBlock
    Set pInputBlock = pInputRawPixel.CreatePixelBlock(pPnt)
      
    pPnt.X = 0
    pPnt.Y = 0
    pInputRawPixel.Read pPnt, pInputBlock
     
    Dim temp As Double, cellsizeX As Integer, cellsizeY As Integer
    cellsizeX = pInputRasProps.MeanCellSize.X
    cellsizeY = pInputRasProps.MeanCellSize.Y
    numResult = 0#
    
    Dim i As Long, j As Long
    For i = 0 To pInputRasProps.Width - 1
        For j = 0 To pInputRasProps.Height - 1
        
            If pInputBlock.GetVal(0, i, j) >= 0 Then
                temp = pInputBlock.GetVal(0, i, j)
                numResult = numResult + CDbl(temp * cellsizeX * cellsizeY)
            End If
        
        Next j
    Next i
    
    Set pPnt = Nothing
'MsgBox "The result is : " & numResult

    Exit Sub
    
ERH:
    MsgBox "栅格统计失败" & ERR.Description

End Sub



'************************************************************************************************'''
''''cellNumber计算图斑的栅格数目

'************************************************************************************************'''
Public Function cellNumber(pRasInput As IRaster) As Integer

    On Error GoTo ERH
    
    Dim pInputBandCol As IRasterBandCollection
    Set pInputBandCol = pRasInput
    Dim pInputBand As iRasterBand
    Set pInputBand = pInputBandCol.Item(0)
    Dim pInputRasProps As IRasterProps
    Set pInputRasProps = pInputBand
    Dim pInputRawPixel As IRawPixels
    Set pInputRawPixel = pInputBand
    
    ' Create a DblPnt to hold the PixelBlock size
    Dim pPnt As IPnt
    Set pPnt = New DblPnt
    pPnt.SetCoords pInputRasProps.Width, pInputRasProps.Height
    
    Dim pInputBlock As IPixelBlock
    Set pInputBlock = pInputRawPixel.CreatePixelBlock(pPnt)
      
    pPnt.X = 0
    pPnt.Y = 0
    pInputRawPixel.Read pPnt, pInputBlock
     
    Dim numPixel As Integer
    numPixel = 0
    Dim i As Long, j As Long
    For i = 0 To pInputRasProps.Width - 1
        For j = 0 To pInputRasProps.Height - 1
        
            If pInputBlock.GetVal(0, i, j) >= 0 Then numPixel = numPixel + 1
        
        Next j
    Next i
    
    cellNumber = numPixel
    
    Set pPnt = Nothing
    Exit Function
    
ERH:
    MsgBox "栅格数目统计失败" & ERR.Description

End Function



'************************************************************************************************'''
''''rasPatchArea

'************************************************************************************************'''
Public Function rasPatchArea(pRasInput As IRaster) As Long

    On Error GoTo ERH
    
    Dim pInputBandCol As IRasterBandCollection
    Set pInputBandCol = pRasInput
    Dim pInputBand As iRasterBand
    Set pInputBand = pInputBandCol.Item(0)
    Dim pInputRasProps As IRasterProps
    Set pInputRasProps = pInputBand
    Dim pInputRawPixel As IRawPixels
    Set pInputRawPixel = pInputBand
    
    ' Create a DblPnt to hold the PixelBlock size
    Dim pPnt As IPnt
    Set pPnt = New DblPnt
    pPnt.SetCoords pInputRasProps.Width, pInputRasProps.Height
    
    Dim pInputBlock As IPixelBlock
    Set pInputBlock = pInputRawPixel.CreatePixelBlock(pPnt)
      
    pPnt.X = 0
    pPnt.Y = 0
    pInputRawPixel.Read pPnt, pInputBlock
    Dim numPixel As Integer
    numPixel = 0
    
    Dim i As Long, j As Long
    For i = 0 To pInputRasProps.Width - 1
        For j = 0 To pInputRasProps.Height - 1

            If CInt(pInputBlock.GetVal(0, i, j)) >= 0 Then
                numPixel = numPixel + 1 'MsgBox pInputBlock.GetVal(0, i, j) '
            End If

        Next j
    Next i
    
    rasPatchArea = numPixel * pInputRasProps.MeanCellSize.X * pInputRasProps.MeanCellSize.Y
    
    Set pPnt = Nothing
    Exit Function
    
ERH:
    MsgBox "栅格面积统计失败" & ERR.Description

End Function




'************************************************************************************************'''
''''CutRasByShp，用多边形切取栅格得到图斑
'************************************************************************************************'''
Public Function CutRasByShpFeat(pFeatClass As IFeatureClass, pRasInput As IRaster) As IRaster
    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
    
'    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 = pRasInput 'OpenRasterDataset(strGRIDPath, strGRIDFile).CreateDefaultRaster
    
    Dim pTempDS As IGeoDataset
    Set pTempDS = pFeatClass 'pFeaLyr.FeatureClass
    
    Dim pConOp As IConversionOp
    Set pConOp = New RasterConversionOp
    Set pEnv = pConOp
    Dim pProp As IRasterProps
    Set pProp = inputRaster
    pEnv.SetCellSize esriRasterEnvValue, pProp.MeanCellSize.X
    
    ' Delete the existing file