modutilities.bas

FloodEvaluation-程序是gis方面的程序

    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
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
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
    End With
    
    ' add oid field (access and sde) - must come before geometry field
    Set pFldEdt = New esriCore.Field
    With pFldEdt
      .name = "OID"
      .Type = esriFieldTypeOID
    End With
    pFldsEdt.AddField pFldEdt
    
    'add Geometry field
    Set pFldEdt = New esriCore.Field
    With pFldEdt
      .name = "Shape"
      .IsNullable = True
      .Type = esriFieldTypeGeometry
      Set .GeometryDef = pGeoDef
    End With
    pFldsEdt.AddField pFldEdt
    
    'add Name field
'    Set pFldEdt = New esriCore.Field
'    With pFldEdt
'      .Name = "地区"
'      .IsNullable = True
'      .Type = esriFieldTypeString
'    '    Set .GeometryDef = pGeoDef
'    End With
'    pFldsEdt.AddField pFldEdt
    
    'add Flood Loss field
'    Set pFldEdt = New esriCore.Field
'    With pFldEdt
'      .Name = sFieldName
'      .IsNullable = True
'      .Type = esriFieldTypeDouble
'    '    Set .GeometryDef = pGeoDef
'    End With
'    pFldsEdt.AddField pFldEdt
    
    Set CreateFeatureFields = pFldsEdt
    Exit Function
    
ERH:
    MsgBox "创建字段失败" & Chr(13) & ERR.Description
  
End Function

'************************************************************************************************'''
''''AppendField，在原有表字段基础上，添加指定字段
'************************************************************************************************'''
Public Sub AppendField(pFields As IFields, strFieldName As String, pFldType As esriFieldType, pIsNullable As Boolean)
On Error GoTo ERH

    Dim lIndex As Long
    Dim pField As IField
    
    lIndex = pFields.FindField(strFieldName)
    If lIndex <> -1 Then
        MsgBox "欲加入的字段已存在"
        Exit Sub
    End If
    
    Dim pFieldsEdit As IFieldsEdit
    Set pFieldsEdit = pFields
    Dim pFieldEdit As IFieldEdit
    Set pFieldEdit = New esriCore.Field
    With pFieldEdit
      .name = strFieldName
      .IsNullable = pIsNullable
      .Type = pFldType
    '    Set .GeometryDef = pGeoDef
    End With
    pFieldsEdit.AddField pFieldEdit
    
    Exit Sub
ERH:
    MsgBox "添加字段失败"
End Sub

'************************************************************************************************'''
''''用多边形图层切割多边形或者线图层，结果存为所给名称
'************************************************************************************************'''
Public Function Intersect(resultFileName As String, resultPathName As String, polyLyr As IFeatureLayer, inputLyr As IFeatureLayer) As IFeatureClass
  ' Get the input layer and feature class

On Error GoTo ERR:
    ' Use the Itable interface from the Layer (not from the FeatureClass)
    Dim pInputTable As ITable
    Set pInputTable = inputLyr
    
    ' Get the input feature class.
    ' The Input feature class properties, such as shape type,
    ' will be needed for the output
    Dim pInputFeatClass As IFeatureClass
    Set pInputFeatClass = inputLyr.FeatureClass
      
    ' Get the overlay layer
    ' Use the Itable interface from the Layer (not from the FeatureClass)
    '  Set pLayer = pMxDoc.FocusMap.Layer(1)
    Dim pOverlayTable As ITable
    Set pOverlayTable = polyLyr
    
    ' Error checking
    If pInputTable Is Nothing Then
        MsgBox "Table QI failed"
        Exit Function
    End If
      
    If pOverlayTable Is Nothing Then
        MsgBox "Table QI failed"
        Exit Function
    End If
    
    ' Define the output feature class name and shape type (taken from the
    ' properties of the input feature class)
    Dim pFeatClassName As IFeatureClassName
    Set pFeatClassName = New FeatureClassName
    With pFeatClassName
        .FeatureType = esriFTSimple
        .ShapeFieldName = "Shape"
        .shapeType = pInputFeatClass.shapeType
    End With
    
    ' Set output location and feature class name
    Dim pNewWSName As IWorkspaceName
    Set pNewWSName = New WorkspaceName
    pNewWSName.WorkspaceFactoryProgID = "esriCore.ShapeFileWorkspaceFactory.1"
    pNewWSName.pathName = resultPathName
    
    Dim pDatasetName As IDatasetName
    Set pDatasetName = pFeatClassName
    pDatasetName.name = Left(resultFileName, Len(resultFileName) - 4)
    
    Set pDatasetName.WorkspaceName = pNewWSName
      
    ' Set the tolerance.  Passing 0.0 causes the default tolerance to be used.
    ' The default tolerance is 1/10,000 of the extent of the data frame's spatial domain
    Dim tol As Double
    tol = 0#
      
    ' Perform the intersect
    Dim pBGP As IBasicGeoprocessor
    Set pBGP = New BasicGeoprocessor
    Dim pOutputFeatClass As IFeatureClass
    Set pOutputFeatClass = pBGP.Intersect(pInputTable, False, pOverlayTable, False, tol, pFeatClassName)
    
    ' Add the output layer to the map
    Set Intersect = pOutputFeatClass
    Exit Function
    
