clsoverlay.cls

FloodEvaluation-程序是gis方面的程序

    Dim pOutputFeatLayer As IFeatureLayer
    Set pOutputFeatLayer = New FeatureLayer
    Set pOutputFeatLayer.FeatureClass = pOutputFeatClass
    pOutputFeatLayer.name = pOutputFeatClass.AliasName
    pMxDoc.FocusMap.AddLayer pOutputFeatLayer

 End Sub
  
 Public Sub selectAllFeature()
 
    Dim pFeatcls As IFeatureClass
    Dim pFeatLayer As IFeatureLayer
    Dim pDoc As IMxDocument
    Dim pMap As IMap
      
    Set pDoc = pApp.Document
    Set pMap = pDoc.Maps.Item(0)
    Set pFeatLayer = pMap.Layer(0)
    Set pFeatcls = pFeatLayer.FeatureClass
      
    'Create a scratch workspace factory to use for the selection
    Dim pScratchWorkspace As IWorkspace
    Dim pScratchWorkspaceFactory As IScratchWorkspaceFactory
    Set pScratchWorkspaceFactory = New ScratchWorkspaceFactory
    Set pScratchWorkspace = pScratchWorkspaceFactory.DefaultScratchWorkspace
    
    Dim pIEnumFeat As IEnumFeature
    
    ' +++ create the query filter, and give
    ' +++ it a where clause
    Dim pQFilt As IQueryFilter
    Set pQFilt = New QueryFilter
    pQFilt.WhereClause = "Shape_Area > 77000"
    
    ' ++ use the query filter to select features
    Dim pSelectionSet As ISelectionSet
    Set pSelectionSet = pFeatcls.Select(Nothing, esriSelectionTypeIDSet, esriSelectionOptionNormal, pScratchWorkspace)
    
    ' +++ count the number of selected features
    MsgBox pSelectionSet.Count
 
 End Sub
 
 Public Sub selectFeatureLayer()
 
    Dim pFilter As IQueryFilter, pFeatCursor As IFeatureCursor, pPt As IPoint
    Dim pFeatLayer As IFeatureLayer
    Dim pDoc As IMxDocument
    Dim pMap As IMap
   
    Set pDoc = pApp.Document
    Set pMap = pDoc.Maps.Item(0)
    Set pFeatLayer = pMap.Layer(0)
    Set pFilter = New QueryFilter
    pFilter.WhereClause = ""

    Set pFeatCursor = pFeatLayer.Search(pFilter, False)
    Dim pFeat As IFeature
    Set pFeat = pFeatCursor.NextFeature
    If pFeat Is Nothing Then
      MsgBox "Nothing found"
      
    Else
      ' show the toolTip
      Dim strTip As String
      Dim lIndex As Long
      lIndex = pFeat.Fields.FindField("STATE_NAME")
      strTip = pFeat.Value(lIndex) & "In Layer of" & pFeatLayer.name
'      MsgBox strTip
    End If
    
 End Sub
 

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''To backup some general operations funciton and subs

Public Function CreateShapefile(sDir As String, sName As String, shapeType As esriGeometryType, _
  hasM As Boolean, hasZ As Boolean, pSR As ISpatialReference) As IFeatureClass
  
  Set CreateShapefile = Nothing
  
  Dim shapeWorkspaceFactory As IWorkspaceFactory
  Set shapeWorkspaceFactory = New ShapefileWorkspaceFactory
  
  Dim connectionProperties As IPropertySet
  Set connectionProperties = New PropertySet
  connectionProperties.SetProperty "DATABASE", sDir
  
  Dim shapeWorkspace As IFeatureWorkspace
  Set shapeWorkspace = shapeWorkspaceFactory.Open(connectionProperties, 0)
  If (Not shapeWorkspace Is Nothing) Then
      
    Dim pFields As IFields
    Set pFields = CreateBasicFields(shapeType, hasM, hasZ, pSR)
  
    Dim pFClass As IFeatureClass
    Set pFClass = shapeWorkspace.CreateFeatureClass(sName, pFields, Nothing, Nothing, esriFTSimple, "Shape", "")
  
    Set CreateShapefile = pFClass
  End If
