mod_layersql.bas

arcengine+vb开发原码

    On Error GoTo errorhand
    Set QueryByAttribute = Nothing
    
    If Not (pfeaturelayer Is Nothing) Then
        
        Set pfeatureselection = pfeaturelayer
        Set pFilter = New QueryFilter
        
        pFilter.SubFields = "*"
        pFilter.whereclause = whereclause
        pfeatureselection.SelectFeatures pFilter, operator, False
        
    
    End If
    
    Set QueryByAttribute = pfeatureselection
    Set pfeatureselection = Nothing
    Set pFilter = Nothing
    
    Exit Function
errorhand:
    
    Set QueryByAttribute = Nothing
    
End Function

Public Sub LocateFeatures()

   Dim pEnumFeatures As IEnumFeature '要素枚举变量接口
   Dim pFeature As IFeature '要素接口
   Dim pEnv As IEnvelope
   Dim pEnvNew As IEnvelope
   Dim xMax As Double, xMin As Double
   Dim yMax As Double, yMin As Double
   Dim intFeatureCount As Long
   Dim pCenter As IPoint

   Dim pActiveView As IActiveView
   Set pActiveView = m_pMap
   On Error GoTo errorhandle
   If m_pMap.SelectionCount < 0 Then
        
        MsgBox "没有目标被选中", vbOKOnly, "信息提示"
        Exit Sub
    
    End If
    
    
   On Error Resume Next
   
   intFeatureCount = 0
   Set pEnumFeatures = m_pMap.FeatureSelection
   
   pEnumFeatures.Reset
   Set pFeature = pEnumFeatures.Next
   

   Do While (Not pFeature Is Nothing)
        
        intFeatureCount = intFeatureCount + 1
        Set pEnv = pFeature.Extent
        
        If intFeatureCount = 1 Then
            
            xMax = pEnv.xMax
            xMin = pEnv.xMin
            yMax = pEnv.yMax
            yMin = pEnv.yMin
            
            If pFeature.Shape.GeometryType = esriGeometryPoint Then
                 
                 Set pCenter = New Point
                 pCenter.PutCoords (xMax + xMin) / 2, (yMax + yMin) / 2
            
            End If
            
        End If
        
        If xMax < pEnv.xMax Then xMax = pEnv.xMax
        If xMin > pEnv.xMin Then xMin = pEnv.xMin
        If yMax < pEnv.yMax Then yMax = pEnv.yMax
        If yMin > pEnv.yMin Then yMin = pEnv.yMin
        Set pFeature = pEnumFeatures.Next
   
   Loop
   
   
   Set pEnvNew = New Envelope
   pEnvNew.PutCoords xMin, yMin, xMax, yMax
   
   pEnumFeatures.Reset
   Set pFeature = pEnumFeatures.Next
   
   If intFeatureCount = 1 And pFeature.Shape.GeometryType = esriGeometryPoint Then
        
        Set pCenter = pFeature.Shape
        pEnvNew.xMax = pCenter.X + 200
        pEnvNew.xMin = pCenter.X - 200
        pEnvNew.yMax = pCenter.Y + 230
        pEnvNew.yMin = pCenter.Y - 230
        pEnvNew.CenterAt pCenter
        pEnvNew.Expand 1.5, 1.5, True
       pActiveView.Extent = pEnvNew
       pActiveView.PartialRefresh esriViewBackground + esriViewGeoSelection, pFeature, Nothing
       
       DoEvents
        Mod_Flash.FlashFeature pFeature, m_pMap

        Set pCenter = Nothing
        Set pEnumFeatures = Nothing
        Set pEnvNew = Nothing
        Set pFeature = Nothing
        Set pEnv = Nothing
        
         
        
        Exit Sub
        
   End If
   
        pEnvNew.Expand 2.5, 2.5, True
       pActiveView.Extent = pEnvNew
       pActiveView.PartialRefresh esriViewBackground + esriViewGeoSelection, Nothing, Nothing
       DoEvents
   Mod_Flash.FlashFeature pFeature, m_pMap
   Set pEnumFeatures = Nothing
   Set pFeature = Nothing
   Set pEnv = Nothing
   Set pEnvNew = Nothing
   Set pActiveView = Nothing
   
 
 
   Exit Sub
   
errorhandle:
   
 End Sub
 

 Function GetFeatureFromSelection(ByVal pSelFeature As IFeatureSelection) As IArray
    
    Set GetFeatureFromSelection = Nothing
    
    Dim pFeatureSelectionset As ISelectionSet '要素选择集接口
    Dim pFeatureSelsetCursor As ICursor '要素集中循环光标
    Dim pFeature As IFeature '要素接口
    Dim pAryFeature As IArray '要素队列接口
    
    On Error GoTo errorhandle
    
    Set pFeatureSelectionset = pSelFeature.SelectionSet
   
   pFeatureSelectionset.Search Nothing, False, pFeatureSelsetCursor

    
    Set pAryFeature = New esriSystem.Array

    Set pFeature = pFeatureSelsetCursor.NextRow

     Do Until pFeature Is Nothing
        
        pAryFeature.Add pFeature
        Set pFeature = pFeatureSelsetCursor.NextRow
    
    Loop
   
   Set GetFeatureFromSelection = pAryFeature
   'update by tjh
   
   Set pAryFeature = Nothing
   Set pFeatureSelectionset = Nothing
   Set pFeatureSelsetCursor = Nothing
   Set pFeature = Nothing
   Set pAryFeature = Nothing
   
   Exit Function

