【C008】ArcGIS VBA+AO入门15例
1.
Sub MyMacro()
Dim pMxDocument As IMxDocument '地图文档
Set pMxDocument = Application.Document '获取当前应用程序的文档
MsgBox pMxDocument.FocusMap.name '显示当前地图的名称
End Sub
2.
Sub MyMacro()
Dim pMxDocument As IMxDocument '地图文档
Dim pMaps As IMaps '地图集
Dim pMap As IMap '地图
Set pMxDocument = Application.Document '获取当前应用程序的文档
Set pMaps = pMxDocument.Maps '获取当前地图文档的地图集
If pMaps.Count > 1 Then '如果该地图集的地图数大于1
Set pMap = pMaps.Item(1) '获取该地图集中的第一幅地图
MsgBox pMap.name '显示该地图的名称
End If
End Sub
3.
Sub MyMacro()
Dim pMxDocument As IMxDocument '地图文档
Dim pMap As IMap '地图
Dim lCount As Long
Dim lIndex As Long
Set pMxDocument = Application.Document '获取当前应用程序的文档
Set pMap = pMxDocument.FocusMap '获取当前地图
lCount = 0
For lIndex = 0 To (pMap.LayerCount - 1)
If TypeOf pMap.Layer(lIndex) Is IFeatureLayer Then '如果当前地图的第lIndex层的类型是IFeatureLayer
lCount = lCount + 1 '计数器加1
End If
Next lIndex
MsgBox "Number of the feature layers " & _
"in the active map: " & lCount '显示当前地图的要素层的总数
End Sub
4.
Sub MyMacro()
Dim pMxDocument As IMxDocument '获取当前应用程序的文档
Dim pMaps As IMaps '地图集
Dim pMap As IMap '地图
On Error GoTo SUB_ERROR '错误处理
Set pMxDocument = Application.Document '获取当前应用程序的文档
Set pMaps = pMxDocument.Maps '获取当前地图文档的地图集
Set pMap = pMaps.Item(1) '获取该地图集中的第一幅地图
MsgBox pMap.name '显示该地图的名称
Exit Sub
SUB_ERROR: '行标签
MsgBox "Error: " & Err.Number & "-" & Err.Descripttion '显示错误数和错误信息
End Sub
5.
'是图层可视
Public Sub MakeLayerVisible()
Dim pMxDocument As IMxDocument '地图文档
Dim pMap As IMap '地图
Dim pFeatureLayer As IFeatureLayer '要素层
Dim pActiveView As IActiveView '活动视图
Dim pContentsView As IContentsView '窗口内容表
'获取地图的第一层
Set pMxDocument = ThisDocument '获取当前应用程序的文档
Set pMap = pMxDocument.FocusMap '获取当前地图
Set pFeatureLayer = pMap.Layer(0) '获取当前地图的第一层
'如果要素层不可见，则使其可见
If Not pFeatureLayer.Visible Then
pFeatureLayer.Visible = True
End If
'刷新地图
Set pActiveView = pMap '将当前地图设为活动地图
pActiveView.Refresh '刷新
'刷新窗口内容表
Set pContentsView = pMxDocument.CurrentContentsView '获取当前地图文档的窗口内容表
pContentsView.Refresh pFeatureLayer '刷新
End Sub
6.
'按NAME查询要素
Private Function GetCountyFeature(pFeatureLayer As IFeatureLayer, strCountyName As String) As IFeature
'查找要素类
Dim pFeatureClass As IFeatureClass '要素类
Dim pQueryFilter As IQueryFilter '查询过滤器
Dim pFeatureCursor As IFeatureCursor
Set pFeatureClass = pFeatureLayer.FeatureClass '从要素层获取要素类
Set pQueryFilter = New QueryFilter '创建一个新的查询过滤器
pQueryFilter.WhereClause = "NAME = '" & strCountyName & "'" '按郡名查找
Set pFeatureCursor = pFeatureClass.Search(pQueryFilter, False) '获取查询到的要素对象
'获取要素
Dim pFeature As IFeature '要素
Set pFeature = pFeatureCursor.NextFeature '获取查询结果的下一个要素
If pFeature Is Nothing Then '如果该要素不存在
Set GetCountyFeature = Nothing '返回值设为空
Else
Set GetCountyFeature = pFeature '将该要素设为返回值
End If
End Function
7.
'放大/缩小
Sub MyZoom()
Dim pDoc As IMxDocument '地图文档
Dim pActiveView As IActiveView '活动地图
Dim pEnv As IEnvelope '显示范围
Set pDoc = Application.Document '获取当前文档，等同于ThisDoucument
Set pActiveView = pDoc.activeView '获取当前活动地图
Set pEnv = pActiveView.Extent '获取当前显示范围
pEnv.Expand 0.5, 0.5, True '按比例放大两倍，把0.5改为2则为缩小一半
pActiveView.Extent = pEnv '更新显示范围
pActiveView.Refresh '刷新
End Sub
MxApplication代表ArcMap本身，只管理一个文档MxDocument（ArcMap是单文档界面）。MxDocument管理一组Map对象和一个PageLayout对象。在数据视图下，ActiveView是一个Map；而在页面视图下，ActiveView是PageLayout。无论在何种视图下，总是只有一个FocusMap，显示操作都是对ActiveView进行。
8.
'全图：
Sub FullExtentPlus()
Dim pDoc As IMxDocument '地图文档
Dim pActiveView As IActiveView '活动地图
Set pDoc = Application.Document '获取当前地图文档
Set pActiveView = pDoc.activeView '获取当前活动地图
pActiveView.Extent = pDoc.activeView.FullExtent '全图显示
pActiveView.Refresh '刷新当前视图
End Sub
9.
'清除图层
Private Sub ClearLayers()
Dim pDoc As IMxDocument '地图文档
Dim pActiveView As IActiveView '活动地图
Dim pMap As IMap '地图
Set pDoc = Application.Document '获取当前地图文档
Set pActiveView = pDoc.activeView '获取当前活动地图
If TypeOf pActiveView Is IMap Then '如果当前活动地图为数据视图模式
Set pMap = pActiveView '获取当前地图
pMap.ClearLayers '清除所有图层
pDoc.UpdateContents '更新窗口内容表
pActiveView.Refresh '刷新
End If
End Sub
10.
'查找图层
Function FindLayer(map As IMap, name As String) As ILayer
Dim i As Integer
For i = 0 To map.LayerCount - 1 '第一层的索引为1
If map.Layer(i).name = name Then '如果第i层的名称为name
Set FindLayer = map.Layer(i) '获取并返回该层
Exit Function
End If
Next
End Function
11.
'添加图层
Sub AddLayer()
Dim wksFact As IWorkspaceFactory '工作空间管理器
Dim wks As IFeatureWorkspace '要素工作空间
Dim fc As IFeatureClass '要素类
Dim lyr As IFeatureLayer '要素层
Dim ds As IDataset '数据集
Dim mxDoc As IMxDocument '地图文档
Dim map As IMap '地图
Set wksFact = New ShapefileWorkspaceFactory '创建Shape工作空间管理器
Set wks = wksFact.OpenFromFile(“c:\Data\shp”, 0) '获取工作空间
Set fc = wks.OpenFeatureClass(“BigCypress”) '获取要素类
Set lyr = New FeatureLayer '创建要素层
Set lyr.FeatureClass = fc '向要素层中添加要素类
Set ds = fc '获取数据集
lyr.name = ds.name '用要素类的名称命名要素层
Set pDoc = Application.Document '获取当前地图文档
Set mxmap = mxDoc.FocusMap '获取当前地图
map.AddLayer lyr '添加图层
End Sub
12.
'添加文本
Private Sub Hello()
Dim pDoc As IMxDocument '地图文档
Dim pActiveView As IActiveView '活动地图
Dim sym As ITextSymbol '文本符号
Dim bnds As IArea '面
Set pDoc = Application.Document '获取当前地图文档
Set pActiveView = pDoc.activeView '获取当前活动地图
Set sym = New TextSymbol '创建文本符号
sym.Font.size = 18 '设置字体大小
With pActiveView.ScreenDisplay '对显示屏操作
Set bnds = .DisplayTransformation.VisibleBounds '获取可视范围
.StartDrawing .hDC, esriNoScreenCache
.SetSymbol sym '设置要绘制的符号
.DrawText bnds.Centroid, "Hello" '添加文本
.FinishDrawing '完成绘制
End With
End Sub
13.
'选择要素
Sub SelectFeatures()
Dim mxDoc As IMxDocument '地图文档
Dim lyr As IFeatureLayer '要素层
Dim sel As IFeatureSelection '选择集
Dim filter As IQueryFilter '查询过滤器
Dim selEvents As ISelectionEvents '？？？
Set mxDoc = Application.Document '获取当前地图文档
Set lyr = FindLayer(mxDoc.FocusMap, "BUILDING") '调用FindLayer函数查找图层
Set sel = lyr '将找到的图层设为选择集
Set filter = New QueryFilter '创建查询过滤器
filter.WhereClause = "BDNAME ='实验楼A'" '设置where子句
sel.SelectFeatures filter, esriSelectionResultNew, False '选中满足条件的要素
mxDoc.activeView.PartialRefresh esriViewGeoSelection, Nothing, Nothing '绘出选中的要素
Set selEvents = mxDoc.FocusMap '？？？
selEvents.SelectionChanged '通知系统选择已经改变了
End Sub
14.
'监听
Dim WithEvents g_Map As map
Private Sub UIButtonControl1_Click()
Dim mxDoc As IMxDocument '地图文档
Dim lyr As IFeatureLayer '要素层
Dim sel As IFeatureSelection '选择集
Dim filter As IQueryFilter '查询过滤器
Dim selEvents As ISelectionEvents '？？？
Set g_Map = mxDoc.FocusMap '获取当前地图
Set mxDoc = Application.Document '获取当前地图文档
Set lyr = FindLayer(mxDoc.FocusMap, "BUILDING") '调用FindLayer函数查找图层
Set sel = lyr '将找到的图层设为选择集
Set filter = New QueryFilter '创建查询过滤器
filter.WhereClause = "BDNAME ='实验楼A'" '设置where子句
sel.SelectFeatures filter, esriSelectionResultNew, False '选中满足条件的要素
mxDoc.activeView.PartialRefresh esriViewGeoSelection, Nothing, Nothing '绘出选中的要素
Set selEvents = mxDoc.FocusMap '？？？
selEvents.SelectionChanged '通知系统选择已经改变了
End Sub
15.
'查找图层
Function FindLayer(map As IMap, name As String) As ILayer
Dim i As Integer
For i = 0 To map.LayerCount - 1 '第一层的索引为1
If map.Layer(i).name = name Then '如果第i层的名称为name
Set FindLayer = map.Layer(i) '获取并返回该层
Exit Function
End If
Next
End Function
Private Sub g_Map_SelectionChanged()
Dim activeView As IActiveView '活动地图
Dim featureEnum As IEnumFeature '列举的要素？
Dim feat As IFeature '要素
Dim index As Long
Dim Msg As String
Set activeView = g_Map '获取当前地图
Set featureEnum = activeView.Selection '列举所选的要素
featureEnum.Reset '还原至初始顺序
Set feat = featureEnum.Next '获取选择集中第一个要素
Do While Not feat Is Nothing '如果要素存在
index = feat.Fields.FindField(“Name”) '获取Name字段的索引值
If index <> -1 Then MsgBox Msg & Chr(13) & Chr(10) & feat.Value(index) '显示该要素的Name
Set feat = featureEnum.Next '移至选择集中的下一个要素
Loop
End Sub
来源：http://www.cnblogs.com/atravellers/archive/2010/01/13/1646606.html