ERR:
    MsgBox "图层叠加操作失败！"
  End Function
  
'************************************************************************************************'''
''''设置线显示属性
'************************************************************************************************'''
Public Sub setLineSymbol(pFeatLyr As IFeatureLayer, nWidth As Integer, pColor As IRgbColor)
    
    Dim bFound As Boolean  ' find a polyline feature layer?
    
    Dim pLSym As ILineSymbol
    Set pLSym = New SimpleLineSymbol  'CustomLineSymbol.MyLineSymbol
    pLSym.Width = nWidth  '2
    
    pLSym.Color = pColor
    
    If pFeatLyr.FeatureClass.shapeType <> esriGeometryPolyline Then
       MsgBox "只对线状图层设置现实属性"  'bFound = True
       Exit Sub
    End If
      
    Dim pRen As ISimpleRenderer
    Dim pGeoFeatLyr As IGeoFeatureLayer
    Set pGeoFeatLyr = pFeatLyr
    Set pRen = pGeoFeatLyr.Renderer
    Set pRen.Symbol = pLSym

End Sub
    
'************************************************************************************************'''
''''设置点、线、面显示属性
'************************************************************************************************'''
Public Sub setFeatureLayerRenderer(pFeatLyr As IFeatureLayer, _
                                   Optional longVbColor As Long = vbRed)
    
On Error GoTo ERH
     
    If Not TypeOf pFeatLyr Is IFeatureLayer Then
        MsgBox "只能设置矢量图层属性"
        Exit Sub
    End If
    
    ' --------------------------------------------------
    '     if point features, use a marker symbol for rendering
    '     else, if line features, then use a line symbol
    '     else, if polygon features, then use a fill symbol
    '     else, do not assign renderer to layer
    Dim pMarkerSym As ISimpleMarkerSymbol
    Dim pLineSymbol As ISimpleLineSymbol
    Dim pFillSymbol As ISimpleFillSymbol
      
    Dim pColor As IRgbColor
    Set pColor = New RgbColor
'    pColor.RGB = vbRed
    
    Set pMarkerSym = New SimpleMarkerSymbol
    With pMarkerSym
        .Size = 12
'        .Color = pColor
        .Style = esriSMSX
    End With
    
    Set pLineSymbol = New SimpleLineSymbol
    With pLineSymbol
        .Width = 1.8
'        .Color = pColor
        .Style = esriSLSSolid  'esriSLSDashDotDot
    End With
    
    Set pFillSymbol = New SimpleFillSymbol
    With pFillSymbol
        .Color = pColor
        .Style = esriSFSNull 'esriSFSBackwardDiagonal
'        .Outline = pLineSymbol
    End With
      
    ' based on feature type, make proper symbol, then assign to pSym
    Dim pSym As ISymbol
    Select Case pFeatLyr.FeatureClass.shapeType
      
      Case esriGeometryPoint     ' set up a marker symbol
          pColor.RGB = longVbColor 'vbYellow
          pMarkerSym.Color = pColor
          Set pSym = pMarkerSym
    
      Case esriGeometryPolyline    ' set up a line symbol
          pColor.RGB = longVbColor 'vbRed
          pLineSymbol.Color = pColor
          Set pSym = pLineSymbol
    
      Case esriGeometryPolygon    ' setup a fill symbol
'          Set pLineSymbol = New SimpleLineSymbol
'          With pLineSymbol
'              .Width = 1.5
'              .Color = pColor
'              .Style = esriSLSSolid  'esriSLSDashDotDot
'          End With
'          Set pSym = MakeNewGradientFillSymbol(pLineSymbol)  'pFillSymbol
          
          pColor.RGB = longVbColor  'vbBlue
          pLineSymbol.Color = pColor
          pFillSymbol.Outline = pLineSymbol
          Set pSym = pFillSymbol
    
      Case Else
          MsgBox "只能设置矢量图层属性"
          Exit Sub
    
    End Select
    ' --------------------------------------------------
      
    ' create a new CustomSimpleRend
    Dim pRend As IFeatureRenderer
    Set pRend = New clsCustomSimpleRend
    
    ' set symbol.  we must use ISimpleRenderer interface
    Dim pSimpleRend As ISimpleRenderer
    Set pSimpleRend = pRend
    Set pSimpleRend.Symbol = pSym
    
    Dim pGeoFL As IGeoFeatureLayer
    Set pGeoFL = pFeatLyr
    
    ' finally, set the new renderer to the layer and refresh the map
    Set pGeoFL.Renderer = pRend
    
    Set pColor = Nothing
    Set pSym = Nothing
    Set pMarkerSym = Nothing
    Set pLineSymbol = Nothing
    Set pFillSymbol = Nothing
    Set pRend = Nothing
    Set pSimpleRend = Nothing
    Set pGeoFL = Nothing
      
    Exit Sub
    
ERH:

    MsgBox "设置图例失败" & ERR.Description
    Exit Sub
End Sub