冲亚

路人甲

注册日期2005-06-01
发帖数83
QQ
铜币389枚
威望0点
贡献值0点
银元0个

加关注写私信

阅读：13053回复：33

VBA+AO入门50例完全注释版

楼主^#

更多发布于：2005-11-15 22:07

网上下的码，自己加的注。
初学，瞎搞，不好，见笑。
和跟我一样的初学者探讨一下怎么入门最快最好，为中国GIS教育事业添一根小火柴
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.Description '显示错误数和错误信息 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
 未完待续

喜欢0 评分0

自主共进

举报回复

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

加关注写私信

1楼^#

发布于：2005-11-16 11:51

希望看到楼主继续翻译下去，<img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em02.gif" />

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

冲亚

路人甲

注册日期2005-06-01
发帖数83
QQ
铜币389枚
威望0点
贡献值0点
银元0个

加关注写私信

2楼^#

发布于：2005-11-16 22:32

上帝啊！！总统竟然光临寒舍……

<img src="images/post/smile/dvbbs/em50.gif" /><img src="images/post/smile/dvbbs/em50.gif" /><img src="images/post/smile/dvbbs/em50.gif" /><img src="images/post/smile/dvbbs/em50.gif" />

'放大/缩小 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进行。

'全图： 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

 '清除图层 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

'查找图层 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

'添加图层 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

'添加文本 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

'选择要素 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

 '监听
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
'查找图层 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

自主共进

举报回复喜欢评分

万里云

路人甲

注册日期2005-01-14
发帖数114
QQ
铜币414枚
威望0点
贡献值0点
银元0个

加关注写私信

3楼^#

发布于：2005-11-17 14:30

呵呵
翻译的这么详细，当初学的时候有这个看就好了~~~
辛苦了

女口果人尔能看日月白这段言舌，那言兑日月人尔白勺目艮目青有严重白勺散光　

举报回复喜欢评分

flycui83 路人甲注册日期2005-03-18 发帖数46 QQ 铜币247枚威望0点贡献值0点银元0个加关注写私信	4楼^# 发布于：2005-11-30 11:34 <P>对初学者应该是个好东西,想起我上半年学的时候，多辛苦哦！</P>
	举报回复(0) 喜欢(0) 评分

balava 路人甲注册日期2005-11-29 发帖数2 QQ 铜币111枚威望0点贡献值0点银元0个加关注写私信	5楼^# 发布于：2005-11-30 11:44 顶
	举报回复(0) 喜欢(0) 评分

xhy874 路人甲注册日期2004-07-06 发帖数17 QQ 铜币110枚威望0点贡献值0点银元0个加关注写私信	6楼^# 发布于：2005-12-17 12:02 希望看到楼主继续翻译下去<img src="images/post/smile/dvbbs/em02.gif" />
	举报回复(0) 喜欢(0) 评分

c_mulder 路人甲注册日期2005-12-23 发帖数42 QQ 铜币216枚威望0点贡献值0点银元0个加关注写私信	7楼^# 发布于：2005-12-25 14:57 <P>可是我对 Document 的添加怎么做</P>
	举报回复(0) 喜欢(0) 评分

lxmzjy 路人甲注册日期2005-03-28 发帖数8 QQ 铜币123枚威望0点贡献值0点银元0个加关注写私信	8楼^# 发布于：2006-01-06 14:01 <P>顶</P>
	举报回复(0) 喜欢(0) 评分

tree 路人甲注册日期2005-01-28 发帖数28 QQ 铜币287枚威望0点贡献值0点银元0个加关注写私信	9楼^# 发布于：2006-01-09 20:59 <P>谢谢楼主，偶正在学习！</P><img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em02.gif" />
	举报回复(0) 喜欢(0) 评分

您需要登录后才可以回帖，登录或者注册

VBA+AO入门50例完全注释版

最新喜欢：