modutilities.bas

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

    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
    numArea = 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)
                numArea = numArea + 1
            End If
        
        Next j
    Next i
'    MsgBox numResult
    numResult = numResult * cellSizeX * cellSizeY
    numArea = numArea * cellSizeX * cellSizeY
    Set pPnt = Nothing
'MsgBox "The result is : " & numResult

    Exit Sub
    
ERH:
    MsgBox "栅格统计失败" & ERR.Description, vbInformation + vbOKOnly, "提示信息"

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, vbInformation + vbOKOnly, "提示信息"

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, vbInformation + vbOKOnly, "提示信息"

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
    Dim strGRIDPath As String
    strGRIDPath = "C:\Program Files\BeijiangTemp"
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FolderExists(strGRIDPath + "\" + "CovTemp") Then                'FileExists
        fs.Deletefolder (strGRIDPath + "\" + "CovTemp")                   'Deletefile
    End If
                
    Set pWksF = New RasterWorkspaceFactory
    Set pWks = pWksF.OpenFromFile(strGRIDPath, 0)                         'sWorkPath
    Dim pGeoDs As IRasterDataset
    Set pGeoDs = pConOp.ToRasterDataset(pTempDS, "GRID", pWks, "CovTemp") 'IMAGINE Image
    
    Dim pLogicalOp As ILogicalOp
    Set pLogicalOp = New RasterMathOps
    Dim pConditionalOp As IConditionalOp
    Set pConditionalOp = New RasterConditionalOp

    Dim pMathOp As IMathSupportOp
    Set pMathOp = New RasterMathSupportOp
    
    Dim pZeroRaster As IRaster
    Set pZeroRaster = pMathOp.Minus(pGeoDs, pGeoDs)
    Dim pOutRas1 As IGeoDataset
    Set pOutRas1 = pConditionalOp.Con(pLogicalOp.GreaterThanEqual(pGeoDs, pZeroRaster), inputRaster)

    Set CutRasByShpFeat = 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, vbInformation + vbOKOnly, "提示信息"
End Function



'************************************************************************************************'''
''''CutRasByShp，用多边形切取栅格得到图斑
'************************************************************************************************'''
Public Function CutRasByShpFile(strPolygonFile As String, strPolygonPath As String, strGRIDFile As String, strGRIDPath As String) As IGeoDataset
    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 = 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 = inputRaster
    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
                
    Set pWksF = New RasterWorkspaceFactory
    Set pWks = pWksF.OpenFromFile(strGRIDPath, 0)                       'sWorkPath
    Dim pGeoDs As IRasterDataset
    Set pGeoDs = pConOp.ToRasterDataset(pTempDS, "GRID", pWks, "CovTemp") 'IMAGINE Image
    
    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 IGeoDataset
    Set pOutRas1 = pConditionalOp.Con(pLogicalOp.GreaterThanEqual(pGeoDs, pZeroRaster), inputRaster)

    Set CutRasByShpFile = 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, vbInformation + vbOKOnly, "提示信息"
End Function


'************************************************************************************************'''
''''CreateFeatureFields，根据参数创建矢量表的基本字段，然后可以调用appendField进行添加特需字段
'************************************************************************************************'''
' Create minimal required fields for featureclass
Public Function CreateFeatureFields(shapeType As esriGeometryType, hasM As Boolean, hasZ As Boolean, _
    pSpaRef As ISpatialReference, sFieldName As String) As IFields
  
    On Error GoTo ERH
    
    Dim pFlds As IFields
    Dim pFldsEdt As IFieldsEdit
    Set pFlds = New esriCore.Fields
    Set pFldsEdt = pFlds
    
    Dim pFld As IField
    Dim pFldEdt As IFieldEdit
    Set pFld = New esriCore.Field
    Set pFldEdt = pFld
      
    Dim pGeoDef As IGeometryDefEdit
    Set pGeoDef = New GeometryDef
    
    With pGeoDef
      .GeometryType = shapeType
      .hasM = hasM
      .hasZ = hasZ
      Set .SpatialReference = pSpaRef