默认头像
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15951
  • QQ
  • 铜币25345枚
  • 威望15368点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
阅读:57637回复:116

[帝国首发]ArcGIS开发教材,0830更新,提问前请先看

楼主#
更多 发布于:2005-07-26 10:42

还没有更新完毕,请大家不要在这里回帖,谢谢!:)

如何在ArcMap的VBA环境中编程

ArcMap是ArcGIS家族的成员之一,它内置了一种集成编程环境―VBA(Visaul Basic for Apllications)。通过VBA编程,用户不但可以扩展ArcMap的菜单、工具条等,而且可以完成大多数用户的特定需求。
   ArcMap中VBA编程的方法有两种,一种是写VBA宏,另一种是创建UIControl并在其事件中写入实现用户需求的代码。下面列出两种方法的一般步骤。
   方法一:写VBA宏(直接在VBA编辑器中编辑函数和过程)
   1、如图1,单击菜单栏中的命令,选择项, 直接启动ArcMap的VBA编辑器;或者选择项,进入如图2所示Macro对话框,在“Macro Name”文本框中输入要创建的宏的名称,并点按钮,启动VBA编辑器。


图1 启动Macro对话框/启动VBA编辑器


图2 Macro对话框
  2、在图3所示的窗口中,用户可以根据实际选择在Normal节点或者Project节点的ThisDocument、Forms、Modules中编写宏(函数或过程),Normal节点下所写的宏系统自动保存,除非用户删除,否则它将始终存在并在任何工程中都有效;而在Project节点下所写得宏随工程保存(如不保存工程,则宏也将不被保存),并中有效。

图3 VBA编辑器(VBE)

   3、运行VBA宏
   在VBA编辑器中写好VBA代码后,有两种方式运行:第一,点击VBA编辑器工具条中的 (运行)按钮,可立即运行写好的代码;第二,退出VBA编辑器,重新启动Macro对话框,如图2,选择要运行的VBA宏名称,点击按钮即可运行相应的VBA宏。
   方法二:创建UIControl(交互式VBA编程)
    1、用鼠标右击任何工具栏(条),在弹出的上托式菜单中选择菜单项,如图4,进入图5所示的Customize对话框。

图4 启动“Customize”对话框

   2、切换到“Customize”对话框的“Commands”页,选中“UIControls”后点击按钮,进入图6所示的“New UIControl”对话框。
   3、在“New UIControl”对话框中,用户可根据需要选择UIControl类型:
   UIButtonControl:创建Button;
   UIToolControl:创建与Map交互的Tool;
   UIEditBoxControl:创建EditBox;
   UIComboBoxControl:创建ComboBox。
   最后点击按钮只创建UIControl或者点击按钮创建UIControl并进入VBA编辑器。与方法一不同,此时应在UIControl的事件中进行VBA编程。



图5 Customize对话框

图6 New UIControl对话框

   4、UIControl创建后,在图5所示的“Customize”对话框选中UIControl并将其拖置到任意工具条上,用户便可象使用系统已有的Control一样使用所创建的UIControl。

[此贴子已经被作者于2005-8-30 15:10:07编辑过]
喜欢0 评分0
GIS麦田守望者,期待与您交流。
默认头像
路人甲
路人甲
  • 注册日期2008-05-19
  • 发帖数26
  • QQ
  • 铜币146枚
  • 威望0点
  • 贡献值0点
  • 银元0个
1楼#
发布于:2008-10-31 15:43
你好历害啊,佩服
举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2007-05-16
  • 发帖数14
  • QQ
  • 铜币21枚
  • 威望0点
  • 贡献值0点
  • 银元0个
2楼#
发布于:2008-10-04 15:58
我顶
举报 回复(0) 喜欢(0)     评分
默认头像
外卖仔
外卖仔
  • 注册日期2007-07-11
  • 发帖数42
  • QQ
  • 铜币221枚
  • 威望2点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
3楼#
发布于:2008-09-25 17:17
举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2007-02-25
  • 发帖数13
  • QQ
  • 铜币158枚
  • 威望0点
  • 贡献值0点
  • 银元0个
4楼#
发布于:2008-08-27 10:17

是相当不错,老大能不能再提供点vb.net开发的东西。