End Function

 ' Create minimal required fields for featureclass
Public Function CreateBasicFields(shapeType As esriGeometryType, hasM As Boolean, hasZ As Boolean, _
    pSpaRef As ISpatialReference) As IFields
  
  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
  
  Set CreateBasicFields = pFldsEdt
End Function

Public Sub AddShapeToFeatureClass(pGeom As IGeometry, pFC As IFeatureClass)
  Dim pFeature As IFeature
  Set pFeature = pFC.CreateFeature
  Set pFeature.Shape = pGeom
  pFeature.Store

End Sub

Public Function OpenShapeFile(dir As String, name As String) As IFeatureClass
  Dim pWSFact As IWorkspaceFactory
  Dim connectionProperties As IPropertySet
  Dim pShapeWS As IFeatureWorkspace
  Dim isShapeWS As Boolean

  Set OpenShapeFile = Nothing
  
  Set pWSFact = New ShapefileWorkspaceFactory
  isShapeWS = pWSFact.IsWorkspace(dir)
  If (isShapeWS) Then
    On Error GoTo errhandler
    Set connectionProperties = New PropertySet
    connectionProperties.SetProperty "DATABASE", dir
    Set pShapeWS = pWSFact.Open(connectionProperties, 0)
    Dim pFClass As IFeatureClass
    Set pFClass = pShapeWS.OpenFeatureClass(name)
    Set OpenShapeFile = pFClass
  End If
errhandler:
End Function

'Public Sub AddFCToScene(pFC As IFeatureClass, sLayerName As String)
'    Dim pDoc As ISxDocument
'
'    If Not TypeOf Application Is ISxApplication Then
'        Exit Sub
'    End If
'
'    ' Create a layer from the shapefile and add it to scene:
'    Dim pLayer As IFeatureLayer
'    Set pLayer = New FeatureLayer
'    Set pLayer.FeatureClass = pFC
'    pLayer.name = sLayerName
'
'    Set pDoc = Application.Document
'    ' Add layer to scene.
'    Dim pBasicMap As IBasicMap
'    Set pBasicMap = pDoc.Scene
'    pBasicMap.AddLayer pLayer
'
'    Dim pSG As ISceneGraph
'    Set pSG = pDoc.Scene.SceneGraph
'    pSG.RefreshViewers
'
'End Sub

Public Function DegreesToRadians(dDeg As Double) As Double
    Dim PI As Double
    PI = 4 * Atn(1#)
    
    Dim RAD As Double
    RAD = PI / 180#
    
    DegreesToRadians = dDeg * RAD
End Function


Public Function CreateShapefile0(sDir As String, sName As String, shapeType As esriGeometryType, _
  hasM As Boolean, hasZ As Boolean, pSR As ISpatialReference) As IFeatureClass
  
On Error GoTo CreateShape_ERR

'  Set CreateShapefile = Nothing
  
    Dim shapeWorkspaceFactory As IWorkspaceFactory
    Set shapeWorkspaceFactory = New ShapefileWorkspaceFactory
    
    Dim connectionProperties As IPropertySet
    Set connectionProperties = New PropertySet
    connectionProperties.SetProperty "DATABASE", sDir
    
    Dim shapeWorkspace As IFeatureWorkspace
    Set shapeWorkspace = shapeWorkspaceFactory.Open(connectionProperties, 0)
    If (Not shapeWorkspace Is Nothing) Then
      Dim pFC As IFeatureClass
      Set pFC = OpenShapeFile(sDir, sName)  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
      
      If Not pFC Is Nothing Then
          Dim pDS As IDataset
          Set pDS = pFC
          pDS.Delete
      End If
      
      Dim pFields As IFields
      Set pFields = CreateBasicFields(shapeType, hasM, hasZ, pSR)
    
      Dim pFClass As IFeatureClass
      Set pFClass = shapeWorkspace.CreateFeatureClass(sName, pFields, Nothing, Nothing, esriFTSimple, "Shape", "")
    
    '    Set CreateShapefile = pFClass
    End If
  
    Exit Function
CreateShape_ERR:
    Debug.Print "CreateShape_ERR: " & err.Description
    Resume Next
    
End Function