pointdensity.txt

VB6.0+AO 进行地理信息系统二次开发 该模块实现空间分析中的点的密度分析

Option Explicit
Sub Main()
    ' Calculating Point Density in a Standalone VB Apllication
    ' This code provides an example of using any Spatial operators in a standalone VB application.
    
    On Error GoTo ERH
    
    ' Specify input path and point shapefile
    Dim sInPath As String
    sInPath = "c:\workspace"  ' Input directory path
    
    Dim sFCName As String
    sFCName = "bapoint.shp"  ' Name of the input point shapefile
    
    ' Specify output path and raster
    Dim sOutPath As String
    sOutPath = "c:\temp"        ' Output workspace path
    
    Dim sRasName As String
    sRasName = "OutPdGrid"  ' Name of the output raster
        
    ' Open input shapefile as a FeatureClass
    Dim pFClass As IFeatureClass
    Set pFClass = OpenFeatureClassFromShapefile(sInPath, sFCName)
    
    ' Check out Spatial Analyst license
    CheckOutSpatialAnalystLicense
    
    ' Create the RasterDensityOp operator
    Dim pDensityOp As IDensityOp
    Set pDensityOp = New RasterDensityOp
    
    ' Create RasterAnalysisEnvironment
    Dim pEnv As IRasterAnalysisEnvironment
    Set pEnv = pDensityOp
    
    ' Set the output workspace
    Dim pWS As IWorkspace
    Set pWS = SetRasterWorkspace(sOutPath)
    Set pEnv.OutWorkspace = pWS
    
    ' Set the output raster cell size
    pEnv.SetCellSize esriRasterEnvValue, 30
    
    ' Set the output extent
    pEnv.SetExtent esriRasterEnvMaxOf
    
    ' Create a RasterNeiborghhood object
    Dim pRasNeighborhood As IRasterNeighborhood
    Set pRasNeighborhood = New RasterNeighborhood
    pRasNeighborhood.SetCircle 100, esriUnitsCells
    
    ' Calculate point density
    Dim pOutRaster As IRaster
    Set pOutRaster = pDensityOp.PointDensity(pFClass, pRasNeighborhood)
    
    ' Save output as a permanent raster dataset in GRID format
    Dim pRasBC As IRasterBandCollection
    Set pRasBC = pOutRaster
    pRasBC.SaveAs sRasName, pWS, "GRID"
    
    ' Release memory
    Set pFClass = Nothing
    Set pWS = Nothing
    Set pDensityOp = Nothing
    Set pEnv = Nothing
    Set pRasNeighborhood = Nothing
    Set pRasBC = Nothing
    Set pOutRaster = Nothing
    Exit Sub
ERH:
    MsgBox Err.Description
End Sub

Public Function SetRasterWorkspace(sPath As String) As IWorkspace
    ' This function returns a raster workspace object for the given path
    On Error GoTo ERH
    Dim pWSF As IWorkspaceFactory
    Set pWSF = New RasterWorkspaceFactory
    If pWSF.IsWorkspace(sPath) Then
        Set SetRasterWorkspace = pWSF.OpenFromFile(sPath, 0)
    End If
    Exit Function
ERH:
    MsgBox "Failed in opening workspace " & Err.Description
End Function

Public Function OpenFeatureClassFromShapefile(sPath As String, sShapeName As String) As IFeatureClass
    'Returns a FeatureClass object given a shapefile's name and its path
    On Error GoTo ERH
    Dim pWSFact As IWorkspaceFactory
    Dim pWS As IWorkspace
    Dim pFWS As IFeatureWorkspace

    Set pWSFact = New ShapefileWorkspaceFactory
    Set pWS = pWSFact.OpenFromFile(sPath, 0)
    Set pFWS = pWS
    Set OpenFeatureClassFromShapefile = pFWS.OpenFeatureClass(sShapeName)
    Exit Function
ERH:
    MsgBox "Failed in creating FeatureClass " & Err.Description
End Function

Public Function CheckOutSpatialAnalystLicense() As Boolean
    On Error GoTo ERH
    Dim m_pExtmanager As IExtensionManagerAdmin
    Set m_pExtmanager = New ExtensionManager
      
    Dim objid As New esriSystem.UID
    objid = "esriGeoAnalyst.SAExtension.1"
    
    Dim v As Variant
    m_pExtmanager.AddExtension objid, v
    
    Dim pEM As IExtensionManager
    Set pEM = m_pExtmanager
    Dim pEC As IExtensionConfig
    Set pEC = pEM.FindExtension(objid)
    pEC.State = esriESEnabled
      
    CheckOutSpatialAnalystLicense = (pEC.State = esriESEnabled)
    
    Exit Function
ERH:
    MsgBox "Failed in checking out Spatial Analyst license " & Err.Description
End Function