举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2007-06-05
  • 发帖数16
  • QQ
  • 铜币145枚
  • 威望0点
  • 贡献值0点
  • 银元0个
5楼#
发布于:2008-06-23 16:23

我有PDF文件,谁要的话联系我吧。

(不会上传)

QQ:280246507

举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2007-06-05
  • 发帖数16
  • QQ
  • 铜币145枚
  • 威望0点
  • 贡献值0点
  • 银元0个
6楼#
发布于:2008-06-23 16:20

如何将Multipoint转换成Points
本例要实现的功能是根据一个FeatureLayer中被选择一个或多个

MultiPoint,生成多个Point并把这些新生成的Point保存在一个Point类型的
Feature Layer上。
●要点
本例将选择的Multipoints上的每个点都生成一个对应得Point,并用一个

接口IPointCollection的变量来接收。利用IPointCollection的方法
point(index),取出新生成的每个点,用来创建Point类型的Feature。
●程序说明

本例要求在ArcMap中添加两个层,最上面的是层Multipoint,下面是层
wind。根据循环得到选择的每个Multipoint的每个点,为wind层生成新的
Feature并保存
●代码
Sub convertMultipointToPoints()
Dim pMxDocument As IMxDocument
Dim pMap As IMap
Dim pActiveView As IActiveView
Dim pEnumFeature As IEnumFeature
Dim pFeature0 As IFeature
Dim pFeatureLayer0 As IFeatureLayer
Dim pFeatureClass0 As IFeatureClass
Dim pFeature1 As IFeature
Dim pFeatureLayer1 As IFeatureLayer
Dim pFeatureClass1 As IFeatureClass
Dim pPointCollection As IPointCollection
Dim pDataSet As IDataset
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pWorkspaceEdit As IWorkspaceEdit
Dim lPointIndex As Long
Dim lPointFieldIndex As Long
On Error GoTo ErrorHanlder

'得到当前层
Set pMxDocument = ThisDocument
Set pMap = pMxDocument.FocusMap
Set pActiveView = pMap

'得到0层和1层的FeatureClass

Set pFeatureLayer0 = pMxDocument.FocusMap.Layer(0)
Set pFeatureClass0 = pFeatureLayer0.FeatureClass
Set pFeatureLayer1 = pMxDocument.FocusMap.Layer(1)
Set pFeatureClass1 = pFeatureLayer1.FeatureClass

'建立编辑工作区
Set pDataSet = pFeatureClass1
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pWorkspaceEdit = pWorkspaceFactory.OpenFromFile(pDataSet.Workspace.PathName,0)
pWorkspaceEdit.StartEditOperation
pWorkspaceEdit.StartEditing True

'得到Feature
Set pEnumFeature = pMxDocument.FocusMap.FeatureSelection
Set pFeature0 = pEnumFeature.Next
If pFeature0 Is Nothing Then
MsgBox "Must have Select in Position 0"
Exit Sub
End If

'循环,通过每个MultiPoint,在1图层上,生成以每个点为特征的Points
While Not pFeature0 Is Nothing
If pFeature0.ShapeCopy.GeometryType = esriGeometryMultipoint Then
Set pPointCollection = pFeature0.ShapeCopy
For nPointIndex = 0 To pPointCollection.PointCount - 1
Set pFeature1 = pFeatureClass1.CreateFeature

'在pFeature1上生成Point
Set pFeature1.Shape = pPointCollection.Point(nPointIndex)
'如果两Feature的FieldCount相同,赋每个Field的值,ID,

'TypeGeometry的Field除外
If pFeature1.Fields.FieldCount = pFeature0.Fields.FieldCount Then
For lPointFieldIndex = 0 To pFeature1.Fields.FieldCount - 1
If Not pFeature1.Fields.Field(lPointFieldIndex).Type = _

esriFieldTypeGeometry And Not pFeature1.Fields. _
Field(lPointFieldIndex).Type = esriFieldTypeOID Then
pFeature1.Value(lPointFieldIndex) = _

pFeature0.Value(lPointFieldIndex)
End If
Next
End If
'保存Feature

pFeature1.Store
Next
Else
MsgBox "Must have Multipoint in position 0"
Exit Sub
End If
Set pFeature0 = pEnumFeature.Next
Wend

'停止编辑
pWorkspaceEdit.StopEditOperation
pWorkspaceEdit.StopEditing True
Exit Sub

