VBA之框选图形个数
来源:互联网 发布:php兄弟连毕业怎么样 编辑:程序博客网 时间:2024/06/07 07:30
准备:添加一个Tool控件,在Mousedown事件中添加以下代码:
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Dim pEnv As IEnvelope
Dim pRubber As IRubberBand
Set pRubber = New RubberEnvelope
Dim pActiveView As IActiveView
Set pActiveView = pMxDoc.FocusMap
Set pEnv = pRubber.TrackNew(pActiveView.ScreenDisplay, Nothing)
Dim pSpatialFilter As ISpatialFilter
Set pSpatialFilter = New SpatialFilter
Set pSpatialFilter.Geometry = pEnv
pSpatialFilter.SpatialRel = esriSpatialRelIntersects
Dim lPoints As Long, lPolylines As Long, lPolygons As Long
Dim pLayer As IFeatureLayer
Dim pFeatureCursor As IFeatureCursor
Dim pFeature As IFeature
Dim i As Long
For i = 0 To pMxDoc.FocusMap.LayerCount - 1
If (TypeOf pMxDoc.FocusMap.Layer(i) Is IGeoFeatureLayer) Then
Set pLayer = pMxDoc.FocusMap.Layer(i)
pSpatialFilter.GeometryField = pLayer.FeatureClass.ShapeFieldName
Set pFeatureCursor = pLayer.Search(pSpatialFilter, True)
Set pFeature = pFeatureCursor.NextFeature
Do Until (pFeature Is Nothing)
Select Case pFeature.Shape.GeometryType
Case esriGeometryPoint
lPoints = lPoints + 1
Case esriGeometryPolyline
lPolylines = lPolylines + 1
Case esriGeometryPolygon
lPolygons = lPolygons + 1
End Select
Set pFeature = pFeatureCursor.NextFeature
Loop
End If
Next i
MsgBox "Features Found:" & vbCrLf & lPoints & " Points " & vbCrLf & _
lPolylines & " Polylines " & vbCrLf & lPolygons & " Polygons "
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Dim pEnv As IEnvelope
Dim pRubber As IRubberBand
Set pRubber = New RubberEnvelope
Dim pActiveView As IActiveView
Set pActiveView = pMxDoc.FocusMap
Set pEnv = pRubber.TrackNew(pActiveView.ScreenDisplay, Nothing)
Dim pSpatialFilter As ISpatialFilter
Set pSpatialFilter = New SpatialFilter
Set pSpatialFilter.Geometry = pEnv
pSpatialFilter.SpatialRel = esriSpatialRelIntersects
Dim lPoints As Long, lPolylines As Long, lPolygons As Long
Dim pLayer As IFeatureLayer
Dim pFeatureCursor As IFeatureCursor
Dim pFeature As IFeature
Dim i As Long
For i = 0 To pMxDoc.FocusMap.LayerCount - 1
If (TypeOf pMxDoc.FocusMap.Layer(i) Is IGeoFeatureLayer) Then
Set pLayer = pMxDoc.FocusMap.Layer(i)
pSpatialFilter.GeometryField = pLayer.FeatureClass.ShapeFieldName
Set pFeatureCursor = pLayer.Search(pSpatialFilter, True)
Set pFeature = pFeatureCursor.NextFeature
Do Until (pFeature Is Nothing)
Select Case pFeature.Shape.GeometryType
Case esriGeometryPoint
lPoints = lPoints + 1
Case esriGeometryPolyline
lPolylines = lPolylines + 1
Case esriGeometryPolygon
lPolygons = lPolygons + 1
End Select
Set pFeature = pFeatureCursor.NextFeature
Loop
End If
Next i
MsgBox "Features Found:" & vbCrLf & lPoints & " Points " & vbCrLf & _
lPolylines & " Polylines " & vbCrLf & lPolygons & " Polygons "
- VBA之框选图形个数
- 工作小记之VBA检测重叠图形
- VBA 统计文件个数
- VBA编程实例----绘制李萨茹图形
- VBA之FormulaR1C1属性
- Excel VBA 之 UBound
- VBA之excel小结
- 【办公-WORD】VBA 统计相同字符(文字)出现的个数
- ArcGIS二次开发方式之VBA
- office之vba脚本录制
- Excel+VBA+之快速上手
- VBA之Like运算符
- excel vba 之 hello world
- VBA程序解释之学习
- vba在excel中的使用之vba语句解释
- CATIA VBA二次开发(二) 快速入门之VBA IDE
- VBA组合框
- VBA消息框
- 在ARCMAP中如何将线自动闭合
- 如何求曲线上任意点到端点的距离
- 距离小于一定数值的点之间连线
- VBA之添加Shape图层
- VBA之计算选中多边形的面积
- VBA之框选图形个数
- 控制网的布设
- 在ArcGIS中如何删除重复的点要素
- WGS84和BJ54坐标转换源程序
- shp-cad互相转(带扩展属性)
- ArcGIS的检查与修复工具
- oracle中获取普通用户密码及更改
- 利用PMON清除标记为Killed的Session
- 分区表导入另一个表空间