errorhandle:
   Set GetFeatureFromSelection = Nothing
   

End Function
Function GetFldIndex(ByVal pFLayer As IFeatureLayer, strFldName As String) As Long
    
    Dim pFeatCls As IFeatureClass '要素类接口
    Dim pTable As ITable '表接口
    Dim lngIndex As Long
    
    If Not pFLayer Is Nothing And strFldName <> "" Then
        Set pFeatCls = pFLayer.FeatureClass
        Set pTable = pFeatCls
        
        lngIndex = pTable.FindField(strFldName)
        GetFldIndex = lngIndex
    
        Set pFeatCls = Nothing
        Set pTable = Nothing
    End If
    
End Function
Public Function GetCharFields(ByVal m_pCurrentLayer As IGeoFeatureLayer) As IArray
     
     Set GetCharFields = Nothing
     
     Dim pFeatureClass As IFeatureClass '要素类接口
     Dim pFields As IFields '字段接口
     Dim pAryFields As IArray '字段队列
     Dim intFieldIndex As Integer '字段循环参数
     
     On Error GoTo errorhandle
    Set pFeatureClass = m_pCurrentLayer.DisplayFeatureClass
     Set pFields = pFeatureClass.Fields
     Set pAryFields = New esriSystem.Array
     
     For intFieldIndex = 0 To pFields.FieldCount - 1
        
        If pFields.Field(intFieldIndex).Type = esriFieldTypeString Then
            
            pAryFields.Add pFields.Field(intFieldIndex)
        
        End If
     
     Next intFieldIndex
     
     Set GetCharFields = pAryFields
     'update by tjh
     Set pAryFields = Nothing
     Set pFields = Nothing
     Set pAryFields = Nothing
     Set pFeatureClass = Nothing
       
     Exit Function
     
errorhandle:
     
     Set GetCharFields = Nothing
     
End Function

'得到数值型型字段队列
Public Function GetNumFields(ByVal m_pCurrentLayer As IGeoFeatureLayer) As IArray
     
     Set GetNumFields = Nothing
     
     Dim pFeatureClass As IFeatureClass '要素类接口
     Dim pFields As IFields '字段接口
     Dim pAryFields As IArray '字段队列接口
     Dim intFieldIndex As Integer '字段循环参数
     
     On Error GoTo errorhandle
     Set pFeatureClass = m_pCurrentLayer.DisplayFeatureClass
     Set pFields = pFeatureClass.Fields
     Set pAryFields = New esriSystem.Array
     
     For intFieldIndex = 0 To pFields.FieldCount - 1
     
        If pFields.Field(intFieldIndex).Type = esriFieldTypeSmallInteger Then
            pAryFields.Add pFields.Field(intFieldIndex)
        End If
        
        If pFields.Field(intFieldIndex).Type = esriFieldTypeInteger Then
            pAryFields.Add pFields.Field(intFieldIndex)
        End If
        
        If pFields.Field(intFieldIndex).Type = esriFieldTypeSingle Then
            pAryFields.Add pFields.Field(intFieldIndex)
        End If
        
        If pFields.Field(intFieldIndex).Type = esriFieldTypeDouble Then
            pAryFields.Add pFields.Field(intFieldIndex)
        End If
     
     Next intFieldIndex
     
     Set GetNumFields = pAryFields
     
     Set pAryFields = Nothing
     Set pFeatureClass = Nothing
     Set pFields = Nothing
     
     Exit Function
     
errorhandle:
     Set GetNumFields = Nothing
End Function

Public Function GetMapSelectableNotNullFeatLayer(ByVal m_pMap As IMap) As Collection
    
    Set GetMapSelectableNotNullFeatLayer = Nothing
    
    Dim pColFeatureLayers As Collection '要素图层集合接口
    Dim pLayer As ILayer '图层接口
    Dim pEnumLayer As IEnumLayer '枚举图层接口
    Dim pfeaturelayer As IFeatureLayer '要素图层接口
    
    On Error GoTo errorhandle
    If m_pMap.LayerCount = 0 Then Exit Function
    
    Set pColFeatureLayers = New Collection
    Set pEnumLayer = m_pMap.Layers
    Set pLayer = pEnumLayer.Next
    
    Do While Not pLayer Is Nothing
    
       If TypeOf pLayer Is IFeatureLayer Then
            Set pfeaturelayer = pLayer
            If pfeaturelayer.Selectable = True And Not pfeaturelayer.FeatureClass Is Nothing Then
                pColFeatureLayers.Add pLayer.Name
            End If
       End If
    
        Set pLayer = pEnumLayer.Next
    
    Loop
    
    Set GetMapSelectableNotNullFeatLayer = pColFeatureLayers
    
    Set pColFeatureLayers = Nothing
    Set pLayer = Nothing
    Set pEnumLayer = Nothing
    Set pfeaturelayer = Nothing
    
    Exit Function
errorhandle:
    Set GetMapSelectableNotNullFeatLayer = Nothing
End Function