ErrorHanlder:
pWorkspaceEdit. AbortEditOperation

MsgBox Err.Description
End Sub

举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2007-06-05
  • 发帖数16
  • QQ
  • 铜币145枚
  • 威望0点
  • 贡献值0点
  • 银元0个
7楼#
发布于:2008-06-23 16:14

如何将选中的点集转换成Polygon

本例要实现的功能是根据选中的Points创建一个Polygon,并且保存到Polygon类型的FeatureLayer中,要求被选择的Points最少为3个。
要点
   根据选择的点创建一个Polygon,首先要判断生成的Polygon是否是Simple,这里用到接口ITopologicalOperator2的属性IsSimple。如果不是,则要对做Polygon排序等处理。此外还用到了接口IPointCollection的方法ReplacePoints,进行点的交换。将排好序的点,按顺序创建Segment,运用实例化为Ring的ISegmentCollection接口方法AddSegment增加Segment。实例化为Polygon的IGeometryCollection接口方法AddGeometry增加Ring。这样,通过上面的方法便可以创建Polygon。

●程序说明

根据接口ITopologicalOperator2.IsSimple属性判断Polygon是否Simple。如果返回为False,就对Polygon上的点进行排序等处理,排好序后,找出X方向上值最大和最小的点,由这两点创建一条直线,将所有点分成在直线左边和右边两部分。
●代码
Public Sub ConvertPointToPolygon()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pEnumFeature As IEnumFeature
Dim pMultiPoint As IPointCollection
Dim pMultiPointSorted As IPointCollection
Dim pFeature As IFeature
Dim pPointi As IPoint
Dim pTopoOp As ITopologicalOperator2
Dim pLine As ILine
Dim pGonColl As IPointCollection
Dim pClonei As IClone
Dim ptMin As IPoint
Dim ptMax As IPoint
Dim pBaseLine As ILine
Dim pBaseCurve As ICurve
Dim pOutpoint As IPoint
Dim pMultiRight As IPointCollection
Dim pMultiLeft As IPointCollection
Dim pGonColl2 As IGeometryCollection
Dim pPolygon As IPolygon
Dim pRing As IRing
Dim pFeatureClass As IFeatureClass
Dim pFeatureLayer As IfeatureLayer
Dim pFeature1 As IFeature
Dim pFeatureClass1 As IFeatureClass
Dim pFeatureLayer1 As IFeatureLayer
Dim pDataSet As IDataset
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pWorkspaceEdit As IWorkspaceEdit

Dim pRingColl As ISegmentCollection
Dim dDistAlong As Double
Dim dDistFrom As Double
Dim bIsRight As Boolean
Dim i As Long
Dim j As Long
Dim lFlag As Long
On Error GoTo errorHander
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Set pActiveView = pMap
Set pFeatureLayer = pMap.Layer(0)
Set pFeatureClass = pFeatureLayer.FeatureClass

'创建一个工作区,开始编辑
Set pDataSet = pFeatureClass
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pWorkspaceEdit = pWorkspaceFactory.OpenFromFile(pDataSet.Workspace.PathName, 0)
pWorkspaceEdit.StartEditOperation
pWorkspaceEdit.StartEditing True

Set pMultiLeft = New Multipoint
Set pMultiRight = New Multipoint
Set pGonColl = New Polygon
Set pMultiPoint = New Multipoint
Set pMultiPointSorted = New Multipoint

'得到所选择的图形集
Set pEnumFeature = pMxDoc.FocusMap.FeatureSelection
Set pFeature = pEnumFeature.Next
'增加点到MultiPoint
While Not pFeature Is Nothing
If pFeature.ShapeCopy.GeometryType = esriGeometryPoint Then
pMultiPoint.AddPoint pFeature.ShapeCopy
ElseIf pFeature.ShapeCopy.GeometryType = esriGeometryMultipoint Then
pMultiPoint.AddPointCollection pFeature.ShapeCopy
End If
Set pFeature = pEnumFeature.Next
Wend
If pMultiPoint.PointCount < 3 Then
MsgBox "Select a least 3 points !"
Exit Sub

End If
'创建第一个Polygon
pGonColl.AddPointCollection pMultiPoint
Set pTopoOp = pGonColl
'
将Polygon是否是Simple设置成未知
pTopoOp.IsKnownSimple = False

