modutilities.bas

来自「FloodEvaluation-程序是gis方面的程序」· BAS 代码 · 共 1,015 行 · 第 1/3 页

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 theFloodName As String, theFloodDate As String, bFloodInfoOK As Boolean
Public m_txtRangeSde As String, m_txtDepthSde As String, m_txtPopuSde As String
Public m_txtAreaSde As String, m_txtCropLossSde As String, m_txtTotalLossSde As String

Public g_bForCropDisplay As Boolean

'''    txtRangeSde = "floodRange" + Right(txtDate, Len(txtDate) - 2)
'''    txtDepthSde = "floodDepth" + Right(txtDate, Len(txtDate) - 2)
'''    txtPopuSde = "floodPopu" + Right(txtDate, Len(txtDate) - 2)
'''    txtPopuTab = "evalPopu"
'''    txtAreaSde = "floodArea" + Right(txtDate, Len(txtDate) - 2)
'''    txtAreaTab = "evalArea"
'''    txtCropLossSde = "cropLoss" + Right(txtDate, Len(txtDate) - 2)
'''    txtCropLossTab = "evalTotalCrop"
'''    txtTotalLossSde = "floodSum" + Right(txtDate, Len(txtDate) - 2)
'''    txtTotalLossTab = "evalLoss"





'************************************************************************************************''''
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 "打开表格失败, " & ERR.Description, vbInformation + vbOKOnly, "提示信息"
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, vbInformation + vbOKOnly, "提示信息"
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, vbInformation + vbOKOnly, "提示信息"

End Sub


'************************************************************************************************'''
''''rasterSum，统计栅格图斑的面积
'************************************************************************************************'''
Public Sub rasterSum2(pRasInput As IRaster, _
                      numResult As Double, _
                      numArea As Long)

    On Error GoTo ERH
    
    Dim pInputBandCol As IRasterBandCollection
    Set pInputBandCol = pRasInput
    Dim pInputBand As iRasterBand
    Set pInputBand = pInputBandCol.Item(0)