'经判断,如果不是Simple,则经过以下处理,将其转换为Simple
If pTopoOp.IsSimple = False and pMultiPoint.PointCount>3 Then
lFlag = 1
Set pTopoOp = pMultiPoint
pTopoOp.IsKnownSimple = False
pTopoOp.Simplify

'将Multipoint进行排序
For i = 0 To pMultiPoint.PointCount - 1
For j = i + 1 To pMultiPoint.PointCount - 1
If pMultiPoint.Point(j).x < pMultiPoint.Point(i).x Or pMultiPoint.Point(j).x = _

pMultiPoint.Point(i).x And_ pMultiPoint.Point(j).y <
pMultiPoint.Point(i).y Then

Set pClonei = pMultiPoint.Point(i)
Set pPointi = pClonei.Clone

'交换两点
pMultiPoint.ReplacePoints i, 1, 1, pMultiPoint.Point(j)
pMultiPoint.ReplacePoints j, 1, 1, pPointi
End If
Next

Next
Set ptMin = New Point
Set ptMax = New Point

'找出MultiPoint中的最大和最小点
pMultiPoint.QueryPoint 0, ptMin
pMultiPoint.QueryPoint pMultiPoint.PointCount - 1, ptMax

'创建一条线段
Set pBaseLine = New Line

pBaseLine.PutCoords ptMin, ptMax
Set pBaseCurve = pBaseLine
For i = 0 To pMultiPoint.PointCount - 1
Set pOutpoint = New Point
pBaseCurve.QueryPointAndDistance esriNoExtension, pMultiPoint.Point(i), False,

pOutpoint, _ dDistAlong, dDistFrom, bIsRight
If bIsRight Then
pMultiRight.AddPoint pMultiPoint.Point(i)
Else
pMultiLeft.AddPoint pMultiPoint.Point(i)
End If
Next
Set pRingColl = New Ring

'将左边的线添加到Ring
For i = 0 To pMultiLeft.PointCount - 2
Set pLine = New Line
pLine.PutCoords pMultiLeft.Point(i), pMultiLeft.Point(i + 1)
pRingColl.AddSegment pLine
Next

'第一条线
Set pLine = New Line
pLine.PutCoords pMultiLeft.Point(pMultiLeft.PointCount - 1), pMultiRight.Point(0)
pRingColl.AddSegment pLine

'将右边的先添加到Ring
For i = (pMultiRight.PointCount - 1) To 1 Step -1
Set pLine = New Line
pLine.PutCoords pMultiRight.Point(i), pMultiRight.Point(i - 1)
pRingColl.AddSegment pLine
Next

'最后一条线
Set pLine = New Line
pLine.PutCoords pMultiRight.Point(0), pMultiLeft.Point(0)
pRingColl.AddSegment pLine
Set pRing = pRingColl
pRing.Close
Set pGonColl2 = New Polygon
pGonColl2.AddGeometry pRing
End If
If lFlag = 0 Then
Set pPolygon = pGonColl
Else
Set pPolygon = pGonColl2 'QI
End If
'画出Polygon
Set pFeatureLayer1 = pMap.Layer(1)
Set pFeatureClass1 = pFeatureLayer1.FeatureClass
Set pFeature1 = pFeatureClass1.CreateFeature

'把画的Polygon加到新建的Feature上
Set pFeature1.Shape = pPolygon
'保存Feature
pFeature1.Store
pMxDoc.ActiveView.Refresh

'停止编辑
pWorkspaceEdit.StopEditOperation
pWorkspaceEdit.StopEditing True

Exit Sub
ErrorHander:
pWorkspaceEdit.AbortEditOperation
MsgBox Err.Description
End Sub



举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2007-06-05
  • 发帖数16
  • QQ
  • 铜币145枚
  • 威望0点
  • 贡献值0点
  • 银元0个
8楼#
发布于:2008-06-23 15:33
总统太辛苦了
举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2005-03-14
  • 发帖数5
  • QQ
  • 铜币132枚
  • 威望0点
  • 贡献值0点
  • 银元0个
9楼#
发布于:2008-06-02 21:10
举报 回复(0) 喜欢(0)     评分
上一页
默认头像

返回顶部