ArcGIS教材

Transcription

1 基础篇 开发环境 如何在 ArcMap 的 VBA 环境中编程 如何在 VB 环境中利用 ArcObjects 组件开发 ActiveX DLL 如何在 ArcMap 中加载利用 ArcObjects 组件开发的 ActiveX DLL 如何在 VB 环境中利用 ArcObjects 控件开发 EXE 用户界面 如何创建定制的按钮 (Button) 如何创建定制的 Tool 如何创建定制的工具条 (Tool Bar) 如何创建定制的 MultiItem 如何创建定制的菜单 (Menu) 如何创建定制的 ToolControl 如何创建定 使用制的可停靠窗口 (Dockable Window) 如何创建 使用定制的 Extension 如何使用状态条 (StatusBar) 与进度条 (ProgressBar) 如何使用 ArcGIS 的对话框 如何调用 ArcMap 中现有的功能 如何创建放大镜 ( 虫眼 ) GeoDataBase 如何加载 Shape 文件 如何在 ArcMap 中加入 Text 和 dbase 文件 如何连接 GeoDataBase 文件 如何连接 Coverage 文件 如何连接栅格文件 如何创建 Shape 文件 如何创建 DBF 文件 如何创建 GeoDataBase 文件 如何创建 Coverage 文件 如何建立文件连接 (Join / Link)

2 如何浏览纪录 ( 属性查询 ) 如何编辑记录 如何增加记录 如何删除记录 如何纪录排序 (ITableSort) 如何添加字段 如何删除字段 如何进行空间查询 如何进行高级空间查询 ( 两个层之间的空间查询 ) 如何进行层与层之间的逻辑运算 如何将 shape 文件转化成 GeoDataBase( 各种文件格式的转换 ) 如何将 Map 中显示的图形转化成栅格文件 如何打开选中的层或独立表的属性窗口 如何拷贝属性表中的一行 如何为当前层或独立表创建一个 Summary 表 如何利用用户定义的规则创建定制的排序 如何实现在 ArcMap 上进行属性查询 (Identify) 如何设置和修改层的数据源 Display 如何实现在 ArcMap 中放大缩小地图 如何实现在 ArcMap 中移动地图 如何实现在 ArcMap 上画 Polygon 如何实现在 ArcMap 上进行测量 如何实现在 ArcMap 上选取中记录 如何实现在 ArcMap 中进行动作的撤销和重做 如何画 Polygon Buffers 图元编辑 如何得到图形的基本属性 如何将选中的点集转换成 Polygon 如何将 Multipoint 转换成 Points

3 如何通过 Polygon 中的多个 Ring 创建多个 Polygon 如何从 Polyline 创建 Polygon 如何从 Polygon 创建 Polyline 如何将 Polygon/PolyCurve 一般化 (Generalize) 如何获得 Polygon 的中点 如何判断图形间的逻辑运算 如何进行图形间的逻辑运算 如何创建 Envelope 的 Boundary 如何通过鼠标移动图形 如何为一个图形添加一个顶点 如何删除一个图形上的一个顶点 如何移动一个图形上的一个顶点 Element 如何创建 MarkerElement 如何创建 TextElement 如何创建 Balloon Callout 如何创建 PolygonElement 如何选中一个 Element 如何移动 Element 如何排列 Element 如何通过名字查询 Element 如何拷贝 Element 如何沿着折线路径显示 Text Symbol 和 Renderer 如何为一个层设置 Simple Renderer 如何为一个层设置 UniqueValue Renderer 如何为一个层设置 ClassBreaks Renderer 如何为一个层设置 ProportionalSymbol Renderer 如何为一个层设置 Chart Renderer 如何为一个层设置 DotDensity Renderer

4 1.8. Layout 和打印 如何在 Page Layout 上添加 Text 如何在 Page Layout 上添加 Legend 如何在 Page Layout 上添加 North Arrow 如何在 Page Layout 上添加 Scale bar 如何在 Page Layout 上添加 Scale Text 如何在 Page Layout 上添加 Picture 如何创建 删除地图网格 (Map Grid) 如何设置 Layout 中 MapFrame 的外观风格属性 何设置 Layout 中 Page 的边框 (Border) 和背景 (Background) 如何设置打印纸张的大小和方向 坐标系统 如何在 ArcMap 中设置地理坐标系和投影坐标系 如何修改层的坐标系统 如何把 Polygon 的顶点从经纬度坐标转换到平面直角坐标 ArcGis 相关文件 如何夹载 grf 文件 如何新建指向 Shape 文件的 lyr 文件 如何新建指向 GeoDataBase 文件的 lyr 文件 如何加载 mxd 文件 如何加载 Apr 文件 (ArcView32) 如何加载 lyr 文件 lyr 文件的属性的设置 其他 如何创建简单的 Column Chart 如何将数据输出到 Excel 如何把 Labels 转换为 Annotation 如何把 Annotation 转换为 Polygon Features 如何设置 Featurelayer 的 Label 如何设置图层显示的透明度

5 如何过滤层中要显示的 Features 如何在 MapControl 中新建一个 Document 并且保存 提高篇 缩略图的实现 FeatureLayer 显示 Symbol 的定制 空间查询的综合应用 图形编辑的综合应用 グラフの重ね合わせ表示と印刷 バッファ処理 Voronio 作成 数据处理加速 地图分块处理 MapControl 的使用 运用 PageLayout 控件打印图形 附录 ArcGIS 的 GUID 一览表

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

7 图 2 Macro 对话框 2 在图 3 所示的窗口中, 用户可以根据实际选择在 Normal 节点或者 Project 节点的 ThisDocument Forms Modules 中编写宏 ( 函数或过程 ),Normal 节点下所写的宏系统自动保存, 除非用户删除, 否则它将始终存在并在任何工程中都有效 ; 而在 Project 节点下所写得宏随工程保存 ( 如不保存工程, 则宏也将不被保存 ), 并只在工程中有效 图 3 VBA 编辑器 (VBE) 3 运行 VBA 宏在 VBA 编辑器中写好 VBA 代码后, 有两种方式运行 : 第一, 点击 VBA 编辑器工具条中的 ( 运行 ) 按钮, 可立即运行写好的代码 ; 第二, 退出 VBA 7

8 编辑器, 重新启动 Macro 对话框, 如图 2, 选择要运行的 VBA 宏名称, 点击 <Run> 按钮即可运行相应的 VBA 宏 方法二 : 创建 UIControl( 交互式 VBA 编程 ) 1 用鼠标右击任何工具栏( 条 ), 在弹出的上托式菜单中选择 <Customize> 菜单项, 如图 4, 进入图 5 所示的 Customize 对话框 图 4 启动 Customize 对话框 2 切换到 Customize 对话框的 Commands 页, 选中 UIControls 后点击 <New UIControl> 按钮, 进入图 6 所示的 New UIControl 对话框 3 在 New UIControl 对话框中, 用户可根据需要选择 UIControl 类型 : UIButtonControl: 创建 Button; UIToolControl: 创建与 Map 交互的 Tool; UIEditBoxControl: 创建 EditBox; UIComboBoxControl: 创建 ComboBox 最后点击 <Create> 按钮只创建 UIControl 或者点击 <Create and Edit> 按钮创建 UIControl 并进入 VBA 编辑器 与方法一不同, 此时应在 UIControl 的事件中进行 VBA 编程 8

9 图 5 Customize 对话框 图 6 New UIControl 对话框 4 UIControl 创建后, 在图 5 所示的 Customize 对话框选中 UIControl 并将其拖置到任意工具条上, 用户便可象使用系统已有的 Control 一样使用所创建的 UIControl 如何在 VB 环境中利用 ArcObjects 组件开发 ActiveX DLL 节讨论了如何在 ArcGis 的 VBA 环境中编程, 虽然通过这种方式可以完成大多数用户的定制需求, 但是, 在某些情况下, 对于特殊的应用, 用户需要脱离 ArcGIS 环境而在 VB 开发环境中开发外部独立的应用程序, 这种外部独立的应用程序有两种形式 : ActiveX DLL 和 Standard EXE Standard EXE 的开发将在 中讨论, 本节将讨论 ActiveX DLL 的开发, 其关键是引用 ArcObjects 对象库和实现 ArcObjects 接口 ( 例如 ICommand,ITool,IToolBar 等 ) 下面介绍在 VB 环境利用 ArcObjects 组件开发 ActiveX DLL 的一般步骤 1 启动 VB 开发环境, 在图 7 所示的 New Project 对话框中选择 ActiveX 9

10 DLL 项, 并点击 < 打开 > 按钮, 进入 VBE 环境 图 7 New Project 对话框 2 引用 ArcObjects 对象库 : 首先点击 <Project> 菜单中的 <References> 项, 如图 8, 进入对象库引用对话框, 如图 9 10

11 图 8 启动对象库引用对话框 图 9 对象库引用对话框 3 对象库引用对话框( 图 9) 中选中 Esri ArcMap Object Library 和 Esri Object Library 两项, 并点击 <OK> 按钮, 返回 VBE 环境 4 一般在类模块中写入实现特定 ArcObjects 接口的代码, 如图 10, 然后 11

12 运行 <File> 菜单中的 <Make project1.dll> 项, 生成 DLL 文件, 如图 11 ( project1.dll 随项目名改变 ) 图 10 类模块编辑窗口 图 11 生成 DLL 文件 如何在 ArcMap 中加载利用 ArcObjects 组件开发的 ActiveX DLL 用户通过 中介绍的方法开发好一个 ActiveX DLL 程序后, 便可根据实际需要, 在 ArcMap 环境下加载这个 ActiveX DLL 程序 其一般步骤如下 : 1 用鼠标右击任何工具栏( 条 ), 点击弹出的上托式菜单中的 <Customize> 菜单项 ( 参见图 4) 2 在 Customize 对话框中, 根据被加载 DLL 的类型切换到 Toolbars 或者 Commands 页 ( 参见图 5), 然后点击 <Add From File> 按钮 3 在 打开文件 对话框中 (Windows 通用 打开文件 对话框, 图略 ), 12

13 选择被加载的 Dll 文件, 并点击 < 打开 > 按钮 4 如果加载是 Commands, 则在图 5 所示的对话框中显示加载的 Command, 并可以将其拖置于任何工具条上 ; 如果加载是 ToolBars, 则在图 12 所示的对话框中显示加载的 ToolBar, 选中后即可在 ArcMap 中显示 图 12 加载 ToolBar 如何在 VB 环境中利用 ArcObjects 控件开发 EXE 利用 ArcObjects 控件开发 EXE 的前三步类似于 中开发 Acrtive Dll 的前三步, 唯一不同的是在 New Project 对话框中选择 Standard EXE 4 点击 <Project> 菜单项中的 <Components> 项, 打开 Components 对话框, 如图 13 图 13 打开 Components 对话框 5 在 Components 对话框中, 切换到 Controls 页, 并选中 ESRI MapControl 项, 点击 < 应用 > 或 < 确定 > 按钮, 如图 14 13

14 图 14 Components 对话框 6 如图 15 所示, 加载 MapControl 控件之后, 在 VBE 的控件面板中出现了 MapControl 控件图标, 用户便可以象在 Form 中添加 Button 一样在 Form 中添加 MapControl 控件, 并利用它开发 EXE 14

15 图 15 添加 MapControl 控件 1.2. 用户界面 如何创建定制的按钮 (Button) 本例要实现的是如何创建定制的按钮 (Button) 要点用户通过在类模块中实现 ICommand 接口来创建定制的按钮 ( COM command) ICommand 接口包括 caption name category bitmap message (StatusBarr 的提示信息 ) tooltip( 微帮助 ) help context id help file enabled 以及 checked 等十个属性和 OnCreate OnClick 两个事件 从 Icommand 接口的 OnCreate 事件中获取的 ArcMap 的 Application 实例必须用一个公共变量保存, 以便在其它事件中 ( 或者其它接口的事件中甚至整个工程中 ) 使用 OnCreate 事件的参数 hook 传入的是一个 Object, 也就是 ArcMAP 的 Application 实例, 可把它赋给一个 IApplication 接口的变量, 便获得了 ArcMAP 的实例 在 OnClick 事件中写入相关代码, 表示按下按钮时要实现的功能. 程序说明程序在类模块中实现 Icommand 接口来创建自己的按钮 (Button) 代码 15

16 Option Explicit ' 实现 Icommand 接口 Implements ICommand Dim m_ppicture as Picture Dim m_papplication As IApplication Private Sub Class_Initialize() ' 调入.RES 文件中 ID 为 101 的 BitMap 作为该按钮的显示图片 Set m_ppicture = LoadResPicture(101, vbresbitmap) Private Property Get ICommand_Bitmap() As esricore.ole_handle ICommand_Bitmap = m_ppicture End Property Private Property Get ICommand_Caption() As String ICommand_Caption = "Create Button" End Property Private Property Get ICommand_Category() As String ICommand_Category = " Create Button " End Property Private Property Get ICommand_Checked() As Boolean End Property Private Property Get ICommand_Enabled() As Boolean ICommand_Enabled = True End Property Private Property Get ICommand_HelpContextID() As Long End Property Private Property Get ICommand_HelpFile() As String End Property Private Property Get ICommand_Message() As String End Property Private Property Get ICommand_Name() As String ICommand_Name = " CreateButton " End Property Private Sub ICommand_OnClick() ' 加入按下按钮时实现的功能代码 在这里, ' 按钮按下时显示 ArcMap 的 Document 的 Tittle Dim pdocument As IDocument Set pdocument = m_papplication.document MsgBox pdocument.title Private Sub ICommand_OnCreate(ByVal hook As Object) ' 获取 ArcMap 的 Application 实例 Set m_papplication = hook 16

17 Private Property Get ICommand_Tooltip() As String ICommand_Tooltip = " Create Button " End Property 如何创建定制的 Tool 要点 本例要实现的是如何创建定制的 Tool 用户在类模块中实现 Icommand( 参见 1.2.1) 和 ITool 接口 ITool 接口包括 mouse move, mouse button press/release, keyboard key press/release, double-click 以 及 right click 等事件 Cursor 属性和 Refresh 方法 Tool 既具有 Button 的功能, 又具有与 ArcMAP 界面交互的功能,Button 的 功能代码必须写在 Icommand 的 OnClick 事件中, 而所有实现交互功能的代码必 须写在 Itool 接口的各个事件中 Itool 接口的各个事件, 用户可以在其中写入相 关代码, 表示用户与 ArcMAP 界面交互时一旦触发某事件要实现的功能 程序说明 代码 程序在类模块中实现 Icommand 和 Itool 接口来创建自己的 Tool. Option Explicit ' 实现 Icommand 和 Itool 接口 Implements ICommand Implements ITool Dim m_papplication As IApplication Dim m_pbitmap As IPictureDisp Dim m_pcursor As IpictureDisp Private Sub Class_Initialize() Set m_pbitmap = LoadResPicture(101, 0) ' 从.RES 文件中调入 ID 为 102 的图片作为按下 Tool 后的 MouseCursor Set m_pcursor = LoadResPicture(102, 2) Private Property Get ICommand_Bitmap() As esricore.ole_handle ICommand_Bitmap = m_pbitmap End Property Private Property Get ICommand_Caption() As String ICommand_Caption = "MyTool" End Property Private Property Get ICommand_Category() As String ICommand_Category = "MyCustomTools" End Property Private Property Get ICommand_Checked() As Boolean End Property 17

18 Private Property Get ICommand_Enabled() As Boolean ICommand_Enabled = True End Property Private Property Get ICommand_HelpContextID() As Long End Property Private Property Get ICommand_HelpFile() As String End Property Private Property Get ICommand_Message() As String ICommand_Message = "This is my custom tool" End Property Private Property Get ICommand_Name() As String ICommand_Name = "MyCustomTool_MyTool" End Property Private Sub ICommand_OnClick() ' 加入按下按钮时实现的功能代码 MsgBox "Clicked on my command" Private Sub ICommand_OnCreate(ByVal hook As Object) ' 获取 ArcMAP 的 Application 实例 Set m_papplication = hook Private Property Get ICommand_Tooltip() As String ICommand_Tooltip = "MyTool" End Property Private Property Get ITool_Cursor() As esricore.ole_handle ITool_Cursor = m_pcursor End Property Private Function ITool_Deactivate() As Boolean ' 如果 ITool_Deactivate 设为 False, 则 Tool 不可用 ITool_Deactivate = True End Function Private Function ITool_OnContextMenu(ByVal X As Long, ByVal Y As Long) As Boolean ' 在这里可以加入用户代码, 点击 Mouse 右键时显示一个定制的 context menu End Function Private Sub ITool_OnDblClick() ' 在这里加入 Mouse 双击时的功能代码 Private Sub ITool_OnKeyDown(ByVal keycode As Long, ByVal Shift As Long) Private Sub ITool_OnKeyUp(ByVal keycode As Long, ByVal Shift As Long) Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, _ ByVal X As Long, ByVal Y As Long) 18

19 ' 加入 Mouse 单击时的功能代码 If Button = 1 Then Dim ppoint As IPoint Dim pmxapplication As IMxApplication Set pmxapplication = m_papp Set ppoint=pmxapplication.display.displaytransformation.tomappoint(x, Y) m_papplication.statusbar.message(0) = Str(pPoint.X) & "," & Str(pPoint.Y) Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal Shift As Long, _ ByVal X As Long, ByVal Y As Long) ' 加入 Mouse 移动时的功能代码 m_papplication.statusbar.message(0) = "ITool_OnMouseMove" Private Sub ITool_OnMouseUp(ByVal Button As Long, ByVal Shift As Long, _ ByVal X As Long, ByVal Y As Long) ' 加入释放 Mouse 时的功能代码 m_papplication.statusbar.message(0) = "ITool_OnMouseUp" Private Sub ITool_Refresh(ByVal hdc As esricore.ole_handle) 如何创建定制的工具条 (Tool Bar) 本例要实现的是如何创建定制的工具条 (Tool Bar) 就必须在类模块中实现 IToolBarDef 接口 IToolBarDef 接口包括 Caption ItemCount 及 Name 三个属性和 GetItemInfo 方法 要点通过在类模块中实现 IToolBarDef 接口 IToolBarDef 接口包括 Caption ItemCount 及 Name 三个属性和 GetItemInfo 方法 ItemCount 属性表示 ToolBar 显示的条目 (Button Tool 或其它控件 ) 数 GetItemInfo 方法定义工具条上各条目的 CLSID, 其中, 参数 pos 表示条目在 ToolBar 中的位置,itemDef 是定义相应位置的条目的 IItemDef 对象 工具条条目的 CLSID 分为两种 : 1 系统 CLSID, 代表 ArcGIS 的一个功能, 其引用方式为 "esricore. 命令名称 ", 如 "esricore.adddatacommand" "esricore.filesavecommand" 等 2 用户定制 CLSID, 表示用户自己定义的功能 其引用方式为 " 工程名称. 定制功能类名称 ", 如 " ToolBarDef.ClsBar " 必须注意, 这里 定制功能类名称 是工程中实现的一个功能类名称, 工程名称 即为当前工程的名称 ( 不是 DLL 文件名, 也不是工具条的名称 ), 每次新建一个工程时, 系统默认的工程名在某些情况下无法使用 ( 在中文版的 VB 中是一个乱字符 ), 必须改名后方能用 19

20 程序说明 代码 程序在类模块中实现 IToolBarDef 接口来创建自己的工具条 (ToolBar) Option Explicit Implements IToolBarDef Private Property Get IToolBarDef_Caption() As String IToolBarDef_Caption = "CustomToolBar" End Property Private Sub IToolBarDef_GetItemInfo(ByVal pos As Long, ByVal itemdef As _ esricore.iitemdef) ' 这里假设在当前工程 ( 工程名称为 ToolBarDef) 中定义了一个类模块 ( 名为 ClsBar), ' 它实现了 Icommand 接口 ( 可参照 1.2.1) Select Case pos Case 0 ' 用户自定义条目 itemdef.id = "ToolBarDef.ClsBar" itemdef.group = False Case 1 ' 系统条目 itemdef.id = "esricore.adddatacommand" itemdef.group = False End Select Private Property Get IToolBarDef_ItemCount() As Long IToolBarDef_ItemCount = 2 End Property Private Property Get IToolBarDef_Name() As String IToolBarDef_Name = "CustomToolBar" End Property 如何创建定制的 MultiItem 本例要实现的是如何创建定制的 MultiItem 要点需要实现 IMultiItem 接口, 但不需要同时实现 Icommand 接口 IMultiItem 接口包括 Caption,itemCaption,ItemBitmap,ItemEnabled,ItemChecked, Message 及 Name 等属性和 OnItemClick, OnPopup 事件 itemcaption,itembitmap,itemenabled,itemchecked 等属性的参数 index 表示当前 Item 的下标索引 OnPopup 事件的参数 hook 同 Icommand 接口的 OnCreate 事件的参数 hook 一样, 传入 ArcGIS 的 Application 实例, 同时, 该事件返回将要显示的 Item 数目 20

21 OnItemClick 事件的参数 Index 表示用户当前点击的 Item 的索引, 用户根 据该索引分别定义点击各个 Item 时实现的功能 程序说明 代码 程序在类模块中实现 IMultiItem 接口来创建定制自己的 MultiItem Option Explicit Implements IMultiItem Private m_papp As IApplication 'ArcMap 的 Document Private m_pmxdoc As IMxDocument ' 当前 Focus Map Private m_pmap As IMap 'Map 中的层数 Private m_playercnt As Long Private Property Get IMultiItem_Caption() As String IMultiItem_Caption = "ZoomToLayers" End Property Private Property Get IMultiItem_HelpContextID() As Long End Property Private Property Get IMultiItem_HelpFile() As String End Property Private Property Get IMultiItem_ItemBitmap(ByVal Index As Long) As esricore.ole_handle End Property Private Property Get IMultiItem_ItemCaption(ByVal Index As Long) As String Dim i As Integer ' 遍历每一个层 For i = 0 To m_playercnt - 1 ' 如果层号与当前 Item 的 Index 相同, 就设置该 Item 的 Caption If Index = i Then IMultiItem_ItemCaption = "Zoom to " & m_pmap.layer(i).name Next End Property Private Property Get IMultiItem_ItemChecked(ByVal Index As Long) As Boolean End Property Private Property Get IMultiItem_ItemEnabled(ByVal Index As Long) As Boolean Dim i As Integer ' 遍历每一个层 For i = 0 To m_playercnt - 1 ' 如果层号与当前 Item 的 Index 相同, 则当前 Item 的 Enable 根据该层的 Visible 设置 If Index = i Then If m_pmap.layer(i).visible Then IMultiItem_ItemEnabled = True Next 21

22 End Property Private Property Get IMultiItem_Message() As String IMultiItem_Message = "Zooms to the layer." End Property Private Property Get IMultiItem_Name() As String IMultiItem_Name = "ZoomMulti" End Property Private Sub IMultiItem_OnItemClick(ByVal Index As Long) Dim i As Integer Dim penv As IEnvelope Dim m_bookmark As IAOIBookmark ' 遍历每一个层 For i = 0 To m_playercnt 1 ' 如果层号与当前 Item 的 Index 相同, 则以该层的 AreaOfInterest 为范围执行 Zoom If Index = i Then Set penv = m_pmap.layer(i).areaofinterest Set m_bookmark = New AOIBookmark Set m_bookmark.location = penv m_bookmark.zoomto m_pmap m_pmxdoc.activeview.refresh Next Private Function IMultiItem_OnPopup(ByVal hook As Object) As Long Set m_papp = hook ' 获取 Map 中的层数 Set m_pmxdoc = m_papp.document Set m_pmap = m_pmxdoc.focusmap m_playercnt = m_pmap.layercount ' 显示的 Item 数等于层数 IMultiItem_OnPopup = m_playercnt End Function 如何创建定制的菜单 (Menu) 本例要实现的是如何创建定制的菜单 (Menu) 要点用户通过在类模块中实现 IMenuDef 接口来创建定制的菜单 (Menu), 如果要使菜单出现在 Customize Dialog 的 Menus 类型中, 必须同时实现 IrootLevelMenu 接口, 它表明菜单为 root menu IMenuDef 接口包括 Caption ItemCount 及 Name 三个属性和 GetItemInfo 方法 类似 IToolBarDef( 参照 1.2.3) 程序说明程序在类模块中实现 IMenuDef 接口来创建定制的菜单 (Menu) 代码 Option Explicit 22

23 'Implement the IMenuDef interface and IRootLevelMenu interface Implements IMenuDef Implements IRootLevelMenu Private Property Get IMenuDef_Caption() As String ' Set the string that appears as the menu's title IMenuDef_Caption = "MyMenu" End Property Private Sub IMenuDef_GetItemInfo(ByVal pos As Long, _ ByVal itemdef As esricore.iitemdef) ' Define the commands that will be on the menu. The built-in ArcMap ' Full Extent command, and Fixed Zoom In command are added to this custom menu. ' ID is the ClassID of the command. Group determines whether the command ' begins a new group on the menu Select Case pos Case 0 itemdef.id = "promenu.clsmultitem" itemdef.group = False Case 1 itemdef.id = "esricore.fullextentcommand" itemdef.group = True Case 2 itemdef.id = "esricore.zoominfixedcommand" itemdef.group = False End Select Private Property Get IMenuDef_ItemCount() As Long ' Set how many commands will be on the menu IMenuDef_ItemCount = 3 End Property Private Property Get IMenuDef_Name() As String ' Set the internal name of the menu. IMenuDef_Name = "MyMenu" End Property 如何创建定制的 ToolControl 本例要实现的是如何创建定制的 ToolControl ToolControl 是指具有 ComboBox 的下拉列表或 EditBox 的编辑功能的一类控件 要创建定制的 ToolControl, 必须在类模块中实现 ICommand 和 IToolControl 接口 IToolControl 接口包括 hwnd 属性和 OnDrop, OnFocus 事件 要点 IToolControl 接口的 hwnd 属性, 接受一个 Window Handle IToolControl 接口的 OnDrop 事件, 支持 ToolControl 的拖放, 传入参数 bartype 表示 Bar 类型 IToolControl 接口的 OnFocus 事件, 传入 IcompletionNotify 类型的参数 23

24 complete, 可以通过执行 IcompletionNotify 接口的 SetComplete 方法告之 ArcMAP, ToolControl 可以失去 Focus 程序说明 本例中涉及三个模块, 详细描述如下, 其中, 在类模块中实现了 IToolBarDef 接口来创建自己的 ToolControl 代码 '1 frmimagecombo.frm 模块, 定义选中 Combox 某一项之后实现的功能 要求在 Form 上放置一个 'ImageComb 控件 ( 名为 ImageCombo1) 和一个 ImageList 控件 ( 名为 ImageList1), 并在 ImageList1 ' 中添加三张图片 Private Sub Form_Load() ' 设置 ImageCombo1 的选择 Item Me.ImageCombo1.ImageList = Me.ImageList1 Me.ImageCombo1.ComboItems.Add 1, "Red", "Red" Me.ImageCombo1.ComboItems.Add 2, "Blue", "Blue" Me.ImageCombo1.ComboItems.Add 3, "Green", "Green" Me.ImageCombo1.ComboItems(1).Image = 1 Me.ImageCombo1.ComboItems(2).Image = 2 Me.ImageCombo1.ComboItems(3).Image = 3 Private Sub ImageCombo1_Click() ' 选择颜色 Dim sel As Variant sel = Me.ImageCombo1.SelectedItem Dim color As Variant Select Case sel Case "Blue" color = vbblue Case "Red" color = vbred Case "Green" color = vbgreen End Select Dim pdocument As IMxDocument Set pdocument = g_papplication.document ' 设置颜色 Dim prgbcolor As IrgbColor Set prgbcolor = New RgbColor prgbcolor.rgb = color ' 改变选中部分的颜色 Dim pselectionenvironment As ISelectionEnvironment Set pselectionenvironment = New SelectionEnvironment Set pselectionenvironment.defaultcolor = prgbcolor ' 刷新视图 pdocument.activatedview.refresh ' 通知 ArcMap,ToolControl 现在可以失去 Focus g_pcompletionnotify.setcomplete ' 2 modpublicvars.bas 模块, 定义工程中用到的全局变量 Option Explicit Public g_papplication As IApplication 24

25 Public g_pcompletionnotify As IcompletionNotify ' 3 CustImageCombo.cls 模块, 实现接口 Icommand 和 IToolControl Option Explicit Implements ICommand Implements IToolControl Private Property Get ICommand_Bitmap() As esricore.ole_handle End Property Private Property Get ICommand_Caption() As String ICommand_Caption = "Custom ImageCombo" End Property Private Property Get ICommand_Category() As String ICommand_Category = "Developer Samples" End Property Private Property Get ICommand_Checked() As Boolean End Property Private Property Get ICommand_Enabled() As Boolean ICommand_Enabled = True End Property Private Property Get ICommand_HelpContextID() As Long End Property Private Property Get ICommand_HelpFile() As String End Property Private Property Get ICommand_Message() As String ICommand_Message = "Change feature selection color" End Property Private Property Get ICommand_Name() As String ICommand_Name = "DevelperSamples_CustomImageCombo" End Property Private Sub ICommand_OnClick() Private Sub ICommand_OnCreate(ByVal hook As Object) Set g_papp = hook Private Property Get ICommand_Tooltip() As String ICommand_Tooltip = "Change Selection Color" End Property Private Property Get IToolControl_hWnd() As esricore.ole_handle ' 将 frmimagecombo.imagecombo1 的 Window Handle 赋给 IToolControl_hWnd IToolControl_hWnd = frmimagecombo.imagecombo1.hwnd End Property Private Function IToolControl_OnDrop(ByVal bartype As esricore.esricmdbartype) As Boolean ' 仅能 25

26 将 ToolControl 拖放到 ToolBar 上 If bartype = esricmdbartypetoolbar Then IToolControl_OnDrop = True End Function Private Sub IToolControl_OnFocus(ByVal complete As esricore.icompletionnotify) Set g_pcompletionnotify = complete 如何创建定 使用制的可停靠窗口 (Dockable Window) 要点 本例要实现的是如何创建定制的可停靠窗口 (Dockable Window) 用户通过在类模块中实现 IDockableWindowDef 接口来创建定制的可停靠窗 口 (Dockable Window) IDockableWindowDef 接口包括 Caption ChildHWND, UserData 及 Name 等属性和 OnCreate OnDestroy 事件 ChildHWND 属性表示可停靠窗口包含的 Window 的 Handle OnCreate 事件的参数 hook 传入 ArcGIS 的 Application 实例 创建并注册可停靠窗口的步骤 : 1 实现 IdockableWindowDef 接口 ( 参见实例 ); 2 编译成 DLL; 3 调用 windows 目录下 system32 子目录下的 regsvr32.exe 用下面的形式注 册编译好的 DLL: win 目录 \system32\regsvr32.exe < 路径 >\< 文件名 >.dll 4 运行 <arcmap 目录 >\arcexe81\bin\categories.exe, 在打开的 Component Catregory Manager 中找到 ESRI Mx Dockable Window, 点击 Add Object 按钮将上 面注册的 DLL 文件加入, 并选中实现 IdockableWindowDef 接口的类名即可 程序说明 类模块 ClsDockableWindow 只是创建与注册可停靠窗口, 但还不能用, 还 必须定义一个 IdockableWindow 接口的变量引用注册的类 ( 必须用 IdockableWindowsManager 接口的 GetDockableWindow 获取, 其 ID 号用 " 实现 IdockableWindowDef 接口的工程名 project1. 实现 IdockableWindowDef 接口的类 名 class1") 代码 ' 类模块 ClsDockableWindow Option Explicit Implements IDockableWindowDef Dim m_papplication As IApplication 26

27 Private Property Get IDockableWindowDef_Caption() As String IDockableWindowDef_Caption = "Dockable Window" End Property Private Property Get IDockableWindowDef_ChildHWND() As esricore.ole_handle ' 将 FrmDWin 窗口的 Handle 赋给 IDockableWindowDef_ChildHWND IDockableWindowDef_ChildHWND = FrmDWin.hWnd End Property Private Property Get IDockableWindowDef_Name() As String IDockableWindowDef_Name = "docwin" End Property Private Sub IDockableWindowDef_OnCreate(ByVal hook As Object) Set m_papplication = hook Private Sub IDockableWindowDef_OnDestroy() Set m_papplication = Nothing Private Property Get IDockableWindowDef_UserData() As Variant End Property ' 类模块 class1 Option Explicit Implements ICommand Dim m_papp As IApplication Dim m_pdwmgr As IDockableWindowManager Dim m_pdwin As IDockableWindow Private Property Get ICommand_Bitmap() As esricore.ole_handle End Property Private Property Get ICommand_Caption() As String ICommand_Caption = "Dockable Window" End Property Private Property Get ICommand_Category() As String ICommand_Category = "Dockable Window" End Property Private Property Get ICommand_Checked() As Boolean End Property Private Property Get ICommand_Enabled() As Boolean ICommand_Enabled = True End Property Private Property Get ICommand_HelpContextID() As Long End Property Private Property Get ICommand_HelpFile() As String End Property Private Property Get ICommand_Message() As String 27

28 End Property Private Property Get ICommand_Name() As String ICommand_Name = "DocWin" End Property Private Sub ICommand_OnClick() m_pdwin.show Not m_pdwin.isvisible Private Sub ICommand_OnCreate(ByVal hook As Object) Set m_papp = hook ' QI(Dockable Window) Set m_pdwmgr = hook Dim pid As New UID pid.value = "Prodockablewindow.Clsdockablewindow" Set m_pdwin = m_pdwmgr.getdockablewindow(pid) Private Property Get ICommand_Tooltip() As String ICommand_Tooltip = "Dockable Window" End Property 如何创建 使用定制的 Extension 要点 本例要实现的是如何创建 使用定制的 Extension 用户需要实现 IExtension 接口来创建定制的 Extension IExtension 接口包括 Name 属性和 startup 和 shutdown 事件 创建并注册 Extension 的步骤 : 1. 实现 IExtension 接口 ; 2. 编译成 DLL; 3. 调用 windows 目录下 system32 子目录下的 regsvr32.exe 用下面的形式注 册编译好的 DLL win 目录 \system32\regsvr32.exe < 路径 >\< 文件名 >.dll 4. 运行 <arcmap 目录 >\arcexe81\bin\categories.exe, 在打开的 Component Catregory Manager 中找到 ESRI Mx Extensions, 点击 Add Object 按钮将上面注册 的 DLL 文件加入, 并选中实现 IExtension 接口的类名即可 程序说明 用户通过在类模块中实现 IExtension 接口来创建定制的 Extension Extension 将在 ArcMap 打开时自动加载, 在 ArcMap 关闭时自动卸载 代码 Option Explicit Implements IExtension 28

29 Dim m_papplication As IApplication ' Need to listen for the MxDocument events Dim WithEvents m_pdocument As MxDocument Private Property Get IExtension_Name() As String IExtension_Name = "My Extension" End Property Private Sub IExtension_Shutdown() ' Clear the reference to the Application and MxDocument Set m_papplication = Nothing Set m_pdocument = Nothing Private Sub IExtension_Startup(initializationData As Variant) ' This extension is an ArcMap Extension. When this extension in loaded on ' ArcMap startup, initializationdata is passed in as a reference to the ' Application object Set m_papplication = initializationdata 'Start listening for the MxDocument events. Set m_pdocument = m_papp.document Private Function m_pdocument_newdocument() As Boolean ' Do something when a new document is created MsgBox "Creating a new document." End Function Private Function m_pdocument_opendocument() As Boolean ' So something when a document is opened. MsgBox "Opening a document" End Function 如何使用状态条 (StatusBar) 与进度条 (ProgressBar) 本例要演示的是如何使用状态条 (StatusBar) 与进度条 (ProgressBar) 实现后的结果为在 ArcMap 中, 状态条位于其底部, 它显示 ArcMAP 当前状态的信息, 包含进度条 要点一般情况下, 通过 ArcMAP 的 Application 实例获取 IstatusBar 的实例, 然后再通过 StatusBar 获取 IprogressBar 的实例, 并将 IprogressBar 的实例赋给 IstepProgressor 类型的变量 程序说明运行函数 ShowProgress 将在 ArcMap 的下方添加一个状态条 (StatusBar) 和进度条 (ProgressBar) 代码 Sub ShowProgress() 29

30 On Error GoTo err1 Dim pdocument As IMxDocument Dim pmap As IMap Dim player As ILayer Dim pfeaturelayer As IFeatureLayer Dim pfeaturecursor As IFeatureCursor Dim pfeatureclass As IFeatureClass Dim pfeature As IFeature Dim dsum As Double Dim lfieldindex As Long Dim lnumfeat As Long Dim dinterval As Double Set pdocument = Application.Document Set pmap = pdocument.focusmap Set player = pmap.layer(0) Set pfeaturelayer = player Set pfeatureclass = pfeaturelayer.featureclass Set pfeaturecursor = pfeaturelayer.search(nothing, True) Dim pstatusbar As IStatusBar Set pstatusbar = Application.StatusBar Dim pstepprogressor As IStepProgressor Set pstepprogressor= pstatusbar.progressbar lnumfeat = pfeatureclass.featurecount(nothing) dinterval = lnumfeat / 100 Set pfeature = pfeaturecursor.nextfeature ' 字段名 "FID" 用户根据实际而改变 lfieldindex = pfeature.fields.findfield("fid") Dim PauseTime, Start, Finish, TotalTime, i PauseTime = 0.5 pstepprogressor.minrange = 1 pstepprogressor.maxrange = lnumfeat pstepprogressor.stepvalue = dinterval For i = 1 To lnumfeat dsum = dsum + pfeature.value(lfieldindex) Set pfeature = Nothing Set pfeature = pfeaturecursor.nextfeature pstepprogressor.position = i pstepprogressor.message = "Reading record " & Str(i) & ". Sum =" & Str(dSum) pstepprogressor.step pstepprogressor.show Start = Timer Do While Timer < Start + PauseTime DoEvents Loop Next pstepprogressor.hide err1: 如何使用 ArcGIS 的对话框 添加对话框可以通过相应的接口实现 比如 添加数据对话框 使用 30

31 IaddDataDialog 接口, 生成点坐标对话框 使用 ICoordinateDialog 接口, 生成字 符串对话框 使用 IGetStringDialog 接口, 生成数值对话框 使用 INumberDialog 接口等等 本例以添加数据对话框 (Add Data Dialog) 为例, 讲述对话框是如何通 过接口实现添加的 要点 用户通过实现 IaddDataDialog 接口来创建定制的添加数据对话框, IaddDataDialog 接口包括 Document 和 Map 属性和 Show 事件 程序说明 在程序中除了必须生成 IaddDataDialog 接口的实例外, 还必须指定对话框的 Document 和 Map 当为 AddDataDialog 指定 Document 和 Map 之后, 系统会自动 将用户选择的数据加入到指定 Document 和 Map 中 最后实现在 ArcMap 中添加 数据的对话框 代码 Sub ShowProgress() Dim mdocument As IMxDocument Dim madddatadialog As IAddDataDialog Set madddatadialog = New AddDataDialog Set mdocument = ThisDocument madddatadialog.document = mdocument madddatadialog.map = mdocument.focusmap madddatadialog.show Application.hWnd, True 如何调用 ArcMap 中现有的功能 如何调用 ArcMap 中现有的功能, 比如菜单栏 工具栏中的某些功能 这 些都可以通过 UID 来实现 本例是通过 UID 调用 另存为 功能 可以通过两种方法得到 UID: 方法一 : 运用 ArcID 模块 要点 通过 ArcID 获得 UID,ArcID 是 ArcMap 的 VBA 中的模块 只需要知道要调用 功能的名称运用代码就可以实现 程序说明 代码 程序通过运用 ArcID 模块和命令名称来实现调用 另存为 的功能 Sub ExecuteCmd() Dim pcommanditem As ICommandItem ' Use ArcID module and the Name of the SaveAs command Set pcommanditem = Application.Document.CommandBars.Find(arcid.File_SaveAs) 31

32 pcommanditem.execute 方法二 : 直接写代码 要点 通过直接写代码获得 UID 实现调用功能 程序说明 写入文件菜单项的 GUID(CLSID 或 ProgID) 来调用文件菜单项, 同时还需要 通过设置 Subtype 的值来调用文件菜单项的 另存为 功能 代码 Sub ExecuteCmd2() Dim puid As New UID Dim pcommanditem As ICommandItem ' Use the GUID of the Save command puid.value = "{119591DB D2-8D EE4E51}" ' or you can use the ProgID ' puid.value = "esricore.mxfilemenuitem" puid.subtype = 3 Set pcommanditem = Application.Document.CommandBars.Find(pUID) pcommanditem.execute 如何创建放大镜 ( 虫眼 ) 要点 本例要实现的是如何创建放大镜 ( 虫眼 ), 将所选区域放大一定的倍数 用户通过定义 IMapInset IMapInsetWindow IDataWindowFactory 三个接口, 运用它们的方法 属性来创建放大镜 ( 虫眼 ) 程序说明 运用这个子程序生成了一个新的放大镜窗口, 在本例中将放大率设定为 200% 代替原来的 400% 代码 Public Sub CreateMagnifierWindow() Dim pmapinset As IMapInset Dim pmapinsetwindow As IMapInsetWindow Dim pdatawindowfactory As IDataWindowFactory Set pdatawindowfactory = New MapInsetWindowFactory If pdatawindowfactory.cancreate(application) Then Set pmapinsetwindow = pdatawindowfactory.create(application) Set pmapinset = pmapinsetwindow.mapinset 'Set the zoom percent to 200% pmapinset.zoompercent = 200 pmapinsetwindow.show True 32

33 1.3. GeoDataBase 如何加载 Shape 文件 本例实现的是在 ArcMap 中连接指定的 Shape 文件, 并将其加载到当前激活的 Map 中 要点 通过 FeatureLayer 类实现 IFeatureLayer 接口对象, 设置 IFeatureLayer.FeatureClass 属性和 Name 属性, 使用 IMap.AddLayer 方法将新层添加到当前地图 利用 IWorkspaceFacktory 接口 IFeatureWorkspace 接口和 IFeatureLayer 接口实现连接 Shape 文件 程序说明 函数 OpenShapeFile 根据输入的 Shape 文件路径 sfilepath, 将文件名为 sfilename 的 Shape 文件连接到当前激活的 Map 中去 代码 Private Sub OpenShapeFile(ByVal sfilepath As String, ByVal sfilename As String) Dim pworkspacefactory As IWorkspaceFactory Dim pfeatureworkspace As IFeatureWorkspace Dim pfeaturelayer As IFeatureLayer Dim pmxdocument As IMxDocument Dim pmap As IMap Dim sdir As String On Error GoTo sdir = Dir(sFilePath & "\" & sfilename & ".shp") If (sdir = "") Then sdir = Dir(sFilePath & "\" & sfilename) If (sdir = "") Then MsgBox (" 文件不存在 ") 'Create a new ShapefileWorkspaceFactory object and open a shapefile folder Set pworkspacefactory = New ShapefileWorkspaceFactory Set pfeatureworkspace = pworkspacefactory.openfromfile(sfilepath, 0) 'Create a new FeatureLayer and assign a shapefile to it Set pfeaturelayer = New FeatureLayer Set pfeaturelayer.featureclass = pfeatureworkspace.openfeatureclass(sfilename) pfeaturelayer.name = pfeaturelayer.featureclass.aliasname 'Add the FeatureLayer to the focus map Set pmxdocument = Application.Document Set pmap = pmxdocument.focusmap pmap.addlayer pfeaturelayer 33

34 Private Sub UIButtonControl1_Click() Dim pvbproject As VBProject On Error GoTo Set pvbproject = ThisDocument.VBProject OpenShapeFile pvbproject.filename & "\..\..\..\.." & "\data\", "Continents" 如何在 ArcMap 中加入 Text 和 dbase 文件 要点 本例实现的是如何在当前的 ArcMap 中加入 Text 文件和 dbase 文件 首先为 Text 文件或 dbase 文件创建一个与之对应的 ITable 接口对象, 然后 通过 IMap 实例获得 IStandaloneTable 接口对象和 IStandaloneTableCollection 接口对 象, 并设置其属性, 最后使用 IStandaloneTableCollection.AddStandaloneTable 方法 将 Text 文件或 dbase 文件加入到当前的 ArcMap 中 加入 Text 文件或 dbase 文件的区别仅在于创建 ITable 对象时 IWorkspaceFactory 的类型不同, 加入 Text 文件时是 TextFileWorkspaceFactory 类型, 加入 dbase 文件时是 ShapefileWorkspaceFactory 类型 主要用到了 IWorkspaceFactory 接口,IWorkspace 接口,IFeatureWorkspace 接口,ITable 接口,IStandaloneTable 接口和 IStandaloneTableCollection 接口 程序说明 函数 AddTextFile 通过文件路径 sfilepath 和文件名 sfilename 找到 Text 文件 并为其创建 ITable 对象 函数 AddDBASEFile 通过文件路径 sfilepath 和文件名 sfilename 找到 dbase 文件并为其创建 ITable 对象 代码 函数 Add_Table_TOC 将 ITable 对象 ptable 加入到当前的 ArcMap 中 Private Sub AddTextFile(ByVal sfilepath As String, ByVal sfilename As String) Dim pworkspacefactory As IWorkspaceFactory Dim pworkspace As IWorkspace Dim pfeatureworkspace As IFeatureWorkspace Dim ptable As ITable Dim sdir As String On Error GoTo sdir = Dir(sFilePath & sfilename & ".txt") If (sdir = "") Then MsgBox (sfilename & ".txt" & " 文件不存在 ") 34

35 'Get the ITable from the geodatabase Set pworkspacefactory = New TextFileWorkspaceFactory Set pworkspace = pworkspacefactory.openfromfile(sfilepath, 0) Set pfeatureworkspace = pworkspace Set ptable = pfeatureworkspace.opentable(sfilename & ".txt") 'Add the table Add_Table_TOC ptable Private Sub AddDBASEFile(ByVal sfilepath As String, ByVal sfilename As String) Dim pworkspacefactory As IWorkspaceFactory Dim pworkspace As IWorkspace Dim pfeatureworkspace As IFeatureWorkspace Dim ptable As ITable On Error GoTo 'Get the ITable from the geodatabase Set pworkspacefactory = New ShapefileWorkspaceFactory Set pworkspace = pworkspacefactory.openfromfile(sfilepath, 0) Set pfeatureworkspace = pworkspace Set ptable = pfeatureworkspace.opentable(sfilename) 'Add the table Add_Table_TOC ptable Private Sub Add_Table_TOC(pTable As ITable) Dim pdoc As IMxDocument Dim pmap As IMap Dim pstandalonetable As IStandaloneTable Dim pstandalonetablec As IStandaloneTableCollection On Error GoTo Set pdoc = ThisDocument Set pmap = pdoc.focusmap 'Create a new standalone table and add it 'to the collection of the focus map Set pstandalonetable = New StandaloneTable Set pstandalonetable.table = ptable Set pstandalonetablec = pmap pstandalonetablec.addstandalonetable pstandalonetable 'Refresh the TOC pdoc.updatecontents 35

36 Private Sub UIButtonControl1_Click() Dim pvbproject As VBProject On Error GoTo Set pvbproject = ThisDocument.VBProject 'Add text file to ArcMap. Dont include.txt extension AddTextFile pvbproject.filename & "\..\..\..\.." & "\data\", "Continents" 'Add dbase file to ArcMap AddDBASEFile pvbproject.filename & "\..\..\..\.." & "\data\", "Continents" 如何连接 GeoDataBase 文件 本例实现的是连接一个 GeoDataBase 文件, 并在 ArcMap 中加载该 GeoDataBase 文件的一个表 要点 定义 IWorkspaceFactory 接口对象, 使用 AccessWorkspaceFactory 类实现之 再创建 IFeatureLayer 接口对象, 用 IFeatureWorkspace.OpenFeatureClass 方法加载 GeoDataBase 文件的一个表到 IFeatureLayer.FeatureClass 对象中 最后用 IMap.AddLayer 方法将新层添加到当前地图 使用接口有 :IWorkspaceFacktory 接口 IFeatureWorkspace 接口 IFeatureLayer 接口和 IMap 接口 程序说明 函数 OpenGeoDataBaseFile 根据输入的 GeoDataBase 文件的路径 ( 带文件名 及后缀 )sallfilename 连接 GeoDataBase 文件, 再根据输入的 GeoDataBase 文件 中的某表表名 stablename 加载该表到激活的 Map 中去 代码 Private Sub OpenGeoDataBaseFile(ByVal sallfilename As String, ByVal stablename As String) Dim pworkspacefactory As IWorkspaceFactory Dim pfeatureworkspace As IFeatureWorkspace Dim pfeaturelayer As IFeatureLayer Dim pmxdocument As IMxDocument Dim pmap As IMap Dim sdir As String On Error GoTo sdir = Dir(sAllFileName) If (sdir = "") Then MsgBox (" 文件不存在 ") 'Create a new AccessWorkspaceFactory object and open a GeoDataBaseFile Set pworkspacefactory = New AccessWorkspaceFactory Set pfeatureworkspace = pworkspacefactory.openfromfile(sallfilename, 0) 36

37 'Create a new FeatureLayer and assign a Table to it Set pfeaturelayer = New FeatureLayer Set pfeaturelayer.featureclass = pfeatureworkspace.openfeatureclass(stablename) pfeaturelayer.name = pfeaturelayer.featureclass.aliasname 'Add the FeatureLayer to the focus map Set pmxdocument = Application.Document Set pmap = pmxdocument.focusmap pmap.addlayer pfeaturelayer Private Sub UIButtonControl1_Click() Dim pvbproject As VBProject On Error GoTo Set pvbproject = ThisDocument.VBProject OpenGeoDataBaseFile pvbproject.filename & "\..\..\..\.." & "\data\airport.mdb", "arterials" 如何连接 Coverage 文件本例实现的是如何在当前激活的 Map 中连接一个 Coverage 文件 要点使用 ArcInfoWorkspaceFactory 类实现 IWorkSpaceFactory 接口对象, 用 IWorkspaceFactory.Open 方法打开一个 Workspace, 并获得 Dataset 对象 由于此时的 Dataset 对象可能有多个 Coverage 文件, 所以要获得 IEnumDataset 接口对象, 通过 IEnumDataset.Next 方法获得一个 Coverage 文件, 并将其所有的 FeatureClass 放在 IFeatureClassContainer 对象中 最后通过 IFeatureClassContainer.Class 方法获得 IFeatureClass 接口实例, 用 IMap.AddLayer 方法将要连接的 Coverage 文件的所有 FeatureClass 加载到当前激活的 Map 中 主要用到 IWorkspaceFactory 接口,IWorkspace 接口,IPropertySet 接口, IDataset 接口,IEnumDataset 接口,IFeatureClassContainer 接口 程序说明函数 ConnectCoverageFile 将 sfilepath 指定的 ArcInfo Workspace 中的名称和 sfilename 相同的 Coverage 文件加载到当前激活的 Map 中 代码 Private Sub ConnectCoverageFile(ByVal sfilepath As String, ByVal sfilename As String) Dim pworkspace As IWorkspace Dim pworkspacefactory As IWorkspaceFactory Dim ppropertyset As IPropertySet 37

38 Dim pdataset Dim penumdataset Dim pfeatureclassc Dim pfeaturelayer Dim pmxdocument Dim pmap Dim nnumber Dim sworkspace As IDataset As IEnumDataset As IFeatureClassContainer As IFeatureLayer As IMxDocument As IMap As Integer As String On Error GoTo sworkspace = Dir(sFilePath, vbdirectory) If (sworkspace = "") Then MsgBox (" 文件不存在 ") Set pworkspacefactory = New ArcInfoWorkspaceFactory Set ppropertyset = New PropertySet 'canada is an arcinfoworkspace ppropertyset.setproperty "DATABASE", sfilepath 'pworksp is a pointer to the IArcInfoWorkspace Set pworkspace = pworkspacefactory.open(ppropertyset, 0) 'now get to dataset objects using Idataset Set pdataset = pworkspace 'use enum to get datasets Set penumdataset = pdataset.subsets penumdataset.reset 'use FeatureClassContainer to get datasets Set pfeatureclassc = penumdataset.next Do While Not pfeatureclassc Is Nothing Set pdataset = pfeatureclassc If (pdataset.name <> sfilename) Then Set pfeatureclassc = penumdataset.next Else Exit Do Loop 'add FeatureClassContainer to map If (pfeatureclassc Is Nothing) Then MsgBox (" 文件不存在 ") Else nnumber = 0 Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Do While nnumber < pfeatureclassc.classcount Set pfeaturelayer = New FeatureLayer Set pfeaturelayer.featureclass = pfeatureclassc.class(nnumber) pfeaturelayer.name = pfeaturelayer.featureclass.aliasname nnumber = nnumber + 1 pmap.addlayer pfeaturelayer Loop 38

39 Private Sub UIButtonControl1_Click() Dim pvbproject As VBProject On Error GoTo Set pvbproject = ThisDocument.VBProject ConnectCoverageFile pvbproject.filename & "\..\..\..\.." & "\data\canada", "canada" 如何连接栅格文件 要点 本例实现的是如何在当前激活的 Map 中添加一个栅格文件 创建一个 IrasterLayer 接口对象, 使用 IRasterLayer.CreateFromFilePath 方法加 载一个 Raster 文件, 最后用 IMap.AddLayer 方法将 IRasterLayer 添加到当前激活 的 Map 中 主要用到 IRasterLayer 接口 程序说明 函数 AddRasterFile 将路径 sfilepath 下的栅格文件 sfilename 添加到当前激活 的 Map 中 代码 Private Sub AddRasterFile(sFilePath As String, sfilename As String) 'sfilename: the filename of the raster dataset 'spath: the directory where the raster dataset resides Dim prasterly As IRasterLayer Dim pmxdoc As IMxDocument Dim pmap As IMap Dim srasterfile As String On Error GoTo srasterfile = Dir(sFilePath & sfilename) If (srasterfile = "") Then MsgBox (" 文件不存在 ") 'Create a raster layer Set prasterly = New RasterLayer 'This is only one of the three ways to create a RasterLayer object. 'If there is already a Raster or RasterDataset object, then 'method CreateFromDataset or CreateFromRaster can be used. prasterly.createfromfilepath sfilepath & sfilename 'Add the raster layer to ArcMap Set pmxdoc = ThisDocument Set pmap = pmxdoc.focusmap pmap.addlayer prasterly pmxdoc.activeview.refresh 39

40 Private Sub UIButtonControl1_Click() Dim pvbproject As VBProject On Error GoTo Set pvbproject = ThisDocument.VBProject AddRasterFile pvbproject.filename & "\..\..\..\.." & "\data\", "photo.tif" 如何创建 Shape 文件 要点 本例实现的是如何创建一个 Shape 文件 首先创建新 IField 接口实例, 生成新字段, 并获得该实例的 IFieldEdit 接口 对象, 用 FieldsEdit 的 AddField 方法将新字段加入到 IFields 接口对象中, 最后 用 IFeatureWorkspace 的 CreateFeatureClass 方法生成新的 Shape 文件 主要用到 IFeatureWorkspace 接口,IWorkspaceFactory 接口,IFieldsEdit 接口, IFieldEdit 接口,IFeatureClass 接口 程序说明 代码 函数 CreatShapeFile 根据输入的文件路径和文件名, 创建 Shape 文件 Private Sub CreatShapeFile(ByVal sfilepath As String, ByVal sfilename As String) Dim pfeatureworkspace As IFeatureWorkspace Dim pworkspacefactory As IWorkspaceFactory Dim pfields As IFields Dim pfieldsedit As IFieldsEdit Dim pfield As IField Dim pfieldedit As IFieldEdit Dim pgeometrydef As IGeometryDef Dim pgeometrydefedit As IGeometryDefEdit Dim pfeatclass As IFeatureClass Dim sshapefieldname As String Dim snewshapefilename As String On Error GoTo snewshapefilename = Dir(sFilePath & sfilename & ".shp") If (snewshapefilename <> "") Then MsgBox (" 文件已经存在 ") sshapefieldname = "Shape" 'Open the folder to contain the shapefile as a workspace Set pworkspacefactory = New ShapefileWorkspaceFactory Set pfeatureworkspace = pworkspacefactory.openfromfile(sfilepath, 0) 40

41 'Set up a simple fields collection Set pfields = New esricore.fields Set pfieldsedit = pfields 'Make the shape field 'it will need a geometry definition, with a spatial reference Set pfield = New esricore.field Set pfieldedit = pfield pfieldedit.name = sshapefieldname pfieldedit.type = esrifieldtypegeometry Set pgeometrydef = New GeometryDef Set pgeometrydefedit = pgeometrydef With pgeometrydefedit.geometrytype = esrigeometrypolygon Set.SpatialReference = New UnknownCoordinateSystem End With Set pfieldedit.geometrydef = pgeometrydef pfieldsedit.addfield pfield 'Add others miscellaneous text field Set pfield = New esricore.field Set pfieldedit = pfield With pfieldedit.name = "SmallInteger".Type = esrifieldtypesmallinteger End With pfieldsedit.addfield pfield Set pfield = New esricore.field Set pfieldedit = pfield With pfieldedit.name = "Integer".Type = esrifieldtypeinteger End With pfieldsedit.addfield pfield Set pfield = New esricore.field Set pfieldedit = pfield With pfieldedit.name = "Single".Type = esrifieldtypesingle End With pfieldsedit.addfield pfield Set pfield = New esricore.field Set pfieldedit = pfield With pfieldedit.precision = 5.Scale = 5.Name = "Double".Type = esrifieldtypedouble End With pfieldsedit.addfield pfield Set pfield = New esricore.field Set pfieldedit = pfield With pfieldedit.length = 30.Name = "String" 41

42 .Type = esrifieldtypestring End With pfieldsedit.addfield pfield Set pfield = New esricore.field Set pfieldedit = pfield With pfieldedit.name = "Date".Type = esrifieldtypedate End With pfieldsedit.addfield pfield 'Create the shapefile '(some parameters apply to geodatabase options and can be defaulted as Nothing) Set pfeatclass = pfeatureworkspace.createfeatureclass _ (sfilename, pfields, Nothing, Nothing, _ esriftsimple, sshapefieldname, "") snewshapefilename = Dir(sFilePath & "\MyShapeFile.shp") If (snewshapefilename = "") Then MsgBox ("Build Success") Else MsgBox ("Build Fail") Private Sub UIButtonControl1_Click() Dim pvbproject As VBProject On Error GoTo Set pvbproject = ThisDocument.VBProject 'Dont include.shp extension CreatShapeFile pvbproject.filename & "\..\..\..\.." & "\data\", "MyShapeFile" Private Sub UIButtonControl1_Click() Dim pvbproject As VBProject On Error GoTo Set pvbproject = ThisDocument.VBProject 'Dont include.shp extension CreatShapeFile pvbproject.filename & "\..\..\..\.." & "\data\", "MyShapeFile" 如何创建 DBF 文件本例要实现的是如何创建一个单独的 DBF 文件 要点 42

43 首先设定 DBF 文件的字段个数, 再创建新的 IField 对象, 生成新字段, 设 置其属性, 再加入到 IFields 对象中, 最后用 IFeatureWorkspace.CreateTable 方法 创建一个新的 DBF 文件并返回 ITable 对象 主要用到 IField 接口,IFieldEdit 接口,IFields 接口,IFieldsEdit 接口 程序说明 函数 CreateDBF 根据输入的路径和文件名创建一个 DBF 文件并返回一个 ITable 对象 代码 Private Function CreateDBF (sfilepath As String, sfilename As String) As ITable 'createdbf: simple function to create a DBASE file. 'note: the name of the DBASE file should not contain the.dbf extension On Error GoTo Dim pfeatureworkspace Dim pworkspacefactory Dim FileFolder Dim pfieldsedit Dim pfieldedit Dim pfields Dim pfield Dim sdir As IFeatureWorkspace As IWorkspaceFactory As New Scripting.FileSystemObject As esricore.ifieldsedit As esricore.ifieldedit As IFields As IField As String 'Open the Workspace Set pworkspacefactory = New ShapefileWorkspaceFactory If Not FileFolder.FolderExists(sFilePath) Then MsgBox " 路径不存在 " & vbcr & sfilepath Exit Function sdir = Dir(sFilePath & sfilename & ".dbf") If (sdir <> "") Then MsgBox (" 文件已存在 ") Exit Function Set pfeatureworkspace = pworkspacefactory.openfromfile(sfilepath, 0) 'if a fields collection is not passed in then create one 'create the fields used by our object Set pfields = New esricore.fields Set pfieldsedit = pfields pfieldsedit.fieldcount = 6 'Create text Fields Set pfield = New Field Set pfieldedit = pfield With pfieldedit.name = "SmallInteger".Type = esrifieldtypesmallinteger End With Set pfieldsedit.field(0) = pfield 43

44 Set pfield = New Field Set pfieldedit = pfield With pfieldedit.name = "Integer".Type = esrifieldtypeinteger End With Set pfieldsedit.field(1) = pfield Set pfield = New Field Set pfieldedit = pfield With pfieldedit.name = "Single".Type = esrifieldtypesingle End With Set pfieldsedit.field(2) = pfield Set pfield = New Field Set pfieldedit = pfield With pfieldedit.precision = 5.Scale = 5.Name = "Double".Type = esrifieldtypedouble End With Set pfieldsedit.field(3) = pfield Set pfield = New Field Set pfieldedit = pfield With pfieldedit.length = 30.Name = "String".Type = esrifieldtypestring End With Set pfieldsedit.field(4) = pfield Set pfield = New Field Set pfieldedit = pfield With pfieldedit.name = "Date".Type = esrifieldtypedate End With Set pfieldsedit.field(5) = pfield Set createdbf = pfeatureworkspace.createtable(sfilename, pfields, Nothing, Nothing, "") sdir = Dir(sFilePath & sfilename & ".dbf") If (sdir <> "") Then MsgBox ("Build Success") Else MsgBox ("Build Fail") Exit Function End Function Private Sub UIButtonControl1_Click() 44

45 Dim pvbproject Dim ptable As VBProject As ITable On Error GoTo Set pvbproject = ThisDocument.VBProject 'Dont include.dbf extension Set ptable = CreateDBF (pvbproject.filename & "\..\..\..\.." & "\data\", "MyDBFFile") 如何创建 GeoDataBase 文件 要点 本例要实现的是如何创建一个 GeoDataBase 文件 定义 IWorkspaceFactory 接口对象, 并用 esricore. AccessWorkspaceFactory 类 来实现, 再调用 IWorkspaceFactory.Create 方法创建一个 GeoDataBase 文件 主要用到了 IWorkspaceFactory 接口 程序说明 函数 CreateAccessWorkspace 根据要创建的 GeoDataBase 文件所在路径 sfilepath 和文件名 sfilename 创建 GeoDataBase 文件 代码 Private Function CreateAccessWorkspace(sFilePath As String, sfilename As String) Dim pworkspacefactory As IWorkspaceFactory Dim sdir As String On Error GoTo sdir = Dir(sFilePath & sfilename & ".mdb") If (sdir <> "") Then MsgBox (" 文件已存在 ") Exit Function 'create the Access Workspace factory Set pworkspacefactory = New esricore.accessworkspacefactory pworkspacefactory.create sfilepath, sfilename, Nothing, 0 sdir = Dir(sFilePath & sfilename & ".mdb") If (sdir <> "") Then MsgBox ("Build Success") Else MsgBox ("Build Fail") Exit Function End Function 45

46 Private Sub UIButtonControl1_Click() Dim pvbproject As VBProject On Error GoTo Set pvbproject = ThisDocument.VBProject 'Dont include.mdb extension CreateAccessWorkspace pvbproject.filename & "\..\..\..\.." & "\data\", "MyGEODataFile" 如何创建 Coverage 文件 要点 本例要实现的是如何创建一个 Coverage 文件 首先为 IWorkspaceFactory 接口创建一个 ArcInfoWorkspaceFactory 的实例, 然后根据路径 sworkspacepath 使用 IWorkspaceFactory.Create 方法和 IWorkspaceFactory.Open 方法, 获得一个名为 sworkspacename 的 ArcInfo Workspace, 最后使用 IArcInfoWorkspace. CreateCoverage 方法创建一个名为 sfilename 的 Coverage 文件 口 主要用到 IWorkspaceFactory 接口,IArcInfoWorkspace 接口和 IPropertySet 接 程序说明 函数 CreateCoverageFile 根据路径 sworkspacepath 和名称 sworkspacename 创 建一个 ArcInfo Workspace, 再在其中创建名为 sfilename 的 Coverage 文件 代码 Private Sub CreateCoverageFile(ByVal sworkspacepath As String, _ ByVal sworkspacename As String, ByVal sfilename As String) Dim pworkspacefactory Dim parcinfoworkspace Dim ppropertyset Dim pfeaturedataset Dim stemplatecoverage Dim scoveragefile As IWorkspaceFactory As IArcInfoWorkspace As IPropertySet As IFeatureDataset As String As String On Error GoTo scoveragefile = Dir(sWorkspacePath & "\" & sworkspacename & "\" & sfilename, vbdirectory) If (scoveragefile <> "") Then MsgBox (" 文件已经存在 ") Set pfeaturedataset = Nothing 46

47 Set ppropertyset = New PropertySet ppropertyset.setproperty "SERVER", sworkspacename Set pworkspacefactory = New ArcInfoWorkspaceFactory 'create an arcinfoworkspace pworkspacefactory.create sworkspacepath, sworkspacename, ppropertyset, 0 ppropertyset.setproperty "DATABASE", sworkspacepath & "\" & sworkspacename 'parcinfoworkspace is a pointer to the IArcInfoWorkspace Set parcinfoworkspace = pworkspacefactory.open(ppropertyset, 0) 'create a coverage without a template Set pfeaturedataset = parcinfoworkspace.createcoverage(sfilename, "", _ esricoverageprecisiondouble) ' ' ' ' or use the methods on iarcinfoworkspace stemplatecoverage = "C:\arcgis\arcexe83\arcobjects developer kit\samples\data\canada\canada" Set pfeaturedataset = parcinfoworkspace.createcoverage(sfilename, stemplatecoverage, _ esricoverageprecisiondouble) If (pfeaturedataset Is Nothing) Then MsgBox ("Build Success") Else MsgBox ("Build Fail") Private Sub UIButtonControl1_Click() Dim pvbproject As VBProject On Error GoTo Set pvbproject = ThisDocument.VBProject CreateCoverageFile pvbproject.filename & "\..\..\..\.." & "\data", _ "MyArcInfoWorkspace", "MyCoverFile" 如何建立文件连接 (Join / Link) 本例实现的是如何将地图中的一个 FeatureLayer 的属性表与另一个数据文件建立连接 要点首先需要定义两个 ITable 接口对象, 分别用来获得地图中的属性表和需要连接的数据文件, 再通过 IMemoryRelationshipClassFactory.Open 方法将两个 ITable 接口对象根据某个关键字段建立连接, 47

48 最后使用 IDisplayRelationshipClass.DisplayRelationshipClass 方法将显示该连接 主要用到 IMemoryRelationshipClassFactory 接口,IRelationshipClass 接口和 IDisplayRelationshipClass 接口 程序说明 函数 Join 是将当前激活的地图中名称为 slayername 的图层和路径为 sfilepath 文件名为 sfilename 的文件按字段名为 sfieldname 的字段进行连接 代码 Private Function Join(ByVal slayername As String, ByVal sfilepath As String, _ ByVal sfilename As String, ByVal sfieldname As String) As Boolean Dim pmxdocument Dim pmap Dim pworkspacefactory Dim pworkspace Dim pfeatureworkspace Dim pfeaturelayer Dim pfeatureclass Dim pprimarytable Dim pforeigntable Dim pdisplaytable Dim pmemoryrelationshipcf Dim prelationshipclass Dim pdisplayrelationshipc Dim nnumber Dim sforeignfile As IMxDocument As IMap As IWorkspaceFactory As IWorkspace As IFeatureWorkspace As IFeatureLayer As IFeatureClass As ITable As ITable As IDisplayTable As IMemoryRelationshipClassFactory As IRelationshipClass As IDisplayRelationshipClass As Integer As String On Error GoTo Join = False sforeignfile = Dir(sFilePath & "\" & sfilename) If (sforeignfile = "") Then MsgBox "The ForeignFile is not exist." Exit Function Set pworkspacefactory = New ShapefileWorkspaceFactory Set pworkspace = pworkspacefactory.openfromfile(sfilepath, 0) Set pfeatureworkspace = pworkspace Set pforeigntable = pfeatureworkspace.opentable(sfilename) Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap For nnumber = 0 To pmap.layercount - 1 If pmap.layer(nnumber).name = slayername Then Set pfeaturelayer = pmap.layer(nnumber) Exit For Next If pfeaturelayer Is Nothing Then MsgBox "No Layer's Name is " & slayername Exit Function Set pdisplaytable = pfeaturelayer 48

49 Set pfeatureclass = pdisplaytable.displaytable Set pprimarytable = pfeatureclass Set pmemoryrelationshipcf = New MemoryRelationshipClassFactory Set prelationshipclass = pmemoryrelationshipcf.open("tabletolayer", pprimarytable, sfieldname, _ pforeigntable, sfieldname, "forward", "backward", esrirelcardinalityonetoone) Set pdisplayrelationshipc = pfeaturelayer pdisplayrelationshipc.displayrelationshipclass prelationshipclass, esrileftouterjoin Join = True Exit Function End Function Private Sub UIButtonControl1_Click() Dim pvbproject As VBProject On Error GoTo Set pvbproject = ThisDocument.VBProject Join "WorldCountries", pvbproject.filename & "\..\..\..\.." & "\data", "Continents.dbf", "FID" 如何浏览纪录 ( 属性查询 ) 要点 本例实现的是如何按照给定的查询要求, 找出满足要求的记录 创建 IQueryFilter 接口对象, 设置 IQueryFilter.WhereClause 属性为属性查询条 件, 使用 IFeatureClass.Search 方法进行查询, 返回 ICursor 接口对象 主要用到了 IFeatureClass 接口 IFeature 接口 IFeatureCursor 接口和 IQueryFilter 接口 程序说明 记录 代码 函数 SelectFeatures 在当前激活的 Map 的第一个图层中查出 "FID < 2" 的所有 Private Sub SelectFeatures() Dim pmxdocument Dim pmap Dim pfeaturelayer Dim pfeatureclass Dim pfeature Dim pfeaturecursor Dim pqueryfilter On Error GoTo Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap If (pmap.layercount = 0) Then MsgBox (" 缺少数据 ") As IMxDocument As IMap As IFeatureLayer As IFeatureClass As IFeature As IFeatureCursor As IqueryFilter 49

50 Set pfeaturelayer = pmap.layer(0) Set pfeatureclass = pfeaturelayer.featureclass Set pqueryfilter = New QueryFilter pqueryfilter.whereclause = "FID < 2" Set pfeaturecursor = pfeatureclass.search(pqueryfilter, False) Set pfeature = pfeaturecursor.nextfeature Do While Not pfeature Is Nothing 'More Operations Set pfeature = pfeaturecursor.nextfeature Loop Private Sub UIButtonControl1_Click() On Error GoTo SelectFeatures 如何编辑记录 要点 本例实现的是如何修改 FeatureClass 中某条记录 (Feature) 的值 通过 IFeatureClass.Update 方法获得可修改记录的 IFeatureCursor 接口对象, 使用 IFeatureCursor.NextFeature 方法获得 Ifeatur 接口对象, 修改其属性值, 通过 IFeatureCursor.UpdateFeature 方法提交 IFeature 修改内容 主要用到 IFeatureCursor 接口 程序说明 象 代码 函数 OpenFeatureClass 获得当前激活的 Map 中第一层的 IFeatureClass 接口对 函数 EditFeature 修改 pfeatureclass 中第一条记录的第七个字段的值 Private Function EditFeature(pFeatureClass As IFeatureClass) As Boolean Dim pfeature As IFeature Dim pfeaturecursor As IFeatureCursor On Error GoTo EditFeature = False If (pfeatureclass Is Nothing) Then Exit Function 50

51 Set pfeaturecursor = pfeatureclass.update(nothing, False) Set pfeature = pfeaturecursor.nextfeature If (Not pfeature Is Nothing) Then pfeature.value(6) = "New Place" pfeaturecursor.updatefeature pfeature MsgBox (" 修改成功 ") EditFeature = True Else MsgBox (" 修改失败 ") Exit Function End Function Private Function OpenFeatureClass() As IFeatureClass Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pfeaturelayer As IFeatureLayer Dim pfeatureclass As IFeatureClass On Error GoTo Set OpenFeatureClass = Nothing Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap If (pmap.layercount = 0) Then MsgBox (" 缺少数据 ") Exit Function Set pfeaturelayer = pmap.layer(0) Set pfeatureclass = pfeaturelayer.featureclass Set OpenFeatureClass = pfeatureclass Exit Function End Function Private Sub UIButtonControl1_Click() On Error GoTo Dim pfeatureclass As IFeatureClass Set pfeatureclass = OpenFeatureClass() EditFeature pfeatureclass 如何增加记录 要点 本例要实现的是如何在 FeatureClass 中新增一条记录 (Feature) 51

52 通过 IFeatureClass.Insert 方法获得可插入记录的游标 IFeatureCursor, 然后使 用 IFeatureClass.CreateFeatureBuff 方法获得 IFeatureBuffer 接口实例, 使用 IFeatureCursor.InsertFeature 方法插入记录 主要用到 IFeatureCursor 接口 程序说明 象 代码 函数 OpenFeatureClass 获得当前激活的 Map 中第一层的 IFeatureClass 接口对 函数 InsertFeature 在 pfeatureclass 中添加一条记录 Private Function InsertFeature(pFeatureClass As IFeatureClass) As Boolean Dim pfeaturecursor As IFeatureCursor Dim pfeaturebuffer As IFeatureBuffer Dim nfeaturenumber As Integer On Error GoTo InsertFeature = False If (pfeatureclass Is Nothing) Then Exit Function Set pfeaturecursor = pfeatureclass.insert(true) Set pfeaturebuffer = pfeatureclass.createfeaturebuffer nfeaturenumber = -1 pfeaturebuffer.value(6) = "Insert Land" nfeaturenumber = pfeaturecursor.insertfeature(pfeaturebuffer) If (nfeaturenumber <> -1) Then MsgBox (" 添加了第 " & nfeaturenumber & " 条记录 ") InsertFeature = True Else MsgBox (" 添加失败 ") InsertFeature = False Exit Function End Function Private Function OpenFeatureClass() As IFeatureClass Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pfeaturelayer As IFeatureLayer Dim pfeatureclass As IFeatureClass On Error GoTo Set OpenFeatureClass = Nothing Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap If (pmap.layercount = 0) Then 52

53 MsgBox (" 缺少数据 ") Exit Function Set pfeaturelayer = pmap.layer(0) Set pfeatureclass = pfeaturelayer.featureclass Set OpenFeatureClass = pfeatureclass Exit Function End Function Private Sub UIButtonControl1_Click() On Error GoTo Dim pfeatureclass As IFeatureClass Set pfeatureclass = OpenFeatureClass() InsertFeature pfeatureclass 如何删除记录 要点 本例要实现的是如何在 FeatureClass 中删除一条记录 (Feature) 获得游标 IFeatureCursor, 然后定义 IFeature 接口对象, 并获得要删除的记 录, 最后使用 IFeature.Delete 方法删除记录 主要用到 IFeature 接口和 IFeatureCursor 接口 程序说明 象 代码 函数 OpenFeatureClass 获得当前激活的 Map 中第一层的 IFeatureClass 接口对 函数 DeleteFeature 删除 PLACENAME 字段值为 Insert Land 的所有记录 Private Sub DeleteFeature(pFeatureClass As IFeatureClass) Dim pfeature As IFeature Dim pfeaturecursor As IFeatureCursor Dim pqueryfilter As IQueryFilter Dim nfeaturenumber As Integer On Error GoTo If (pfeatureclass Is Nothing) Then Set pqueryfilter = New QueryFilter pqueryfilter.whereclause = "PLACENAME = 'Insert Land'" Set pfeaturecursor = pfeatureclass.search(pqueryfilter, False) Set pfeature = pfeaturecursor.nextfeature nfeaturenumber = 0 53

54 Do While Not pfeature Is Nothing pfeature.delete nfeaturenumber = nfeaturenumber + 1 Set pfeature = pfeaturecursor.nextfeature Loop MsgBox ("Delete " & nfeaturenumber & " Features") Private Function OpenFeatureClass() As IFeatureClass Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pfeaturelayer As IFeatureLayer Dim pfeatureclass As IFeatureClass On Error GoTo Set OpenFeatureClass = Nothing Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap If (pmap.layercount = 0) Then MsgBox (" 缺少数据 ") Exit Function Set pfeaturelayer = pmap.layer(0) Set pfeatureclass = pfeaturelayer.featureclass Set OpenFeatureClass = pfeatureclass Exit Function End Function Private Sub UIButtonControl1_Click() On Error GoTo Dim pfeatureclass As IFeatureClass Set pfeatureclass = OpenFeatureClass() DeleteFeature pfeatureclass 如何纪录排序 (ITableSort) 本例要实现的是如何将一个 FeatureClass 中的数据按某字段的值进行排序 要点定义 ITableSort 接口对象, 并用 TableSort 类实现之, 设置排序所用到的字段 排序方式 ( 升序或降序 ) 以及排序的数据源, 然后使用 ITableSort.Sort 方法进行排序 主要用到 ITableSort 接口 54

55 程序说明 象 函数 OpenFeatureClass 获得当前激活的 Map 中第一层的 IFeatureClass 接口对 函数 SortFeatures 按照 pfeatureclass 的第五个字段值对 pfeatureclass 的数据 进行从小到大排序, 并返回一个排好序的 ICursor 接口对象 代码 Private Function SortFeatures(pFeatureClass As IFeatureClass) As ICursor Dim ptablesort As ITableSort Dim pfields As IFields Dim pfield As IField Dim pqueryfilter As IQueryFilter Dim pcursor As ICursor On Error GoTo Set SortFeatures = Nothing Set pfields = pfeatureclass.fields Set pfield = pfields.field(5) Set ptablesort = New esricore.tablesort Set pqueryfilter = New QueryFilter Set pcursor = Nothing With ptablesort.fields = pfield.name.ascending(pfield.name) = True.CaseSensitive(pField.Name) = True Set.QueryFilter = pqueryfilter Set.Table = pfeatureclass End With ptablesort.sort Nothing Set pcursor = ptablesort.rows Set SortFeatures = pcursor If (pcursor Is Nothing) Then MsgBox (" 未排序 ") Else MsgBox (" 排序完成 ") Exit Function End Function Private Function OpenFeatureClass() As IFeatureClass Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pfeaturelayer As IFeatureLayer Dim pfeatureclass As IFeatureClass On Error GoTo Set OpenFeatureClass = Nothing Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap If (pmap.layercount = 0) Then 55

56 MsgBox (" 缺少数据 ") Exit Function Set pfeaturelayer = pmap.layer(0) Set pfeatureclass = pfeaturelayer.featureclass Set OpenFeatureClass = pfeatureclass Exit Function End Function Private Sub UIButtonControl1_Click() On Error GoTo Dim pfeatureclass As IFeatureClass Set pfeatureclass = OpenFeatureClass() SortFeatures pfeatureclass Private Sub UIButtonControl1_Click() On Error GoTo Dim pfeatureclass As IFeatureClass Set pfeatureclass = OpenFeatureClass() SortFeatures pfeatureclass 如何添加字段 要点 本例实现的是如何在一个 FeatureClass 中新增一个字段 (Field) 定义 IField 接口对象, 并用 Field 类实现, 通过 IFieldEdit 接口对象设置 IField 接口对象的属性, 最后通过 IFeatureClass.AddField 方法添加一个字段 主要用到 IField 接口 IFieldEdit 接口和 IFeatureClass 接口 程序说明 象 代码 函数 OpenFeatureClass 获得当前激活的 Map 中第一层的 IFeatureClass 接口对 函数 AddField 生成一个新的字段 (Field) 并添加到 pfeatureclass 中 Private Function AddField(pFeatureClass As IFeatureClass) As Boolean Dim pfield As IField Dim pfieldedit As IFieldEdit On Error GoTo AddField = False 56

57 If (pfeatureclass Is Nothing) Then Exit Function Set pfield = New esricore.field Set pfieldedit = pfield With pfieldedit.length = 10.Name = "NewField".Type = esrifieldtypestring End With pfeatureclass.addfield pfield MsgBox (" 已添加新字段 :" & " AddField = True Exit Function End Function " & pfield.name) Private Function OpenFeatureClass() As IFeatureClass Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pfeaturelayer As IFeatureLayer Dim pfeatureclass As IFeatureClass On Error GoTo Set OpenFeatureClass = Nothing Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap If (pmap.layercount = 0) Then MsgBox (" 缺少数据 ") Exit Function Set pfeaturelayer = pmap.layer(0) Set pfeatureclass = pfeaturelayer.featureclass Set OpenFeatureClass = pfeatureclass Exit Function End Function Private Sub UIButtonControl1_Click() On Error GoTo Dim pfeatureclass As IFeatureClass Set pfeatureclass = OpenFeatureClass() AddField pfeatureclass 如何删除字段 本例实现的是如何在一个 FeatureClass 中删除一个字段 (Field) 57

58 要点 定义 IField 接口实例, 并使用 Field 类实现, 使用 IFields.FindField 方法和 IFields.Field 方法获得 IFeatureClass 中要删除的字段, 最后用 IFeatureClass.DeleteField 方法删除字段 主要用到 IFields 接口,IField 接口和 IFeatureClass 接口 程序说明 象 代码 函数 OpenFeatureClass 获得当前激活的 Map 中第一层的 IFeatureClass 接口对 函数 DeleteField 删除 pfeatureclass 中字段名为 NewField 的字段 Private Function DeleteField(pFeatureClass As IFeatureClass) As Boolean Dim pfields As IFields Dim pfield As IField Dim lfieldnumber As Long On Error GoTo DeleteField = False If (pfeatureclass Is Nothing) Then Exit Function Set pfields = pfeatureclass.fields lfieldnumber = pfields.findfield("newfield") If (lfieldnumber = -1) Then MsgBox (" 无此字段 ") Exit Function Set pfield = pfields.field(lfieldnumber) pfeatureclass.deletefield pfield MsgBox (" 已删除字段 :" & "NewField") DeleteField = True Exit Function End Function Private Function OpenFeatureClass() As IFeatureClass Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pfeaturelayer As IFeatureLayer Dim pfeatureclass As IFeatureClass On Error GoTo Set OpenFeatureClass = Nothing Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap If (pmap.layercount = 0) Then MsgBox (" 缺少数据 ") 58

59 Exit Function Set pfeaturelayer = pmap.layer(0) Set pfeatureclass = pfeaturelayer.featureclass Set OpenFeatureClass = pfeatureclass Exit Function End Function Private Sub UIButtonControl1_Click() On Error GoTo Dim pfeatureclass As IFeatureClass Set pfeatureclass = OpenFeatureClass() DeleteField pfeatureclass 如何进行空间查询 本例实现的是在一个图层上画一个 polygon, 根据该 polygon 查询出图层上 与之相交的 polygon 并高亮显示出来 要点 通过 RubberPolygon 类来实现接口 IRubberBand 接口对象, 用 IRubberBand.TrackNew 方法在图层上画出 polygon, 然后定义 IGeometry 获得该 polygon, 创建 ISpatialFilter 接口对象实现过滤功能, 通过 ILayer 接口实例获得 IFeatureSelection 接口, 调用 IFeatureSelection.SelectFeatures 方法将结果高亮显示 程序说明 代码 过程 UIToolControl1_MouseDown 是实现模块 Option Explicit Private Function UIToolControl1_Deactivate() As Boolean UIToolControl1_Deactivate = True End Function Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim pmxdoc As IMxDocument Dim pactiveview As IActiveView Dim pscreendisplay As IScreenDisplay Dim prubberpolygon As IRubberBand Dim pfillsymbol As ISimpleFillSymbol Dim prgbcolor As IRgbColor Dim ppolygon As IPolygon 59

60 Dim pgeometry Dim pfeatselect Dim pspatialfilter As IGeometry As IFeatureSelection As ISpatialFilter On Error GoTo Set pmxdoc = ThisDocument Set pactiveview = pmxdoc.focusmap 'Draw Polygon Set pscreendisplay = pactiveview.screendisplay Set prubberpolygon = New RubberPolygon Set pfillsymbol = New SimpleFillSymbol Set prgbcolor = New RgbColor prgbcolor.nullcolor = True pfillsymbol.color = prgbcolor Set ppolygon = prubberpolygon.tracknew(pscreendisplay, pfillsymbol) With pscreendisplay.startdrawing pscreendisplay.hdc, esrinoscreencache.setsymbol pfillsymbol.drawpolygon ppolygon.finishdrawing End With 'set up pfilter Set pgeometry = ppolygon Set pspatialfilter = New SpatialFilter With pspatialfilter Set.Geometry = pgeometry.spatialrel = esrispatialrelintersects End With 'select Set pfeatselect = pmxdoc.focusmap.layer(0) pfeatselect.selectfeatures pspatialfilter, esriselectionresultnew, False pfeatselect.selectionset.refresh pmxdoc.activeview.refresh 如何进行高级空间查询 ( 两个层之间的空间查询 ) 本例实现的是在 Map 的两个 Poylgon 图层中, 查询出第一个 Polygon 层中的 Poylgon 被第二个 Polygon 层的 Polygon 包含的所有记录 要点定义 IGeometryCollection 接口实例, 并使用 GeometryBag 类实现, 将查询图层所有记录的图形信息添加进去 创建 ISpatialFilter 接口实例来设置空间查询运算符, 本例设为 esrispatialrelcontains 通过查询层 Featurelayer 获得 IFeatureSelection 接口实例, 最后使用 IFeatureSelection.SelectFeatures 方法实现本 60

61 例 程序说明 代码 本例使用的数据为 WorldCountries.shp 和 USUrbanAreas.shp 过程 UIButtonControl1_Click 是实现模块 Option Explicit Private Sub UIButtonControl1_Click() Dim pmxdoc Dim pmap Dim pqueryfeatlayer Dim pfeatlayer Dim pfeatureclass Dim pinfeaturecursor Dim poutfeaturecursor Dim pfeature Dim pfeatselect Dim pfilter Dim pgeocollection On Error GoTo Err_Handle: Set pmxdoc = ThisDocument Set pmap = pmxdoc.focusmap As IMxDocument As IMap As IFeatureLayer As IFeatureLayer As IFeatureClass As IFeatureCursor As IFeatureCursor As IFeature As IFeatureSelection As ISpatialFilter As IGeometryCollection 'according to the name of layers to set up featurelayer If pmap.layer(1).name = "WorldCountries" Then Set pfeatlayer = pmap.layer(1) Set pqueryfeatlayer = pmap.layer(0) Else Set pfeatlayer = pmap.layer(0) Set pqueryfeatlayer = pmap.layer(1) Set pfeatureclass = pfeatlayer.featureclass Set pgeocollection = New esricore.geometrybag Set poutfeaturecursor = pfeatureclass.search(nothing, False) Set pfeature = poutfeaturecursor.nextfeature ' add feature into pgeocollection Do While Not pfeature Is Nothing pgeocollection.addgeometry pfeature.shape Set pfeature = poutfeaturecursor.nextfeature Loop Set pfilter = New SpatialFilter 'set up pfilter With pfilter Set.Geometry = pgeocollection.geometryfield = "Shape".SpatialRel = esrispatialrelcontains End With Set pfeatselect = pqueryfeatlayer 'filter the features and display the results in screen pfeatselect.selectfeatures pfilter, esriselectionresultnew, False 61

62 pfeatselect.selectionset.refresh pmxdoc.activeview.refresh Err_Handle: 如何进行层与层之间的逻辑运算 本例要实现的是将两个同一 GeometryType 图层联合成为一个图层, 输出 Shape 文件, 并且加载到 Map 中显示出来 要点 定义 ITable 的两个接口变量, 通过两个图层 FeatureClass 实例化 然后由接 口 IFeatureClassName IWorkspaceName 和 IDatasetName 实现创建一个新的 shape 文件 再创建 IBasicGeoprocessor 接口对象, 使用 IBasicGeoprocessor.Union 方法 实现两个图层的联合 程序说明 代码 过程 UIButtonControl1_Click 是实现模块 Option Explicit Private Sub UIButtonControl1_Click() Dim pmxdoc As IMxDocument Dim player As ILayer Dim pinputtable As ITable Dim poverlaytable As ITable Dim pfeatclassname As IFeatureClassName Dim pnewwsname As IWorkspaceName Dim pdatasetname As IDatasetName Dim dtol As Double Dim pbasicgeop As IBasicGeoprocessor Dim poutputfeatclass As IFeatureClass Dim poutputfeatlayer As IFeatureLayer Dim App As VBProject On Error GoTo Set pmxdoc = ThisDocument Set player = pmxdoc.focusmap.layer(0) Set App = ThisDocument.VBProject ' Get the input table ' Use the Itable interface from the Layer (not from the FeatureClass) Set pinputtable = player ' Get the overlay layer and table ' Use the Itable interface from the Layer (not from the FeatureClass) Set player = pmxdoc.focusmap.layer(1) Set poverlaytable = player ' Error checking If pinputtable Is Nothing Then 62

63 MsgBox "Table QI failed" If poverlaytable Is Nothing Then MsgBox "Table QI failed" ' Define the output feature class name Set pfeatclassname = New FeatureClassName ' Set output location and feature class name Set pnewwsname = New WorkspaceName pnewwsname.workspacefactoryprogid = "esricore.shapefileworkspacefactory.1" pnewwsname.pathname = App.FileName & "\.." Set pdatasetname = pfeatclassname pdatasetname.name = "Union_result" Set pdatasetname.workspacename = pnewwsname ' Set the tolerance. Passing 0.0 causes the default tolerance to be used. ' The default tolerance is 1/10,000 of the extent of the data frame's spatial domain dtol = 0# ' Perform the union Set pbasicgeop = New BasicGeoprocessor Set poutputfeatclass = pbasicgeop.union(pinputtable, False, poverlaytable, False, _ dtol, pfeatclassname) ' Add the output layer to the map Set poutputfeatlayer = New FeatureLayer Set poutputfeatlayer.featureclass = poutputfeatclass poutputfeatlayer.name = poutputfeatclass.aliasname pmxdoc.focusmap.addlayer poutputfeatlayer 如何将 shape 文件转化成 GeoDataBase( 各种文件格式的转换 ) 本例演示的是如何将 shape 文件转化成 personal GeoDatabase 文件, 其它格式间的与此转换类似 主要用到 IFeatureDataConverter 接口的 ConvertFeatureClass 方法 要点 首先, 创建新的 GeoDataBase 数据库, 并创建 IFeatureDatasetName 对象 创 建定义两个 IFeatureClassName 接口对象分别引用输入表 (shape 文件 ) 和输出 表 63

64 然后设置输出表的 Shape 字段的 GeormetryDef 属性 这一步非常关键, 因 为其中包含了数据库和 shape 文件的空间参考信息 最后调用 IFeatureDataConverter.ConvertFeatureClass 方法完成功能 程序说明 过程 UIBConvert_Click 是实现模块, 调用过程 ConvertShapeToGeodatabase 实 现功能 sdatapath 定义了数据与工程文件的相对路径 SHAPE_NAME 描述了要转化 的 shape 文件的文件名 MDB_NAME 和 F_DS_NAME 分别描述了 Access 数据库 名和库的数据集的名称 代码 Option Explicit Private Sub UIBConvert_Click() Call ConvertShapeToGeodatabase Private Sub ConvertShapeToGeodatabase() Dim poutworkspacefactory As IWorkspaceFactory Dim poutworkspacename As IWorkspaceName Dim pinworkspacename As IWorkspaceName Dim poutfeaturedsname As IFeatureDatasetName Dim poutdsname As IDatasetName Dim pinfeatureclassname As IFeatureClassName Dim pindatasetname As IDatasetName Dim poutfeatureclassname As IFeatureClassName Dim poutdatasetname As IDatasetName Dim icounter As Long Dim poutfields As IFields Dim pinfields As IFields Dim pfieldchecker As IFieldChecker Dim pgeofield As IField Dim poutgeometrydef As IGeometryDef Dim poutgeometrydefedit As IGeometryDefEdit Dim pname As IName Dim pinfeatureclass As IFeatureClass Dim pshptofeatclsconverter As IFeatureDataConverter Dim pvbproject As VBProject Dim sdatapath As String Const SHAPE_NAME As String = "country" Const MDB_NAME As String = "countrydb" Const F_DS_NAME As String = "World" On Error GoTo ErrorHandler Set pvbproject = ThisDocument.VBProject sdatapath = pvbproject.filename & "\..\..\..\..\data\" If Not "" = Dir(sDataPath & MDB_NAME & ".mdb") Then MsgBox MDB_NAME & ".mdb already exist" 64

65 Else ' Create a new Access database Set poutworkspacefactory = New AccessWorkspaceFactory Set poutworkspacename = poutworkspacefactory.create(sdatapath, MDB_NAME, Nothing, 0) ' create a new feature datset name object for the output Access feature dataset, call ' it "World" Set poutfeaturedsname = New FeatureDatasetName Set poutdsname = poutfeaturedsname Set poutdsname.workspacename = poutworkspacename poutdsname.name = F_DS_NAME ' Get the name object for the input shapefile workspace Set pinworkspacename = New WorkspaceName pinworkspacename.pathname = sdatapath pinworkspacename.workspacefactoryprogid = _ "esricore.shapefileworkspacefactory.1" Set pinfeatureclassname = New FeatureClassName Set pindatasetname = pinfeatureclassname pindatasetname.name = SHAPE_NAME Set pindatasetname.workspacename = pinworkspacename ' Create the new output FeatureClass name object that will be passed ' into the conversion function Set poutfeatureclassname = New FeatureClassName Set poutdatasetname = poutfeatureclassname ' Set the new FeatureClass name to be the same as the input FeatureClass name poutdatasetname.name = pindatasetname.name ' Open the input Shapefile FeatureClass object, so that we can get its fields Set pname = pinfeatureclassname Set pinfeatureclass = pname.open ' Get the fields for the input feature class and run them through ' field checker to make sure there are no illegal or duplicate field names Set pinfields = pinfeatureclass.fields Set pfieldchecker = New FieldChecker pfieldchecker.validate pinfields, Nothing, poutfields ' Loop through the output fields to find the geometry field For icounter = 0 To poutfields.fieldcount If poutfields.field(icounter).type = esrifieldtypegeometry Then Set pgeofield = poutfields.field(icounter) Exit For Next icounter ' Get the geometry field's geometry definition Set poutgeometrydef = pgeofield.geometrydef ' Give the geometry definition a spatial index grid count and grid size Set poutgeometrydefedit = poutgeometrydef poutgeometrydefedit.gridcount = 1 poutgeometrydefedit.gridsize(0) = ' Now use IFeatureDataConverter::Convert to create the output FeatureDataset and ' FeatureClass. 65

66 Set pshptofeatclsconverter = New FeatureDataConverter pshptofeatclsconverter.convertfeatureclass pinfeatureclassname, Nothing, _ poutfeaturedsname, poutfeatureclassname, Nothing, poutfields, "", 1000, 0 MsgBox "Convert operation complete!", vbinformation 如何将 Map 中显示的图形转化成栅格文件 要点 本例要实现的是如何将当前激活的 Map 中显示的图形转化成栅格文件 通过 IMap 实例获得 IActiveView 接口对象, 定义 IExporter 接口变量, 使用 TiffExporter 实现该接口并对其中的属性进行赋值, 使用 IActiveView.Output 方 法将 Map 中显示的图形导出 主要用到 IActiveView 接口,IExporter 接口和 IEnvelope 接口 程序说明 函数 Output 将当前激活的 Map 中显示的图形转化成栅格文件, 栅格文件路 径及名称由参数 sfileallname 确定 代码 Private Sub Output(ByVal sfileallname As String) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView Dim pexporter As IExporter Dim penvelope As IEnvelope Dim ptagrect As tagrect Dim ptrackcancel As ITrackCancel Dim lscreenresolution As Long On Error GoTo Set pmxdocument = ThisDocument Set pactiveview = pmxdocument.activeview lscreenresolution = pactiveview.screendisplay.displaytransformation.resolution ptagrect.top = 0 ptagrect.left = 0 ptagrect.right = pactiveview.extent.width ptagrect.bottom = pactiveview.extent.height 'We must calculate the size of the user specified Rectangle in Device units 'Hence convert width and height Set penvelope = New Envelope penvelope.putcoords ptagrect.left, ptagrect.bottom, ptagrect.right, ptagrect.top Set pexporter = New TiffExporter pexporter.resolution = lscreenresolution 66

67 pexporter.exportfilename = sfileallname pexporter.pixelbounds = penvelope Set ptrackcancel = New CancelTracker pactiveview.output pexporter.startexporting, lscreenresolution, _ ptagrect, pactiveview.extent, ptrackcancel pexporter.finishexporting Private Sub UIButtonControl1_Click() Dim pvbproject As VBProject On Error GoTo Set pvbproject = ThisDocument.VBProject Output pvbproject.filename & "\..\..\..\.." & "\data\mytiffile.tif" 如何打开选中的层或独立表的属性窗口 本例实现的是如何打开选中的层或独立表的属性窗口 (Attribute Table) 主要用到 ITableWindow 和 ITableWindow2 接口 要点 首先需要选中一个层或独立表 可在 UI Button Cotrol 的 Enabled 事件中测试 用户选定了有效的对象后, 才使按钮有效 对象 然后判断属性窗口是否已经打开 如果尚未打开, 则创建新的 ITableView2 程序说明 过程 UIBAttributeWindow_Click 调用过程 OpenAttribWnd 实现功能 函数 UIBAttributeWindow_Enabled 用来测试用户是否已正确选中了层或独立 表, 如果是, 则使按钮有效 示 代码 过程 OpenAttribWnd 是功能模块, 实现了属性窗口的测试和创建, 以及显 Option Explicit Private Sub UIBAttributeWindow_Click() Call OpenAttribWnd Private Function UIBAttributeWindow_Enabled() As Boolean Dim pmxdocument As IMxDocument 67

68 Dim pselecteditem As IUnknown Dim benabled As Boolean Set pmxdocument = ThisDocument Set pselecteditem = pmxdocument.selecteditem benabled = True ' Disable if the selected item is nothing or if ' it is not a layer or table If pselecteditem Is Nothing Then benabled = False ElseIf (TypeOf pselecteditem Is IFeatureLayer) Or (TypeOf pselecteditem Is IStandaloneTable) Then benabled = True UIBAttributeWindow_Enabled = benabled End Function Private Sub OpenAttribWnd() Dim pmxdocument Dim player Dim pstandalonetable Dim pselecteditem Dim ptablewindowexist Dim ptablewindow2 Dim bsetproperties As IMxDocument As ILayer As IStandaloneTable As IUnknown As ITableWindow As ITableWindow2 As Boolean On Error GoTo Set pmxdocument = ThisDocument Set pselecteditem = pmxdocument.selecteditem Set ptablewindow2 = New TableWindow ' Determine the selected item's type ' Exit sub if item is not a feature layer or standalone table If TypeOf pselecteditem Is IFeatureLayer Then Set player = pselecteditem Set ptablewindowexist = ptablewindow2.findvialayer(player) ' Check if a table already exist; if not create one If ptablewindowexist Is Nothing Then Set ptablewindow2.layer = player bsetproperties = True ElseIf TypeOf pselecteditem Is IStandaloneTable Then Set pstandalonetable = pselecteditem Set ptablewindowexist = ptablewindow2.findviastandalonetable(pstandalonetable) ' Check if a table already exists; if not, create one If ptablewindowexist Is Nothing Then Set ptablewindow2.standalonetable = pstandalonetable bsetproperties = True If bsetproperties Then ptablewindow2.tableselectionaction = esriselectfeatures ptablewindow2.showselected = False ptablewindow2.showaliasnamesincolumnheadings = True Set ptablewindow2.application = Application Else 68

69 Set ptablewindow2 = ptablewindowexist ' Ensure Table Is Visible If Not ptablewindow2.isvisible Then ptablewindow2.show True 如何拷贝属性表中的一行 本例要实现的是如何将所有属性表 ( Attribute Table) 中的行拷贝到 Windows 剪贴板, 使用户能使用文本编辑器等软件对选中的数据做进一步编辑, 从而满足特殊要求 行中的每个属性用半角字符的逗号, 分隔, 行间用换行符分隔 要点 首先需要取得某属性表中的所有选中记录的全部属性, 以一个字符串来存 储 因为在属性表中选取中记录 (Row) 后, 层中的相应记录 (Feature) 也将 选中 两种途径都能获得所需属性值 得到所需的字符串 sresult 后, 就可以将其拷贝到剪贴板 在 VB 中剪贴板 是全局对象 可像如下使用 : Clipboard.Clear Clipboard.SetText sresult 本例将在 VBA 中实现相同的功能 用到了 IGraphicsContianer IGraphicsContainerSelect ITextElement IElement IClipboardFormat 接口 程序说明 过程 UIBCopyRow_Click 是实现模块, 调用过程 CopyRow 实现功能 过程 CopyRow 将选中行的全部属性值 ( 忽略 Shape 属性 ) 连接成字符串, 然后创建 TextElement 对象, 并添加到 IGraphicsContainer 对象的选择集中, 再调用 TextClipboardFormat 的 Copy 方法, 把字符拷贝到 Windows 剪贴板 代码 Option Explicit Private Sub UIBCopyRow_Click() Call CopyRow Public Sub CopyRow() Dim pmxdocument As IMxDocument 69

70 Dim pmap Dim pactiveview Dim pgraphicscontainer Dim pgraphicscontainers Dim pfields Dim icounter Dim iindex Dim ptextelement Dim pelement Dim sresult Dim penumfeature Dim penumfeatures Dim pfeature Dim pclipboardformat As IMap As IActiveView As IGraphicsContainer As IGraphicsContainerSelect As IFields As Integer As Integer As ITextElement As IElement As String As IEnumFeature As IEnumFeatureSetup As IFeature As IClipboardFormat On Error GoTo ErrorHandler ' Used for string operation on the clipboard Set pclipboardformat = New TextClipboardFormat Set pmxdocument = ThisDocument Set pactiveview = pmxdocument.activatedview Set pmap = pmxdocument.focusmap Set pgraphicscontainer = pmap ' Get selected features to retieve their attribute values Set penumfeature = pmap.featureselection Set penumfeatures = penumfeature penumfeatures.allfields = True Set pfeature = penumfeature.next If pfeature Is Nothing Then MsgBox "No row selected" Set pfields = pfeature.fields icounter = pfields.fieldcount Do Until pfeature Is Nothing For iindex = 0 To icounter - 1 If Not TypeOf pfeature.value(iindex) Is IGeometry Then sresult = sresult & pfeature.value(iindex) & "," Next iindex ' Remove the trailing comma sresult = Left(sResult, Len(sResult) - 1) sresult = sresult & vbnewline Set pfeature = penumfeature.next Loop ' If you're tending to build a dll to implement the same function and ' programming in VB enviroment, simply use the next to statement ' to copy the string into windows clippboard ' Clipboard.Clear ' Clipboard.SetText sresult ' Otherwise, programe as follows ' Copy the string into clippboard using objects included in esricore ' To clear clippboard pclipboardformat.paste pmxdocument 70

71 pgraphicscontainer.deleteallelements ' Construct a new TextElement with the string to copy into clipboard Set ptextelement = New TextElement ptextelement.text = sresult Set pelement = ptextelement ' Point(100, 100) is for temporary use pelement.geometry = pactiveview.screendisplay.displaytransformation _.ToMapPoint(100, 100) Set pgraphicscontainer = pmap pgraphicscontainer.addelement pelement, 0 Set pgraphicscontainers = pgraphicscontainer pgraphicscontainers.unselectallelements pgraphicscontainers.selectelement pelement pclipboardformat.copy pmxdocument pgraphicscontainers.unselectelement pelement pgraphicscontainer.deleteelement pelement pactiveview.refresh 如何为当前层或独立表创建一个 Summary 表 本例要实现的是如何按某一字段 分组 (dissolve), 统计其它字段的数据信息摘要 ( 创建 Summary 表 ) 可得到的主要信息包括该字段值相同的每组记录中的记录数量 最大值 最小值 和 平均值等 主要用到 IBasicGeoprocessor 接口的 Dissolve 方法 要点 为当前层创建 Summary 表, 要得到当前层的引用, 并确定在其上执行 Dissolve 操作的字段 对独立表的操作方法与层的操作类似 程序说明 过程 UIBCreateSummaryTable_Click 是实现模块, 调用过程 CreateSummaryTable 实现功能 过程 CreateSummaryTable 中应先确认层 ( 例中为 states) 和要 Dissolve 的字段 ( 例中为 SUB_REGION) 存在, 同时要定义摘要表的名字 ( 本例为 SumStates) 然后指定执行 Dissolve 方法的操作符 ( 如 Minimum,Count,Average 等 ) 和在 其上施行操作的字段名 ( 例中为 AREA) 操作结果作为独立表添加到当前 Map 因为 Dissolve 方法参数表中的 输入表 和 输出数据集的名字 都是引 用, 为了避免多次调用过程使最终 SumStates 表中的结果不唯一, 每次执行 Dissolve 前, 将 SumStates 的已存内容删除 代码 71

72 Private Sub UIBCreateSummaryTable_Click() Call CreateSummaryTable Public Sub CreateSummaryTable() Dim pmxdocument Dim pmap Dim player Dim pfeatlayer Dim icount Dim pfeatureclass Dim ptable Dim pdataset Dim pworkspace Dim pworkspacedataset Dim pworkspacename Dim pouttablename Dim poutdatasetname Dim penumdataset Dim pbasicgeoprocessor Dim psumtable Dim pstandalonetable Dim pstandalonetablecoll As IMxDocument As IMap As ILayer As IFeatureLayer As Integer As IFeatureClass As ITable As IDataset As IWorkspace As IDataset As IName As ITableName As IDatasetName As IEnumDataset As IBasicGeoprocessor As ITable As IStandaloneTable As IStandaloneTableCollection ' Define current layer name and output table name Const slayername As String = "states" Const ssumtablename As String = "SumStates" Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap On Error GoTo ErrorHandler ' Find the layer named states For icount = 0 To pmap.layercount - 1 Set player = pmap.layer(icount) If TypeOf player Is IFeatureLayer Then If player.name = slayername Then Set pfeatlayer = player Exit For Next If pfeatlayer Is Nothing Then MsgBox "The " & slayername & " layer was not found" ' Get the workspace of the states layer Set pfeatureclass = pfeatlayer.featureclass 72

73 Set ptable = pfeatureclass Set pdataset = ptable Set pworkspace = pdataset.workspace Set pworkspacedataset = pworkspace Set pworkspacename = pworkspacedataset.fullname ' Set up the output table Set pouttablename = New TableName Set poutdatasetname = pouttablename poutdatasetname.name = ssumtablename Set poutdatasetname.workspacename = pworkspacename ' Make sure there is a field called SUB_REGION in the layer If ptable.findfield("sub_region") = -1 Then MsgBox "There must be a field named SUB_REGION in states" ' Check if SumStates.dbf file already exist: if yes, delete it Set penumdataset = pworkspace.datasets(esridttable) Set pworkspacedataset = penumdataset.next Do Until pworkspacedataset Is Nothing If pworkspacedataset.name = poutdatasetname.name Then pworkspacedataset.delete Exit Do Set pworkspacedataset = penumdataset.next Loop ' Perform the summarize. Note the summary fields string (minimum.sub_region...) ' below. This is a comma-delimited string that lists the generated summary ' fields. Each field must start with a keyword, and be followed by.fieldname, ' where fieldname is the name of a field in the original table. ' ' If you specify the Shape field, you must use the keyword 'Dissolve'. This ' is not used below since we are creating a non-spatial summary table. Set pbasicgeoprocessor = New BasicGeoprocessor Set psumtable = pbasicgeoprocessor.dissolve(ptable, False, "SUB_REGION", _ "Minimum.SUB_REGION, Count.SUB_REGION, Sum.AREA, Average.AREA," & _ "Minimum.AREA, Maximum.AREA, StdDev.AREA, Variance.AREA", _ poutdatasetname) ' add the table to map Set pstandalonetable = New StandaloneTable Set pstandalonetable.table = psumtable Set pstandalonetablecoll = pmap pstandalonetablecoll.addstandalonetable pstandalonetable ' Refresh the TOC pmxdocument.updatecontents MsgBox Err.Number & " " & Err.Description 73

74 如何利用用户定义的规则创建定制的排序利用 ITableSort 接口可以完成普通的对记录排序的功能 ITableSortCallBack 机制允许用户通过执行自定义的排序算法来完成定制的排序 本例演示了如何创建这样的用户类, 通过实现 ITableSortCallBack 接口来完成该功能 假设有如下原始数据 : 其中 Address 字段描述了道路 (Street) 的道路编号 (Street Number) 如 2805, 和道路名 (Stree Name) 如 Citrus Ave 现在要按道路名排序所有的记录 因为排序字段时必须忽略道路编号, 故需要自定排序规则 要点首先需要创建用户自定义的类, 并生成其实例 该类实现了 ITableSortCallBack 接口 然后把它的引用赋给 ITableSort 的 Compare 属性 最后用 ITableSort 的 Sort 方法完成排序 程序说明过程 UIBCustomSort_Click 是实现模块, 调用过程 CustomSort 实现功能 类模块 clstailsort 为自定义模块, 实现 ITalbeSortCallBack 接口 包括两个函数 :ITableSortCallBack_Compare( 用于定义字符串比较的规则 ) 和 Get_String( 用于得到地址字段的道路名部分 ) 过程 CustomSort 中创建 Tablesort 和 clstailsort 的实例, 并对结果进行排序, 然后调用过程 CreateTable, 将排序后的结果存入 C:\temp 目录的 NewSortTable.dbf 文件, 并作为独立表加入当前 Map 代码类模块 clstailsort Option Explicit ' Custom class for ITableSortCallBack ' ClassName: clstailsort 74

75 Implements ItableSortCallBack Private Function ITableSortCallBack_Compare(ByVal value1 As Variant, ByVal value2 As_ Variant,ByVal FieldIndex As Long, ByVal fieldsortindex As Long) As Long ' Custom table sort ' Get_string function gets the first block of characters (e.g street numbers) ' in each value. ' Comparison is then made on the remaining characters (e.g. street names). On Error GoTo ErrorHandler value1 = Get_String(value1) value2 = Get_String(value2) If value1 > value2 Then ITableSortCallBack_Compare = 1 ElseIf value1 < value2 Then ITableSortCallBack_Compare = -1 Else: value1 = value2 ITableSortCallBack_Compare = 0 Exit Function End Function Private Function Get_String(ByVal smystr As Variant) As Variant ' This function gets the tail of the string ' after the first block of characters Dim sfindstring As String Dim nposition As Integer Dim nstringlen As Integer On Error GoTo ErrorHandler nstringlen = Len(sMyStr) nposition = 1 Do Until nposition = nstringlen sfindstring = Mid(sMyStr, nposition, 1) If sfindstring = " " Then Exit Do nposition = nposition + 1 Loop Get_String = Mid(sMyStr, nposition + 1) Exit Function End Function 功能模块 Option Explicit Private pmxdocument As IMxDocument 75

76 Private pmap Private papplication Public Sub CustomSort() Dim pselecteditem Dim pstandalonetable Dim ptable Dim ptablesort Dim ptablesortcallback Dim pcursor Dim prow As IMap As IApplication As IUnknown As IStandaloneTable As ITable As ITableSort As ITableSortCallBack As ICursor As IRow On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set papplication = Application Set pselecteditem = pmxdocument.selecteditem If pselecteditem Is Nothing Then MsgBox "Nothing selectd.", vbexclamation ' If a table is selected ElseIf Not TypeOf pselecteditem Is IStandaloneTable Then MsgBox "No table selectd.", vbexclamation Else Set pstandalonetable = New esricore.standalonetable Set pstandalonetable = pselecteditem Set ptable = pstandalonetable.table ' Create a new custom TableSortCallBack and TableSort object ' Class clstailsort defined in Class Modules Set ptablesortcallback = New clstailsort Set ptablesort = New TableSort ' Set up the parameters for the sort and excute With ptablesort.fields = "Address".Ascending("Address") = True.CaseSensitive("Address") = True Set.Table = ptable Set.Compare = ptablesortcallback End With ptablesort.sort Nothing ' Create a new cursor object to hold the sorted rows Set pcursor = ptablesort.rows ' Create a new sorted table Call CreateTable(pTable, pcursor) Set ptablesortcallback = Nothing Set ptablesort = Nothing 76

77 Public Sub CreateTable(pTab As ITable, pcur As ICursor) ' Create a new.dbf file of the sorted data Dim pworkspacefactory As IWorkspaceFactory Dim pfeatureworkspace As IFeatureWorkspace Dim pworkspace As IWorkspace Dim pdatasetwksp As IDataset Dim pworkspacename As IWorkspaceName Dim pdatasetnameout As IDatasetName Dim pfields As IFields Dim pfields2 As esricore.ifields Dim pdataset As IDataset Dim pdatasetname As IDatasetName Dim pds As IDataset Dim penumds As IEnumDataset Dim pstandalonetable2 Dim ptable2 Dim ptablenew Dim pcursor2 Dim prowbuffer Dim prow Dim pname Dim pstandalonetable Dim pstandalonetablec Dim j Dim i As IStandaloneTable As ITable As ITable As ICursor As IRowBuffer As IRow As IName As IStandaloneTable As IStandaloneTableCollection As Integer As Integer On Error GoTo ErrorHandler ' Get the dataset name for the input table Set pdataset = ptab Set pdatasetname = pdataset.fullname ' Set the output dataset name. ' New.dbf file will be created in c:\temp Set pfields = ptab.fields Set pworkspacefactory = New ShapefileWorkspaceFactory Set pworkspace = pworkspacefactory.openfromfile("c:\temp", 0) Set pfeatureworkspace = pworkspace Set pdatasetwksp = pworkspace Set pworkspacename = pdatasetwksp.fullname Set pdatasetnameout = New TableName pdatasetnameout.name = "NewSortTable" Set pdatasetnameout.workspacename = pworkspacename ' Check if.dbf file already exist: if yes, delete it Set penumds = pworkspace.datasets(esridttable) Set pds = penumds.next Do Until pds Is Nothing If pds.name = pdatasetnameout.name Then pds.delete Exit Do Set pds = penumds.next Loop 77

78 ' Create a new.dbf table pfeatureworkspace.createtable pdatasetnameout.name, pfields, Nothing, Nothing, "" ' Create a new stand alone table object to represent the.dbf table Set pstandalonetable2 = New StandaloneTable Set pstandalonetable2.table = pfeatureworkspace.opentable(pdatasetnameout.name) Set ptable2 = pstandalonetable2.table Set pfields2 = ptable2.fields ' Open an insert cursor on the new table Set pcursor2 = ptable2.insert(true) ' Create a row buffer for the row inserts Set prowbuffer = ptable2.createrowbuffer ' Loop through the sorted cursor and write to new table For j = 0 To ptab.rowcount(nothing) - 1 Set prow = pcur.nextrow If Not prow Is Nothing Then i = 1 Do Until i = pfields2.fieldcount If Not IsEmpty(pRow.Value(i)) Then If pfields.field(i).editable Then prowbuffer.value(i) = prow.value(i) i = i + 1 Loop pcursor2.insertrow prowbuffer Next j ' Add the new sorted table to map document Set pname = pdatasetnameout Set ptablenew = pname.open Set pstandalonetable = New StandaloneTable Set pstandalonetable.table = ptablenew Set pstandalonetablec = pmap pstandalonetablec.addstandalonetable pstandalonetable pmxdocument.updatecontents 如何实现在 ArcMap 上进行属性查询 (Identify) 本例要演示的是如何查询 Feature 的属性信息 实现后的结果为选择了 UI Tool Control 后, 在要查询的 Feature 上单击鼠标, 查询的结果将显示在弹出的窗体上 要点首先需要得到要查询的 Feature 对象 使用 IIdentify 接口的 Identify 方法可 78

79 以对给定的位置进行查询, 得到结果为 IIdentifyObj 对象的数组 然后通过为 IIdentifyObj 对象设置 IFeatureIdentifyObj 查询接口, 即可进一步得到 Feature 对 象 因为 IFeatureIdentifyObj 接口的 Feature 属性具有只写 (write only) 属性, 故又用到另一个接口 IRowIdentifyObj 得到 Feature 对象后即可操作其 Fields 属性和 Value 属性, 得到其属性字段 名和值 程序说明 在窗体上使用了 MSFlexGrid Control 6.0 来显示查询结果 所以本例也演示 了 MSFlexGrid 控件的使用方法 坐标 ) 代码 窗体名 : MSFlexGrid 控件名 : frmresult flxattr 标签控件名 : lbllocation ( 标签用来显示查询位置的地理 Private Sub UIT_Identify_MouseDown(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim pmxapplication As IMxApplication Dim pmxdocument As IMxDocument Dim pmap As IMap Dim ppoint As IPoint Dim pidarray As IArray Dim pidentify As IIdentify Dim pfeatureidentifyobj As IFeatureIdentifyObj Dim pidentifyobj As IIdentifyObj Dim prowidentifyobj As IRowIdentifyObject Dim pfeature As IFeature Dim pfields As IFields Dim pfield As IField Dim ifieldindex As Integer Dim ilayerindex As Integer Dim sshape As String On Error GoTo ErrorHandler Set pmxapplication = Application Set pmxdocument = Application.Document Set pmap = pmxdocument.focusmap 'Identify from TOP layer to BOTTOM, exit loop since one Feature identified For ilayerindex = 0 To pmap.layercount - 1 Set pidentify = pmap.layer(ilayerindex) 'Convert x and y to map units Set ppoint = pmxapplication.display.displaytransformation.tomappoint(x, y) 'Set label on the form, coordinates would have 6 digits behind decimal point frmresult.lbllocation = "Location:(" & Format(pPoint.x, "## ") & "," _ & Format(pPoint.y, "## ") & ")" 79

80 Set pidarray = pidentify.identify(ppoint) 'Get the FeatureIdentifyObject If Not pidarray Is Nothing Then Set pfeatureidentifyobj = pidarray.element(0) Set pidentifyobj = pfeatureidentifyobj pidentifyobj.flash pmxapplication.display 'Feature property of FeatureIdentifyObject has write only access Set prowidentifyobj = pfeatureidentifyobj Set pfeature = prowidentifyobj.row Set pfields = pfeature.fields 'Set the MSFlexGrid control on form te display identify result With frmresult.flxattr.allowuserresizing = flexresizecolumns.colalignment(1) = AlignmentSettings.flexAlignLeftCenter.ColWidth(0) = 1500.ColWidth(1) = 1800 'Add header to MSFlexGrid control.rows = pfields.fieldcount + 1.Cols = 2.FixedRows = 1.FixedCols = 0.TextMatrix(0, 0) = "Field".TextMatrix(0, 1) = "Value" For ifieldindex = 0 To pfields.fieldcount - 1 Set pfield = pfields.field(ifieldindex) 'Set field "Field" of the MSFlex control.textmatrix(ifieldindex + 1, 0) = pfield.name 'Set field "Value" of the MSFlex control Select Case pfield.type Case esrifieldtypeoid.textmatrix(ifieldindex + 1, 1) = pfeature.oid Case esrifieldtypegeometry 'The function QueryShapeType return a String that ' correspond with the esrigeoemtrytype const sshape = QueryShapeType(pField.GeometryDef.GeometryType).TextMatrix(iFieldIndex + 1, 1) = sshape Case Else.TextMatrix(iFieldIndex + 1, 1) = pfeature.value(ifieldindex) End Select Next ifieldindex End With frmresult.show modal Next ilayerindex 'If code goes here, no Feature was indentified, clear the MSFlex control's content ' and show a message frmresult.flxattr.clear MsgBox "No feature identified." 80

81 Public Function QueryShapeType(ByVal enugeometrytype As esrigeometrytype) As String Dim sshapetype As String Select Case enugeometrytype Case esrigeometrypolyline sshapetype = "Polyline" Case esrigeometrypolygon sshapetype = "Polygon" Case esrigeometrypoint sshapetype = "Point" Case esrigeometrymultipoint sshapetype = "Multipoint" Case esrigeometrynull sshapetype = "Unknown" Case esrigeometryline sshapetype = "Line" Case esrigeometrycirculararc sshapetype = "CircularArc" Case esrigeometryellipticarc sshapetype = "EllipticArc" Case esrigeometrybezier3curve sshapetype = "BezierCurve" Case esrigeometrypath sshapetype = "Path" Case esrigeometryring sshapetype = "Ring" Case esrigeometryenvelope sshapetype = "Envelope" Case esrigeometryany sshapetype = "Any valid geometry" Case esrigeometrybag sshapetype = "GeometryBag" Case esrigeometrymultipatch sshapetype = "MultiPatch" Case esrigeometrytrianglestrip sshapetype = "TriangleStrip" Case esrigeometrytriangefan sshapetype = "TriangleFan" Case esrigeometryray sshapetype = "Ray" Case esrigeometrysphere sshapetype = "Sphere" Case Else sshapetype = "Unknown!" End Select QueryShapeType = sshapetype End Function 如何设置和修改层的数据源 本例要实现的是如何改变 ( 或设置 ) 一个层的数据源 (Data Source) 主要用到 IMapAdmin2 接口 要点 81

82 首先需要得到新数据源的 IFeatureClass 接口对象和当前要改变数据源的层 的当前 IFeatureClass 接口对象, 然后调用 IMapAdmin2 接口的 FireChangeFeatureClass 方法实现之 程序说明 过程 UICMD_ChageDataSource_Click 是实现模块, 调用过程 ChangeLayerDataSource 实现功能 代码 snewfilename 是层的新数据源的 shape 文件的完整文件名 ( 包含 ) Private Sub UICMD_ChageDataSource_Click() Dim pvbproject As VBProject Dim sprojectname As String Dim snewfilename As String On Error GoTo Set pvbproject = ThisDocument.VBProject 'Get MXD File Path sprojectname = pvbproject.filename 'Get Data File Path snewfilename = sprojectname & "\..\..\..\..\data\country.shp" 'Call Procedure ChangeLayerDataSource snewfilename Private Sub ChangeLayerDataSource(ByVal snewfilename As String) Dim pworkspacefactory As IWorkspaceFactory Dim pworkspace As IWorkspace Dim pfeatureworkspace As IFeatureWorkspace Dim pnewfeaturecls As IFeatureClass Dim poldfeaturecls As IFeatureClass Dim pmxdocument Dim pmap Dim pactiveview Dim pmapadmin2 Dim pfeaturelayer As IMxDocument As IMap As IActiveView As IMapAdmin2 As IFeatureLayer On Error GoTo ErrorHandler 'Get Data FeatureClass Set pworkspacefactory = New ShapefileWorkspaceFactory Set pworkspace = pworkspacefactory.openfromfile(snewfilename & "\..\", 0) Set pfeatureworkspace = pworkspace Set pnewfeaturecls = pfeatureworkspace.openfeatureclass("country") 'Get Lay(0) s FeatureClass Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pmapadmin2 = pmap Set pactiveview = pmap 82

83 Set pfeaturelayer = pmap.layer(0) Set poldfeaturecls = pfeaturelayer.featureclass 'Change Data Source Set pfeaturelayer.featureclass = pnewfeaturecls pmapadmin2.firechangefeatureclass poldfeaturecls, pnewfeaturecls pactiveview.refresh 'if want to change Display in Toc,cancel these comment below 'pfeaturelayer.name = pnewfeaturecls.aliasname 'pmxdocument.currentcontentsview.refresh Display 如何实现在 ArcMap 中放大缩小地图 要点 用户点击按钮后, 可以在地图上进行点击或者拖放矩形框来放大缩小地图 因为考虑到用户可以单击放大缩小, 也可以拖放矩形框来放大缩小, 所以 不可以直接使用 IRubberBand 接口, 而是采用 INewEnvelopeFeedback 接口 程序说明 主要通过 InewEnvelopeFeedback.StartPoint 和 MoveTo 方法来绘制矩形框, 然 后赋值给 IActiveView.Extend 属性, 达到地图的放大缩小 代码 Private m_pfeedbackenv Private m_ppoint Private m_bismousedown Private m_pactiveview As INewEnvelopeFeedback As IPoint As Boolean As IActiveView Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ ByVal y As Long) Dim pmxdocument As IMxDocument On Error GoTo 'Left Button Check If button <> 1 Then If m_pactiveview Is Nothing Then Set pmxdocument = ThisDocument Set m_pactiveview = pmxdocument.activatedview ' 得到起始点 Set m_ppoint = m_pactiveview.screendisplay.displaytransformation.tomappoint(x, y) m_bismousedown = True Private Sub UIToolControl1_MouseMove(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ 83

84 ByVal y As Long) On Error GoTo If Not m_bismousedown Then If m_pfeedbackenv Is Nothing Then Set m_pfeedbackenv = New NewEnvelopeFeedback Set m_pfeedbackenv.display = m_pactiveview.screendisplay m_pfeedbackenv.start m_ppoint Set m_ppoint = m_pactiveview.screendisplay.displaytransformation.tomappoint(x, y) 'Draw Envelope m_pfeedbackenv.moveto m_ppoint Private Sub UIToolControl1_MouseUp(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ ByVal y As Long) Dim penv As IEnvelope On Error GoTo 'Left Button Check If button <> 1 Then If (m_pfeedbackenv Is Nothing) Then 'User Only Click Map with left button Set penv = m_pactiveview.extent ' 如果是缩小的话, 将这里的两个 0.5 都改成 1.5 penv.expand 0.5, 0.5, True Else 'User Draw a Envelope Set penv = m_pfeedbackenv.stop m_pactiveview.extent = penv m_bismousedown = False Set m_ppoint = Nothing Set m_pfeedbackenv = Nothing m_pactiveview.refresh 如何实现在 ArcMap 中移动地图用户点击按钮后, 可以拖动地图显示 要点采用 IActiveView.ScreenDisplay.PanStart 和 PanStop 方法使地图移动 程序说明通过 IActiveView.ScreenDisplay 的 PanStart 和 PanStop 方法在 ITool 的 MouseDown,MouseUp 和 MouseMove 事件的响应实现移动效果, 将移动结果得到 IEnvelope 赋值给 IActiveView.Extent, 实现地图的刷新 代码 Option Explicit 84

85 Private m_pmxapp As IMxApplication Private m_pmxdocument As IMxDocument Private m_pscreendisplay As IScreenDisplay Private m_pmapinsetwindow As IMapInsetWindow Private m_bmousedown As Boolean Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim pstartpoint As IPoint If Not button = 1 Then Set m_pscreendisplay = GetFocusDisplay Set m_pmapinsetwindow = GetMapInset(m_pScreenDisplay) If Not m_pmapinsetwindow Is Nothing Then If m_pmapinsetwindow.islive Then m_bmousedown = True Set pstartpoint = m_pscreendisplay.displaytransformation.tomappoint(x, y) ' 得到起始点, 开始移动 m_pscreendisplay.panstart pstartpoint Private Sub UIToolControl1_MouseMove(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim pmovetopoint As IPoint If Not m_bmousedown Then Set pmovetopoint = m_pscreendisplay.displaytransformation.tomappoint(x, y) ' 根据鼠标移动, 移动地图 m_pscreendisplay.panmoveto pmovetopoint Private Sub UIToolControl1_MouseUp(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim penvelope As IEnvelope Dim pactiveview As IActiveView Dim pmapinset As IMapInset Dim pmapinsetwindow As IMapInsetWindow If Not m_bmousedown Then m_bmousedown = False Set penvelope = m_pscreendisplay.panstop If penvelope Is Nothing Then ' 窗口判断 If Not m_pmapinsetwindow Is Nothing Then Set pmapinset = m_pmapinsetwindow.mapinset pmapinset.visiblebounds = penvelope m_pmapinsetwindow.refresh Else Set pactiveview = m_pmxdocument.activeview ' 地图刷新 If TypeOf pactiveview Is IMap Then pactiveview.extent = penvelope pactiveview.refresh Else Set pactiveview = pactiveview.focusmap pactiveview.extent = penvelope pactiveview.refresh 85

86 Private Sub UIToolControl1_Select() ' 初始化接口 m_bmousedown = False Set m_pmxapp = Application Set m_pmxdocument = Application.Document Private Function GetFocusDisplay() As IScreenDisplay Dim pactiveview As IActiveView Dim pactivemap As IMap Set pactiveview = m_pmxdocument.activeview If TypeOf pactiveview Is IMap Then Set GetFocusDisplay = m_pmxapp.display.focusscreen Else Set pactiveview = pactiveview.focusmap Set GetFocusDisplay = pactiveview.screendisplay End Function Private Function GetMapInset(pScreenDisplay As IScreenDisplay) As IMapInsetWindow Dim pappwindows As IApplicationWindows Dim pwindowsset As ISet Dim pdatawindow As IDataWindow Dim plenswindow As ILensWindow Set pappwindows = m_pmxapp 'QI Set pwindowsset = pappwindows.datawindows pwindowsset.reset Set pdatawindow = pwindowsset.next Do While Not pdatawindow Is Nothing If TypeOf pdatawindow Is ILensWindow Then Set plenswindow = pdatawindow If plenswindow.screendisplay Is m_pscreendisplay Then If TypeOf plenswindow Is IMapInsetWindow Then Set GetMapInset = plenswindow Exit Function Set pdatawindow = pwindowsset.next Loop Set GetMapInset = Nothing End Function 如何实现在 ArcMap 上画 Polygon 用户点击按钮后, 在地图上任意点击生成 Polygon, 双击 Polygon 生成完成 要点 IRubberBand.TrackNew 方法, IActiveview.ScreenDisplay.StartDrawing,DrawPolygon 和 EndDrawing 方法 程序说明通过 IRubberBand.TrackNew 方法实现 Polygon 的作成, 86

87 通过 IActiveview.ScreenDisplay.StartDrawing,DrawPolygon 和 EndDrawing 方 法来绘制 Polygon 代码 通过 Map 事件的重载, 使绘制的 Polygon 不会因为 Map 的刷新而消失 Private m_ppolygon As IPolygon Private m_pfillsymbol As IFillSymbol Private m_pscreendisplay As IscreenDisplay ' 事件重载 Private WithEvents ActiveViewEvents As Map ' 重新绘制 Polygon Private Sub ActiveViewEvents_AfterDraw(ByVal Display As IDisplay, ByVal phase As esriviewdrawphase) If Not phase = esridpgeography Then If m_ppolygon Is Nothing Then With m_pscreendisplay.setsymbol m_pfillsymbol.drawpolygon m_ppolygon End With ' 事件初始化 Private Sub UIToolControl1_Select() Dim pmxdoc As IMxDocument Set pmxdoc = ThisDocument Set ActiveViewEvents = pmxdoc.focusmap Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim pmxdoc As IMxDocument Dim pactiveview As IActiveView Dim prubberpolygon As IRubberBand Dim pfillsymbol As ISimpleFillSymbol Dim prgbcolor As IRgbColor Dim ppolygon As IPolygon Set pmxdoc = Application.Document Set pactiveview = pmxdoc.focusmap Set m_pscreendisplay = pactiveview.screendisplay Set prubberpolygon = New RubberPolygon Set m_pfillsymbol = New SimpleFillSymbol Set prgbcolor = New RgbColor prgbcolor.red = 255 m_pfillsymbol.color = prgbcolor ' 获得 Polygon Set m_ppolygon = prubberpolygon.tracknew(m_pscreendisplay, pfillsymbol) ' 绘制 Polygon With m_pscreendisplay.startdrawing m_pscreendisplay.hdc, esrinoscreencache.setsymbol m_pfillsymbol.drawpolygon m_ppolygon 87

88 .FinishDrawing End With 如何实现在 ArcMap 上进行测量 距离的测量 : 要实现的是测量两个点之间的距离 用 ToolControl 实现, 选中工具后, 在测量的开始点按鼠标左键, 鼠标拖动过程中实时画一条从开始点到鼠标当前位置的橡皮线, 计算并显示开始点到目标点的距离, 释放左键后擦除所画的线和文本 要点 要实时显示结果, 计算过程应该在 MouseMove 事件中处理 要绘制橡皮线, 必须设置当前绘图模式为 esriropxorpen 即混合后的颜色 取为当前背景色和画笔颜色的 异或 结果 这样在设定了画笔颜色后, 在同 一位置第二次画同一图形, 就会将图形 擦除, 并恢复原来的背景色 所有的对设备 ( 包括显示器 打印机 内存位图 ) 的绘图操的前后都应分 别调用 IDisplay 的两个方法 StartDrawing 和 EndDrawing StartDrawing 可以准备 特定的设备环境, 管理本例中要用到的各种 Symbols,FinishDrawing 完成收尾 工作, 以保证下一次对 StartDrawing 的调用不会出错 程序说明 函数 UITMeasureDistance_Deactivate 是 Deactivate 属性的处理代码, 当工具 失去焦点时, 清除已创建的对象 过程 UITMeasureDistance_MouseDown 是 MouseDown 事件的处理代码, 当鼠标键按下时, 记录起始点 过程 UITMeasureDistance_MouseMove 是 MouseMove 事件的处理代码, 鼠标移动过程 中测量距离, 计算文本显示的角度, 以及完成屏幕上橡皮线的绘制 过程 UITMeasureDistance_MouseUp 是 MouseUp 事件的处理代码, 当释放鼠标键时, 擦除刚绘制的图形 函数 GetSmashedLine 将获得一条 IPolyline 对象, 这条 Polyline 在要显示文本的地方留下了空白, 以防止出现所画线穿过文字的现象 另外, 本例未考虑坐标系的转换, 在球面地理坐标系是测量结果为经度差 或纬度差 代码 Option Explicit Private m_binuse As Boolean Private m_plinesymbol As ILineSymbol Private m_plinepolyline As IPolyline Private m_ptextsymbol As ITextSymbol Private m_pstartpoint As IPoint Private m_ptextpoint As IPoint Private Function UITMeasureDistance_Deactivate() As Boolean 88

89 ' Stop doing operation Set m_ptextsymbol = Nothing Set m_ptextpoint = Nothing Set m_plinepolyline = Nothing Set m_plinesymbol = Nothing m_binuse = False UITMeasureDistance_Deactivate = True End Function Private Sub UITMeasureDistance_MouseDown(ByVal Button As Long, ByVal Shift As Long, _ ByVal X As Long, ByVal Y As Long) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView m_binuse = True Set pmxdocument = ThisDocument Set pactiveview = pmxdocument.focusmap ' Get point to measure distance from Set m_pstartpoint = pactiveview.screendisplay.displaytransformation.tomappoint(x, Y) Private Sub UITMeasureDistance_MouseMove(ByVal Button As Long, ByVal Shift As Long, _ ByVal X As Long, ByVal Y As Long) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView Dim bfirsttime As Boolean Dim ppoint As IPoint Dim prgbcolor As IRgbColor Dim psymbol As ISymbol Dim pfont As IFontDisp Dim pline As ILine Dim dangle As Double Dim ddeltax As Double Dim ddeltay As Double Dim ddistance As Double Dim ppolyline As IPolyline Dim psegmentcollection As ISegmentCollection On Error GoTo ErrorHandler If (Not m_binuse) Then Set pmxdocument = ThisDocument Set pactiveview = pmxdocument.focusmap If (m_plinesymbol Is Nothing) Then bfirsttime = True ' Get current point Set ppoint = pactiveview.screendisplay.displaytransformation.tomappoint(x, Y) pactiveview.screendisplay.startdrawing pactiveview.screendisplay.hdc, -1 If bfirsttime Then ' Set Line Symbol Set m_plinesymbol = New SimpleLineSymbol 89

90 m_plinesymbol.width = 2 Set prgbcolor = New RgbColor With prgbcolor.red = 222.Green = 222.Blue = 222 End With m_plinesymbol.color = prgbcolor Set psymbol = m_plinesymbol psymbol.rop2 = esriropxorpen ' Set Text Symbol Set m_ptextsymbol = New TextSymbol m_ptextsymbol.horizontalalignment = esrithacenter m_ptextsymbol.verticalalignment = esritvacenter m_ptextsymbol.size = 16 Set psymbol = m_ptextsymbol Set pfont = m_ptextsymbol.font pfont.name = "Arial" psymbol.rop2 = esriropxorpen ' Create point to draw text in Set m_ptextpoint = New Point Else ' Use existing symbols and draw existing text and polyline pactiveview.screendisplay.setsymbol m_ptextsymbol pactiveview.screendisplay.drawtext m_ptextpoint, m_ptextsymbol.text pactiveview.screendisplay.setsymbol m_plinesymbol If (m_plinepolyline.length > 0) Then pactiveview.screendisplay.drawpolyline m_plinepolyline ' Get line between from and to points, and dangle for text Set pline = New esricore.line pline.putcoords m_pstartpoint, ppoint dangle = pline.angle dangle = dangle * (180# / ) If ((dangle > 90#) And (dangle < 180#)) Then dangle = dangle + 180# ElseIf ((dangle < 0#) And (dangle < -90#)) Then dangle = dangle - 180# ElseIf ((dangle < -90#) And (dangle > -180)) Then dangle = dangle - 180# ElseIf (dangle > 180) Then dangle = dangle - 180# ' For drawing text, get text(ddistance), dangle, and point ddeltax = ppoint.x - m_pstartpoint.x ddeltay = ppoint.y - m_pstartpoint.y m_ptextpoint.x = m_pstartpoint.x + ddeltax / 2# m_ptextpoint.y = m_pstartpoint.y + ddeltay / 2# m_ptextsymbol.angle = dangle ddistance = Round(pLine.Length, 3) 90

91 m_ptextsymbol.text = "[" & ddistance & "]" ' Draw text pactiveview.screendisplay.setsymbol m_ptextsymbol pactiveview.screendisplay.drawtext m_ptextpoint, m_ptextsymbol.text ' Get polyline with blank space for text Set ppolyline = New Polyline Set psegmentcollection = ppolyline psegmentcollection.addsegment pline Set m_plinepolyline = GetSmashedLine(pActiveView.ScreenDisplay, m_ptextsymbol, _ m_ptextpoint, ppolyline) ' Draw polyline pactiveview.screendisplay.setsymbol m_plinesymbol If (m_plinepolyline.length > 0) Then pactiveview.screendisplay.drawpolyline m_plinepolyline pactiveview.screendisplay.finishdrawing Private Sub UITMeasureDistance_MouseUp(ByVal Button As Long, ByVal Shift As Long, _ ByVal X As Long, ByVal Y As Long) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView On Error GoTo ErrorHandler If (Not m_binuse) Then m_binuse = False If (m_plinesymbol Is Nothing) Then Set pmxdocument = ThisDocument Set pactiveview = pmxdocument.focusmap 'Draw measure line and text pactiveview.screendisplay.startdrawing pactiveview.screendisplay.hdc, -1 pactiveview.screendisplay.setsymbol m_ptextsymbol pactiveview.screendisplay.drawtext m_ptextpoint, m_ptextsymbol.text pactiveview.screendisplay.setsymbol m_plinesymbol If (m_plinepolyline.length > 0) Then pactiveview.screendisplay.drawpolyline m_plinepolyline pactiveview.screendisplay.finishdrawing Set m_ptextsymbol = Nothing 91

92 Set m_ptextpoint = Nothing Set m_plinepolyline = Nothing Set m_plinesymbol = Nothing Private Function GetSmashedLine(pDisplay As IScreenDisplay, ptextsymbol As ISymbol, _ ppoint As IPoint, ppolyline As IPolyline) As IPolyline ' Returns a Polyline with a blank space for the text to go in Dim psmashed As IPolyline Dim pboundary As IPolygon Dim ptopologicaloperator As ITopologicalOperator Dim pintersect As IPolyline On Error GoTo ErrorHandler Set pboundary = New Polygon ptextsymbol.queryboundary pdisplay.hdc, pdisplay.displaytransformation, ppoint, pboundary Set ptopologicaloperator = pboundary Set pintersect = ptopologicaloperator.intersect(ppolyline, esrigeometry1dimension) Set ptopologicaloperator = ppolyline Set GetSmashedLine = ptopologicaloperator.difference(pintersect) Exit Function End Function 要点 本例要实现的是如何在 ArcMap 上测量一个 Polygon 的面积 首先用 IRubberBand.TrackNew 方法在 ArcMap 上画出一个 Polygon, 然后由这 个 Polygon 获得一个 IArea 的实例, 最后使用 IArea.Area 方法计算出这个 Polygon 的面积 主要用到 IRubberBand 接口,IPolygon 接口和 IArea 接口 程序说明 代码 函数 DrawPolygon 实现在 ArcMap 上画一个 Polygon 函数 MeasurePolygon 实现测量 ppolygon 的面积 Private Function DrawPolygon() As IPolygon Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView Dim psimplefills As ISimpleFillSymbol Dim prgbcolor As IRgbColor Dim prubberband As IRubberBand Dim ppolygon As IPolygon On Error GoTo Set pmxdocument = ThisDocument 92

93 Set pactiveview = pmxdocument.activeview Set psimplefills = New SimpleFillSymbol Set prgbcolor = New RgbColor prgbcolor.red = 255 psimplefills.color = prgbcolor Set prubberband = New esricore.rubberpolygon Set ppolygon = prubberband.tracknew(pactiveview.screendisplay, psimplefills) With pactiveview.screendisplay.startdrawing pactiveview.screendisplay.hdc, esrinoscreencache.setsymbol psimplefills.drawpolygon ppolygon.finishdrawing End With Set DrawPolygon = ppolygon Exit Function MsgBox Err.Desciption End Function Private Function MeasurePolygon(pPolygon As IPolygon) As Double Dim parea As IArea On Error GoTo Set parea = ppolygon MeasurePolygon = Abs(pArea.Area()) Exit Function MsgBox Err.Desciption End Function Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim ppolygon As IPolygon Dim darea As Double On Error GoTo Set ppolygon = DrawPolygon() darea = MeasurePolygon(pPolygon) MsgBox " 面积为 :" & darea MsgBox Err.Desciption 如何实现在 ArcMap 上选取中记录 本例要演示的是如何通过鼠标点击在 ArcMap 上选中一条记录 用到 IMap 接口的 SelectByShape 方法 要点 Tool Control 的 MouseDown 事件发生时传入了鼠标的位置参数 X 和 Y, 此为 鼠标位置的设备坐标 ( 屏幕坐标 ), 要转换成逻辑坐标 ( 地理坐标 ) 后, SelectByShape 方法才能正常工作 在 SelectByShape 方法中指定参数为 IPoint 对象 可选中处于当前鼠标位置 93

94 ( 点 ) 的记录 程序说明 本例功能的实现代码较为简单, 故只处理了 MouseDown 事件 为了 Tool Control 未被选中时按钮能够弹起, 设置了其 Deactivate 属性为 True 代码 Option Explicit Private Function UITSelectFeature_Deactivate() As Boolean UITSelectFeature_Deactivate = True End Function Private Sub UITSelectFeature_MouseDown(ByVal Button As Long, ByVal Shift As Long, _ ByVal X As Long, ByVal Y As Long) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView Dim ppoint As IPoint On Error GoTo ErrorHandler ' Get the ActiveView for the map Set pmxdocument = ThisDocument Set pactiveview = pmxdocument.focusmap ' Store current mouse point Set ppoint = pactiveview.screendisplay.displaytransformation.tomappoint(x, Y) ' Select by point pmxdocument.focusmap.selectbyshape ppoint, Nothing, False ' Refresh the selections pactiveview.partialrefresh esriviewgeoselection, Nothing, Nothing 如何实现在 ArcMap 中进行动作的撤销和重做 本例要演示的是如何在 ArcMap 中对图形的移动动作进行撤销和重做, 用到 IExtentStack 接口 以帮助理解 ArcMap 中对撤销和重做实现的方法 要点 IActiveView 的 ExtentStack 属性保存了其 Extent 改变的 历史记录, 而 IMxDocument 的 OperationStack 属性则有能力记录更复杂的编辑动作的历史 用 户只有深刻理解了概念, 才能够完成特定功能 历史记录 的定制 程序说明 过程 Extent_UnDo 和 Extent_RnDo 分别模拟了 ArcMap 中 Tools 工具栏上的 Go Back To Previous Extent 和 Go To Next Extent 两个按钮的功能 94

95 代码 Option Explicit Public Sub Extent_UnDo() Dim pmxdocument Dim pactiveview Dim pextentstack As IMxDocument As IActiveView As IExtentStack On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pactiveview = pmxdocument.focusmap Set pextentstack = pactiveview.extentstack If pextentstack.canundo Then pextentstack.undo Public Sub Extent_ReDo() Dim pmxdocument Dim pactiveview Dim pextentstack As IMxDocument As IActiveView As IExtentStack On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pactiveview = pmxdocument.focusmap Set pextentstack = pactiveview.extentstack If pextentstack.canredo Then pextentstack.redo 如何画 Polygon Buffers 本例要实现的是如何利用 Polygon Buffer 自定义记录选中时的显示方式 要点首先通过 IRgbColor 接口和 ISimpleFillSymbol 接口设置 Polygon Buffer 的填充方式 然后在发生 SelectionChanged 事件时, 设置选中记录被显示时的边界并将选中的 Polygon 通过 ITopologicalOperator.ConstructUnion 方法, 联合成一个临时的 Polygon Buffer, 使用 IActiveView.PartialRefresh 方法刷新这个 Polygon Buffer 区域, 最后在发生 AfterItemDraw 事件时将这个 Polygon Buffer 画在 Map 上 主要用到 IPolygon 接口,IEnvelope 接口,ISimpleFillSymbol 接口,IActiveView 95

96 接口,IEnumFeature 接口,IGeometryCollection 接口和 ITopologicalOperator 接口 程序说明函数 InitEvents 是初始化变量并设置 Polygon Buffer 的填充方式 AfterItemDraw 事件实现的是画出 Polygon Buffer SelectionChanged 事件实现的是生成 Polygon Buffer 并设置边界 代码 Private WithEvents ActiveViewEvents As Map Private pmxdocument Private pbufferpolygon Private penvelope Private psimplefills Public Sub InitEvents() Dim pviewmanager Dim prgbcolor As IMxDocument As IPolygon As IEnvelope As ISimpleFillSymbol As IViewManager As IRgbColor Set pmxdocument = Application.Document Set pviewmanager = pmxdocument.focusmap pviewmanager.verboseevents = True Set ActiveViewEvents = pmxdocument.focusmap 'Create a fill symbol Set psimplefills = New SimpleFillSymbol Set prgbcolor = New RgbColor prgbcolor.red = 255 psimplefills.style = esrisfsforwarddiagonal psimplefills.color = prgbcolor Private Sub ActiveViewEvents_AfterItemDraw(ByVal Index As Integer, ByVal Display As IDisplay, ByVal phase As esridrawphase) 'Only draw in the geography phase If Not phase = esridpgeography Then 'Draw the buffered polygon If pbufferpolygon Is Nothing Then With Display.SetSymbol psimplefills.drawpolygon pbufferpolygon End With Private Sub ActiveViewEvents_SelectionChanged() Dim pactiveview As IActiveView Dim penumfeature As IEnumFeature Dim pfeature As IFeature Dim pselectionpolygon As IPolygon Dim ptopologicaloperator As ITopologicalOperator Dim pgeometrycollection As IGeometryCollection Set pactiveview = pmxdocument.focusmap Set pgeometrycollection = New GeometryBag 'Flag last buffered region for invalidation 96

97 If Not penvelope Is Nothing Then pactiveview.partialrefresh esriviewgeography, Nothing, penvelope If pmxdocument.focusmap.selectioncount = 0 Then 'Nothing selected; don't draw anything; bail Set pbufferpolygon = Nothing 'Buffer each selected feature Set penumfeature = pmxdocument.focusmap.featureselection penumfeature.reset Set pfeature = penumfeature.next Do While Not pfeature Is Nothing Set ptopologicaloperator = pfeature.shape Set pselectionpolygon = ptopologicaloperator.buffer(0.1) pgeometrycollection.addgeometry pselectionpolygon 'Get next feature Set pfeature = penumfeature.next Loop 'Union all the buffers into one polygon Set pbufferpolygon = New Polygon Set ptopologicaloperator = pbufferpolygon 'QI ptopologicaloperator.constructunion pgeometrycollection Set penvelope = pbufferpolygon.envelope 'Flag new buffered region for invalidation pactiveview.partialrefresh esriviewgeography, Nothing, pbufferpolygon.envelope Private Sub UIButtonControl1_Click() InitEvents 1.5. 图元编辑 如何得到图形的基本属性本例要实现的功能是得到一个 FeatureLayer 中被选择的 Feature 的基本图形属性, 如, 图形的维数, 类型, 范围, 空间坐标系统等 要点接口 IGeometry 的主要属性有 Dimension( 维数 ),GeometryType( 图形类型 ), Envelope( 范围 ),IsEmpty ( 是否为空 ),SpatialReference( 空间坐标系 ) 等 程序说明该过程在开始处使用 IEnumFeature 接口来得到所选择的 Features, 用 Next 方法取得每个 Feature 然后利用 IFeature 接口的 Shape 属性得到 Geometry 最后弹出消息框显示图形的属性信息 代码 97

98 Public Sub GetGeometryProperty() Dim pmxdocument As IMxDocument Dim penumfeature As IEnumFeature Dim pfeature As IFeature Dim pgeometry As IGeometry On Error GoTo ErrorHandler Set pmxdocument = Application.Document ' 得到图形集 Set penumfeature = pmxdocument.focusmap.featureselection ' 重新设置图形集 penumfeature.reset ' 得到第一个图形 Set pfeature = penumfeature.next ' 判断是否有图形被选上 If pfeature Is Nothing Then MsgBox "no selection,please select a Feature" Else 循环图形, 直到最后 While Not pfeature Is Nothing Set pgeometry = pfeature.shape ' 得到图形的基本属性 MsgBox "+++Polygon::IGeometry properties..." & vbcrlf _ & "Dimension = " & pgeometry.dimension & vbcrlf _ & "Geometry type = " & pgeometry.geometrytype & vbcrlf _ & "Envelope = " & pgeometry.envelope.xmin & "," & pgeometry.envelope.ymin & "," _ & pgeometry.envelope.xmax & "," & pgeometry.envelope.ymin & vbcrlf _ & "IsEmpty = " & pgeometry.isempty & vbcrlf _ & "SpatialReference = " & pgeometry.spatialreference.name 指向下一个图形 Set pfeature = penumfeature.next Wend 如何将选中的点集转换成 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 98

99 程序说明 根据接口 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 99

100 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 Set pfeature = penumfeature.next Wend If pmultipoint.pointcount < 3 Then MsgBox "Select a least 3 points!" ' 创建第一个 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 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 100

101 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) 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 If lflag = 0 Then Set ppolygon = pgoncoll Else Set ppolygon = pgoncoll2 'QI ' 画出 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 ErrorHander: pworkspaceedit.aborteditoperation 101

102 如何将 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 102

103 Set penumfeature = pmxdocument.focusmap.featureselection Set pfeature0 = penumfeature.next If pfeature0 Is Nothing Then MsgBox "Must have Select in Position 0" ' 循环, 通过每个 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) Next ' 保存 Feature pfeature1.store Next Else MsgBox "Must have Multipoint in position 0" Set pfeature0 = penumfeature.next Wend ' 停止编辑 pworkspaceedit.stopeditoperation pworkspaceedit.stopediting True ErrorHanlder: pworkspaceedit. AbortEditOperation 如何通过 Polygon 中的多个 Ring 创建多个 Polygon 本例要实现的是如何在一个 FeatureLayer 中, 选择 Polygon(Feature) 的 Shape, 如果它有多个 Ring, 则在另一个 Polygon 的图层上根据每一个 Ring 创建一个 Polygon 要点取出 Polygon 中的每个 Ring, 声明一个 IGeometryColletion 接口, 将其实例化 103

104 为 Polygon, 利用此接口的方法 AddGeometry 生成一个 Polygon, 再用一个实例化 为 GeometryBag 的 IGeometryColletion 接口变量来放置生成的每个 Polygon 程序说明 程序中添加了两个图层, 两层都是 Polylgon 型 在第一个层选择有多个 Ring 的 Polygon, 再运行本函数, 则在第二个层由这些多个 Ring 的 Polygon 创建生成 了多个 Polygon 代码 Private Function PolygonsFromPolygonRings(pGeomColl As IGeometryCollection, bclone As Boolean) As _ IGeometryCollection Dim i As Long Dim pgeometrycollection As IGeometryCollection Dim ptopologicaloperator As ITopologicalOperator If Not pgeomcoll Is Nothing Then If pgeomcoll.geometrycount > 0 Then Set PolygonsFromPolygonRings = New GeometryBag If bclone Then If TypeOf pgeomcoll Is IClone Then Dim pclone As IClone Set pclone = pgeomcoll Set pgeomcoll = pclone.clone ' 为每个 Ring 创建一个新 Polygon, 将 Polygon 进行 simplify 后, 放在 GeometryBag 中 For i = 0 To pgeomcoll.geometrycount - 1 If pgeomcoll.geometry(i).geometrytype = esrigeometryring Then Set pgeometrycollection = New Polygon Set ptopologicaloperator = pgeometrycollection pgeometrycollection.addgeometry pgeomcoll.geometry(i) ptopologicaloperator.simplify PolygonsFromPolygonRings.AddGeometry pgeometrycollection Next i End Function Public Sub PolygonRingsToPolygons() Dim pmxdocument Dim pmap Dim pactiveview Dim penumfeature Dim pfeature0 Dim pfeaturelayer0 Dim pfeatureclass0 Dim pfeature1 Dim pfeaturelayer1 Dim pfeatureclass1 Dim ppointcollection Dim pgeometrycollection Dim pdataset Dim pworkspacefactory Dim pworkspaceedit As IMxDocument As IMap As IActiveView As IEnumFeature As IFeature As IFeatureLayer As IFeatureClass As IFeature As IFeatureLayer As IFeatureClass As IPointCollection As IGeometryCollection As IDataset As IWorkspaceFactory As IWorkspaceEdit 104

105 Dim ppolygon Dim pgeometrycolpolygon Dim pgeometrycolpolygonnew Dim pgeometrycollectionpolygon Dim lgeometryindex Dim lpointfieldindex As IPolygon As IGeometryCollection As IGeometryCollection As IgeometryCollection As Long As Long On Error GoTo ErrorHanlder ' 得到当前层 Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pactiveview = pmap Set ppolygon1 = New Polygon Set pgeometrycolpolygon = New Polygon Set pgeometrycolpolygonnew = New Polygon Set pgeometrycolpolygonnew1 = New Polygon Set pgeometrycollectionpolygon = New GeometryBag ' 得到 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" ' 将一个 Polygon 上的多个 Ring 转换成多个 Polygon Set pgeometrycollectionpolygon = PolygonsFromPolygonRings(pGeometryColPolygonNew, True) ' 将转换成的多个 Polygon 添加到第二层上 For lgeometryindex = 0 To pgeometrycollectionpolygon.geometrycount - 1 Set pfeature1 = pfeatureclass1.createfeature ' 把画的 Polygon 加到新建的 Feature 上 Set ppolygon1 = pgeometrycollectionpolygon.geometry(lgeometryindex) Set pfeature1.shape = ppolygon1 ' 保存 Feature pfeature1.store Next pmxdocument.activeview.refresh ' 停止编辑 pworkspaceedit.stopeditoperation pworkspaceedit.stopediting True ErrorHanlder: pworkspaceedit.aborteditoperation 105

106 如何从 Polyline 创建 Polygon 本例要实现的功能是根据一个 FeatureLayer 中被选择的一条 Polyline 生成一 个 Polygon, 并把该 Polygon 做为一个新的 Feature 保存在一个 Polygon 类型的 FeatureLayer 中 要点 通过所选择的 Polyline 创建一个新的 Polygon, 即要根据 Polyline 中的每个 Path 生成相应的 Ring 程序中用到 ISegmentCollection 接口, 将它实例化为 Ring, 利 用它的方法 AddSegmentCollection 实现了这一目的 程序说明 程序中添加了两个图层, 第一图层 Polyline 型, 第二图层 Polylgon 型 因为 Polyline 型的图层中不能放 Polygon 型的数据, 所以多增加一个 Polygon 层, 以便 将通过 Polyline 生成的一个新的 Polygon 显示到上面, 使得程序运行结果清晰明 了 函数 PolylineToPolygon(ByRef ppolyline As IPolyline) 中, 通过 psegs_ring.addsegmentcollection, 创建了一个新 Ring, 其中 psegs_ring 是一个实 例化为 Ring 的 ISegmentCollection 接口变量 代码 Private Function PolylineToPolygon(ByRef ppolyline As IPolyline) As IGeometryCollection Dim pgeoms_polyline As IGeometryCollection Dim pclone As IClone Dim psegs_ring As ISegmentCollection Dim ppolygon As IPolygon Dim i As Long On Error Goto ErrorHander ' 创建一个新的 Polygon geometry. Set PolylineToPolygon = New Polyline ' 克隆即将要操作的 Polyline Set pclone = ppolyline Set pgeoms_polyline = pclone.clone ' 通过 Polyline 的每个 Path 创建为一个新的 Ring, 并把 Ring 增加到一个新的 Polygon For i = 0 To pgeoms_polyline.geometrycount - 1 Set psegs_ring = New Ring psegs_ring.addsegmentcollection pgeoms_polyline.geometry(i) PolylineToPolygon.AddGeometry psegs_ring Next I ' 生成的 Polygon 旋转的顺序可能不正确, 为确保正确调用 SimplifyPreserveFromTo Set ppolygon = PolylineToPolygon ppolygon.simplifypreservefromto Exit Function ErrorHander: End Function 106

107 Public Sub CreateNewPolygonFromPolylineGraphic() Dim pmxdocument As IMxDocument Dim penumfeature As IEnumFeature Dim pfeature0 As IFeature Dim pfeatureclass0 As IFeatureClass Dim pfeaturelayer0 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 ppolygon As IPolygon Dim ppolyline As IPolyline Dim pmap As IMap Dim pactiveview As IActiveView On Error GoTo ErrorHander Set pmxdocument = ThisDocument ' 得到当前层 Set pmap = pmxdocument.focusmap Set pactiveview = pmap ' 得到 0,1 层的 FeatureClass,pFeatureClass0,pFeatureClass1 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 ' 循环 Feature While Not pfeature0 Is Nothing If pfeature0.shapecopy.geometrytype = esrigeometrypolygon Then 'Copy 当前层上的一个 Featureµ 到 Polygon Set ppolyline = pfeature0.shapecopy 将 Polyline 创建为 Polygon Set ppolygon = PolygonToPolyline(pPolyline) ' 将创建的 Polygon, 加到 Polygon 层上, 新建的 Feature 中 Set pfeature1 = pfeatureclass1.createfeature Set pfeature1.shape = ppolygon ' 保存 Feature pfeature1.store Else MsgBox "Must have Polygon in position 0" Set pfeature0 = penumfeature.next Wend pmxdocument.activeview.refresh ' 停止编辑 pworkspaceedit.stopeditoperation pworkspaceedit.stopediting True 107

108 ErrorHander: pworkspaceedit. AbortEditOperation 如何从 Polygon 创建 Polyline 本例要实现的功能是根据一个 FeatureLayer 中被选择的一个 Polygon 生成一 条 Polyline, 并把该 Polyline 做为一个新的 Feature 保存在一个 Polyline 类型的 FeatureLayer 中 要点 通过所选择 Polygon 创建一个新的 Polyline, 即要根据 Polylgon 中的每个 Ring 生成相应的 Path, 程序中用到 ISegmentCollection 接口, 将它实例化为 Path, 利用 它的方法 AddSegmentCollection 实现了这一目的 程序说明 程序中添加了两个图层, 第一图层 Polylgon 型, 第二图层 Polyline 型 因为 Polygon 型的图层中不能放 Polyline 型的数据, 所以多增加一个 Polyline 层, 以便 将通过 Polygon 来创建的一个新的 Polyline 显示到上面, 使得程序运行结果清晰 明了 函数 PolygonToPolyline(ByRef ppolylgon As IPolygon) 中, psegmentcollectionpath.addsegmentcollection 创建了一个新 Ring, 其中 psegmentcollectionpath 是一个实例化为 Ring 的 ISegmentCollection 接口变量 代码 Private Function PolygonToPolyline(ByRef ppolygon As IPolygon) As IGeometryCollection Dim pgeometrycollectionpolygon As IGeometryCollection Dim pclone As IClone Dim psegmentcollectionpath As ISegmentCollection Dim i As Long On Error GoTo ErrorHander ' 创建一个新的 Polyline geometry. Set PolygonToPolyline = New Polyline ' 克隆即将要操作的 Polygon Set pclone = ppolygon Set pgeometrycollectionpolygon = pclone.clone ' 把 Polygon 的每个 Ring 创建为一个新的 Path, 并把 Path 增加到一个新的 Polyline For i = 0 To pgeometrycollectionpolygon.geometrycount - 1 Set psegmentcollectionpath = New Path psegmentcollectionpath.addsegmentcollection pgeometrycollectionpolygon.geometry(i) PolygonToPolyline.AddGeometry psegmentcollectionpath Next i Exit Function ErrorHander: 108

109 End Function Public Sub CreateNewPolylineFromPolygonGraphic() Dim pmxdocument As IMxDocument Dim penumfeature As IEnumFeature Dim pfeature0 As IFeature Dim pfeatureclass0 As IFeatureClass Dim pfeaturelayer0 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 ppolygon As IPolygon Dim ppolyline As IPolyline Dim pmap As IMap Dim pactiveview As IActiveView On Error GoTo ErrorHander Set pactiveview = pmap Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap ' 得到 0,1 层的 FeatureClass,pFeatureClass0,pFeatureClass1 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 ' 循环 Feature While Not pfeature0 Is Nothing If pfeature0.shapecopy.geometrytype = esrigeometrypolygon Then 'Copy 当前层上的一个 Featureµ 到 Polygon Set ppolygon = pfeature0.shapecopy ' 将 Polygon 创建为 Polyline Set ppolyline = PolygonToPolyline(pPolygon) ' 将创建的 Polyline, 加到 Polyline 层上, 新建的 Feature 中 Set pfeature1 = pfeatureclass1.createfeature Set pfeature1.shape = ppolyline ' 保存 Feature pfeature1.store Else MsgBox "Must have Polygon in position 0" Set pfeature0 = penumfeature.next Wend pmxdocument.activeview.refresh ' 停止编辑 109

110 pworkspaceedit.stopeditoperation pworkspaceedit.stopediting True ErrorHander: pworkspaceedit. AbortEditOperation 如何将 Polygon/PolyCurve 一般化 (Generalize) 本例要实现的功能是使用道格拉斯 - 普克 (Douglas-Poiker) 算法对 Polyline 或 Polygon 做抽稀运算 要点所谓道格拉斯 - 普克抽稀算法, 是用来对大量冗余的图形数据点进行压缩以提取必要的数据点 该算法实现抽稀的过程是 : 先将一条曲线首尾点虚连一条直线, 求其余各点到该直线的距离, 取其最大者与规定的临界值相比较, 若小于临界值, 则将直线两端间各点全部舍去, 否则将离该直线距离最大的点保留, 并将原线条分成两部分, 对每部分线条再实施该抽稀过程, 直到结束 抽稀结果点数随选取限差临界值的增大而减少, 应用时应根据精度来选取限差临界值, 以获得最好的效果 下面是该抽稀算法的过程示意图 本例中使用接口 IPolycurve2 的方法 Generalize(maxAllowableOffset ) 来实现 Polygon 或 Polyline 的抽稀运算, 其中的参数 maxallowableoffset, 就是拉斯 - 普克 抽稀算法中的限差临界值 110

111 程序说明 在本例的实现中, 从一个 Element 的 Geometry 属性得到一条曲线, 并将其抽 稀 限差临界值设为该线条长度的三十分之一 代码 Public Sub Generalize() Dim pmxdocument Dim pgraphicscontainerselect Dim pgeometry Dim pelement Dim ppolycurve As IMxDocument As IGraphicsContainerSelect As IGeometry As IElement As IPolycurve2 On Error GoTo ErrorHandler Set pmxdocument = ThisDocument ' 在一般化 Polyline 或 Polygon 之前, 首先要找到将要一般化的 Geometry Set pgraphicscontainerselect = pmxdocument.activeview If pgraphicscontainerselect.elementselectioncount = 1 Then ' 得到当前选择的 Element Set pelement = pgraphicscontainerselect.selectedelement(0) Set pgeometry = pelement.geometry ' 一般化 Polygon 或 Polyline If (pgeometry.geometrytype = esrigeometrypolygon) Or _ (pgeometry.geometrytype = esrigeometrypolyline) Then Set ppolycurve = pgeometry ppolycurve.generalize ppolycurve.length / 30 pelement.geometry = pgeometry pmxdocument.activeview.partialrefresh esriviewgraphics, Nothing, Nothing 如何获得 Polygon 的中点本例要实现的功能是根据一个 Polygon 类型的 FeatureLayer 中被选择的 Polygon, 得到它们的中心 并根据它们的中心点在 Point 型的 FeatureLayer 中新建 Feature 要点本例使用接口 IArea 的方法 QueryCentroid (Center ), 来得到一个 Polygon 的中心点 程序说明程序中加了两个层, 第一个层是 Point 类型的, 第二个层是 Polygon 类型的 在选择了一个或多个 Polygon 之后, 运行本例程序, 就会在 Point 层上新生成这些 Polygon 的中心点 111

112 代码 Public Sub ConvertPointToPolygon() Dim pmxdocument As IMxDocument Dim pmap As IMap Dim penumfeature As IEnumFeature Dim pactiveview As IActiveView Dim pfeature As IFeature Dim ppoint As IPoint Dim parea As IArea 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 On Error GoTo ErrorHander Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pactiveview = pmap Set pfeaturelayer = pmap.layer(0) Set pfeatureclass = pfeaturelayer.featureclass Set pfeaturelayer1 = pmap.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 ' 将变量进行实例化 Set ppoint = New Point ' 得到所选择的图形集 Set penumfeature = pmxdocument.focusmap.featureselection Set pfeature = penumfeature.next If pfeature Is Nothing Then MsgBox "Select Polygon" ' 得到 Polygon 的中心 While Not pfeature Is Nothing If pfeature.shapecopy.geometrytype = esrigeometrypolygon Then Set parea = pfeature.shape ' 得到 Polygon 的中心 ppoint parea.querycentroid ppoint Set pfeature1 = pfeatureclass1.createfeature ' 中心储存在第二层 Set pfeature1.shape = ppoint pfeature1.store Set pfeature = penumfeature.next Wend pmxdocument.activeview.refresh 112

113 ' 停止编辑 pworkspaceedit.stopeditoperation pworkspaceedit.stopediting True ErrorHander: pworkspaceedit.aborteditoperation 如何判断图形间的逻辑运算本小节以 Polyline(Polygon 类似 ) 为例, 讲解如何判断图形间的逻辑关系, 主要用到的接口是 IRelationalOperator 要点在本例中, 使用 Relational Operator 对两个图形进行比较, 返回一个布尔值来指出这两个图形间是否存在特定的关系 一些关系的判断是要求两个图形要有相同的维数的 ( 如必须 Polyline 之间或 Polygon 之间 ), 而另外一些对图形维数就没有太多限制 大多数已定义的关系操作符是互斥的 RelationalOperator 的具体方法有 : Contains: 判断一个图形是否包含另外一个图形 Within: 判断一个图形是否被另外一个图形所包含 Crosses: 判断两个图形是否在维数较少的那个图形的内部相交 Disjoint: 判断两个图形间是否没有相同点 Equals: 判断两个图形是否是同一个类型并且在平面上的点是否是相同的位置 如果返回值为真, 则它们应该包含 (Contains) 另外一个图形同时也被另外一个图形所包含 (Within) Overlaps: 判断两个图形的交集是否和其中的一个图形拥有相同的维数, 并且他们交集不能和其中任何一个图形相等 该方法只使用与两个 Polyline 之间或者两个 Polygon 之间 Touch: 判断两个图形的边界是否相交, 如果两个图形的交集不为空, 但两个图形内部的交集为空, 则返回值为真 下图为几个图形的边界 (Boundary) 和内部 (Interior) 概念的图解 : 113

114 下面针对较易混淆的两个概念, Crosses 和 Touch 进行举例说明 (Polyline/Polyline): Crossess Touch Crossess Touch 程序说明 首先创建两条 Polyline:pLine1,pLine2, 然后对这两条 Polyline 进行各种逻辑运 算 针对不同的逻辑运算创建不同位置的 Polyline 以进行验证 代码 Public Sub RelationalOperatorsDemo() Dim pline1 Dim pline2 Dim pbasesegmentc Dim pcompsegmentc Dim prelationaloperator Dim pbasegeometry Dim pcompgeometry Dim ppoints(0 To 1) On Error GoTo ErrorHandler Set pline1 = New Line Set pline2 = New Line Set pbasesegmentc = New Polyline Set pcompsegmentc = New Polyline Set prelationaloperator = pbasesegmentc Set pbasegeometry = pbasesegmentc Set pcompgeometry = pcompsegmentc Set ppoints(0) = New Point As ILine As Iline As ISegmentCollection As ISegmentCollection As IRelationalOperator As IGeometry As IGeometry As Ipoint 114

115 Set ppoints(1) = New Point ppoints(0).putcoords 0, 0 ppoints(1).putcoords 100, 100 pline1.putcoords ppoints(0), ppoints(1) 'Example of Contains ppoints(0).putcoords 20, 20 ppoints(1).putcoords 80, 80 pline2.putcoords ppoints(0), ppoints(1) '(0,0) to (100,100) pbasesegmentc.addsegment pline1 '(20,20) to (80,80) pcompsegmentc.addsegment pline2 MsgBox "Contains: " & prelationaloperator.contains(pcompsegmentc) 'Set polylines empty so they can be reused pbasegeometry.setempty pcompgeometry.setempty 'Example of Within (Within is the complement of Contains) '(0,0) to (100,100) pcompsegmentc.addsegment pline1 '(20,20) to (80,80) pbasesegmentc.addsegment pline2 MsgBox "Within: " & prelationaloperator.within(pcompsegmentc) pbasegeometry.setempty pcompgeometry.setempty 'Example of Equals ppoints(0).putcoords 0, 0 ppoints(1).putcoords 100, 100 pline2.putcoords ppoints(0), ppoints(1) '(0,0) to (100,100) pbasesegmentc.addsegment pline1 '(0,0) to (100,100) pcompsegmentc.addsegment pline2 'If Equals is True, then Within and Contains should also be true If prelationaloperator.equals(pcompsegmentc) Then MsgBox "Equals is true" MsgBox "Within: " & prelationaloperator.within(pcompsegmentc) & vbcrlf & _ "Contains: " & prelationaloperator.contains(pcompsegmentc) pbasegeometry.setempty pcompgeometry.setempty 'Example of Disjoint ppoints(0).putcoords -40, 40 ppoints(1).putcoords -100, 80 pline2.putcoords ppoints(0), ppoints(1) '(0,0) to (100,100) pbasesegmentc.addsegment pline1 '(-40,40) to (-100,80) pcompsegmentc.addsegment pline2 MsgBox "Disjoint: " & prelationaloperator.disjoint(pcompsegmentc) pbasegeometry.setempty pcompgeometry.setempty 'Example of Touches (Objects touch on their boundaries) 115

116 ppoints(0).putcoords 100, 100 ppoints(1).putcoords 200, 150 pline2.putcoords ppoints(0), ppoints(1) '(0,0) to (100,100) pbasesegmentc.addsegment pline1 '(100,100) to (200,150) pcompsegmentc.addsegment pline2 MsgBox "Touches: " & prelationaloperator.touches(pcompsegmentc) pbasegeometry.setempty pcompgeometry.setempty 'Example of Overlaps ppoints(0).putcoords 140, 140 ppoints(1).putcoords 60, 60 pline2.putcoords ppoints(0), ppoints(1) '(0,0) to (100,100) pbasesegmentc.addsegment pline1 '(140,140) to (60,60) pcompsegmentc.addsegment pline2 MsgBox "Overlaps: " & prelationaloperator.overlaps(pcompsegmentc) 如何进行图形间的逻辑运算本例主要运用 ITopologicalOperator 接口来实现一个或多个图形间的逻辑运算 要点 ITopologicalOperator 接口主要用来对已存在的一个或多个图形进行拓扑逻辑关系运算, 从而生成一个新的图形 该接口主要有以下几种方法 : Buffer: 由距离某个图形特定长度内的所有点的轨迹的集合构建的一个多边形区域 Clip: 得到一个图形和一个矩形线框相交部分区域 ConvexHull: 得到一个图形的凸包, 即该图形的最小外接多边形 Difference: 构建一个图形, 它包含了这个图形中的所有点但不包含另外一个图形中的任何点 Intersect: 得到两个图形的交集, 即两个具有相同维数的图形的重叠区域 Union: 得到两个相同维数的图形的合集, 两个图形的相同部分在该图形中只存在一个 程序说明 116

117 本例以 ITopologicalOperator 接口中的 Buffer 方法为例, 对地图中选中的一个或多个 Polygon 使用 Buffer 方法生成新多边形区域 当地图放大或缩小时, 该多变形区域会跟着放大或缩小 代码 ' 对模块中的全局变量进行声明 ' 对 Map 定义一个名为 ActiveViewEvents 的事件 Private WithEvents ActiveViewEvents As Map Private m_pmxdocument Private m_pbufferpolygon Private m_pbufferenvelope Private m_psimplefills As IMxDocument As IPolygon As IEnvelope As IsimpleFillSymbol ' 事件 ActiveViewEvent 执行前的初始化, 设置多边形的填充属性 Public Sub InitEvents() Dim pviewmanager As IViewManager Dim prgbcolor As IRgbColor On Error GoTo Set m_pmxdocument = ThisDocument Set pviewmanager = m_pmxdocument.focusmap pviewmanager.verboseevents = True Set ActiveViewEvents = m_pmxdocument.focusmap 'Create a fill symbol Set m_psimplefills = New SimpleFillSymbol Set prgbcolor = New RgbColor prgbcolor.blue = 255 ' 设置填充符的类型和颜色 m_psimplefills.style = esrisfsforwarddiagonal m_psimplefills.color = prgbcolor Exit sub ' 事件 ActiveViewEvents 在画了 Item 后要执行的过程, 本例中当一个或多 ' 个多边形进行 Buffer 处理后, 重画这些多边形 Private Sub ActiveViewEvents_AfterItemDraw(ByVal Index As Integer, ByVal display As IDisplay, ByVal phase As esridrawphase) On Error GoTo 'Only draw in the geography phase If Not phase = esridpgeography Then 'Draw the buffered polygon If m_pbufferpolygon Is Nothing Then ' 将逻辑运算后的图形具体显示出来 With display 117

118 .SetSymbol.DrawPolygon End With m_psimplefills m_pbufferpolygon Exit sub ' 事件 ActiveViewEvents 在改变所选的图形后要执行的过程 本例中, 对所 ' 选择的图形做 Buffer 运算 Private Sub ActiveViewEvents_SelectionChanged() Dim pactiveview Dim penumfeature Dim pfeature Dim ppolygon Dim ptopologicaloperator Dim pgeometrycollection On Error GoTo As IActiveView As IEnumFeature As IFeature As IPolygon As ITopologicalOperator As IGeometryCollection Set pactiveview = m_pmxdocument.focusmap Set pgeometrycollection = New GeometryBag 'Flag last buffered region for invalidation If Not m_pbufferenvelope Is Nothing Then pactiveview.partialrefresh esriviewgeography, Nothing, m_pbufferenvelope If m_pmxdocument.focusmap.selectioncount = 0 Then 'Nothing selected; don't draw anything Set m_pbufferpolygon = Nothing 'Buffer each selected feature ' 将用户选中的 Polygon 都放入 peumfeature 中 Set penumfeature = m_pmxdocument.focusmap.featureselection penumfeature.reset ' 将 peumfeature 中的第一个 Polygon 赋给 pfeature Set pfeature = penumfeature.next ' 将 peumfeature 中所有的 Polygon 进行 Buffer 逻辑运算, 并且将运算后的 Buffers 加入到 pgeometrycollection 的队列中 Do While Not pfeature Is Nothing Set ptopologicaloperator = pfeature.shape Set ppolygon = ptopologicaloperator.buffer(0.5) pgeometrycollection.addgeometry ppolygon 'Get next feature Set pfeature = penumfeature.next Loop ' 通过 Union 运算将所有的 Buffers 连接成一个 Polygon Set m_pbufferpolygon = New Polygon Set ptopologicaloperator = m_pbufferpolygon ptopologicaloperator.constructunion pgeometrycollection Set m_pbufferenvelope = m_pbufferpolygon.envelope 118

119 'Flag new buffered region for invalidation pactiveview.partialrefresh esriviewgeography, Nothing, m_pbufferpolygon.envelope Exit sub 如何创建 Envelope 的 Boundary 本例主要实现对一个或多个 Polygon 的 Envelope 创建 Boundary 要点在本例的实现过程中, 首先运用 ITopologicalOperator 接口对多个 Polygon 进行 Union 操作, 将其合并为单个 Polygon 但由于 Envelope 类未实现 ITopologicalOperator 接口, 从而不能直接返回 Bondery 这个属性, 因此需要创建一个函数来得到这个 Envelope 的 Bondery 程序说明 ActiveViewEvents_SelectionChanged() 过程是将用户选中的多个 Polygon 进行 Union 逻辑运算得到一个新的 Polygon, 然后求出这个 Polygon 的 Envelope CreateBoundaryOfEnvelope() 过程是求出 Envelope 的 Boundary, 并运用 CreateLine 这个函数将 Boundary 画出 ActiveViewEvents_AfterDraw() 是将 Boundary 在屏幕上具体显示出来 使用该程序时, 先运行宏的 InitEvents( ) 过程, 然后在地图上选择若干个 Polygon 即可得到这若干个 Polygon 的 Envelope 的 Boundary 代码 Option Explicit Private WithEvents ActiveViewEvents As Map Private m_pmxdocument As IMxDocument Private m_ppolygon As IPolygon Private m_penvelope As IEnvelope Private m_ppolycurve As IPolycurve Private m_pgeometrycollection As IGeometryCollection Private m_psegmentcollection As ISegmentCollection Public Sub InitEvents() Set m_pmxdocument = ThisDocument Set ActiveViewEvents = m_pmxdocument.focusmap Private Sub CreateBoundaryOfEnvelope(ByVal penvelope As IEnvelope, ByRef ppolycurve As IPolycurve) On Error GoTo ErrorHandler 'Check we have valid parameters. 'ppolycurve must be initialized as either a Polygon or Polyline, and must be empty. If penvelope Is Nothing Or ppolycurve Is Nothing Then 119

120 ppolycurve.setempty Dim pline As ILine 'Build the boundary of the Envelope, penvelope. ' 根据 ppolycurve 的类型来设置 m_psegmentcollection If TypeOf ppolycurve Is IPolygon Then Set m_psegmentcollection = New Ring ElseIf TypeOf ppolycurve Is IPolyline Then Set m_psegmentcollection = New Path Else ' 画出 Bondery, 并将其存储在 m_psegmentcollection 中 Set pline = CreateLine(pEnvelope.UpperLeft, penvelope.upperright) m_psegmentcollection.addsegment pline Set pline = CreateLine(pEnvelope.UpperRight, penvelope.lowerright) m_psegmentcollection.addsegment pline Set pline = CreateLine(pEnvelope.LowerRight, penvelope.lowerleft) m_psegmentcollection.addsegment pline Set pline = CreateLine(pEnvelope.LowerLeft, penvelope.upperleft) m_psegmentcollection.addsegment pline Set m_pgeometrycollection = ppolycurve m_pgeometrycollection.addgeometry m_psegmentcollection Private Function CreateLine(ByVal pfrom As IPoint, ByVal pto As IPoint) As ILine 'This function creates a new Line object with the passed in From and To points. Set CreateLine = New esricore.line CreateLine.PutCoords pfrom, pto End Function Private Sub ActiveViewEvents_AfterDraw(ByVal Display As IDisplay, ByVal phase As esriviewdrawphase) Dim i As Integer Dim psimplelines As ISimpleLineSymbol Dim prgbcolor As IRgbColor Dim pscreendisplay As IScreenDisplay On Error GoTo ErrorHandler If m_pgeometrycollection Is Nothing Then If m_pgeometrycollection.geometrycount = 0 Then ' 设置填充类型为 Line, 并将颜色设置为红色 Set psimplelines = New SimpleLineSymbol Set prgbcolor = New RgbColor prgbcolor.blue = 0 prgbcolor.green = 0 prgbcolor.red = 255 psimplelines.color = prgbcolor 120

121 If TypeOf Display Is IScreenDisplay Then Set pscreendisplay = Display ' 画出 Bondery With pscreendisplay.startdrawing pscreendisplay.hdc, esrinoscreencache.setsymbol psimplelines.drawpolyline m_pgeometrycollection.finishdrawing End With Private Sub ActiveViewEvents_SelectionChanged() Dim pactiveview As IActiveView Dim penumfeature As IEnumFeature Dim pfeature As IFeature Dim ppolygon As IPolygon Dim pgeometrycollection As IGeometryCollection Dim ptopologicaloperator As ITopologicalOperator Set pactiveview = m_pmxdocument.focusmap Set pgeometrycollection = New GeometryBag On Error GoTo ErrorHandler ' 如果 Envelope 不为空, 则刷新屏幕 If Not m_penvelope Is Nothing Then pactiveview.partialrefresh esriviewgeography, Nothing, m_penvelope If m_pmxdocument.focusmap.selectioncount = 0 Then 'Nothing selected; don't draw anything Set m_ppolygon = Nothing Set penumfeature = m_pmxdocument.focusmap.featureselection penumfeature.reset Set pfeature = penumfeature.next ' 将所选的 Polygon 加入到 pgeometrycollection 中 Do While Not pfeature Is Nothing Set ppolygon = pfeature.shape pgeometrycollection.addgeometry ppolygon 'Get next feature Set pfeature = penumfeature.next Loop ' 合并所有选定的 Polygon Set m_ppolygon = New Polygon Set ptopologicaloperator = m_ppolygon ptopologicaloperator.constructunion pgeometrycollection 121

122 Set m_penvelope = m_ppolygon.envelope ' 初始化 m_ppolycurve Set m_ppolycurve = New Polygon ' 调用 CreateBoundaryOfEnvelope 函数作出 Boundary CreateBoundaryOfEnvelope m_penvelope, m_ppolycurve 如何通过鼠标移动图形本例主要通过引用 IMoveLineFeedback 和 IMovePolygonFeedback 两个接口实现对地图中的 Polyline 和 Polygon 的移动 要点对于类型为 Polygon 的 Feature, 本例使用接口 IMovePolygonFeedback 的 Start 和 Stop 方法来移动选定的 Feature 其他类型的 Feature 类似, 只需相应地改变接口类型即可 程序说明在工具条上设置一个 ToolButton, 通过响应该 Button 的 MouseDown( ),MouseMove( ),MouseUp( ) 事件来实现对图形的移动 本例只列举了 Polyline 和 Polygon 两种类型的图形, 其他类型的图形可类似操作 代码 Dim m_pfeature As IFeature Dim m_pmxdocument As IMxDocument Dim m_pdisplayfeedback As IDisplayFeedback Dim m_pscreendisplay As IScreenDisplay Dim m_pmousecursor As IMouseCursor Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim pgeometry As IGeometry Dim pselectionset As ISelectionSet Dim pfeaturelayer As IFeatureLayer Dim pfeaturecursor As IFeatureCursor Dim pspatialfilter As ISpatialFilter Dim ppoint As IPoint Dim penvelope As IEnvelope Dim index As Integer On Error GoTo ErrorHandler Set m_pmxdocument = ThisDocument Set m_pscreendisplay = m_pmxdocument.activeview.screendisplay If m_pmxdocument.focusmap.layercount = 0 Then 122

123 ' 得到鼠标点击的起点坐标 Set ppoint = m_pscreendisplay.displaytransformation.tomappoint(x, y) ' 得到当前鼠标位置的 Envelope Set pgeometry = m_pmxdocument.currentlocation.envelope Set pspatialfilter = New SpatialFilter Set penvelope = pgeometry.envelope ' 扩大 Envelope 的范围便于搜索 penvelope.expand 0.2, 0.2, False ' 设置空间检索的条件 With pspatialfilter Set.Geometry = penvelope.geometryfield = "SHAPE".SpatialRel = esrispatialrelintersects End With ' 在当前 Map 的所有 FeatureLayer 中查找所要移动的图形 Dim i As Integer i = 0 index = m_pmxdocument.focusmap.layercount Do While i < index Set pfeaturelayer = m_pmxdocument.focusmap.layer(i) Set pfeaturecursor = pfeaturelayer.featureclass.search(pspatialfilter, True) Set m_pfeature = pfeaturecursor.nextfeature If Not m_pfeature Is Nothing Then Exit Do Else i = i + 1 Loop If m_pfeature Is Nothing Then ' 针对不同的 Feature 类型调用不同的接口进行操作 Select Case m_pfeature.shape.geometrytype ' 若 Feature 类型为 Polyline Case 3: Set m_pdisplayfeedback = New MoveLineFeedback Set m_pdisplayfeedback.display = m_pscreendisplay Dim pmovelinef As IMoveLineFeedback Set pmovelinef = m_pdisplayfeedback pmovelinef.start m_pfeature.shape, ppoint ' 若 Feature 类型为 Polygon Case 4: Set m_pdisplayfeedback = New MovePolygonFeedback Set m_pdisplayfeedback.display = m_pscreendisplay Dim pmovepolygonf As IMovePolygonFeedback Set pmovepolygonf = m_pdisplayfeedback pmovepolygonf.start m_pfeature.shape, ppoint ' 若为其他类型, 本例则省略, 不进行操作 Case Else MsgBox "Other SHP Type" Set m_pfeature = Nothing Set m_pscreendisplay = Nothing End Select m_pmxdocument.activeview.refresh 123

124 ' 设置鼠标外观 Set m_pmousecursor = New MouseCursor m_pmousecursor.setcursor 5 Private Sub UIToolControl1_MouseMove(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) On Error GoTo ErrorHandler If Not m_pdisplayfeedback Is Nothing Then Dim ppoint As IPoint ' 得到鼠标点击位置在地图上的坐标 Set ppoint = m_pscreendisplay.displaytransformation.tomappoint(x, y) m_pdisplayfeedback.moveto ppoint Private Sub UIToolControl1_MouseUp(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long) Dim pgeometry As IGeometry _ On Error GoTo ErrorHandler ' 检查是否存在一个元素 If Not m_pfeature Is Nothing Then ' 检测此元素的类型 Select Case m_pfeature.shape.geometrytype Case 3: Dim pmovelinef As IMoveLineFeedback Set pmovelinef = m_pdisplayfeedback Set pgeometry = pmovelinef.stop Case 4: Dim pmovepolygonf As IMovePolygonFeedback Set pmovepolygonf = m_pdisplayfeedback Set pgeometry = pmovepolygonf.stop End Select ' 更新元素 Set m_pfeature.shape = pgeometry m_pfeature.store Set m_pdisplayfeedback = Nothing m_pmxdocument.activeview.refresh ' 将鼠标外观还原 Set m_pmousecursor = New MouseCursor m_pmousecursor.setcursor 0 124

125 如何为一个图形添加一个顶点 本例要实现的功能是为一个 FeatureLayer 中被选择的一个 Feature 的 Shape 增加一个顶点 实现的方法中用到了接口 IPointCollection 的方法 AddPoint, 和接 口 IHitTest 的方法 HitTest 要点 为图形增加顶点, 用到接口 IPointCollection 中的方法 AddPoint (inpoint,[,before] [,after] ) 如果 before 和 after 默认, 则点加到点集合的最后 ; 如果指定了 before 或 after, 则点加到指定的位置 接口 IHitTest 的方法 :HitTest(QueryPoint, earchradius, eometrypart, itpoint, itdistance, itpartindex, itsegmentindex, RightSide), 其中 QueryPoint 是被用来查询 的点,hitPoint 返回被点击图形中离查询点最近的一个点 使用该方法来判断 要添加的点是否在图形设定的偏差范围内, 是就在该位置为图形添加一个顶 点 程序说明 本例是为一个 Polygon 添加一个顶点, 如果该 Polygon 只有一个 Ring, 则就 在该 Ring 上添加顶点, 如果该 Polygon 多于一个 Ring, 则在 Polygon 的第一个 Ring 上添加顶点 函数 AddVertex(pPolygon As IPolygon, pnewpoint As IPoint, LAfterIndex As Long), 将点 pnewpoint 插入到 ppolygon 中, 在索引为 LAfterIndex 的顶点之后 代码 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ ByVal y As Long) Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pactiveview As IActiveView Dim pfeaturelayer As IFeatureLayer Dim pfeatureclass As IFeatureClass Dim penumfeature As IEnumFeature Dim pfeature As IFeature Dim phittest As IHitTest Dim phitpoint As IPoint Dim DhitDist As Double Dim LpartIndex As Long Dim LvertexIndex As Long Dim BvertexHit As Boolean Dim ppoint As IPoint Dim ppolygon As IPolygon On Error GoTo ErrorHandler Set pmxdocument = ThisDocument 125

126 Set pmap = pmxdocument.focusmap Set pactiveview = pmap ' 将鼠标点下的点坐标转换为地图坐标 Set ppoint = pactiveview.screendisplay.displaytransformation.tomappoint(x, y) ' 得到第一层 Set pfeaturelayer = pmap.layer(0) ' 得到第一层的 FeatureClass Set pfeatureclass = pfeaturelayer.featureclass ' 得到第一层所选择的 EnumFeature Set penumfeature = pmxdocument.focusmap.featureselection penumfeature.reset Set pfeature = penumfeature.next ' 判断是否有 Feature 被选中 If pfeature Is Nothing Then MsgBox "no selection,please select a polygon" Else Set phitpoint = New Point Set phittest = pfeature.shape ' 判断增加的点是否在 Polygon 所能容忍的边界上 ' 在偏差值为 4 的情况下, 返回 True, 并返回增加点的前面 Polygon 的一个索引号 'LvertexIndex If phittest.hittest(ppoint, 4, esrigeometrypartboundary, phitpoint, DhitDist,_ LpartIndex,LvertexIndex, False) Then Set ppolygon = pfeature.shape ' 为 Polygon 增加一个顶点 Call AddVertex(pPolygon, ppoint, LvertexIndex + 1) Set pfeature.shape = ppolygon pfeature.store Set pfeature = Nothing pmxdocument.focusmap.clearselection pmxdocument.activeview.refresh Else ' 增加的点不在偏差值范围内, 信息框提示重新选点 MsgBox " 增加的点不在容忍范围内, 请冲重选 " Public Sub AddVertex(pPolygon As IPolygon, pnewpoint As IPoint, LAfterIndex As Long) Dim ppointcollection As IPointCollection Dim pgeocollection As IGeometryCollection Dim pring As Iring On Error GoTo ErrorHandler If ppolygon Is Nothing Then Set pgeocollection = ppolygon ' 判断 Polygon 是否是一个 Part If pgeocollection.geometrycount = 1 Then ' 是一个 Part 就把 ppolygon 赋给 ppointcollection Set ppointcollection = ppolygon Else ' 如果有多个 Part 就把 Feature 的第一个 Part 赋给 ppointcollection If pgeocollection.geometry(0).geometrytype = esrigeometryring Then 126

127 Set pring = pgeocollection.geometry(0) Set ppointcollection = pring ' 给 Polygon 增加一个顶点 ppointcollection.addpoint pnewpoint, LafterIndex 如何删除一个图形上的一个顶点本例要实现的功能是为一个 FeatureLayer 中被选择的一个 Feature 的 Shape 删除一个顶点 实现的方法中用到了接口 IPointCollection 的方法 RemovePoint, 和接口 IHitTest 的方法 HitTest 要点删除图形的顶点, 用到接口 IPointCollection 中的方法 RemovePoints (Index, Count ): 从指定的位置起移除指定个数的点 接口 IHitTest 的方法 :HitTest(QueryPoint, earchradius, eometrypart, itpoint, itdistance, itpartindex,hitsegmentindex,brightside), 用来判断要删除的点是否在图形设定的偏差范围内, 如果是就将在该位置的顶点删除 其中 QueryPoint 是被用来查询的点,hitPoint 返回被点击图形中离查询点最近的一个点 程序说明本例是为一个 Polygon 删除一个顶点, 如果该 Polygon 只有一个 Ring, 则就在该 Ring 上删除顶点 ; 如果该 Polygon 多于一个 Ring, 则删除 Polygon 的第一个 Ring 上的顶点 函数 RemoveVertex(pPolygon As IPolygon, lremovepointindex As Long), 是将索引为 lremovepointindex 的顶点从 ppolygon 中删除 代码 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ ByVal y As Long) Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pactiveview As IActiveView Dim pfeaturelayer As IFeatureLayer Dim pfeatureclass As IFeatureClass Dim penumfeature As IEnumFeature Dim pfeature As IFeature Dim phittest As IHitTest Dim phitpoint As IPoint Dim DhitDist As Double Dim LpartIndex As Long Dim LvertexIndex As Long Dim BvertexHit As Boolean 127

128 Dim ppoint Dim ppolygon Dim ppointcollection As IPoint As IPolygon As IPointCollection 号 On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pactiveview = pmap ' 将鼠标点下的点坐标转换为地图坐标 Set ppoint = pactiveview.screendisplay.displaytransformation.tomappoint(x, y) ' 得到第一层 Set pfeaturelayer = pmap.layer(0) ' 得到第一层的 FeatureClass Set pfeatureclass = pfeaturelayer.featureclass ' 得到第一层所选择的特征 Set penumfeature = pmxdocument.focusmap.featureselection penumfeature.reset Set pfeature = penumfeature.next If pfeature Is Nothing Then MsgBox "no selection,please select a polygon" End if Set ppointcollection = pfeature.shape If ppointcollection.pointcount <= 4 Then MsgBox "Polygon 的顶点数小于 4 时, 不能再删 " ' 判断是否有 Featrue 被选中 Set phitpoint = New Point Set phittest = pfeature.shape ' 判断增加点是否在 Polygon 的所能容忍的边界上 ' 如果点在偏差范围为 4 的情况下, 返回 True, 返回 LvertexIndex 的值是要删除的点的索引 If phittest.hittest(ppoint, 4, esrigeometrypartvertex, phitpoint, DhitDist, LpartIndex, _ LvertexIndex, False) Then Set ppolygon = pfeature.shape ' 删除 Polygon 上选中的顶点 Call RemoveVertex(pPolygon, LvertexIndex, LpartIndex) Set pfeature.shape = ppolygon pfeature.store Set pfeature = Nothing pmxdocument.activeview.refresh Else ' 如果没有在偏差范围内, 提示重新选点 MsgBox " 点不在 Polygon 偏差范围内, 请重新再点 " Public Sub RemoveVertex(pPolygon As IPolygon, lremovepointindex As Long,lRemovePartIndex as long) Dim ppointcollection As IPointCollection Dim pgeocollection As IGeometryCollection Dim pring As IRing 128

129 On Error GoTo ErrorHandler If ppolygon Is Nothing Then Set pgeocollection = ppolygon ' 判断 Polygon 是否是一个 Part If pgeocollection.geometrycount = 1 Then ' 是一个 Part 就把 ppolygon 赋给 ppointcollection Set ppointcollection = ppolygon Else ' 如果有多个 Part 就把 Feature 的第一个 Part 赋给 ppointcollection If pgeocollection.geometry(lremovepartindex).geometrytype = esrigeometryring Then Set pring = pgeocollection.geometry(lremovepartindex) Set ppointcollection = pring ' 删除 Polygon 中索引为 lremovepointindex 的一个顶点 ppointcollection.removepoints lremovepointindex, 1 ppointcollection.updatepoint 0, ppointcollection.point(0) 如何移动一个图形上的一个顶点本例通过引用接口 IPolygonMovePointFeedBack 实现在一个 Polygon 上面移动一个顶点 要点对于类型为 Polygon 的 Feature, 本例使用 IPolygonMovePointFeedBack 这个接口的 Start 和 Stop 方法来移动 Polygon 上被鼠标选中的顶点 其中 Start (Polygon, pointindex, Point ) 方法中, 参数 Polygon 是被移动顶点所在的 Polygon,pointIndex 是顶点在 Polygon 的索引位置,Point 是鼠标点击的位置点 要移动 Polyline 或其它图形的顶点方法类似, 只需相应地改变接口类型即可 程序说明在工具条上添加一个 ToolButton, 通过对该 ToolButton 的 MouseDown( ),MouseMove( ),MouseUp( ) 事件的响应来实现对用户所选 Polygon 的顶点的移动 该方法仅适用于单个 Part 的 Polygon, 如果一个 Polygon 是由多个 Part 组成则本方法不适用 代码 Private m_pmxdocument As IMxDocument Private m_pactiveview As IActiveView Private m_pscreendisplay As IScreenDisplay Private m_ppolygonmovepf As IPolygonMovePointFeedback Private m_pfeature As IFeature 129

130 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim ppoint As IPoint Dim ppolygon As IPolygon Dim pgeometry As IGeometry Dim pspatialfilter As ISpatialFilter Dim penvelope As IEnvelope Dim pfeaturelayer As IFeatureLayer Dim pfeaturecursor As IFeatureCursor Dim phittest As IHitTest Dim ppthit As IPoint Dim DblHitDis As Double Dim LngPrtIdx As Long Dim LngSegIdx As Long Dim i As Integer Dim index As Integer Dim BoolHitRt As Boolean Dim BoolHitTest As Boolean On Error GoTo ErrorHandler Set m_pmxdocument = ThisDocument Set m_pactiveview = m_pmxdocument.activeview Set m_pscreendisplay = m_pactiveview.screendisplay ' 得到鼠标点击的起点坐标 Set ppoint = m_pscreendisplay.displaytransformation.tomappoint(x, y) ' 得到当前鼠标位置的 Envelope Set pgeometry = m_pmxdocument.currentlocation.envelope Set pspatialfilter = New SpatialFilter Set penvelope = pgeometry.envelope ' 扩大 Envelope 的范围便于搜索 penvelope.expand 0.2, 0.2, False ' 设置空间检索的条件 With pspatialfilter Set.Geometry = penvelope.geometryfield = "SHAPE".SpatialRel = esrispatialrelintersects End With ' 在当前 Map 的所有 FeatureLayer 中查找所要改动的图形 i = 0 index = m_pmxdocument.focusmap.layercount Do While i < index Set pfeaturelayer = m_pmxdocument.focusmap.layer(i) Set pfeaturecursor = pfeaturelayer.featureclass.search(pspatialfilter, True) Set m_pfeature = pfeaturecursor.nextfeature If Not m_pfeature Is Nothing Then Exit Do Else i = i + 1 Loop ' 若用户所选图形不为空, 则移动所选顶点 If Not m_pfeature Is Nothing Then Set ppolygon = m_pfeature.shape Set phittest = ppolygon ' 查询用户选中的点是否是图形的顶点 BoolHitTest = phittest.hittest(ppoint, 1, esrigeometrypartvertex, ppthit, DblHitDis, LngPrtIdx, L 130

131 ngsegidx, BoolHitRt) If BoolHitTest Then Set m_ppolygonmovepf = New PolygonMovePointFeedback Set m_ppolygonmovepf.display = m_pscreendisplay ' 根据顶点索引 LngSegIdx 找到所选顶点并进行移动 m_ppolygonmovepf.start ppolygon, LngSegIdx, ppoint Private Sub UIToolControl1_MouseMove(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) On Error GoTo ErrorHandler If Not m_ppolygonmovepf Is Nothing Then Dim ppoint As IPoint ' 得到鼠标点击的当前位置在地图上的坐标 Set ppoint = m_pscreendisplay.displaytransformation.tomappoint(x, y) m_ppolygonmovepf.moveto ppoint Private Sub UIToolControl1_MouseUp(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim ppolygon As IPolygon On Error GoTo ErrorHandler If Not m_ppolygonmovepf Is Nothing Then ' 得到顶点移动后的图形并更新 Set ppolygon = m_ppolygonmovepf.stop Set m_pfeature.shape = ppolygon m_pfeature.store Set m_ppolygonmovepf = Nothing m_pactiveview.refresh 1.6. Element 如何创建 MarkerElement 本例要实现的功能是根据鼠标在 Map 上点击的位置增加 MarkerElement 要点本例中, 首先需要在 Map 上创建一个 MarkerElement 元素, 然后再设置该元素的属性 实现此功能, 用到了 IMarkerElement 接口 以下是该接口的主要属 131

132 性的介绍 : Symbol: 设置 Marker 元素的风格 在设置 Marker 元素风格的时候可以使用很多 MarkerSymbol 接口, 这里重点介绍一下本例中用到的 ISimpleMarkerSymbol 的使用 Angle: 设置旋转角度 Color: 设置颜色 Outline: 是否显示边框 OutlineSize: 边框宽度 OutlineColor: 边框颜色 Size: 大小 Style:Marker 的风格, 有圆形, 正方形, 叉型等可供选择 程序说明 函数 AddTextToLayout 根据传入的点 ( x,y ) 参数在 Map 上添加一个 MarkerElement 代码 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long,_ ByVal y As Long) AddMarkerElement x, y Sub AddMarkerElement(x, y) Dim pmxdocument Dim pactiveview Dim pgraphicscontainer Dim pmarkerelement Dim psimplemarkers Dim pelement Dim prgbcolor As IMxDocument As IActiveView As IGraphicsContainer As IMarkerElement As ISimpleMarkerSymbol As IElement As IRgbColor On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pactiveview = pmxdocument.focusmap Set pgraphicscontainer = pmxdocument.focusmap Set pmarkerelement = New MarkerElement Set prgbcolor = New RgbColor prgbcolor.red = 0 prgbcolor.blue = 0 prgbcolor.green = 100 ' 设置大小, 颜色, 风格, 旋转角度 Set psimplemarkers = New SimpleMarkerSymbol psimplemarkers.size = 50 psimplemarkers.color = prgbcolor psimplemarkers.style = esrismscross psimplemarkers.angle = 45 pmarkerelement.symbol = psimplemarkers Set pelement = pmarkerelement pelement.geometry = pactiveview.screendisplay.displaytransformation._ omappoint(x, y) pgraphicscontainer.addelement pmarkerelement, 0 pmxdocument.activeview.refresh 132

133 如何创建 TextElement 本例要实现的功能是根据鼠标在 Map 上点击的位置添加 Text 元素 要点实现本例的功能, 首先需要在 Map 上创建一个 Text 元素, 然后再设置该元素的属性 主要通过接口 ITextElement 和 IGraphicsContainer 来实现 ITextElement 接口是用来控制 Text 元素, 以下是它的几个主要属性 : ScaleText:BOOL 型, 表示地图比例尺变化时 Text 大小是否变化 ; Symbol: 用来设置 Text 元素的风格 ; Text: 用来设置 Text 元素的内容 IGraphicsContainer 是用来控制 PageLayout, Map 等对象上图形元素的接口 以下是它的几个主要属性和方法 : AddElement: 向层中增加一个元素 ; DeleteAllElements: 删除所有的元素 ; FindFrame: 查找可以放在该容器中的某对象, 例如 Text 元素 ; Next: 返回该容器中的下一个对象 ; UpdateElement: 更新某个元素 程序说明 素 代码 函数 AddText 根据鼠标点击的位置点 (x,y) 在 PageLayout 上添加一个文本元 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ ByVal y As Long) AddText x, y Sub AddText(x As Long, y As Long) Dim pmxdocument Dim pactiveview Dim pgraphicscontainer Dim ptextelement Dim pelement As IMxDocument As IActiveView As IGraphicsContainer As ITextElement As IElement On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pactiveview = pmxdocument.focusmap Set pgraphicscontainer = pmxdocument.focusmap Set ptextelement = New TextElement Set pelement = ptextelement ' 设置 Text 元素的内容 ptextelement.text = "My Map" ' 将元素的图形定位在点 (x,y) 处 pelement.geometry = pactiveview.screendisplay.displaytransformation.tomappoint(x, y) ' 向 Map 中添加元素 133

134 pgraphicscontainer.addelement ptextelement, 0 ' 刷新 pmxdocument.activeview.partialrefresh esriviewgraphics, Nothing, Nothing 如何创建 Balloon Callout 要点 本例要实现的功能是在 ActiveView 的中心位置添加一个 Balloon Callout Balloon Callout 是一种具有特殊特征的 TextElement 普通的 TextElement 的 Symbol 属性是 ITextSymbol 类型的, 但是要创建 Balloon Callout 就要用到 IFormattedTextSymbol 和 ICallout 两个接口 通过 IFormattedTextSymbol 中的 Background 属性可以创建各种特殊的 TextElement, 在本例中它用类 BalloonCallout 进行实例化 程序说明 运行函数 AddBalloonCallout 将在 ActiveView 的中心位置添加一个 BalloonCallout 代码 Public Sub AddBalloonCallout() Dim pmxdocument Dim ptextelement Dim pelement Dim ppoint Dim pcallout Dim ptextsymbol Dim pgraphicscontainer Dim midx dim midy As IMxDocument As ITextElement As IElement As IPoint As ICallout As IFormattedTextSymbol As IGraphicsContainer As Double As Double On Error GoTo ErrorHandler Set pmxdocument = ThisDocument ' 创建一个 TextElement Set ptextelement = New TextElement Set pelement = ptextelement ptextelement.text = "Text callout" & vbcrlf & "In the middle of the screen" ' 把 TextElement 放在屏幕的中央 midx = (pmxdocument.activeview.extent.xmax + pmxdocument.activeview.extent.xmin) / 2 midy = (pmxdocument.activeview.extent.ymax + pmxdocument.activeview.extent.ymin) / 2 Set ppoint = New esricore.point ppoint.putcoords midx, midy pelement.geometry = ppoint ' 设置 TextElement 的风格为默认气球类型的 callout Set ptextsymbol = New TextSymbol Set pcallout = New BalloonCallout Set ptextsymbol.background = pcallout 134

135 ' 利用如下规则计算出 TextElement 的锚点的位置 ppoint.putcoords midx - pmxdocument.activeview.extent.width / 4, _ midy + pmxdocument.activeview.extent.width / 20 pcallout.anchorpoint = ppoint ptextelement.symbol = ptextsymbol Set pgraphicscontainer = pmxdocument.activeview pgraphicscontainer.addelement pelement, 0 pelement.activate pmxdocument.activeview.screendisplay pmxdocument.activeview.partialrefresh esriviewgraphics, pelement, Nothing Msgbox Err.Description 如何创建 PolygonElement 要点 本例要实现的功能是在 ActiveView 的中心位置添加一个 Polygon Element 在 ArcMap 中创建二维图形的 Element 主要是通过接口 IFillShapeElement 实现 的 实现 IFillShapeElement 接口的类有 5 个 : CircleElement EllipseElement MultiPatchElement PolygonElement 和 RectangleElement, 分别实现 5 种图形类型的 Element 接口 IFillShapeElement 只有一个属性 Symbol, 类型为 IFillSymbol, 用来填 充二维图形的 Element 创建 PolygonElement, 就是用类 PolygonElement 实例化 IFillShapeElement 接口 的变量, 如果要创建其它图形类型的 Element, 方法也是类似 一般一个二维 的 Element 都需要用 Symbol 进行填充, 通过 IFillSymbol 实现 程序说明 通过鼠标点击来确定 Polygone 的顶点, 再用指定好的风格来填充这个 Polygon 代码 Private Sub UIToolControl1_MouseDown(ByVal button As Long, _ ByVal shift As Long, ByVal x As Long, ByVal y As Long) Dim pmxdoc As IMxDocument Dim pactiveview As IActiveView Dim pfillshapeelement As IFillShapeElement Dim pelement As IElement Dim psfillsymbol As ISimpleFillSymbol Dim prubberband As IRubberBand Dim ppolygon As IPolygon Dim pcolor As IColor On Error GoTo ErrorHandler Set pmxdoc = ThisDocument Set pactiveview = pmxdoc.focusmap ' 创建一个 PolygonElement Set pfillshapeelement = New PolygonElement 135

136 Set pelement = pfillshapeelement Set pcolor = New RgbColor pcolor.rgb = RGB(0, 0, 255) Set psfillsymbol = New SimpleFillSymbol With psfillsymbol.color = pcolor.style = esrisfsdiagonalcross End With ' 设置 PolygonElement 的填充 Symbol pfillshapeelement.symbol = psfillsymbol ' 画 polygon Set prubberband = New RubberPolygon Set ppolygon = prubberband.tracknew(pactiveview.screendisplay, Nothing) pelement.geometry = ppolygon ' 把 TextElement 加到 Map 上 pactiveview.graphicscontainer.addelement pelement, 0 pactiveview.partialrefresh esriviewgraphics, Nothing, Nothing 如何选中一个 Element 本例要实现的功能是选择 Map 上在鼠标点击位置上的或者在鼠标拖动范围内的 Elements 要点实现本例的功能用到两个重要的接口 IGraphicsContainerSelect 和 IGraphicsContainer IGraphicsContainerSelect 是用来控制 Graphics Container 中选择的元素 以下是它的几个主要方法 : SelectAllElements: 选中所有元素 ; SelectElement: 选中指定的元素 ; UnselectAllElements: 不选中任何元素 IGraphicsContainer 是用来控制 Graphics Container 中所有元素 在本例中主要用到它以下两个方法 : LocateElements: 根据点和偏差值选择元素 ; LocateElementsByEnvelope: 根据范围选择元素 程序说明通过鼠标点击或者拖动来选择 Map 上的 Element 代码 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim pmxdocument As IMxDocument 136

137 Dim pmap Dim pelement Dim pmapgraphicsselect Dim pgraphicscontainer Dim prubberband Dim penv Dim penumelem Dim DSrchDis Dim ppoint As IMap As IElement As IGraphicsContainerSelect As IGraphicsContainer As IRubberBand As IEnvelope As IEnumElement As Double As IPoint On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pgraphicscontainer = pmap Set pmapgraphicsselect = pmap Set prubberband = New RubberEnvelope Set penv = prubberband.tracknew(pmxdocument.activeview.screendisplay, Nothing) pmapgraphicsselect.unselectallelements ' 根据 penv 确定哪些元素需要选中 If penv.isempty Then Set ppoint =_ pmxdocument.activeview.screendisplay.displaytransformation.tomappoint(x, y) DSrchDis = pmxdocument.activeview.extent.width / 200 Set penumelem = pgraphicscontainer.locateelements(ppoint, DSrchDis) Else Set penumelem = pgraphicscontainer.locateelementsbyenvelope(penv) ' 选中指定的元素 If Not penumelem Is Nothing Then pmapgraphicsselect.unselectallelements penumelem.reset pmapgraphicsselect.selectelements penumelem pmxdocument.activeview.refresh 如何移动 Element 本例实现的功能是让一个 Element 跟着鼠标移动, 包括 MarkerElement LineElement PolygonElement RectangleElement 等 要点本例中使用了一个重要的接口 IDisplayFeedback, 该接口有众多针对具体图形的子接口, 如 IMovePolygonFeedback IMoveLineFeedback IMoveTextFeedback 等 接口 IDisplayFeedback 具有如下属性和方法 : Display: 设置 Feedback 所利用的显示属性 ; MoveTo: 当鼠标移动时, 设置鼠标点所在的坐标 ; Refresh: 刷新画面 ; 137

138 Symbol: 设置显示风格 程序说明函数 GetHitElement 通过传入的坐标点, 返回 GraphicsContainer 中被该点选中的一个 Element 代码 Option Explicit Private m_pmxdocument Private m_pactiveview Private m_pscreendisplay Private m_pdisplayfeedback Private m_pelement Private m_pgraphicscontainer Private m_pmousecursor As IMxDocument As IActiveView As IScreenDisplay As IDisplayFeedback As IElement As IGraphicsContainer As ImouseCursor Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long,_ ByVal y As Long) Dim ppoint As IPoint Dim pgeometry As IGeometry On Error GoTo ErrorHandler ' 得到鼠标点击位置在地图上的坐标 Set ppoint = m_pscreendisplay.displaytransformation.tomappoint(x, y) ' 得到鼠标点击位置的第一个元素 ( 如果存在 ) Set m_pelement = GetHitElement(pPoint) ' 如果存在一个元素, 则检测该元素的类型 (Point, Polyline, Envelope or Polygon) If Not m_pelement Is Nothing Then m_pmousecursor.setcursor 5 Set pgeometry = m_pelement.geometry 'Point If TypeOf pgeometry Is IPoint Then Set m_pdisplayfeedback = New MovePointFeedback Set m_pdisplayfeedback.display = m_pscreendisplay Dim pmovepointf As IMovePointFeedback Set pmovepointf = m_pdisplayfeedback pmovepointf.start pgeometry, ppoint ' Polyline ElseIf TypeOf pgeometry Is esricore.ipolyline Then Set m_pdisplayfeedback = New MoveLineFeedback Set m_pdisplayfeedback.display = m_pscreendisplay Dim pmovelinef As IMoveLineFeedback Set pmovelinef = m_pdisplayfeedback pmovelinef.start pgeometry, ppoint ' Rectangle (Envelope) ElseIf TypeOf pgeometry Is IEnvelope Then Set m_pdisplayfeedback = New MoveEnvelopeFeedback Set m_pdisplayfeedback.display = m_pscreendisplay Dim pmoveenvelopef As IMoveEnvelopeFeedback Set pmoveenvelopef = m_pdisplayfeedback pmoveenvelopef.start pgeometry, ppoint ' Polygon ElseIf TypeOf pgeometry Is IPolygon Then Set m_pdisplayfeedback = New MovePolygonFeedback Set m_pdisplayfeedback.display = m_pscreendisplay 138

139 Dim pmovepolygonf As IMovePolygonFeedback Set pmovepolygonf = m_pdisplayfeedback pmovepolygonf.start pgeometry, ppoint Private Sub UIToolControl1_MouseMove(ByVal button As Long, ByVal shift As Long, ByVal x As Long,_ ByVal y As Long) On Error GoTo ErrorHandler If Not m_pdisplayfeedback Is Nothing Then Dim ppoint As IPoint ' 得到鼠标点击位置在地图上的坐标 Set ppoint = m_pscreendisplay.displaytransformation.tomappoint(x, y) m_pdisplayfeedback.moveto ppoint Private Sub UIToolControl1_MouseUp(ByVal button As Long, ByVal shift As Long, ByVal x As Long,_ ByVal y As Long) Dim pgeomresult As IGeometry Dim pgeometry As IGeometry On Error GoTo ErrorHandler ' 是否存在一个元素 If Not m_pelement Is Nothing Then Set pgeometry = m_pelement.geometry ' 检测此元素的类型 (Point, Polyline, Envelope or Polygon) ' Point If TypeOf pgeometry Is IPoint Then Dim pmovepointf As IMovePointFeedback Set pmovepointf = m_pdisplayfeedback Set pgeomresult = pmovepointf.stop 'Polyline ElseIf TypeOf pgeometry Is IPolyline Then Dim pmovelinef As IMoveLineFeedback Set pmovelinef = m_pdisplayfeedback Set pgeomresult = pmovelinef.stop 'Envelope ElseIf TypeOf pgeometry Is IEnvelope Then Dim pmoveenvelopef As IMoveEnvelopeFeedback Set pmoveenvelopef = m_pdisplayfeedback Set pgeomresult = pmoveenvelopef.stop 'Polygon ElseIf TypeOf pgeometry Is IPolygon Then Dim pmovepolygonf As IMovePolygonFeedback Set pmovepolygonf = m_pdisplayfeedback Set pgeomresult = pmovepolygonf.stop ' 更新元素 m_pelement.geometry = pgeomresult m_pgraphicscontainer.updateelement m_pelement 139

140 Set m_pdisplayfeedback = Nothing Set m_pelement = Nothing m_pactiveview.refresh m_pmousecursor.setcursor 0 Private Sub UIToolControl1_Refresh(ByVal hdc As Long) Set m_pmxdocument = ThisDocument Set m_pactiveview = m_pmxdocument.activeview Set m_pscreendisplay = m_pactiveview.screendisplay Set m_pmousecursor = New MouseCursor m_pmousecursor.setcursor 0 Private Sub UIToolControl1_Select() Set m_pmxdocument = ThisDocument Set m_pactiveview = m_pmxdocument.activeview Set m_pscreendisplay = m_pactiveview.screendisplay Set m_pmousecursor = New MouseCursor m_pmousecursor.setcursor 0 Private Function GetHitElement(pInPt As IPoint) As IElement Dim penumelem As IEnumElement Dim DSrchDis As Double On Error GoTo ErrorHandler Set m_pgraphicscontainer = m_pactiveview ' 计算出一个缓冲范围 DSrchDis = m_pactiveview.extent.width / 200 Set penumelem = m_pgraphicscontainer.locateelements(pinpt, DSrchDis) If Not penumelem Is Nothing Then Set GetHitElement = penumelem.next Exit Function End Function 如何排列 Element 本例实现的功能是按照占支配地位的 Element 所在的位置排列选中的 Elements 比如按照 Top Bottom Left Right 等方式排列 在 ArcMap 中最后被选中的 Element 作为占支配地位的 Element 要点本例中使用了一个重要的接口 ITransform2D, 该接口具有如下方法 : Move : 根据输入的 dx,dy 移动对象 ; 140

141 MoveVector : 根据输入的矢量移动对象 ; Rotate: 根据输入的角度旋转对象 程序说明 本例中编写了三个函数, 下面逐一介绍 : Move: 根据输入的 dx,dy 移动指定的元素 ; AlignPos: 返回 penvelopemove 向 penvelopehome 对齐时需要移动的距离, 参 数 lcontrol 用来设置对齐的种类 代码 Align: 参数 lcontrol 设置对齐的种类 0 表示左对齐 ; 1 表示水平居中对齐 ; 2 表示右对齐 ; 3 表示置顶对齐 4 表示垂直居中对齐 ; 5 表示底部对齐 本例通过 DLL 实现, 如何添加菜单参见本书 节和 节 Public Sub Move(pElementMove As IElement, dx As Long, dy As Long) Dim pmxdocument As IMxDocument Dim ptransform2d As ITransform2D Dim pgraphicscontainer As IGraphicsContainer Dim pgraphicscontainers As IGraphicsContainerSelect On Error GoTo ErrorHandler Set pmxdocument = m_papplication.document Set pgraphicscontainer = pmxdocument.activeview Set pgraphicscontainers = pmxdocument.activeview pgraphicscontainer.reset If pgraphicscontainers.elementselectioncount = 0 Then ' 检索所有选中的元素 Set ptransform2d = pelementmove ' 移动选中的元素 ptransform2d.move dx, dy pgraphicscontainer.updateelement pelementmove Exit Function Private Function AlignPos(pEnvelopeHome As IEnvelope, penvelopemove As IEnvelope, _ lcontrol As Long) As IPoint Dim ppoint As IPoint On Error GoTo ErrorHandler 141

142 Set ppoint = New Point Select Case lcontrol 'align left Case 0 ppoint.x = penvelopehome.xmin - penvelopemove.xmin ppoint.y = 0 'align center Case 1 ppoint.x = (penvelopehome.xmin + penvelopehome.width / 2) _ - (penvelopemove.xmin + penvelopemove.width / 2) ppoint.y = 0 'align right Case 2 ppoint.x = penvelopehome.xmax - penvelopemove.xmax ppoint.y = 0 'align top Case 3 ppoint.x = 0 ppoint.y = penvelopehome.ymax - penvelopemove.ymax 'align vertical center Case 4 ppoint.x = 0 ppoint.y = (penvelopehome.ymin + penvelopehome.height / 2) _ - (penvelopemove.ymin + penvelopemove.height / 2) 'align bottom Case 5 ppoint.x = 0 ppoint.y = penvelopehome.ymin - penvelopemove.ymin End Select Set AlignPos = ppoint Exit Function End Function Public Function Align(lControl As Long) Dim pmxdocument As IMxDocument Dim pgraphicscontainers As IGraphicsContainerSelect Dim pelementhome As IElement Dim pelementmove As IElement Dim ppoint As IPoint Dim penumelement As IEnumElement Dim penvelopehome As IEnvelope Dim penvelopemove As IEnvelope On Error GoTo ErrorHandler Set pmxdocument = m_papplication.document Set pgraphicscontainers = pmxdocument.activeview Set penumelement = pgraphicscontainers.selectedelements If pgraphicscontainers.elementselectioncount = 0 Then Exit Function penumelement.reset ' 设定 Set penvelopehome = New Envelope Set penvelopemove = New Envelope Set pelementhome = penumelement.next ' 得到元素所显示的 Envelope pelementhome.querybounds pmxdocument.activeview.screendisplay, penvelopehome 142

143 Set pelementmove = penumelement.next pelementmove.querybounds pmxdocument.activeview.screendisplay, penvelopemove Do While Not pelementmove Is Nothing Set ppoint = AlignPos(pEnvelopeHome, penvelopemove, lcontrol) ' 移动 Move pelementmove, ppoint.x, ppoint.y Set pelementmove = penumelement.next If Not pelementmove Is Nothing Then pelementmove.querybounds pmxdocument.activeview.screendisplay,_ penvelopemove Loop pmxdocument.activeview.refresh Exit Function End Function 如何通过名字查询 Element 本例实现了两个功能 : 1. 在鼠标点击的位置创建一个 Element, 并且根据输入的内容为该 Element 设定一个名字 ; 2. 根据输入的名字查询 Element, 并将其设为选中状态 要点设定元素的名字通过接口 IElementProperties 实现 IElementProperties 是控制元素属性的接口 其主要属性有 : Name: 元素的名字 ; Type: 元素的类型 程序说明本例中编写了两个函数, 下面逐一介绍 : AddMarkerElement: 根据输入的 x,y 坐标添加一个 Element, 在这个过程中可以设定 Element 的名字 ; SelectByName: 通过输入名字来查询元素, 并将其设为选中状态 代码 Sub AddMarkerElement(x As Long, y As Long) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView Dim pgraphicscontainer As IGraphicsContainer Dim pmarkerelement As IMarkerElement Dim psimplemarkers As ISimpleMarkerSymbol Dim pelement As IElement 143

144 Dim prgbcolor Dim pelementproperties As IRgbColor As IElementProperties On Error GoTo ErrorHandler frmnameinput.show Set pmxdocument = ThisDocument Set pactiveview = pmxdocument.focusmap Set pgraphicscontainer = pmxdocument.focusmap Set pmarkerelement = New MarkerElement Set prgbcolor = New RgbColor prgbcolor.red = 0 prgbcolor.blue = 0 prgbcolor.green = 100 Set psimplemarkers = New SimpleMarkerSymbol psimplemarkers.size = 50 psimplemarkers.color = prgbcolor psimplemarkers.style = esrismscross psimplemarkers.angle = 45 pmarkerelement.symbol = psimplemarkers Set pelement = pmarkerelement pelement.geometry = pactiveview.screendisplay.displaytransformation._ ToMapPoint(x, y) pgraphicscontainer.addelement pmarkerelement, 0 ' 设定元素名字 Set pelementproperties = pmarkerelement pelementproperties.name = NameInput NameInput = "" pmxdocument.activeview.refresh Sub SelectByName() Dim pelementproperties Dim pgraphicscontainer Dim pgraphicscontainers Dim pmxdocument As IElementProperties As IGraphicsContainer As IGraphicsContainerSelect As ImxDocument On Error GoTo ErrorHandler frmnameinput.show Set pmxdocument = ThisDocument Set pgraphicscontainer = pmxdocument.activeview Set pgraphicscontainers = pmxdocument.activeview pgraphicscontainer.reset pgraphicscontainers.unselectallelements Set pelementproperties = pgraphicscontainer.next ' 循环检索 Do While Not pelementproperties Is Nothing If pelementproperties.name = NameInput Then pgraphicscontainers.selectelement pelementproperties Set pelementproperties = pgraphicscontainer.next Loop 144

145 pmxdocument.activeview.refresh 如何拷贝 Element 本例实现的功能是复制各种类型的 Element, 包括 MarkerElement LineElement PolygonElement CircleElement EllipseElement RectangleElement TextElement 和 PictureElement 等 要点本例综合了创建各种元素的方法, 使用的很多接口大部分都在前面章节讲解过, 这里就不再多做介绍 主要的实现方式是先获取被复制的 Element 的属性, 在按照这些属性生成一个同类型的 Element 程序说明函数 CopyElement 实现了通过判断元素的类型来复制多种元素的功能, 并将复制的元素添加到 Graphics Container 中 代码 Dim m_pmxdocument As IMxDocument Dim m_pgraphicscontainers As IGraphicsContainerSelect Private Sub UIButtonControl1_Click() Dim pelementproperties Dim pelement Dim penumelement As IElementProperties As IElement As IEnumElement On Error GoTo ErrorHandler Set m_pmxdocument = ThisDocument Set m_pgraphicscontainers = m_pmxdocument.activeview Set penumelement = m_pgraphicscontainers.selectedelements penumelement.reset Set pelementproperties = penumelement.next ' 对所有选中的元素进行复制 Do While Not pelementproperties Is Nothing CopyElement pelementproperties Set pelementproperties = penumelement.next Loop m_pmxdocument.activeview.refresh Sub CopyElement(pElementProperties As IElementProperties) Dim psymbol As ISymbol Dim penvelope As IEnvelope 145

146 Dim pgeometry Dim pcopyelement Dim pelement As IElement As IGeometry As Ielement On Error GoTo ErrorHandler Set pelement = pelementproperties ' 根据不同的类型创建元素, 并设置其属性 Select Case pelementproperties.type Case "Marker" Dim pmarkerelement Dim pcopymarkerelement As IMarkerElement As IMarkerElement Set pmarkerelement = pelement Set pcopymarkerelement = New MarkerElement Set psymbol = pmarkerelement.symbol pcopymarkerelement.symbol = psymbol Set pcopyelement = pcopymarkerelement Case "Line" Dim plineelement As ILineElement Dim pcopylineelement As ILineElement Set plineelement = pelement Set pcopylineelement = New LineElement Set psymbol = plineelement.symbol pcopylineelement.symbol = psymbol Set pcopyelement = pcopylineelement Case "Text" Dim ptextelement As ITextElement Dim pcopytextelement As ITextElement Set ptextelement = pelement Set pcopytextelement = New TextElement Set psymbol = ptextelement.symbol With pcopytextelement.symbol = psymbol.text = ptextelement.text End With Set pcopyelement = pcopytextelement Case "Circle" Dim pcfillshapee As IFillShapeElement Dim pccopyfillshapee As IFillShapeElement Set pcfillshapee = pelement Set pccopyfillshapee = New CircleElement Set psymbol = pcfillshapee.symbol pccopyfillshapee.symbol = psymbol Set pcopyelement = pccopyfillshapee Case "Ellipse" Dim pefillshapee As IFillShapeElement Dim pecopyfillshapee As IFillShapeElement Set pefillshapee = pelement Set pecopyfillshapee = New EllipseElement Set psymbol = pefillshapee.symbol pecopyfillshapee.symbol = psymbol Set pcopyelement = pecopyfillshapee Case "Polygon" Dim ppfillshapee As IFillShapeElement Dim ppcopyfillshapee As IFillShapeElement 146

147 Set ppfillshapee = pelement Set ppcopyfillshapee = New PolygonElement Set psymbol = ppfillshapee.symbol ppcopyfillshapee.symbol = psymbol Set pcopyelement = ppcopyfillshapee Case "Rectangle" Dim prfillshapee As IFillShapeElement Dim prcopyfillshapee As IFillShapeElement Set prfillshapee = pelement Set prcopyfillshapee = New RectangleElement Set psymbol = prfillshapee.symbol prcopyfillshapee.symbol = psymbol Set pcopyelement = prcopyfillshapee Case "Picture" Dim ppictureelement As IPictureElement Dim pcopypictureelement As IPictureElement Set ppictureelement = pelement If TypeOf ppictureelement Is BmpPictureElement Then Set pcopypictureelement = New BmpPictureElement Else Set pcopypictureelement = New EmfPictureElement With pcopypictureelement.importpicturefromfile pelementproperties.name.savepictureindocument = ppictureelement.savepictureindocument End With Set pcopyelement = pcopypictureelement Case Else MsgBox pelementproperties.type End Select Set pgeometry = pelement.geometry pcopyelement.geometry = pgeometry Dim pgraphicscontainer Set pgraphicscontainer = m_pmxdocument.activeview pgraphicscontainer.addelement pcopyelement, 0 ' 移动 Element Dim ptransform2d As ITransform2D Set ptransform2d = pcopyelement ptransform2d.move 20, -20 m_pmxdocument.activeview.refresh As IGraphicsContainer 如何沿着折线路径显示 Text 本例实现的功能是让新生成的 Text 沿着折线路径显示 147

148 要点 本例使用接口 ITextPath 来实现控制 TextElement 显示路径的功能 本例主 要用到接口 ITextPath 的 Geometry 属性 :TextElement 显示路径的参照图形 代码 DPrivate Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim pmxdocument As IMxDocument Dim prubberband As IRubberBand Dim pgeometry As IGeometry Dim psimpletexts As ISimpleTextSymbol Dim ptextpath As ITextPath Dim pelement As IElement Dim ptextelement As ITextElement Dim pgraphicscontainer As IGraphicsContainer On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set prubberband = New RubberLine ' 画折线 Set pgeometry = prubberband.tracknew(pmxdocument.activeview.screendisplay, Nothing) Set ptextpath = New SimpleTextPath ' 设置 Text 路径 Set ptextpath.geometry = pgeometry Set psimpletexts = New TextSymbol Set psimpletexts.textpath = ptextpath Set ptextelement = New TextElement With ptextelement.symbol = psimpletexts ' 设置 Text 内容.Text = InputBox("Text:", "Text2") End With Set pelement = ptextelement pelement.geometry = pgeometry Set pgraphicscontainer = pmxdocument.activeview ' 添加元素 pgraphicscontainer.addelement pelement, 0 pmxdocument.activeview.refresh 1.7. Symbol 和 Renderer 如何为一个层设置 Simple Renderer 本例要实现的是如何为一个层设置 Simple Renderer 用同一颜色填充 polygon 要点首先实例化接口 IGeoFeatureLayer, 然后创建 IFillSymbol 接口对象和 148

149 ILineSymbol 接口对象来设置填充的颜色和外线框 Symbol, 创建 ISimpleRenderer 接口对象并对属性设置, 最后赋值给 IGeoFeatureLayer.Render 属性 程序说明 本程序的加载的数据是 WorldCountries.shp 点击 UIButtonControl1 程序开 始运行 过程 SimpleRenderer 根据 psimplerenderer 的属性值完成本图层的 Simple Renderer 代码 在过程 SimpleRenderer 运行中颜色数据都由调用函数 GetRGBColor 得到 Private Sub UIButtonControl1_Click() 'call SimpleRenderer SimpleRenderer Private Sub SimpleRenderer() Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pgeofeaturel As IGeoFeatureLayer Dim psimplerenderer As ISimpleRenderer Dim psimplefills As IFillSymbol Dim plinesymbol As ILineSymbol On Error GoTo Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set psimplefills = New SimpleFillSymbol Set pgeofeaturel = pmap.layer(0) ' Initialise a color object to Lilac psimplefills.color = GetRGBColor(235, 202, 250) ' Now initialise the line symbol used for the outline, set it to black ' and make it width of 1 point. ' Assign this into the fill symbols outline propetry. Set plinesymbol = New SimpleLineSymbol plinesymbol.color = GetRGBColor(0, 0, 0) plinesymbol.width = 1 psimplefills.outline = plinesymbol ' Now initialise the simple renderer and assign it a fill symbol, ' by default it doesn't have a symbol Set psimplerenderer = New SimpleRenderer Set psimplerenderer.symbol = psimplefills ' Now set the layers renderer property to be this simple renderer, ' and refresh the screen ' Set pgeofeaturel.renderer = psimplerenderer pmxdocument.activeview.refresh pmxdocument.updatecontents 149

150 Private Function GetRGBColor(yourRed As Long, yourgreen As Long, _ yourblue As Long) As IRgbColor Dim prgb As IRgbColor Set prgb = New RgbColor With prgb.red = yourred.green = yourgreen.blue = yourblue.usewindowsdithering = True End With Set GetRGBColor = prgb End Function 如何为一个层设置 UniqueValue Renderer 本例要实现的是如何在一个层中设置 UniqueValue Renderer, 根据 PLACENAME 字段填充上不同的颜色的 polygon, 并在 Table of Contents 窗口 中显示出对其记数和描述 要点 首先实例化接口 IGeoFeatureLayer, 通过类 UniqueValueRenderer 实现 IUniqueValueRender 接口的对象实例, 通过对 IUniqueValueRender 的属性进行赋值, 最后赋值给 IGeoFeatureLayer.Render 属性 程序说明 行 本程序的加载的数据是 Contenties.shp 点击 UIButtonControl1 程序开始运 过程 UniqueValueRenderer 根据 puniquevaluer 的属性值填充颜色记录 过程 UniqueValues_LabelCount_and_DescripFromField 调用函数 GetLabelDescription 实现记数和描述的功能 代码 'Declare global variable Dim m_pmxdocument As IMxDocument Dim m_pmap As IMap Dim m_pgeofeaturel As IGeoFeatureLayer Const DESCRIP_FIELD = "PLACENAME" ' Field name for unique value Renderer Const CONCATENATE_TO_BUILD_DESCRIPTION = True Const CONCAT_CHAR = vbnewline Private Sub UIButtonControl1_Click() 'call sub UniqueValueRenderer and UniqueValues_LabelCount_and_DescripFromField UniqueValueRenderer UniqueValues_LabelCount_and_DescripFromField Private Sub UniqueValueRenderer() Dim puniquevaluer As IUniqueValueRenderer Dim pfillsymbol As IFillSymbol Dim pcolor As IColor 150

151 Dim pnextuniquecolor As IColor Dim penumramp As IEnumColors Dim ptable As ITable Dim lfieldnumber As Long Dim pnextrow As IRow Dim pnextrowbuffer As IRowBuffer Dim pcursor As ICursor Dim pqueryfilter As IQueryFilter Dim codevalue As Variant Dim pcolorramp As IRandomColorRamp ' A field for the shapefile Const strnamefield = DESCRIP_FIELD On Error GoTo Set m_pmxdocument = ThisDocument Set m_pmap = m_pmxdocument.focusmap Set m_pgeofeaturel = m_pmap.layer(0) ' Iterate through the class and a random color ramp ' retrieve a state name, and a corresponding random color. Put the name and ' color into the unique value renderer. When complete assign the renderer to the ' layer and refresh to display the symbology. ' Create a color ramp, color object and a unique value renderer to be set up ' later on ' Set puniquevaluer = New UniqueValueRenderer ' QI the table from the geofeaturelayer and get the field number of ' Set ptable = m_pgeofeaturel lfieldnumber = ptable.findfield(strnamefield) If lfieldnumber = -1 Then MsgBox "Can't find field called " & strnamefield ' Specify the fied to renderer unique values with ' puniquevaluer.fieldcount = 1 puniquevaluer.field(0) = strnamefield ' Set up the Color ramp, this came from looking at ArcMaps Color Ramp ' properties for Pastels. ' Set pcolorramp = New RandomColorRamp pcolorramp.starthue = 0 pcolorramp.minvalue = 99 pcolorramp.minsaturation = 15 pcolorramp.endhue = 360 pcolorramp.maxvalue = 100 pcolorramp.maxsaturation = 30 pcolorramp.size = 100 pcolorramp.createramp True Set penumramp = pcolorramp.colors Set pnextuniquecolor = Nothing ' Get a enumerator on the first row of the Layer ' Set pqueryfilter = New QueryFilter pqueryfilter.addfield strnamefield Set pcursor = ptable.search(pqueryfilter, True) Set pnextrow = pcursor.nextrow ' Iterate through each row, adding values and a color to the unique value renderer ' Note we don't bother filtering out duplicates, 151

152 ' if we add in a second value that is already there ' the symbol changes but the value remains ' Do While Not pnextrow Is Nothing ' QI the row buffer from the row and get the value ' Set pnextrowbuffer = pnextrow codevalue = pnextrowbuffer.value(lfieldnumber) ' Get a Color object from the color ramp and advance the enumerator ' if we've run out then reset and start again ' Set pnextuniquecolor = penumramp.next If pnextuniquecolor Is Nothing Then penumramp.reset Set pnextuniquecolor = penumramp.next ' Set the symbol to the Color and add it to render a given value ' Set pfillsymbol = New SimpleFillSymbol pfillsymbol.color = pnextuniquecolor puniquevaluer.addvalue codevalue, codevalue, pfillsymbol ' Advance the cursor to the next row, or end of the dataset Set pnextrow = pcursor.nextrow Loop ' Now set the layers renderer to the unique value renderer Set m_pgeofeaturel.renderer = puniquevaluer m_pmxdocument.activeview.refresh Private Sub UniqueValues_LabelCount_and_DescripFromField() Dim puniquevaluer As IUniqueValueRenderer Dim sfieldname As String Dim i As Integer Dim varvalue As Variant Dim pfeatureclass As IFeatureClass Dim varlabeldescrip As Variant On Error GoTo If Not TypeOf m_pgeofeaturel.renderer Is IUniqueValueRenderer Then MsgBox "Current symbology is not Unique values. Exiting." Set puniquevaluer = m_pgeofeaturel.renderer If puniquevaluer.fieldcount > 1 Then MsgBox "Current Unique values symbology is based on multiple fields. Exiting." sfieldname = puniquevaluer.field(0) Set pfeatureclass = m_pgeofeaturel.featureclass For i = 0 To puniquevaluer.valuecount - 1 varvalue = puniquevaluer.value(i) varlabeldescrip = GetLabelDescription(pFeatureClass, _ 152

153 puniquevaluer.field(0), varvalue) puniquevaluer.label(varvalue) = varlabeldescrip(0) puniquevaluer.description(varvalue) = varlabeldescrip(1) Next i m_pmxdocument.activeview.contentschanged m_pmxdocument.updatecontents m_pmxdocument.activeview.refresh Private Function GetLabelDescription(pFeatureClass As IFeatureClass, _ ValField As String, Value As Variant) As Variant ' returns an array of length 2 ' (0) is the new label (string) appended with count of features ' (1) is the new descrip (string) driven from DESCRIP_FIELD Dim pqueryfilter As IQueryFilter Dim pfeaturecursor As IFeatureCursor Dim pfeature As IFeature Dim sdescrip As String Dim idescrip As Integer Dim icount As Integer Dim bcountsdetermined As Boolean Dim slabel As String Dim sreturnarray(2) As String On Error GoTo Set pqueryfilter = New QueryFilter pqueryfilter.whereclause = ValField & " = '" & CStr(Value) & "'" pqueryfilter.addfield DESCRIP_FIELD Set pfeaturecursor = pfeatureclass.search(pqueryfilter, False) ' ' Description idescrip = pfeatureclass.fields.findfield(descrip_field) Set pfeature = pfeaturecursor.nextfeature icount = 0 bcountsdetermined = False If CONCATENATE_TO_BUILD_DESCRIPTION Then bcountsdetermined = True Do While Not pfeature Is Nothing icount = icount + 1 If sdescrip <> "" Then sdescrip = sdescrip + CONCAT_CHAR ' get value from DESCRIP_FIELD sdescrip = sdescrip + CStr(pFeature.Value(iDescrip)) Set pfeature = pfeaturecursor.nextfeature Loop Else ' only get descrip from first feature found If Not pfeature Is Nothing Then ' get value from DESCRIP_FIELD sdescrip = CStr(pFeature.Value(iDescrip)) ' ' Label 153

154 If Not bcountsdetermined Then ' optimization: re-query only if we don't ' already have the counts from above icount = pfeatureclass.featurecount(pqueryfilter) slabel = Value & " (" & icount & ") " ' ' setup return array and return sreturnarray(0) = slabel sreturnarray(1) = sdescrip GetLabelDescription = sreturnarray Exit Function End Function 如何为一个层设置 ClassBreaks Renderer 本例要实现的是在一个层设置 ClassBreaks Renderer, 在 states 层中根据人口 (Pop1990) 字段的数据, 将它分成五个等级, 填充以不同的颜色 要点 首先实例化 IGeoFeatureLayer, 再创建 ITableHistogram 接口实例来接受数据, 通过 IHistogram 和 IClassify 接口对象对数据进行处理分成五个等级, 创建 ISimpleFillSymbol 接口对象, 创建 IClassBreaksRenderer 接口对象接收 symbol 和 break 的设置信息, 最后赋值给 IGeoFeatureLayer.Renderer 属性 程序说明 本程序的加载的数据是 states.shp 点击 UIButtonControl1 程序开始运行 过程 ClassBreaksRenderer 根据 pclassbreaksrenderer 的属性值来控制 Map 的显 示效果 代码 Private Sub UIButtonControl1_Click() 'call sub ClassBreaksRenderer ClassBreaksRenderer Private Sub ClassBreaksRenderer() Dim pmxdocument Dim pmap Dim pgeofeaturel Dim ptable Dim pclassify Dim ptablehistogram Dim phistogram Dim datafrequency Dim datavalues Dim stroutput Dim Classes() As IMxDocument As IMap As IGeoFeatureLayer As ITable As IClassify As ITableHistogram As IHistogram As Variant As Variant As String As Double 154

155 Dim ClassesCount As Long Dim pclassbreaksrenderer As IClassBreaksRenderer Dim pfromcolor As IHsvColor Dim ptocolor As IHsvColor Dim palgorithmiccr As IAlgorithmicColorRamp Dim penumcolors As IEnumColors Dim ok As Boolean Dim pcolor As IColor Dim psimplefills As ISimpleFillSymbol Dim lbreakindex As Long 'A field for the shapefile Const strpopfield = "POP1990" Const numdesiredclasses As Long = 5 ' We're going to retrieve frequency data from a population field ' and then classify this data ' On Error GoTo Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pgeofeaturel = pmap.layer(0) Set ptable = pgeofeaturel Set ptablehistogram = New TableHistogram Set phistogram = ptablehistogram ' Get values and frequencies for the population field ' into a table histogram object ptablehistogram.field = strpopfield Set ptablehistogram.table = ptable phistogram.gethistogram datavalues, datafrequency ' Put the values and frequencies into an Equal Interval classify object ' Set pclassify = New EqualInterval pclassify.sethistogramdata datavalues, datafrequency ' Now a generate the classes ' Note: ' 1/ The number of classes returned may be different from requested ' (depends on classification algorithm) ' 2/ The classes array starts at index 0 and has datavalues starting ' from the minumum value, going to maximum ' pclassify.classify numdesiredclasses Classes = pclassify.classbreaks ClassesCount = UBound(Classes) ' Initialise a new class breaks renderer and supply the number of ' class breaks and the field to perform the class breaks on. ' Set pclassbreaksrenderer = New ClassBreaksRenderer pclassbreaksrenderer.field = strpopfield pclassbreaksrenderer.breakcount = ClassesCount pclassbreaksrenderer.sortclassesascending = True ' Use an algorithmic color ramp to generate an range of colors between ' yellow to red (taken from ArcMaps colorramp properties) ' ' Set the initial color to yellow ' Set pfromcolor = New HsvColor pfromcolor.hue = 60 ' Yellow pfromcolor.saturation =

156 pfromcolor.value = 96 ' Set the final color to be red ' Set ptocolor = New HsvColor ptocolor.hue = 0 ' Red ptocolor.saturation = 100 ptocolor.value = 96 ' Set up the HSV colour ramp to span from yellow to red ' Set palgorithmiccr = New AlgorithmicColorRamp palgorithmiccr.algorithm = esrihsvalgorithm palgorithmiccr.fromcolor = pfromcolor palgorithmiccr.tocolor = ptocolor palgorithmiccr.size = ClassesCount palgorithmiccr.createramp ok Set penumcolors = palgorithmiccr.colors ' Iterate through each class brake, setting values and corresponding ' fill symbols for each polygon, note we skip the minimum value (classes(0)) ' For lbreakindex = 0 To ClassesCount - 1 ' Retrieve a color and set up a fill symbol, ' put this in the symbol array corresponding to the class value ' Set pcolor = penumcolors.next Set psimplefills = New SimpleFillSymbol psimplefills.color = pcolor psimplefills.style = esrisfssolid pclassbreaksrenderer.symbol(lbreakindex) = psimplefills pclassbreaksrenderer.break(lbreakindex) = Classes(lbreakIndex + 1) ' Store each break value for user output stroutput = stroutput & "- " & Classes(lbreakIndex + 1) & vbnewline Next lbreakindex ' Assign the renderer to the layer and update the display ' Set pgeofeaturel.renderer = pclassbreaksrenderer pmxdocument.activeview.refresh pmxdocument.updatecontents 如何为一个层设置 ProportionalSymbol Renderer 本例要实现的是如何在一个层中设置 ProportionalSymbol Renderer 按 states 层中人口字段 (Pop1990) 值的大小按比例画出 Symbols 要点首先实例化 IGeoFeatureLayer, 创建 IdataStatistics 接口对象来计算数据的最大最小值, 然后创建 ICharacterMarkerSymbol 接口对象, 将 Min Symbol 设置为 character marker symbol 再创建 IpoportionalSymbolRenderer 接口对象接收所有 Symbol 的设置信息并将数据分段 最后赋值给 IGeoFeatureLayer.Render 属性 程序说明 156

157 本程序的加载的数据是 states.shp 点击 UIButtonControl1 程序开始运行 过程 ProportionalSymbol 根据 pproportionalsymbolr 的属性值画出预定的 Symbol 背景的填充由 pfillsymbol.color 调用函数 GetRGBColor 实现,Symbol 颜色 由 pcharater 代码 MarkerS.Color 调用函数 GetRGBColor 实现 Private Sub UIButtonControl1_Click() 'call sub ProportionalSymbol ProportionalSymbol Private Sub ProportionalSymbol() Dim pmxdocument Dim pmap Dim pfeaturelayer Dim pgeofeaturelayer Dim pproportionalsymbolr Dim ptable Dim pqueryfilter Dim pcursor Dim pfillsymbol Dim pcharatermarkers Dim pcolor Dim poutlinecolor Dim pdatastatistics Dim pstatisticsresult Dim pfontdisp Dim protationrenderer As IMxDocument As IMap As IFeatureLayer As IGeoFeatureLayer As IProportionalSymbolRenderer As ITable As IQueryFilter As ICursor As IFillSymbol As ICharacterMarkerSymbol As IColor As IColor As IDataStatistics As IStatisticsResults As IFontDisp As IRotationRenderer On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap 'Get the first layer Set pfeaturelayer = pmap.layer(0) Set pgeofeaturelayer = pfeaturelayer 'QI the feature layer for the table interface Set ptable = pgeofeaturelayer 'Initialise a query and get a cursor Set pqueryfilter = New QueryFilter pqueryfilter.addfield "" Set pcursor = ptable.search(pqueryfilter, True) 'Use the statistics objects to calculate the max value 'and the min value Set pdatastatistics = New DataStatistics Set pdatastatistics.cursor = pcursor 'Set statistical field pdatastatistics.field = "POP1990" 'Get the result of statistics Set pstatisticsresult = pdatastatistics.statistics If pstatisticsresult Is Nothing Then 157

158 MsgBox "Failed to gather stats on the feature class" ' Set up the background fill color Set pfillsymbol = New SimpleFillSymbol pfillsymbol.color = GetRGBColor(239, 228, 190) 'Set up the min symbol to a special character marker symbol Set pcharatermarkers = New CharacterMarkerSymbol Set pfontdisp = New StdFont pfontdisp.name = "ESRI Business" pfontdisp.size = 10 With pcharatermarkers.font = pfontdisp.characterindex = 95.Color = GetRGBColor(0, 0, 0).Size = 4 End With ' Create a new proportional symbol renderer to draw pop1990 Set pproportionalsymbolr = New ProportionalSymbolRenderer With pproportionalsymbolr.valueunit = esriunknownunits.field = "POP1990".FlanneryCompensation = False.MinDataValue = pstatisticsresult.minimum.maxdatavalue = pstatisticsresult.maximum.backgroundsymbol = pfillsymbol.minsymbol = pcharatermarkers.legendsymbolcount = 5.CreateLegendSymbols End With 'set rotation renderer by pop1990 Set protationrenderer = pproportionalsymbolr protationrenderer.rotationfield = "POP1990" protationrenderer.rotationtype = esrirotatesymbolgeographic ' Set the cities layers renderer to the proportional 'symbol renderer and refresh the display Set pgeofeaturelayer.renderer = pproportionalsymbolr pmxdocument.activeview.refresh pmxdocument.updatecontents Public Function GetRGBColor(red As Integer, _ green As Integer, _ blue As Integer) As IColor Dim pcolor As IColor Set pcolor = New RgbColor pcolor.rgb = RGB(red, green, blue) Set GetRGBColor = pcolor End Function 如何为一个层设置 Chart Renderer 本例要实现的是为一个层设置 Chart Renderer, 使用一个 bar chart symbol 和一个 chart Renderer 来显示在每个 US State 人口的情况 用图解的方法说明 states 158

159 层的两个字段 Pop1990( 紫色显示 ) 和 Pop1999( 绿色显示 ) 之间人口的对比 情况 要点 首先实例化 IGeoFeatureLayer, 创建 IBarChartSymbol 接口对象, 设置 bar 的宽 度 ; 创建 IMarkerSymbol 接口对象设置 Renderer; 创建 IChartSymbol 接口对象找 出最大值传递给 IMarkerSymbol 来设置 bar 的最大高度, 创建 IFillSymbol 接口对 象来设置填充的颜色, 最后赋值给 IGeoFeatureLayer.Render 属性 程序说明 本程序的加载的数据是 states.shp 点击 UIButtonControl1 程序开始运行 过程 BarChartRenderer 根据 pchartrenderer 的属性值画出预定的 Symbol 所有 颜色的设置都由 pfillsymbol.color 调用函数 GetRGBColor 完成 代码 Private Sub UIButtonControl1_Click() 'call sub BarChartRenderer BarChartRenderer Private Sub BarChartRenderer() Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pgeofeaturel As IGeoFeatureLayer Dim pchartrenderer As IChartRenderer Dim prendererfields As IRendererFields Dim ptable As ITable Dim pcursor As ICursor Dim pqueryfilter As IQueryFilter Dim prowbuffer As IRowBuffer ' Number of bars Const numfields As Long = 2 Dim fieldindecies(0 To numfields - 1) As Long Dim lfieldindex As Long Dim dmaxvalue As Double Dim firstvalue As Boolean Dim dfieldvalue As Double Dim pbarchartsymbol As IBarChartSymbol Dim pfillsymbol As IFillSymbol Dim pmarkersymbol As IMarkerSymbol Dim psymbolarray As ISymbolArray Dim pchartsymbol As IChartSymbol Const strpopfield1 = "POP1990" Const strpopfield2 = "POP1999" On Error GoTo Set pchartrenderer = New ChartRenderer ' Set up the fields to draw charts of Set prendererfields = pchartrenderer prendererfields.addfield strpopfield1 prendererfields.fieldalias(0) = prendererfields.field(0) prendererfields.addfield strpopfield2 159

160 prendererfields.fieldalias(1) = prendererfields.field(1) ' Calculate the max value of the data fields to allow the bar chart ' to scale the bars correctly ' Do this by looking through all the data fields of all the features Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pgeofeaturel = pmap.layer(0) Set ptable = pgeofeaturel Set pqueryfilter = New QueryFilter pqueryfilter.addfield strpopfield1 pqueryfilter.addfield strpopfield2 Set pcursor = ptable.search(pqueryfilter, True) ' Make an array of the field numbers to iterate accross, ' this is to keep the code generic in the number of bars to draw. fieldindecies(0) = ptable.findfield(strpopfield1) fieldindecies(1) = ptable.findfield(strpopfield2) firstvalue = True dmaxvalue = 0 ' Iterate across each feature Set prowbuffer = pcursor.nextrow Do While Not prowbuffer Is Nothing ' iterate through each data field and update the maxval if needed For lfieldindex = 0 To numfields - 1 dfieldvalue = prowbuffer.value(fieldindecies(lfieldindex)) If firstvalue Then ' Special case for the first value in a feature class dmaxvalue = dfieldvalue firstvalue = False Else If dfieldvalue > dmaxvalue Then ' we've got a new biggest value dmaxvalue = dfieldvalue Next lfieldindex Set prowbuffer = pcursor.nextrow Loop If (dmaxvalue <= 0) Then MsgBox "Failed to calculate the maximum value or max value is 0." ' Set up the chart marker symbol to use with the renderer Set pbarchartsymbol = New BarChartSymbol Set pchartsymbol = pbarchartsymbol pbarchartsymbol.width = 6 Set pmarkersymbol = pbarchartsymbol ' Finally we've got the biggest value, set this into the symbol pchartsymbol.maxvalue = dmaxvalue ' This is the maximum height of the bars pmarkersymbol.size = 15 ' Now set up symbols for each bar Set psymbolarray = pbarchartsymbol ' Add some colours in for each bar Set pfillsymbol = New SimpleFillSymbol ' This is a pastel purple pfillsymbol.color = GetRGBColor(213, 212, 252) psymbolarray.addsymbol pfillsymbol 160

161 Set pfillsymbol = New SimpleFillSymbol ' This is a pastel green pfillsymbol.color = GetRGBColor(193, 252, 179) psymbolarray.addsymbol pfillsymbol ' Now set the barchart symbol into the renderer Set pchartrenderer.chartsymbol = pbarchartsymbol pchartrenderer.label = "Population" ' set up the background symbol to use tan color Set pfillsymbol = New SimpleFillSymbol pfillsymbol.color = GetRGBColor(239, 228, 190) Set pchartrenderer.basesymbol = pfillsymbol ' Disable overpoaster so that charts appear in the centre of polygons pchartrenderer.useoverposter = False ' Update the renderer and refresh the screen Set pgeofeaturel.renderer = pchartrenderer pmxdocument.activeview.refresh pmxdocument.updatecontents Private Function GetRGBColor(yourRed As Long, yourgreen As Long, _ yourblue As Long) As IRgbColor Dim prgb As IRgbColor Set prgb = New RgbColor With prgb.red = yourred.green = yourgreen.blue = yourblue.usewindowsdithering = True End With Set GetRGBColor = prgb End Function 如何为一个层设置 DotDensity Renderer 本例要实现的是为一个层设置 DotDensity Renderer 一般情况下, 用一个 Dot Density Fill Symbol 和一个 Dot Density Renderer 来描述层中某一特征的分布密度 本例中描述的是 states 层中人口的密度分布 ( 字段 Pop1990), 并且每个点表示 人 要点首先实例化接口 IGeoFeatureLayer, 通过 DotDensityFillSymbol 类来创建 IdotDensityFillSymbol 接口对象来设置 Dot Density Symbol, 然后创建 IsimpleMarkerSymbol 接口对象, 将 Dot Density Symbol 的类型设置成为 marker 类型, 再将 Symbol 赋给 IDotDensityRenderer 属性, 最后赋值给 IGeoFeatureLayer.Render 属性 程序说明本程序的加载的数据是 states.shp 点击 UIButtonControl1 程序开始运行 161

162 过程 DotDensityRenderer 根据 pdotdensityrenderer 的属性值画出预定的 Symbol 所有颜色设置都调用函数 GetRGBColor 传入过程 代码 Private Sub UIButtonControl1_Click() 'call sub DotDensityRenderer DotDensityRenderer Private Sub DotDensityRenderer() Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pgeofeaturel As IGeoFeatureLayer Dim pdotdensityrenderer As IDotDensityRenderer Dim pdotdensityfills As IDotDensityFillSymbol Dim prendererfields As IRendererFields Dim psymbolarray As ISymbolArray Dim psimplemarkers As ISimpleMarkerSymbol Const strpopfield = "POP1990" ' Population fields On Error GoTo Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pgeofeaturel = pmap.layer(0) Set pdotdensityrenderer = New DotDensityRenderer ' Set up the fields to draw charts of Set prendererfields = pdotdensityrenderer prendererfields.addfield strpopfield ' Set up dot density symbol Set pdotdensityfills = New DotDensityFillSymbol pdotdensityfills.dotsize = 3 pdotdensityfills.color = GetRGBColor(0, 0, 0) ' color of tan pdotdensityfills.backgroundcolor = GetRGBColor(239, 228, 190) ' Put one marker type into the dot density symbol Set psymbolarray = pdotdensityfills Set psimplemarkers = New SimpleMarkerSymbol psimplemarkers.style = esrismscircle psimplemarkers.size = 3 psimplemarkers.color = GetRGBColor(0, 0, 0) ' Black psymbolarray.addsymbol psimplemarkers Set pdotdensityrenderer.dotdensitysymbol = pdotdensityfills ' This relates to the number of dots per polygon, ' this value works for the US population pdotdensityrenderer.dotvalue = ' Update the renderer and refresh the screen Set pgeofeaturel.renderer = pdotdensityrenderer pmxdocument.activeview.refresh Private Function GetRGBColor(yourRed As Long, yourgreen As Long, _ yourblue As Long) As IRgbColor 162

163 Dim prgb As IRgbColor Set prgb = New RgbColor With prgb.red = yourred.green = yourgreen.blue = yourblue.usewindowsdithering = True End With Set GetRGBColor = prgb End Function 1.8. Layout 和打印 如何在 Page Layout 上添加 Text 本例要实现的功能是根据鼠标在 Page Layout 上点击的位置添加 Text 元素 要点要实现本例的功能, 首先需要在 PageLayout 上创建一个 Text 元素, 然后再设置该元素的属性 其中主要使用了两个接口 ITextElement 和 IGraphicsContainer ITextElement 接口是用来控制 Text 元素, 以下是它的几个主要属性 : ScaleText:BOOL 型, 表示地图比例尺变化时 Text 大小是否变化 ; Symbol: 用来设置 Text 元素的风格 ; Text: 用来设置 Text 元素的内容 IGraphicsContainer 是用来控制 PageLayout, Map 等对象上图形元素的接口 以下是它的几个主要属性和方法 : AddElement: 向层中增加一个元素 ; DeleteAllElements: 删除所有的元素 ; FindFrame: 查找可以放在该容器中的某对象, 例如 Text 元素 ; Next: 返回该容器中的下一个对象 ; UpdateElement: 更新某个元素 程序说明 函数 AddTextToLayout 根据鼠标点击的位置点 (x,y) 在 PageLayout 上添加一个 文本元素 代码 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long,_ ByVal y As Long) AddTextToLayout x, y Sub AddTextToLayout(x As Long, y As Long) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView Dim pgraphicscontainer As IGraphicsContainer Dim ptextelement As ITextElement Dim pelement As IElement On Error GoTo ErrorHandler 163

164 Set pmxdocument = ThisDocument ' 确保 ArcMap 在 layout 模式下 If Not pmxdocument.activeview Is pmxdocument.pagelayout Then Set pactiveview = pmxdocument.pagelayout Set pgraphicscontainer = pmxdocument.pagelayout Set ptextelement = New TextElement Set pelement = ptextelement ' 设置 Text 的内容 ptextelement.text = "My Map" ' 将元素的图形定位在点 (x,y) 处 pelement.geometry = pactiveview.screendisplay.displaytransformation.tomappoint(x, y) ' 向 PageLayout 中添加一个元素 pgraphicscontainer.addelement ptextelement, 0 ' 刷新 pmxdocument.activeview.partialrefresh esriviewgraphics, Nothing, Nothing 如何在 Page Layout 上添加 Legend 本例要实现的功能是以鼠标在 Page Layout 上画的 Envelope 为范围在 Pagelayout 增加一个跟第一个层相关联的图例 要点要实现本例的功能首先需要在 PageLayout 上创建一个 Legend 元素, 然后再设置该元素的属性, 其中用到了两个主要的接口 :ILegend 和 IlegendItem ILegend 用来控制 Legend( 图例 ) 以下是该接口成员的介绍 : Layer: 实现与相关层的关联 ; Columns: 图例以几列显示 ; ShowDescription ShowHeading ShowLabels ShowLayerName: 分别表示描述 标题 分类 层名称是否显示 ; IlegendItem 用来设置 Legend 的风格 以下是该接口成员的介绍 : AddItem : 在图例的最后添加一项 ; ClearItem: 清除所有项 ; Title: 设置标题 程序说明 元素 代码 函数 CreateLegend 根据传入的 pextent 参数在 PageLayout 上添加一个 Legend Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ ByVal y As Long) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView Dim penvelope As IEnvelope Dim pfeaturelayer As IFeatureLayer Dim prubberband As IRubberBand 164

165 On Error GoTo ErrorHandler Set pmxdocument = ThisDocument ' 确保 AcrMap 在 Layout 模式下 ' 确保 AcrMap 中有数据 If Not pmxdocument.activeview Is pmxdocument.pagelayout Or pmxdocument.focusmap.layercount = 0 Then ' 初始设定 Set pactiveview = pmxdocument.pagelayout Set prubberband = New RubberEnvelope 'IRubberBand 接口用于画 Envelope,Polygon 等 Set penvelope = prubberband.tracknew(pmxdocument.activeview.screendisplay, Nothing) Set pfeaturelayer = pmxdocument.focusmap.layer(0) CreateLegend penvelope, pfeaturelayer, pactiveview pactiveview.refresh Public Sub CreateLegend(pExtent As IEnvelope, pfeaturelayer As IFeatureLayer, _ pactiveview As IActiveView) Dim pmapframe As IMapFrame Dim pmapsurroundf As IMapSurroundFrame Dim pmapsurround As IMapSurround Dim plegend As ILegend Dim plegenditem As ILegendItem Dim pelement As IElement Dim parealayer As IFeatureLayer Dim ptextsymbol As ITextSymbol Dim pfillsymbol As IFillSymbol Dim plinesymbol As ILineSymbol Dim pcolor As IColor Dim psymbolbackground As ISymbolBackground Dim puid As New UID On Error GoTo ErrorHandler If pfeaturelayer Is Nothing Then If pactiveview Is Nothing Then If Not TypeOf pactiveview Is IPageLayout Then ' 得到 MapFrame Set pmapframe = pactiveview.graphicscontainer.findframe(pactiveview.focusmap) puid.value = "esricore.legend" Set pmapsurroundf = pmapframe.createsurroundframe(puid, Nothing) ' 创建底图 Symbol Set psymbolbackground = New esricore.symbolbackground Set pfillsymbol = New esricore.simplefillsymbol Set plinesymbol = New esricore.simplelinesymbol Set pcolor = New esricore.rgbcolor pcolor.rgb = RGB(255, 255, 255) plinesymbol.color = pcolor pfillsymbol.color = pcolor pfillsymbol.outline = plinesymbol psymbolbackground.fillsymbol = pfillsymbol pmapsurroundf.background = psymbolbackground 165

166 Set pelement = pmapsurroundf pelement.geometry = pextent Set pmapsurround = pmapsurroundf.mapsurround Set plegend = pmapsurround ' 创建一个水平的 LegendItem Set plegenditem = New esricore.horizontallegenditem ' 设置 LegendItem 的相关层和列数 With plegenditem Set.Layer = pfeaturelayer.columns = 1.ShowDescriptions = True.ShowHeading = True.ShowLabels = True.ShowLayerName = True End With ' 先清除所有的 LegendItem plegend.clearitems ' 在 Legend 上添加一个 LegendItem With plegend.additem plegenditem.title = "New Legend" End With pactiveview.graphicscontainer.addelement pelement, 如何在 Page Layout 上添加 North Arrow 本例要实现的功能是以鼠标在 Page Layout 上画的 Envelope 为范围在 PageLayout 上增加指北针 要点要实现本例的功能首先要在 PageLayout 上创建一个 North Arrow 元素, 然后再设置该元素的属性 其中用到了两个主要接口 : IMarkerNorthArrow 和 ICharacterMarkerSymbol IMarkerNorthArrow 用来控制 NorthArrow 以下是该接口主要的属性介绍 : MarkerSymbol: 设置 North Arrow 的风格 ICharacterMarkerSymbol 用来设置特征标志的风格 以下是该接口主要的属性介绍 : Size: 该标志的大小 CharacterIndex:Long 型, 该标志使用风格的索引 程序说明函数 CreateNorthArrow 根据传入的 pextent 参数在 PageLayout 上添加一个 NorthArrow 元素 代码 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long,_ ByVal y As Long) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView Dim penvelope As IEnvelope Dim prubberband As IRubberBand 166

167 On Error GoTo ErrorHandler Set pmxdocument = ThisDocument ' 确保 AcrMap 在 Layout 模式下 If Not pmxdocument.activeview Is pmxdocument.pagelayout Then ' 初始设定 Set pactiveview = pmxdocument.pagelayout Set prubberband = New RubberEnvelope Set penvelope = prubberband.tracknew(pmxdocument.activeview.screendisplay, Nothing) CreateNorthArrow penvelope, pactiveview pactiveview.refresh Public Sub CreateNorthArrow(pExtent As IEnvelope, pactiveview As IActiveView) Dim pmapframe As IMapFrame Dim pmapsurroundf As IMapSurroundFrame Dim pmapsurround As IMapSurround Dim pelement As IElement Dim pmarkernortha As IMarkerNorthArrow Dim pcharactermarkers As ICharacterMarkerSymbol Dim puid As New UID On Error GoTo ErrorHandler If Not TypeOf pactiveview Is IPageLayout Then Set pmapframe = pactiveview.graphicscontainer.findframe(pactiveview.focusmap) puid.value = "esricore.markernortharrow" ' 根据 UID 创建 North Arrow Set pmapsurroundf = pmapframe.createsurroundframe(puid, Nothing) Set pelement = pmapsurroundf pelement.geometry = pextent Set pmapsurround = pmapsurroundf.mapsurround ' 得到创建的 North Arrow Set pmarkernortha = pmapsurround Set pcharactermarkers = pmarkernortha.markersymbol ' 设置 North Arrow 的 Size pcharactermarkers.size = 40 ' 设置 North Arrow 的特征值, 即显示风格 pcharactermarkers.characterindex = 173 pmarkernortha.markersymbol = pcharactermarkers pactiveview.graphicscontainer.addelement pelement, 如何在 Page Layout 上添加 Scale bar 本例要实现的功能是以鼠标在 Page Layout 上画的 Envelope 为范围在 167

168 PageLayout 上添加 Scale Bar 要点首先需要在 PageLayout 上创建一个 Scale Bar 元素, 然后再设置该元素的属性 要实现此功能, 用到了接口 IScaleBar, 用来控制 ScaleBar 以下是该接口的属性介绍 : Division: 设置比例尺的分割单位 ; DivisionsBeforeZero: 设置比例尺原点左侧显示的段数 ; Divisions: 设置比例尺的总段数 ( 包括原点左侧的段数 ); Subdivisions: 设置主比例尺分为几个子段 ; Units: 设置比例尺的单位 ; UnitLabel:String 型, 设置单位标签上的内容 ; UnitLabelPosition: 设置单位标签显示的位置 ; LabelPosition: 比例尺数字标签的显示位置 ; LabelFrequency: 比例尺数字标签的风格 程序说明 函数 CreateScaleBar 根据传入的 pextent 参数在 PageLayout 上添加一个 ScaleBar 元素 代码 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long,_ ByVal y As Long) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView Dim penvelope As IEnvelope Dim prubberband As IRubberBand On Error GoTo ErrorHandler Set pmxdocument = ThisDocument ' 确保 AcrMap 在 Layout 模式下 If Not pmxdocument.activeview Is pmxdocument.pagelayout Then ' 初始设定 Set pactiveview = pmxdocument.pagelayout Set prubberband = New RubberEnvelope Set penvelope = prubberband.tracknew(pmxdocument.activeview.screendisplay, Nothing) CreateScaleBar penvelope, pactiveview pactiveview.refresh Public Sub CreateScaleBar(pExtent As IEnvelope, pactiveview As IActiveView) Dim pmapframe As IMapFrame Dim pmapsurroundf As IMapSurroundFrame Dim pmapsurround As IMapSurround Dim pelement As IElement Dim pfillsymbol As IFillSymbol Dim plinesymbol As ILineSymbol Dim pcolor As IColor 168

169 Dim psymbolbackground Dim pscalebar Dim puid As ISymbolBackground As IScaleBar As New UID On Error GoTo ErrorHandler If Not TypeOf pactiveview Is IPageLayout Then Set pmapframe = pactiveview.graphicscontainer.findframe(pactiveview.focusmap) puid.value = "esricore.scalebar" ' 根据 UID 创建 Scale Bar Set pmapsurroundf = pmapframe.createsurroundframe(puid, Nothing) Set psymbolbackground = New esricore.symbolbackground Set pfillsymbol = New esricore.simplefillsymbol Set plinesymbol = New esricore.simplelinesymbol Set pcolor = New esricore.rgbcolor pcolor.rgb = RGB(255, 255, 255) plinesymbol.color = pcolor pfillsymbol.color = pcolor pfillsymbol.outline = plinesymbol psymbolbackground.fillsymbol = pfillsymbol pmapsurroundf.background = psymbolbackground Set pelement = pmapsurroundf pelement.geometry = pextent Set pmapsurround = pmapsurroundf.mapsurround ' 创建一个 single alternating scale bar Set pscalebar = New esricore.alternatingscalebar Set pmapsurround = pscalebar ' 设置 Scale Bar 的属性, 如分割单位 数字显示的位置 label 和 label 显示位置等 With pscalebar.division = 100.DivisionsBeforeZero = 0.Divisions = 2.Subdivisions = 4.Units = esrimeters.unitlabel = "m".unitlabelposition = esriscalebarafterbar.labelposition = esriabove.labelfrequency = esriscalebardivisionsandfirstmidpoint End With Set pmapsurroundf.mapsurround = pmapsurround Set pelement = pmapsurroundf pactiveview.graphicscontainer.addelement pelement, 如何在 Page Layout 上添加 Scale Text 本例要实现的功能是以鼠标在 Page Layout 上画的 Envelope 为范围在 PageLayout 上添加 Scale Text 169

170 要点本例中, 首先需要在 PageLayout 上创建一个 Scale Text 元素, 然后再设置该元素的属性 实现此功能, 用到了接口 IScaleText, 该接口是用来控制 Scale Text, 下面是接口属性的介绍 : Symbol: 设置 Scale Text 的 Text 的属性 Style: 设置 Scale Text 风格 Scale Text 有两种风格 :esriscaletextabsolute ( 例 :1:5000) 和 esriscaletextrelative( 例 :1 inch equals 800 miles) 程序说明 函数 CreateScaleText 根据传入的 pextent 参数在 PageLayout 上添加一个 Scale Text 元素 代码 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ ByVal y As Long) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView Dim penvelope As IEnvelope Dim prubberband As IRubberBand On Error GoTo ErrorHandler Set pmxdocument = ThisDocument ' 确保 AcrMap 在 Layout 模式下 If Not pmxdocument.activeview Is pmxdocument.pagelayout Then ' 初始设定 Set pactiveview = pmxdocument.pagelayout Set prubberband = New RubberEnvelope Set penvelope = prubberband.tracknew(pmxdocument.activeview.screendisplay, Nothing) CreateScaleText penvelope, pactiveview pactiveview.refresh Public Sub CreateScaleText(pExtent As IEnvelope, pactiveview As IActiveView) Dim pmapframe As IMapFrame Dim pmapsurroundf As IMapSurroundFrame Dim pmapsurround As IMapSurround Dim pelement As IElement Dim pscaletext As IScaleText Dim ptextsymbol As ITextSymbol Dim puid As New UID On Error GoTo ErrorHandler If Not TypeOf pactiveview Is IPageLayout Then Set pmapframe = pactiveview.graphicscontainer.findframe(pactiveview.focusmap) puid.value = "esricore.scaletext" ' 根据 UID 创建 Scale Text Set pmapsurroundf = pmapframe.createsurroundframe(puid, Nothing) Set pelement = pmapsurroundf pelement.geometry = pextent 170

171 Set pmapsurround = pmapsurroundf.mapsurround Set pscaletext = pmapsurround Set ptextsymbol = New esricore.textsymbol ptextsymbol.size = 20 ' 设置 Scale Text 的 Symbol 属性 pscaletext.symbol = ptextsymbol ' 设置 Scale Text 的 Style pscaletext.style = esriscaletextrelative pactiveview.graphicscontainer.addelement pelement, 如何在 Page Layout 上添加 Picture 本例要实现的功能以鼠标在 Page Layout 上画的 Envelope 为范围在 PageLayout 上增加 Picture 要点本例中, 首先需要在 PageLayout 上创建一个 Picture 元素, 然后再设置该元素的属性 实现此功能, 用到了 IPictureElement 接口 以下是该接口中主要属性和方法的介绍 : ImportPictureFromFile: 需要图片路径 ; MaintainAspectRatio: 是否保证图片的纵横比 程序说明 函数 CreatePicture 根据传入的 pextent 参数在 PageLayout 上添加一个图片, 该图片是存放在 mxd 文件所在目录下的 arcgisbook.bmp 文件 代码 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, _ ByVal y As Long) Dim pmxdocument As IMxDocument Dim pactiveview As IActiveView Dim penvelope As IEnvelope Dim prubberband As IRubberBand On Error GoTo ErrorHandler Set pmxdocument = ThisDocument ' 确保 AcrMap 在 Layout 模式下 If Not pmxdocument.activeview Is pmxdocument.pagelayout Then ' 初始设定 Set pactiveview = pmxdocument.pagelayout Set prubberband = New RubberEnvelope Set penvelope = prubberband.tracknew(pmxdocument.activeview.screendisplay, Nothing) CreatePicture penvelope, pactiveview pactiveview.refresh 171

172 Sub CreatePicture(pExtent As IEnvelope, pactiveview As IActiveView) Dim pelement As IElement Dim ppictureelement As IPictureElement Dim pvbproject As VBProject Dim spicpath As String On Error GoTo ErrorHandler Set ppictureelement = New BmpPictureElement ' 得到 mxd 文件的路径 Set pvbproject = ThisDocument.VBProject spicpath = pvbproject.filename spicpath = Left(sPicPath, InStrRev(sPicPath, "\")) ' 设置图片路径 ppictureelement.importpicturefromfile spicpath & "arcgisbook.bmp" ' 保持纵横比 ppictureelement.maintainaspectratio = False Set pelement = ppictureelement pelement.geometry = pextent pactiveview.graphicscontainer.addelement pelement, 如何创建 删除地图网格 (Map Grid) 本例主要实现 Layerout 中 Map Grid 的创建和删除 要点通过 IMapGridFactory 接口可创建 Map Grid 并对其命名 然后运用 IMapGrids 和 IMapGrid 接口来实现对 Map Grid 的添加, 删除等操作 IMapGrids 只能被 MapFrame 这个对象来实现 通过这个接口, 可以对一个具体的 MapFrame 所展示的网格进行接收和设置 IMapGrid 是个可以对所有类型网格 (Grid) 的属性进行设置的接口, 四种类型的 Grid 类实现了 IMapGrids 接口 它们是 IMeasuredGrid,IGraticule,IndexGrid,ICustomGridOverlay 程序说明在宏里定义了两个模块 :Add 和 Delete Add 模块里定义了一个过程 CreateMapGrid(), 是用来创建一个当前 MapFrame 的 IndexGrid Delete 模块里定义了一个过程 DeleteMapGrids(), 用来删除当前 MapFrame 里的所有 Grid 运用时, 先在 ArcMap 主菜单中单击 View, 然后选择 Layout View 接着在宏里先运行 Add 模块, 可以看到在 ArcMap 主窗口中创建了一个网格 要删除该网格, 运行 Delete 模块即可 代码 172

173 Private Sub CreateMapGrid() Dim pmxdocument Dim pmap Dim pgraphicscontainer Dim pmapframe Dim pactiveview Dim pmapgrids Dim pmapgrid Dim pmapgridfactory As IMxDocument As IMap As IGraphicsContainer As IMapFrame As IActiveView As IMapGrids As IMapGrid As IMapGridFactory On Error GoTo Errorhandler Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pgraphicscontainer = pmxdocument.pagelayout Set pmapframe = pgraphicscontainer.findframe(pmap) 'Create map grid ' 创建类型为 IndexGrid 的 Map Grid Set pmapgridfactory = New IndexGridFactory ' 还可创建其他类型, 如下 ''Set pmapgridfactory = New GraticuleFactory ''Set pmapgridfactory = New MeasuredGridFactory ' 创建一个 Map Grid Set pmapgrid = pmapgridfactory.create(pmapframe) ' 将 Map Grid 添加到当前的 MapFrame 中, 并刷新 Set pmapgrids = pmapframe pmapgrids.addmapgrid pmapgrid Set pactiveview = pmxdocument.pagelayout pactiveview.partialrefresh esriviewbackground, Nothing, Nothing Errorhandler: Public Sub DeleteMapGrids() Dim pmxdocument Dim pmap Dim pactiveview Dim pgraphicscontainer Dim pmapframe Dim pmapgrids Dim pmapgrid Dim i Dim count As IMxDocument As IMap As IActiveView As IGraphicsContainer As IMapFrame As IMapGrids As IMapGrid As Long As Long On Error GoTo Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pactiveview = pmxdocument.pagelayout Set pgraphicscontainer = pmxdocument.pagelayout Set pmapframe = pgraphicscontainer.findframe(pmap) Set pmapgrids = pmapframe 173

174 ' 通过循环操作删除所有的 Map Grid 并且刷新 count = pmapgrids.mapgridcount For i = count - 1 To 0 Step -1 'if you remove grid(0) first, then grid(1) becomes grid(0) Set pmapgrid = pmapgrids.mapgrid(i) pmapgrids.deletemapgrid pmapgrid Set pmapgrid = Nothing Next i pactiveview.partialrefresh esriviewbackground, Nothing, Nothing 如何设置 Layout 中 MapFrame 的外观风格属性 本例要完成的功能是设置 Page Layout 中 MapFrame 的边框 (Border) 背景 (Background) 和阴影 (Shadow) 等属性 要点 本例主要运用 IBorder IBackground IShadow 等接口对 MapFrame 的 Border, Background,Shadow 等属性的颜色和宽度进行设置, 并且将其在 Page Layout 中 显示出来 程序说明 通过 IMapFrame 的 Border 属性设置 Border 的颜色和宽度 ; 通过对 IMapFrame 的 Background 属性设置 Background 的颜色 ; 通过 IFrameProperties 的 Shadow 属 性设置 MapFrame 的 Shadow 颜色 代码 Private Sub cmddraw_click() Dim pmxdocument Dim pmap Dim pgraphicscontainer Dim pmapframe Dim plinesymbol Dim pcolor Dim prgbcolor Dim pborder Dim psymbolborder Dim pbackground Dim psymbolbackg Dim pfillsymbol Dim pshadow Dim psymbolshadow Dim pframeproperties On Error GoTo Errorhandler Set pmxdocument = ThisDocument As IMxDocument As IMap As IGraphicsContainer As IMapFrame As ILineSymbol As IColor As IRgbColor As IBorder As ISymbolBorder As IBackground As ISymbolBackground As IFillSymbol As IShadow As ISymbolShadow As IFrameProperties 174

175 Set pmap = pmxdocument.focusmap Set pgraphicscontainer = pmxdocument.pagelayout Set pmapframe = pgraphicscontainer.findframe(pmap) Set pframeproperties = pmapframe ' 对用户输入的 Border 数据进行检测 If txtborderred.value >= 0 And txtborderred.value <= 255 And _ txtborderblue.value >= 0 And txtborderblue.value <= 255 And _ txtbordergreen.value >= 0 And txtbordergreen.value <= 255 And _ txtborderwidth.value > 0 Then ' 设置 Border 的颜色和宽度 Set prgbcolor = New RgbColor prgbcolor.red = txtborderred.value prgbcolor.blue = txtborderblue.value prgbcolor.green = txtbordergreen.value Set pcolor = prgbcolor Set plinesymbol = New SimpleLineSymbol plinesymbol.color = pcolor plinesymbol.width = txtborderwidth.value Set psymbolborder = New SymbolBorder psymbolborder.linesymbol = plinesymbol Set pborder = psymbolborder pmapframe.border = pborder Else MsgBox "You input a wrong number in border set!" ' 对用户输入的 Background 数据进行检测 If txtbackred.value >= 0 And txtbackred.value <= 255 And _ txtbackblue.value >= 0 And txtbackblue.value <= 255 And _ txtbackgreen.value >= 0 And txtbackgreen.value <= 255 Then ' 设置 BackGround 的颜色 Set prgbcolor = New RgbColor prgbcolor.red = txtbackred.value prgbcolor.blue = txtbackblue.value prgbcolor.green = txtbackgreen.value Set pcolor = prgbcolor Set pfillsymbol = New SimpleFillSymbol pfillsymbol.color = pcolor Set psymbolbackg = New SymbolBackground psymbolbackg.fillsymbol = pfillsymbol Set pbackground = psymbolbackg pmapframe.background = pbackground Else MsgBox "You input a wrong number in Background Set!" ' 对用户输入的 Shadow 数据进行检测 If txtshadowred.value >= 0 And txtshadowred.value <= 255 And _ txtshadowblue.value >= 0 And txtshadowblue.value <= 255 And _ txtshadowgreen.value >= 0 And txtshadowgreen.value <= 255 Then ' 设置 Shadow 的颜色 Set prgbcolor = New RgbColor prgbcolor.red = txtshadowred.value prgbcolor.blue = txtshadowblue.value 175

176 prgbcolor.green = txtshadowgreen.value Set pcolor = prgbcolor Set pfillsymbol = New SimpleFillSymbol pfillsymbol.color = pcolor Set psymbolshadow = New SymbolShadow psymbolshadow.fillsymbol = pfillsymbol Set pshadow = psymbolshadow pframeproperties.shadow = pshadow Else MsgBox "You input a wrong number in Shadow Set!" ' 刷新 Page Layout pmxdocument.activeview.refresh Errorhandler: 何设置 Layout 中 Page 的边框 (Border) 和背景 (Background) 本例要完成的功能是设置 Page Layout 中 Page 的边框 (Border) 和背景 (Background) 属性 要点 IStyleGallery.items: 根据不同的参数可以得到系统中所有的 Border,Background, Shadow 等的风格属性 IPage.Border: 设置 Page 的边框式样 IPage.Backgound: 设置 Page 的背景式样 程序说明 先用 IStyleGallery.items 得到系统中所有的 Border,Background 式样的属性值, 把它们分别放在对应的 ListBox 中 ; 然后再把选择的 Border 或 Background 属性 值赋给 IPage.Border 或 IPage.Backgound, 这样就可以实现设置 Page 的边框或背 景的效果 代码 ' 模块变量的定义 : Option Explicit Dim m_pstylesarray(0 To 2) As IArray Dim m_pstylegallery As IstyleGallery ' 设置 Background 的过程 Private Sub lstbackground_dblclick(byval Cancel As MSForms.ReturnBoolean) Dim psymbol As IBackground Dim pmxdocument As IMxDocument Dim ppagelayout As IPageLayout 176

177 Dim ppage As IPage On Error GoTo ErrorHandler Set psymbol = m_pstylesarray(1).element(lstbackground.listindex) Set pmxdocument = ThisDocument Set ppagelayout = pmxdocument.pagelayout Set ppage = ppagelayout.page ppage.background = psymbol pmxdocument.activatedview.refresh ' 设置 Border 的过程 Private Sub lstborder_dblclick(byval Cancel As MSForms.ReturnBoolean) Dim psymbol As IBorder Dim pmxdocument As IMxDocument Dim ppagelayout As IPageLayout Dim ppage As IPage On Error GoTo ErrorHandler Set psymbol = m_pstylesarray(0).element(lstborder.listindex) Set pmxdocument = ThisDocument Set ppagelayout = pmxdocument.pagelayout Set ppage = ppagelayout.page ppage.border = psymbol ' 设置 Shadow 的 Sub pmxdocument.activatedview.refresh Private Sub UserForm_Initialize() UpdateArrayAndListBoxFromStyleGallery "Borders", m_pstylesarray(0), lstborder UpdateArrayAndListBoxFromStyleGallery "Backgrounds", m_pstylesarray(1), lstbackground UpdateArrayAndListBoxFromStyleGallery "Shadows", m_pstylesarray(2), lstshadow Public Sub UpdateArrayAndListBoxFromStyleGallery(styleClass As String,& _ ByRef parray As IArray, & _ ByRef plistbox As ListBox) 'Get IStyleGalleryClass interface Dim pstyleclass As IStyleGalleryClass Dim penumstylegallery As IEnumStyleGalleryItem Dim pstyleitem As IstyleGalleryItem On Error GoTo 'If the StyleGallery hasn't been used before If m_pstylegallery Is Nothing Then Set m_pstylegallery = New StyleGallery 177

178 'Get IEnumStyleGalleryItem interface and retrieve all stles within the class Set penumstylegallery = m_pstylegallery.items(styleclass, "ESRI.style", "") penumstylegallery.reset 'Create a new array Set parray = New esricore.array 'Clear out the list box plistbox.clear 'Get IStyleGalleryItem interface Set pstyleitem = penumstylegallery.next 'Loop through the style gallery items Do While Not pstyleitem Is Nothing 'Add the style to the array parray.add pstyleitem.item 'Add the style name to the list box plistbox.additem pstyleitem.name Set pstyleitem = penumstylegallery.next Loop Private Sub UIButtonControl1_Click() UserForm1.Show 如何设置打印纸张的大小和方向 本例主要运用 IPageLayout 这个接口来对打印的纸张进行设置, 包括用纸的 大小和横竖方向 要点 本例中运用 IPage 中的 FormID 属性对纸张的大小进行设置, 运用 Orientation 属性对纸张的打印方向 ( 水平或垂直 ) 进行设置 程序说明 将所有的纸张大小和方向分别插入到两个 ComboBox 中, 然后根据用户不 同的选择对打印纸张进行不同的设置 代码 初始化窗口菜单 Private Sub UserForm_Initialize() On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set ppagelayout = pmxdocument.pagelayout ' 设置纸张大小, 将所有的类型插入到 ComboBox 中 Me.cmbSize.AddItem "Letter - 8.5in x 11in" Me.cmbSize.AddItem "Legal - 8.5in x 14in" Me.cmbSize.AddItem "Tabloid - 11in x 17in" Me.cmbSize.AddItem "C - 17in x 22in" 178

179 Me.cmbSize.AddItem "D - 22in x 34in" Me.cmbSize.AddItem "E - 34in x 44in" Me.cmbSize.AddItem "Metric A5-148mm x 210mm" Me.cmbSize.AddItem "Metric A4-210mm x 297mm" Me.cmbSize.AddItem "Metric A3-297mm x 420mm" Me.cmbSize.AddItem "Metric A2-420mm x 594mm" Me.cmbSize.AddItem "Metric A1-594mm x 841mm" Me.cmbSize.AddItem "Metric A0-841mm x 1189mm" Me.cmbSize.AddItem "Custom Page Size" Me.cmbSize.AddItem "Page Form same as Printer Form" ' 设置纸张方向, 并将其类型插入到 ComboBox 中 Me.cmbOri.AddItem "Portrait" Me.cmbOri.AddItem "Landscape" ' 将当前纸张的打印大小和方向在两个 ComboBox 中显示 Me.cmbSize.ListIndex = ppagelayout.page.formid Me.cmbOri.ListIndex = ppagelayout.page.orientation - 1 ' 点击 Set 按钮所触发的事件 Private Sub cmdset_click() On Error GoTo ErrorHandler ppagelayout.page.formid = Me.cmbSize.ListIndex ppagelayout.page.orientation = Me.cmbOri.ListIndex + 1 Unload Me 1.9. 坐标系统 如何在 ArcMap 中设置地理坐标系和投影坐标系本例要实现的功能是给 Map 设置地理坐标系或者投影坐标系 如果改变 Map 中的地理坐标系或投影坐标系,Map 中图形的形状也会随之改变 要点在 ArcGis 中, 坐标系分为地理坐标系和投影坐标系, 创建一个坐标系通常用接口 ISpatialReferenceFactory2 实现 在接口 ISpatialReferenceFactory2 中有两个常用的方法 : CreateGeographicCoordinateSystem 和 CreateProjectedCoordinateSystem, 分别用来创建地理坐标系和投影坐标系 并且, ArcGis 中预定义了大多数国际上公认的坐标系统的参数, 可以直接引用 此外, 也可以读入 prj 文件进行设置 179

180 程序说明 本例在点击按钮事件中设置 Map 的坐标系 由于 Map 中不能同时设置地理 坐标系和投影坐标系, 所以例子代码中注释了设置地理坐标系的代码 如果读 者想给 Map 设置地理坐标系, 只要去掉相关地理坐标系的注释, 并且注释掉相 关投影坐标系的代码即可 代码 Private Sub UIButtonControl1_Click() Dim pmxdocument Dim pmap Dim pspatialreferencef Dim pprojectedcoordinates 'Dim pgeographiccoordinates On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap As IMxDocument As IMap As ISpatialReferenceFactory2 As IProjectedCoordinateSystem As esricore.igeographiccoordinatesystem ' 实例化 ISpatialReferenceFactory2 的变量 Set pspatialreferencef = New SpatialReferenceEnvironment ' 创建空間投影坐标系, 类型为 TokyoJapan10 Set pprojectedcoordinates = pspatialreferencef. _ CreateProjectedCoordinateSystem(esriSRProjCS_TokyoJapan10) ' 创建地理坐标系, 类型为 GCS_Tokyo ' Set pgeographiccoordinates = pspatialreferencef. _ CreateGeographicCoordinateSystem(esriSRGeoCS_Tokyo) ' 给 Map 设置投影坐标系 Set pmap.spatialreference = pprojectedcoordinates ' 给 Map 设置地理坐标系 'Set pmap.spatialreference = pgeographiccoordinates ' 弹出消息框显示当前 Map 的坐标系名字 MsgBox pmap.spatialreference.name pmxdocument.activeview.refresh 如何修改层的坐标系统当 ArcMap 加载一个 Shape 文件的时候, 会检查有没有跟 Shape 文件相关的 prj 文件, 如果有就根据该 prj 文件内的参数设置层的坐标系统, 反之就会提示该 Shape 文件没有相关的空间坐标系, 并且把层的坐标系统设置为 Unknown 本例要实现的功能是当 ArcMap 已经运行时, 改变一个已加载进 ArcMap 的 Feature Layer 的坐标系统 要点 1. 本例使用接口 IGeoDatasetSchemaEdit 来改变层的坐标系统 180

181 2. 本例使用的数据包括两个 Shape 文件, 在路径.. \data\1.9projection 下 File Name Description ShapeType Projected Coord System europeequidistant Eastern Europe Polygon Two Point Equidistant westeuutm33 Western Europe Polygon UTM Grid Zone 33N 3. 本例的操作过程为 : 首先在以上提到的目录下重命名文件 europeequidistant.prj 为 europeequidistant.prjxxx; 接着打开工程文件, 你会发现 两个层的图形不在一起, 层 europeequidistant 在层 westeuutm33 的东南边 ; 你也 可以观察两个层的坐标系统, 层 westeuutm33 为 UTM Grid Zone 33N, 而层 europeequidistant 为 Unknown ; 现在运行宏里的程序, 你会发现层 europeequidistant 经过坐标投影后跟层 westeuutm33 排在一起了 这是回到数据 保存的路径下, 会发现多了一个 europeequidistant.prj 文件 程序说明 在过程运行时, 必须保证层 europeequidistant 为第一个层 程序首先检查层 europeequidistant 的坐标系统名字是否为 Unknown, 如果是就把它变换为 Two Point Equidistant 投影坐标系 代码 Sub AlterSpatialReference() Dim pmxdocument Dim pmap Dim pfeaturelayer Dim pgeodataset Dim pspatialreference Dim pfeatureclass Dim pgeodatasetedit Dim pspatialreferencef Dim pprojectedcoordinates As IMxDocument As IMap As IFeatureLayer As IGeoDataset As ISpatialReference As IFeatureClass As IGeoDatasetSchemaEdit As ISpatialReferenceFactory2 As IProjectedCoordinateSystem On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap 'Assume that europeequidistant is added last and that it is at the top of the map. Set pfeaturelayer = pmap.layer(0) 'This is how we get the current spatial reference for a layer 'QI for the geodatset from the layer Set pgeodataset = pfeaturelayer Set pspatialreference = pgeodataset.spatialreference 'Note that ArcMap sets the SR as "Unknown" MsgBox pfeaturelayer.name + " SpatialReference is " + pspatialreference.name If (pspatialreference.name = "Unknown") Then 'Get the FeatureClass from the Layer Set pfeatureclass = pfeaturelayer.featureclass 'QI for the Geodataset from the FeatureClass Set pgeodataset = pfeatureclass 'QI for GeoDatasetSchemaEdit from the Geodataset 181

182 Set pgeodatasetedit = pgeodataset 'Test if we can alter the spatialreference, if we can then we create a factory 'and use that to create a projected coordinate system. If (pgeodatasetedit.canalterspatialreference = True) Then Set pspatialreferencef = New SpatialReferenceEnvironment 'Use a SpatialReferenceFactory to create the Projected Coordinate System. 'Here we are using a Factory Code for the Two Point Equidistant 'coordinate system. Set pprojectedcoordinates = pspatialreferencef._ CreateProjectedCoordinateSystem(esriSRProjCS_World_TwoPointEquidistant) 'Now alter the layers spatial reference pgeodatasetedit.alterspatialreference pprojectedcoordinates 'Now get the updated SpatialReference and its name Set pspatialreference = pgeodataset.spatialreference MsgBox pfeaturelayer.name + " SpatialReference is " + pspatialreference.name 'Force a full refresh pmxdocument.activeview.refresh 如何把 Polygon 的顶点从经纬度坐标转换到平面直角坐标本例要实现的功能是对 Polygon 的顶点作坐标投影 所谓坐标投影就是把在地理坐标系下的经纬度坐标按照指定的投影系转换成平面坐标 比如东经 度, 北纬 度的一个点, 按照东京测地系第 9 系的投影坐标进行投影后的平面坐标为 ( , ) 要点坐标的投影主要是对一个几何图形进行 对于一个已经设置了地理坐标系的图形, 比如一个 polygon, 可以利用 IPolygon 的 project 方法对其进行投影, 使其顶点的坐标投影为平面直角坐标 程序说明本例在鼠标点击事件中得到唯一被选择的 Feature, 并得到该 Feature 的图形上在鼠标点击位置的顶点 过程 VertexProject 对图形进行投影, 并且弹出消息框显示同一个顶点在投影前和投影后的坐标值 代码 Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim pmxdocument As IMxDocument Dim pmap As IMap Dim penumfeature As IEnumFeature Dim pfeature As IFeature Dim ppoint As IPoint 182

183 Dim phitpoint Dim phittest Dim dsearchradius Dim dhitdistance Dim lhitpartindex Dim lhitsegmentindex As IPoint As IHitTest As Double As Double As Long As Long On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set ppoint = pmxdocument.activeview.screendisplay.displaytransformation.tomappoint(x, y) ' 計算査找半径 dsearchradius = pmxdocument.activeview.extent.width / 100 ' 只在一个 Feature 被选择的情况下进行 If pmap.selectioncount = 1 Then Set penumfeature = pmap.featureselection If penumfeature Is Nothing Then penumfeature.reset ' 得到被选择的 Feature Set pfeature = penumfeature.next If Not pfeature Is Nothing Then ' 根据鼠标点得到图形相应的顶点 Set phittest = pfeature.shape If phittest.hittest(ppoint, dsearchradius, esrigeometrypartvertex,_ phitpoint, dhitdistance, lhitpartindex, lhitsegmentindex, False) Then ' 投影变换 VertexProject pfeature.shape, lhitpartindex, lhitsegmentindex Private Sub VertexProject(ByRef pgeometry As IGeometry, ByVal lpartindex As Long, _ ByVal lvertexindex As Long) Dim ppointcollection As IPointCollection Dim ppoint As IPoint Dim pspatialreferencef As ISpatialReferenceFactory2 Dim pspatialreference As ISpatialReference On Error GoTo ErrorHandler If pgeometry Is Nothing Then Set ppointcollection = pgeometry ' 得到被选中的顶点 Set ppoint = ppointcollection.point(lvertexindex) ' 弹出投影变换前的 X Y 坐标值 MsgBox "Before projected X: " & ppoint.x & " Y: " & ppoint.y Set pspatialreferencef = New SpatialReferenceEnvironment Set pspatialreference = pspatialreferencef. _ CreateProjectedCoordinateSystem(esriSRProjCS_TokyoJapan9) ' 给图形设置投影坐标系 pgeometry.project pspatialreference Set ppoint = ppointcollection.point(lvertexindex) ' 弹出投影变换后的 X Y 坐标值 MsgBox "After projected X: " & ppoint.x & " Y: " & ppoint.y 183

184 1.10. ArcGis 相关文件 如何夹载 grf 文件 本例要实现的是如何在把一个 grf 文件加载到当前工程中 grf 文件即 Grapher(GolderSoftware 公司 ) 图形文件, 可以在 ArcMap 中由 Tools->Graphs->Create 来创建一个当前图层的 grf 文件 利用 IDataGraph,IDataGraphs,IDatagraphWindow 三个接口来实现加载 grf 文件 程序说明 在过程 addgrffile 中实现加载 grf 文件的过程 首先利用当前的 MxDocument 生成一个 IDataGraphs 接口的对象, 然后用该对象创建一个 IDataGraph 对象用来 控制 grf 图形文件 IDataGraphWindow 接口的对象用来显示图形 代码 Private Sub UIButtonControl1_Click() 'Call addgrffile Dim pvbproject As VBProject Dim nindex As Integer Set pvbproject = ThisDocument.VBProject nindex = InStrRev(pVBProject.fileName, "\") addgrffile Left(pVBProject.fileName, nindex) & "..\..\..\data\tmpidoukui.grf" Private Sub addgrffile(byval sfilename As String) On Error GoTo Dim pmxdocument As IMxDocument Dim pdatagraphw As IDataGraphWindow Dim pdatagraph As IDataGraph Dim pdatagraphs As IDataGraphs Dim sgrffile As String If Dir(sFileName) = "" Then MsgBox sfilename & " File is not Exist" sgrffile = sfilename Set pmxdocument = ThisDocument Set pdatagraphs = pmxdocument Set pdatagraph = pdatagraphs.create pdatagraph.loadfromfile sgrffile Set pdatagraphw = New DataGraphWindow Set pdatagraphw.datagraph = pdatagraph Set pdatagraphw.application = Application 184

185 MsgBox "There are some error!" 如何新建指向 Shape 文件的 lyr 文件 本例实现的是如何新建一个指向 Shape 文件的 lyr 文件 利用 IGxLayer,IGxFile 和 IFeatureLayer 接口来实现该功能 通过 GxLayer 类实现 IGxLayer 接口对象 通过 GxFile 类实现 IGxFile 接口对象 程序说明 函数 OpenFeatureClass 打开用来新建 lyr 文件的 shape 文件 参数 spath,sname 指定 shape 文件的位置 过程 CreateLyrFileFromShape 创建 lyr 文件 代码 Option Explicit Private Sub CreateLyrFileFromShape(sLyrFilePath As String, sshpfilepath As String, _ sshpfilename As String) On Error GoTo Dim pgxlayer As IGxLayer Dim pgxfile As IGxFile Dim pfeaturelayer As IFeatureLayer Dim pmxdocument As IMxDocument Set pgxlayer = New GxLayer Set pgxfile = pgxlayer pgxfile.path = slyrfilepath Set pfeaturelayer = New FeatureLayer Set pfeaturelayer.featureclass = OpenFeatureClass(sShpFilePath, sshpfilename) If pfeaturelayer.featureclass Is Nothing Then GoTo pfeaturelayer.name = "mycountrylyr" Set pgxlayer.layer = pfeaturelayer Set pmxdocument = ThisDocument pmxdocument.focusmap.addlayer pgxlayer.layer Set pgxlayer = Nothing Set pgxfile = Nothing Function OpenFeatureClass(ByVal spath As String, ByVal sname As String) As IFeatureClass On Error GoTo Dim pworkspacefactory As IWorkspaceFactory Set pworkspacefactory = New ShapefileWorkspaceFactory 185

186 Dim pfeatureworkspace As IFeatureWorkspace Set pfeatureworkspace = pworkspacefactory.openfromfile(spath, 0) Set OpenFeatureClass = pfeatureworkspace.openfeatureclass(sname) Exit Function Set OpenFeatureClass = Nothing End Function Private Sub UIButtonControl1_Click() Dim sdatafilepath As String Dim pvbproject As VBProject Dim nindex As Integer Set pvbproject = ThisDocument.VBProject nindex = InStrRev(pVBProject.FileName, "\") sdatafilepath = Left(pVBProject.FileName, nindex) & "..\..\..\data\" 'call AddLayerFileToMap CreateLyrFileFromShape sdatafilepath & "mycountry.lyr", sdatafilepath, "WorldCountries" 如何新建指向 GeoDataBase 文件的 lyr 文件 本例实现的是如何新建指向 GeoDataBase 文件的 lyr 文件 本实例的过程和 新建指向 Shape 文件的 lyr 文件相似 要求 要点 方法 : 使用 IGxLayer,IGxFile,IFeatureLayer,IPropertySet 等接口实现该实例的 使用 IPropertySet 接口设置 lyr 文件的数据源 语句 ppropertyset.setproperty "DATABASE", GdbPath + GdbName 用来设置数据源 程序说明 函数 OpenFeatureClass 根据 GeoDatabase 文件的所在位置和表名来设置 lyr 文件 的数据源, 过程 CreateLyrFileFromGDB 依据传入的参数 slyrfilepath 创建 lyr 文件 在 UIButtonControl1 按钮的 click 事件中调用 CreateLyrFileFromGDB 过程 代码 Option Explicit Private Sub CreateLyrFileFromGDB(sLyrFilePath As String, smdbfilename As String, stablename As String) On Error GoTo Dim pgxlayer As IGxLayer Dim pgxfile As IGxFile Dim pfeaturelayer As IFeatureLayer Dim pmxdocument As IMxDocument If Dir(sLyrFilePath) <> "" Then MsgBox "File already Exist" 186

187 Set pgxlayer = New GxLayer Set pgxfile = pgxlayer pgxfile.path = slyrfilepath Set pfeaturelayer = New FeatureLayer Set pfeaturelayer.featureclass = OpenFeatureClass(sMDBFileName, stablename) If pfeaturelayer.featureclass Is Nothing Then GoTo pfeaturelayer.name = "mycountrylyr" Set pgxlayer.layer = pfeaturelayer Set pmxdocument = ThisDocument pmxdocument.focusmap.addlayer pgxlayer.layer Set pgxlayer = Nothing Set pgxfile = Nothing Function OpenFeatureClass(ByVal GdbName As String, ByVal tablename As String) As IFeatureClass On Error GoTo Dim ppropertyset As IPropertySet Dim pfeatureworkspace As IFeatureWorkspace Dim pworkspacefactory As IWorkspaceFactory Dim pworkspace As IWorkspace Dim pfeatureclass As IFeatureClass Set ppropertyset = New PropertySet 'Set data source ppropertyset.setproperty "DATABASE", GdbName Set pworkspacefactory = New AccessWorkspaceFactory Set pworkspace = pworkspacefactory.open(ppropertyset, 0) Set pfeatureworkspace = pworkspace Set pfeatureclass = pfeatureworkspace.openfeatureclass(tablename) If Not pfeatureclass Is Nothing Then Set OpenFeatureClass = pfeatureclass Exit Function Set OpenFeatureClass = Nothing Dim Msg As String Msg = "Error # " & Str(Err.Number) & " was generated by " _ & Err.Source & Chr(13) & Err.Description MsgBox Msg,, "Error", Err.HelpFile, Err.HelpContext End Function Private Sub UIButtonControl1_Click() Dim sdatafilepath As String Dim pvbproject As VBProject Dim nindex As Integer Set pvbproject = ThisDocument.VBProject 187

188 nindex = InStrRev(pVBProject.FileName, "\") sdatafilepath = Left(pVBProject.FileName, nindex) & "..\..\..\data\" & "USA" 'call AddLayerFileToMap CreateLyrFileFromGDB Left(sDataFilePath, Len(sDataFilePath) - 3) & "mycountry.lyr", sdatafilepath, "states" 如何加载 mxd 文件 mxd 文件是 ArcMap 生成的工程文件 本例将告诉你如何在程序中加载 mxd 文件 使用 MapControl 控件来实现 mxd 文件的加载 要点 首先在 VBA 中添加一个 Form, 然后在 Toolbox 中单击鼠标右键, 在弹出的 窗口中选择 Additional Controls 将会出现 Additional Controls 对话框, 从中选择 ESRI MapControl 8.1, 单击 OK 在 Toolbox 中就会出现 MapControl 控件 程序说明 在 UserForm1 中添加一个 MapControl 控件和两个按钮 一个 name 为 cmdaddmxd, caption 为 Add MxdFile, 另一个 name 为 cmdclose,caption 为 Close 代码 Private Sub cmdaddmxd_click() Dim pvbproject As New VBProject Set pvbproject = ThisDocument.VBProject Dim pmxfilepath As String pmxfilepath = pvbproject.filename & "\..\" & "data\addlyrfile.mxd" 'Load a MxFile according the pmxfilepath UserForm1.MapControl1.LoadMxFile pmxfilepath 'show in full extent MapControl1.Extent = MapControl1.FullExtent Private Sub cmdclose_click() Unload Me 如何加载 Apr 文件 (ArcView32) 本例要实现的是如何在 ArcGis 中加载 Apr(ArcView32 工程 ) 文件 首先使用 ArcView32 创建一个 Apr 文件 方法 : 使用 IAVObject,IAVObjectConverter,IMap 三个接口来实现该实例 要点定义 IAVObjectConverter 接口对象, 并用 AVObjectConverter 类来实现, 利用该对象读取 Apr 文件 然后将 IAVObjectConverter 接口对象中的 View 对象赋值 188

189 给 IAVObject 接口的一个对象 使用 IAVObjectConverter 接口的 ConnectToView 方法返回一个和 AV View 对象相联系的 IMap 对象 程序说明 本实例在过程 ImportAprFile 中实现加载 Apr 文件的过程, 然后在 UIButtonControl 按钮的 Click 事件中调用 ImportAprFile 过程 代码 Public Sub ImportAprFile() Dim pavobject Dim pavobjectc Dim player Dim paprdialog Dim saprfile Dim pmap Dim pmxdocument As IAVObject As IAVObjectConverter As ILayer As New CommonDialog As String As IMap As IMxDocument On Error GoTo ErrorHandler paprdialog.dialogtitle = "Select ArcView 32 Project file" paprdialog.filter = "ArcView32 Project file(*.apr) *.apr" paprdialog.filterindex = 0 paprdialog.cancelerror = True paprdialog.showopen saprfile = paprdialog.filename If saprfile = "" Then MsgBox "you have not select a Apr file" Set pavobjectc = New AVObjectConverter 'Read Apr file pavobjectc.readobjects saprfile pavobjectc.reset Set pavobject = pavobjectc.nextobject 'Make sure search for a View object Do While pavobject.type <> "View" Set pavobject = pavobjectc.nextobject If pavobject Is Nothing Then Exit Do Loop 'Returns the map associated with an AV view object Set pmap = pavobjectc.connecttoview(pavobject) Set pmxdocument = ThisDocument Dim LayerCount As Integer LayerCount = 0 'Show the View Object in ThisDocument Do While LayerCount < pmap.layercount pmxdocument.addlayer pmap.layer(layercount) LayerCount = LayerCount + 1 Loop Msg = "Error # " & Str(Err.Number) & " was generated by " _ & Err.Source & Chr(13) & Err.Description 189

190 MsgBox Msg,, "Error", Err.HelpFile, Err.HelpContext Private Sub UIButtonControl1_Click() ImportAprFile 如何加载 lyr 文件 后缀为 lyr 的文件即 layer file, 存放关于 layer 的相关信息 本实例实现的功能是将一 layer file 加载到当前打开的 Map document 中 方法 : 在实现的过程中主要用到了 IGxLayer,IGxFile 两个接口 要点利用 IGxLayer 对象的 Path 属性得到 layer file 将 IGxLayer 对象的 Layer 属性赋值给一个 IFeatureLayer 对象 然后利用 AddLayer 方法将该 layer file 加载到当前的 Map document 中 程序说明首先从 Tools->Customize... 的对话框中选择 Commands 标签, 选中 UIControls 然后单击 New UIControls 按钮新建一个 Project.UIButtonControl1 按钮, 并且将其拖放到 ArcMap 的工具栏上 在 Project.UIButtonControl1 按钮的 click 事件中调用过程 AddLayerfileToMap 实现加载 lyr 文件 代码 Option Explicit Private Sub AddLayerFileToMap(sLyrFilePath As String) On Error GoTo Dim pgxlayer As IGxLayer Dim pgxfile As IGxFile Dim pmxdoc As IMxDocument Dim pfeaturelayer As IFeatureLayer If Dir(sLyrFilePath) = "" Then MsgBox slyrfilepath & " File is not Exist" Set pgxlayer = New GxLayer Set pgxfile = pgxlayer pgxfile.path = slyrfilepath Set pfeaturelayer = pgxlayer.layer Set pmxdoc = ThisDocument pmxdoc.focusmap.addlayer pgxlayer.layer pmxdoc.activeview.refresh Set pgxlayer = Nothing Set pgxfile = Nothing Private Sub UIButtonControl1_Click() Dim slyrfilepath As String 190

191 Dim nindex As Integer Dim pvbproject As VBProject Set pvbproject = ThisDocument.VBProject nindex = InStrRev(pVBProject.FileName, "\") slyrfilepath = Left(pVBProject.FileName, nindex) & "..\..\..\data\" & "standb5 polygon.lyr" 'call AddLayerFileToMap AddLayerFileToMap slyrfilepath lyr 文件的属性的设置 本例要实现的是如何对 lyr 文件的属性进行设置 在此例中是对 lyr 文件的 name 属性和 scale 属性以及 visiable 属性的一些设置操作 要点 方法 : 使用 IGxLayer,IGxFile 等接口的方法和属性对 lyr 文件进行操作 首先在 VBA 中插入一个类模块取名为 clslyrfile, 在该模块中实现对 lyr 文 件的属性的设置 然后插入一个 Form 模块取名为 SetPropertyFrm 用来输入设置 参数 在 Module 模块中放公共变量 程序说明 在 clslyrfile 中 OpenFile 过程用来加载 lyr 文件,SetScale 过程设置 lyr 文件的显 示比例 SetName 过程设置 lyr 文件的 name 属性 SetVisible 过程决定 lyr 文件是 否可见 SaveFile 过程保存 lyr 文件 代码 ' clslyrfile 模块中的代码 Option Explicit Private pgxlayer As IGxLayer Private pgxfile As IGxFile Private PFeatureLayer As IFeatureLayer Public Sub OpenFile(ByVal lyrfilename As String) On Error GoTo ErrorHandler Set pgxlayer = New GxLayer Set pgxfile = pgxlayer pgxfile.path = lyrfilename Set PFeatureLayer = pgxlayer.layer mmxdocument.focusmap.addlayer PFeatureLayer Public Sub SetScale(ByVal maximumscale As Double, ByVal minimumscale As Double) If Not PFeatureLayer Is Nothing Then 'MsgBox PFeatureLayer.maximumScale & ":" & PFeatureLayer.minimumScale PFeatureLayer.maximumScale = maximumscale PFeatureLayer.minimumScale = minimumscale 191

192 Public Sub SetName(ByVal Name As String) If Not pfeaturelayer Is Nothing Then pfeaturelayer.name = Name 'Decide the lyr file is visiable or not. 'if visiable is ture then lyr file is visiable. Public Sub SetVisible(ByVal visiable As Boolean) pgxlayer.layer.visible = visiable Public Sub SaveFile() On Error GoTo ErrorHandler If Not pgxfile Is Nothing Then If Not PFeatureLayer Is Nothing Then Set pgxlayer.layer = PFeatureLayer pgxfile.save pgxfile.close True 'SetPropertyFrm 模块中的代码 Option Explicit Private Sub cmdcancel_click() On Error GoTo ErrorHandler If MsgBox("Are you want to save the set!", vbokcancel) = vbok Then mcurrentlyr.savefile Unload Me Private Sub cmdok_click() On Error GoTo ErrorHandler If txtname.text <> "" Then mcurrentlyr.setname txtname.text mmxdocument.contentsview(0).refresh (0) mmxdocument.activeview.refresh mcurrentlyr.setvisible (cbxvisiable.value) mmxdocument.updatecontents If optnotshow.value Then If IsNumeric(txtMaximum.Text) And IsNumeric(txtMinimum.Text) Then mcurrentlyr.setscale CDbl(txtMaximum.Text), CDbl(txtMinimum.Text) mmxdocument.activeview.refresh Else MsgBox "you must input some numeric!" 192

193 Private Sub optnotshow_click() txtmaximum.enabled = True txtminimum.enabled = True txtmaximum.backcolor = &H txtminimum.backcolor = &H Private Sub optshow_click() txtmaximum.enabled = False txtminimum.enabled = False txtmaximum.backcolor = &H txtminimum.backcolor = &H mcurrentlyr.setscale 0, 0 mcurrentlyr.setvisible (True) 'Module 模块中的代码 Option Explicit 'some commom variant Public mcurrentlyr As clslyrfile Public mmxdocument As IMxDocument 其他 如何创建简单的 Column Chart 本例实现的功能是根据 FeatureLayer 被选择 Features 和属性表中指定的字段, 生成一个 Chart 主要用到 IDataGraphProperties 接口 要点要实现本例的功能, 首先需要创建一个 IDataGraph, 然后通过 IDataGraphProperties 接口来设置 DataGraph 的属性, 接着创建 IDataGraphWindow, 把 pdatagraph 赋给 pgraphwindow.datagraph 就可以实现 程序说明先把选择的数据赋给 pdatagraph.table, 再用 pdatagraph.field1 设置要显示的 X 轴的字段, 把 pdatagraph 赋给 pdatagraphp, 再设置 pdatagraphp 的属性, 然后再把 DataGraphP 赋给 pgraphwindow.datagraph, 最后把 pgraphwindow 显示出来就完成了 代码 Private Sub UIButtonControl1_Click() 193

194 'call sub CreateNewChart CreateNewChart Public Sub CreateNewChart() Dim pmxdocument Dim pdatagraph Dim pdatagraphp Dim pgraphwindow Dim pdatagraphs As IMxDocument As IDataGraph As IDataGraphProperties As IDataGraphWindow As IDataGraphs On Error GoTo ErrorHandler Set pmxdocument = ThisDocument If pmxdocument.selectedlayer Is Nothing Then If Not TypeOf pmxdoc.selectedlayer Is IFeatureLayer Then 'Create a new graph Set pdatagraph = New DataGraph 'Set the default Table, DataGraph will select a default graph type and some fields Set pdatagraph.table = pmxdocument.selectedlayer 'Specifically give the chart a name and title pdatagraph.name = pmxdocument.selectedlayer.name & " Chart" Set pdatagraphp = pdatagraph pdatagraphp.title = "My Chart" pdatagraphp.showxaxislabels = True pdatagraphp.showlegend = True pdatagraphp.subtitle = pdatagraph.fieldset1 & " vs. " & pdatagraphp.xaxislabelfield 'Associate the data graph with a data graph window Set pgraphwindow = New DataGraphWindow Set pgraphwindow.datagraph = pdatagraph Set pgraphwindow.application = Application 'Add the graph to the system Set pdatagraphs = pmxdocument pdatagraphs.add pdatagraph 如何将数据输出到 Excel 本例要实现的是将指定文件里的 DBF 数据用导出到 Excel 中 程序说明 先将数据读入到 Recordset 中, 然后再将 Recordset 中的数据按照 Excel 中单元 格的位置填写到 Sheet 中 代码 Private Sub UIButtonControl1_Click() Dim pdocument Dim pvbproject Dim strpath Set pdocument = ThisDocument Set pvbproject = pdocument.vbproject As IDocument As VBProject As String 194

195 strpath = pvbproject.filename strpath = Mid(strPath, 1, InStrRev(strPath, "\")) Call ExporToExcel(strPath & "\..\..\..\data") Public Function ExporToExcel(ByVal strpath As String) As Boolean Dim adoconn As New ADODB.Connection Dim Rs_Data1 As New ADODB.Recordset Dim xlapp As New Excel.Application Dim xlbook As New Excel.Workbook Dim xlsheet1 As New Excel.Worksheet Dim strsql As String Dim lngrow As Long Dim lngcol As Long Dim lngtag As Long On Error GoTo ErrorHandler _ ' 打开一个数据库连接 adoconn.open "[PROVIDER=MSDASQL.1];DRIVER=Microsoft Visual FoxPro Driver;UID=;Deleted=yes;" & "Null=no;Collate=Machine;BackgroundFetch=no;Exclusive=No;SourceType=DBF;SourceDB=" & _ strpath strsql = "SELECT * FROM spcs27;" ' 打开一个记录集 Rs_Data1.Open strsql, adoconn, adopenstatic, adlockreadonly xlapp.visible = False ' 新建一个 Excel 对像 Set xlapp = CreateObject("Excel.Application") ' 设置 Sheet 的个数 xlapp.sheetsinnewworkbook = 1 Set xlbook = xlapp.workbooks().add Set xlsheet1 = xlbook.worksheets("sheet1") ' 重命名 Sheet1 xlsheet1.name = "spcs27" 'Excel 不可见 xlapp.visible = False If Not IsNull(Rs_Data1) Then lngtag = 1 lngrow = 2 While Not Rs_Data1.EOF If lngtag = 1 Then For lngcol = 0 To Rs_Data1.Fields.Count 1 ' 将 Recordset 的字段名称写入 Sheet 的单元格中 xlsheet1.cells(1, lngcol + 1) = Rs_Data1.Fields(lngCol).Name Next lngcol lngtag = lngtag + 1 If lngtag > 1 Then For lngcol = 0 To Rs_Data1.Fields.Count 1 ' 将 Recordset 的字段值写入 Sheet 的单元格中 xlsheet1.cells(lngrow, lngcol + 1) = Rs_Data1.Fields(lngCol).Value Next lngcol Rs_Data1.MoveNext lngrow = lngrow + 1 Wend 195

196 'Excel 可见 xlapp.visible = True ' 清除对像变量 Set xlapp = Nothing Set xlbook = Nothing Set xlsheet1 = Nothing Rs_Data1.Close Set Rs_Data1 = Nothing ExporToExcel = True Exit Function ' 出错处理 ExporToExcel = False End Function 如何把 Labels 转换为 Annotation 本例要完成的功能是根据指定 FeatureLayer 的 Labels 生成一个新的 Annotation 类型的 FeatureLayer 要点 用 IFeatureWorkspaceAnno 的 CreateAnnotationClass 方法可以创建 Annotation 的 FeatureClass, 在创建之前, 先要设定好 Annotation 层的名字, 相关属性表的 字段,GraphicsLayerScale,SymbolCollection 等 程序说明 首先根据指定 FeatureLayer 中的 Label 创建一个 Annotation 层的 FeatureClass, 然后根据新生成的 FeatureClass 在 GeoDatabase 中新建一个属性层, 并添加到当 前的 Map 中 代码 Option Explicit Const ANNO_FC_NAME = "Test_01" Private Sub UIButtonControl1_Click() ConvertLabels2Anno Sub ConvertLabels2Anno() On Error GoTo ErrorHandler Dim pmxdocument Dim pmap Dim player Dim pgeofeaturel Dim pannoclass Dim pfdographicslayerf As IMxDocument As IMap As ILayer As IGeoFeatureLayer As IFeatureClass As IFDOGraphicsLayerFactory 196

197 Dim pannodataset Dim paview Dim pfdographicslayer As IDataset As IActiveView As IFDOGraphicsLayer ' Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set player = pmap.layer(0) Set pgeofeaturel = player If pmap Is Nothing Then MsgBox "No active map" If pgeofeaturel Is Nothing Then MsgBox "First layer in map must be feature layer" Set pannoclass = CreateRelatedAnnoClass(pMap, pgeofeaturel) Set pfdographicslayerf = New FDOGraphicsLayerFactory Set pannodataset = pannoclass Set pfdographicslayer = pfdographicslayerf.opengraphicslayer(pannodataset.workspace, & _ pannoclass.featuredataset, pannodataset.name) pmap.addlayer pfdographicslayer AddAnnoElements pmap, pgeofeaturel, pfdographicslayer ' make sure labels are off for source layer pgeofeaturel.displayannotation = False ' refresh map Set paview = pmap paview.refresh Private Function CreateRelatedAnnoClass(ByVal pmap As IMap, & _ ByVal pgeofeaturelayer As IGeoFeatureLayer) & _ As IFeatureClass On Error GoTo ErrorHandler Dim pfeatureclass Dim pdataset Dim pfeatureworkspacea Dim pannotatelayerpc Dim pannotatelayerp Dim plabelenginellp Dim pannotatelayertp Dim pgeodataset Dim psymbolcollection Dim pgraphicslayers Dim strannoname Dim pannofeaturecd As IFeatureClass As IDataset As IFeatureWorkspaceAnno As IAnnotateLayerPropertiesCollection As IAnnotateLayerProperties As ILabelEngineLayerProperties As IAnnotateLayerTransformationProperties As IGeoDataset As ISymbolCollection As IGraphicsLayerScale As String As IFeatureClassDescription 197

198 Dim pannoobjectcd Dim pfields Dim pfieldsedit Dim pfield Dim pfieldedit Dim pgeomdefe As IObjectClassDescription As IFields As IFieldsEdit As IField As IFieldEdit As IgeometryDefEdit Set pfeatureclass = pgeofeaturelayer.featureclass Set pdataset = pfeatureclass Set pfeatureworkspacea = pdataset.workspace 'Get Annotation Properties from Layer Set pannotatelayerpc = pgeofeaturelayer.annotationproperties 'Get First AnnotateLayerProperties and QI to ILabelEngineLayerProperties pannotatelayerpc.queryitem 0, pannotatelayerp Set plabelenginellp = pannotatelayerp 'Update IAnnotateLayerTransformationProperties Set pannotatelayertp = pannotatelayerp Set pgeodataset = pgeofeaturelayer.featureclass pannotatelayertp.referencescale = pmap.mapscale pannotatelayertp.units = pmap.mapunits pannotatelayertp.scaleratio = 1 pannotatelayertp.bounds = pgeodataset.extent 'Add Symbol from ILabelEngineLayerProperties to new symbolcollection Set psymbolcollection = New SymbolCollection Set psymbolcollection.symbol(0) = plabelenginellp.symbol 'Create GraphicsLayerScale object and populate Set pgraphicslayers = New GraphicsLayerScale pgraphicslayers.referencescale = pmap.mapscale pgraphicslayers.units = pmap.mapunits strannoname = ANNO_FC_NAME Set pannofeaturecd = New AnnotationFeatureClassDescription Set pannoobjectcd = pannofeaturecd Set pfields = pannoobjectcd.requiredfields Set pfieldsedit = pfields Set pfield = pfields.field(pfields.findfield(pannofeaturecd.shapefieldname)) Set pfieldedit = pfield Set pgeomdefe = pfield.geometrydef Set pgeomdefe.spatialreference = pgeodataset.spatialreference Set pfieldedit.geometrydef = pgeomdefe Set pfieldsedit.field(pfields.findfield(pannofeaturecd.shapefieldname)) = pfieldedit Set pfeatureclass = pfeatureworkspacea.createannotationclass(strannoname, pfieldsedit, _ pannoobjectcd.instanceclsid, pannoobjectcd.classextensionclsid, _ pannofeaturecd.shapefieldname, "", pfeatureclass.featuredataset, pfeatureclass, _ pgeofeaturelayer.annotationproperties, pgraphicslayers, psymbolcollection, True) Set CreateRelatedAnnoClass = pfeatureclass Exit Function 198

199 Set CreateRelatedAnnoClass = Nothing End Function Private Sub AddAnnoElements(pMap pgeofeatlayer pannolayer On Error GoTo ErrorHandler As IMap, &_ As IGeoFeatureLayer, & _ As IFDOGraphicsLayer) Dim pactiveview Dim pscreendisplay Dim pgraphicslayer Dim AnnotateMapP Dim pannolayerpc Dim pannolayerp Dim penv Dim pdisplaytransformation Dim dblscaleratio Dim dblrefscale Dim pbounds Dim dunits Dim pannotatelayertp Dim AnnotateMap Dim ptrackcancel As IActiveView As IScreenDisplay As IGraphicsLayer As IAnnotateMapProperties As IAnnotateLayerPropertiesCollection As IAnnotateLayerProperties As IEnvelope As IDisplayTransformation As Double As Double As IEnvelope As esriunits As IAnnotateLayerTransformationProperties As IAnnotateMap As ItrackCancel Set pactiveview = pmap Set pscreendisplay = pactiveview.screendisplay Set pgraphicslayer = pannolayer pgraphicslayer.activate pscreendisplay ' get AnnotateMapProperties from source layer Set AnnotateMapP = New AnnotateMapProperties ' get AnnotateLayerPropertiesCollection from source layer Set pannolayerpc = pgeofeatlayer.annotationproperties Set AnnotateMapP.AnnotateLayerPropertiesCollection = pannolayerpc ' get the (first) property set in the collection pannolayerpc.queryitem 0, pannolayerp, Nothing, Nothing ' direct labels to target anno feature class Set pannolayerp.graphicscontainer = pannolayer With pannolayerp Set.FeatureLayer = pgeofeatlayer.addunplacedtographicscontainer = False.AnnotationMaximumScale = 0.AnnotationMinimumScale = 0.CreateUnplacedElements = False.DisplayAnnotation = True.Extent = pgeofeatlayer.areaofinterest 'source layer.featurelinked = False.LabelWhichFeatures = esriallfeatures.useoutput = True.WhereClause = "" End With Set pdisplaytransformation = pscreendisplay.displaytransformation 199

200 'dblscaleratio = pdisplaytransformation.sdblscaleratio dblscaleratio = pdisplaytransformation.scaleratio dblrefscale = pdisplaytransformation.referencescale Set pbounds = pdisplaytransformation.bounds dunits = pdisplaytransformation.units Set pannotatelayertp = pannolayerp With pannotatelayertp.units = dunits.bounds = pbounds.scaleratio = dblscaleratio.referencescale = dblrefscale End With ' Label features Set AnnotateMap = New AnnotateMap Set ptrackcancel = New CancelTracker AnnotateMap.Label AnnotateMapP, pmap, ptrackcancel Set pannolayerp.featurelayer = Nothing 如何把 Annotation 转换为 Polygon Features 本例要完成的功能是将指定的 GeoDatabase 中的 Annotation Features 转换为 Polygon Features 每一个 Annotation Feature 都被转换为多 Ring 的 Polygon Feature, 并且通过创建新的 Feature 保存在一个图形类型为 Polygon 的 FeatureLayer 中 要点 IFDOGraphicsLayerRead. NextGraphic: 得到 FDOGraphicsLayer 层中每一个 Annotation Feature 的 Element 属性 IQueryGeometry.GetGeometry: 得到一个 Element 的 Geometry 程序说明 首先将一个 Annotation 层加入到当前 Map 中, 并置为第 0 层 ; 再加一个 polygon 层, 并置为第 1 层, 并让这些层处于编辑状态 代码 Private Sub UIButtonControl1_Click() AnnoPolyCon_Click Private Sub AnnoPolyCon_Click() On Error GoTo ErrorHandler Dim lngflayernum Dim lngfdolayernum Dim dblreferencescale As Long As Long As Double 200

201 Dim dblmapscale As Double Dim dbloutputdpi As Double Dim dbloptimumscale As Double Dim dblscreenresolution As Double Dim dblannoscalefactor As Double Dim dbltemptextsize As Double Dim dblfinaloutputscale As Double Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pactiveview As IActiveView Dim pscreendisplay As IScreenDisplay Dim pdisplaytransform As IDisplayTransformation Dim pflayer As IFeatureLayer Dim IFeatureClass As IFeatureClass Dim pclass As IClass Dim pannoclass As IAnnoClass Dim pannofeature As IFeature Dim pannoelement As IElement Dim pfdographicslayer As IFDOGraphicsLayer Dim pfdographicsread As IFDOGraphicsLayerRead Dim ppolygon As IPolygon Dim ptextelement As ITextElement Dim ptextsymbol As ITextSymbol Dim ptextquery As IQueryGeometry Dim ptextpointgeo As IGeometry Dim ptopooperator2 As ITopologicalOperator2 Dim pfeature As IFeature 'SET these variables for your individual case lngfdolayernum = 0 'Set annotation layer here (zero-based: 0 is first layer in TOC) lngflayernum = 1 'Set empty feature layer here (zero-based: 1 is second layer in TOC) dbloutputdpi = 1200 'Highest DPI of your final output device(s) dblscreenresolution = 96 'Resolution of your monitor dblfinaloutputscale = 'Final scale that your map will be printed with Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pactiveview = pmap Set pscreendisplay = pactiveview.screendisplay Set pdisplaytransform = pscreendisplay.displaytransformation Set pflayer = pmap.layer(lngflayernum) Set IFeatureClass = pflayer.featureclass Set pclass = pmap.layer(lngfdolayernum) Set pannoclass = pclass.extension dblreferencescale = pmap.referencescale dblmapscale = pmap.mapscale dbloptimumscale = (dblscreenresolution / dbloutputdpi) * (dblfinaloutputscale / 2) dblannoscalefactor = pannoclass.referencescale / dbloptimumscale Set pfdographicslayer = pmap.layer(lngfdolayernum) Set pfdographicsread = pfdographicslayer pmap.referencescale = 0 pmap.mapscale = dbloptimumscale 201

202 'Generate graphacigs for pfdographicsread.startgeneratinggraphics Nothing, pscreendisplay, True, True, False Set pannoelement = pfdographicsread.nextgraphic Do Until pannoelement Is Nothing Set ppolygon = New Polygon Set ptextelement = pannoelement Set ptextsymbol = ptextelement.symbol 'Temporarily change textsymbol's size dbltemptextsize = ptextsymbol.size ptextsymbol.size = dbltemptextsize * dblannoscalefactor Set ptextquery = ptextsymbol Set ptextpointgeo = pannoelement.geometry 'Setup screen for drawing pscreendisplay.startdrawing pscreendisplay.windowdc, pscreendisplay.activecache 'Get ESRI geometry from Text Set ppolygon = ptextquery.getgeometry(pscreendisplay.windowdc, & _ pdisplaytransform, ptextpointgeo) 'Ensure geometry is suitable for a feature (sorts inner/outter rings) Set ptopooperator2 = ppolygon ptopooperator2.isknownsimple = False ppolygon.simplifypreservefromto pscreendisplay.finishdrawing 'Restore textsymbol size ptextsymbol.size = dbltemptextsize 'Store geometry in a feature Set pfeature = IFeatureClass.CreateFeature Set pfeature.shape = ppolygon pfeature.store 'Move to next piece of anno and loop Set pannoelement = pfdographicsread.nextgraphic Loop 'Restore dataframe's previous extent pmap.referencescale = dblreferencescale pmap.mapscale = dblmapscale pactiveview.refresh 如何设置 Featurelayer 的 Label 本例要完成的功能是将指定层上的某个字段所有值或根据某个表达式选择部分值作为 label 显示出来 要点 IGeoFeatureLayer.AnnotationProperties.Add: 将设置好的 LabelEngineLayerProperties 添加到 IGeoFeatureLayer 中 ILabelEngineLayerProperties.IsExpressionSimple: 设置显示 Label 的表达式是简单表达式还是复杂表达式 202

203 ILabelEngineLayerProperties. Expression: 设置要显示 Label 的表达式 IGeoFeatureLayer.DisplayAnnotation: 设置是否要显示 Label 程序说明 先把一个指定的层赋给一个 IGeoFeatureLayer 变量, 生成一个 ILineLabelPosition 的实例, 并设置与它相关的属性 方法 ; 再生成一个 ILabelEngineLayerProperties 的实例, 设置相关的属性 方法 ; 最后将生成好的 ILabelEngineLayerProperties 赋给要设定的层 代码 Private Sub UIButtonControl1_Click() ShowLabel Public Sub ShowLabel() Dim pmxdocument Dim pgeofeaturel Dim plinelabelp Dim plabelenginelp Dim pannotatelayerp As IMxDocument As IGeoFeatureLayer As ILineLabelPosition As ILabelEngineLayerProperties As IAnnotateLayerProperties On Error GoTo ErrorHandler Set pmxdocument = ThisDocument Set pgeofeaturel = pmxdocument.focusmap.layer(0) pgeofeaturel.annotationproperties.clear Set plinelabelp = New LineLabelPosition With plinelabelp.above = False.AtEnd = False.Below = False.Horizontal = False.InLine = True.OnTop = True.Parallel = True.ProduceCurvedLabels = True End With Set plabelenginelp = New LabelEngineLayerProperties With plabelenginelp Set.Symbol = New TextSymbol ' 方法一.IsExpressionSimple = False.Expression = "Function FindLabel ( [ZONENAME27],[FID])" _ & "FindLabel = [ZONENAME27] & [FID]" _ & " End Function" ' ' ' ' 方法二.IsExpressionSimple = True.Expression = "[ZONENAME27]".BasicOverposterLayerProperties.LineLabelPosition = plinelabelp End With Set pannotatelayerp = plabelenginelp With pannotatelayerp 203

204 .DisplayAnnotation = True Set.FeatureLayer = pgeofeaturel.labelwhichfeatures = esrivisiblefeatures.whereclause = "" End With pgeofeaturel.annotationproperties.add plabelenginelp pgeofeaturel.displayannotation = True pmxdocument.activeview.refresh 如何设置图层显示的透明度 要点 本例要完成的功能是设置指定层的透明度, 使其下面的层也能够被看见 接口 ILayerEffects 中有个属性 Transparency 可以用来设置层的透过率 该属性 的值是从 的, 数值越大, 透过率也越大 程序说明 先将要设置透明度的层的引用赋给一个 ILayerEffects 的实例, 然后再用 ILayerEffects.Transparency 进行透过率的设置 代码 Private Sub UIButtonControl1_Click() Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pfeaturelayer As IFeatureLayer Dim playereffects As ILayerEffects Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pfeaturelayer = pmap.layer(0) Set playereffects = pfeaturelayer If playereffects.supportstransparency Then ' 设置层的透过率 playereffects.transparency = 75 EndIf pmxdocument.activatedview.refresh 如何过滤层中要显示的 Features 本例要完成的功能是过滤层中要显示的 Features, 即根据指定的条件显示层中的 Features 要点 204

205 实现本例的功能用到接口 IFeatureLayerDefinition 中的属性 DefinitionExpression : 设置查询条件来选择出要显示的 Features 程序说明 先得到要过滤层的 FeatureLayer, 再用 IFeatureLayerDefinition. DefinitionExpression 设置显示条件 代码 Private Sub UIButtonControl1_Click() Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pactiveview As IActiveView Dim pfeatlayer As IFeatureLayer Dim pfeaturelayerd As IFeatureLayerDefinition Set pmxdocument = Application.Document Set pmap = pmxdocument.focusmap Set pactiveview = pmap Set pfeatlayer = pmap.layer(0) Set pfeaturelayerd = pfeatlayer pfeaturelayerd.definitionexpression = "FID <=10" pmxdoc.updatecontents pactiveview.refresh 如何在 MapControl 中新建一个 Document 并且保存 本例要完成的功能是把一个选择的 Shape 文件添加到 Mapcontrol 控件中, 并在 Mapcontrol 调用 ArcMap 把它保存在一个工程文件 (mxd) 里 要点 IDocument. Parent: 从已打开的文档中返回 IApplication IApplication.NewDocument: 根据设定的模版创建一个新的文档 IApplication.SaveDocument: 根据指定的路径保存文档 程序说明 先选择一个 Shape 文件加入到 MapControl 控件中 (AddShapeFile), 然后再把 它保存到一个工程文件 (CreateNewDoc) 中 代码 Private Sub cmdaddlayer_click() On Error GoTo ErrorHandler CommonDialog1.ShowOpen AddShapeFile (CommonDialog1.FileName) 205

206 Public Sub AddShapeFile(ByVal strfilename As String) Dim pworkspacefactory As IWorkspaceFactory Dim pfeatureworkspace As IFeatureWorkspace Dim pfeaturelayer As IFeatureLayer Dim pmxdocument As IMxDocument Dim pmap As IMap Dim strpath As String Dim strname As String strpath = Mid(strFileName, 1, InStrRev(strFileName, "\")) strname = Mid(strFileName, InStrRev(strFileName, "\") + 1) strname = Mid(strName, 1, Len(strName) - 4) 'Create a new ShapefileWorkspaceFactory object and open a shapefile folder Set pworkspacefactory = New ShapefileWorkspaceFactory Set pfeatureworkspace = pworkspacefactory.openfromfile(strpath, 0) 'Create a new FeatureLayer and assign a shapefile to it Set pfeaturelayer = New FeatureLayer Set pfeaturelayer.featureclass = pfeatureworkspace.openfeatureclass(strname) pfeaturelayer.name = pfeaturelayer.featureclass.aliasname 'Add the FeatureLayer to the focus map MapControl1.AddLayer pfeaturelayer MapControl1.Refresh Private Sub cmdsavemxd_click() If CreateNewDoc() = True Then MsgBox "Finish--OK" Else MsgBox "Finish--Err" Public Function CreateNewDoc() As Boolean On Error GoTo ErrorHandler Dim index Dim pmapcontrol Dim papplication Dim pdocument Dim ptemplates Dim pmxdocument Dim pmap Dim pactiveview Dim pworkspacefactory Dim pobjfactory Dim pfeatureworkspace Dim pmdataset Dim pmlayer Dim pmfeaturelayer Dim pfeaturelayer Dim pmgeolayer Dim pgeolayer Dim fso As Integer As esrimapcontrol.mapcontrol As esricore.iapplication As esricore.idocument As esricore.itemplates As esricore.imxdocument As esricore.imap As esricore.iactiveview As esricore.iworkspacefactory As esricore.iobjectfactory As esricore.ifeatureworkspace As esricore.idataset As esricore.ilayer As esricore.ifeaturelayer As esricore.ifeaturelayer As esricore.igeofeaturelayer As esricore.igeofeaturelayer As New FileSystemObject CreateNewDoc = False 206

207 CommonDialog1.ShowSave If Not fso.fileexists(commondialog1.filename) Then Set pmapcontrol = MapControl1 Set pdocument = New esricore.mxdocument Set papplication = pdocument.parent Set ptemplates = papplication.templates papplication.newdocument False, ptemplates.item(0) Set pmxdocument = pdocument Set pmap = pmxdocument.focusmap Set pmap.spatialreference = pmapcontrol.spatialreference Set pobjfactory = papplication For index = pmapcontrol.layercount - 1 To 0 Step -1 Set pmlayer = pmapcontrol.layer(index) If Not pmlayer Is Nothing Then If TypeOf pmlayer Is IFeatureLayer Then Dim l As Long Dim str As String Set pmfeaturelayer = pmlayer Set pmdataset = pmfeaturelayer Set pmgeolayer = pmfeaturelayer '' strfilename = pmdataset.workspace.pathname l = InStrRev(strFileName, ".") str = Right(strFileName, Len(strFileName) - l + 1) If UCase(Trim(str)) = ".MDB" Then Set pworkspacefactory = New esricore.accessworkspacefactory Set pfeatureworkspace =_ pworkspacefactory.openfromfile(strfilename, 0) Set pfeaturelayer = _ pobjfactory.create("esricore.featurelayer") Set pfeaturelayer.featureclass = pfeatureworkspace._ OpenFeatureClass & (pmfeaturelayer.featureclass.aliasname) pfeaturelayer.name = pfeaturelayer.featureclass.aliasname Set pgeolayer = pfeaturelayer Set pgeolayer.renderer = pmgeolayer.renderer Else Set pworkspacefactory = New esricore.shapefileworkspacefactory Set pfeatureworkspace =_ pworkspacefactory.openfromfile(strfilename, 0) Set pfeaturelayer = _ pobjfactory.create("esricore.featurelayer") Set pfeaturelayer.featureclass = pfeatureworkspace.)_ OpenFeatureClass & (pmfeaturelayer.featureclass.aliasname) pfeaturelayer.name = pfeaturelayer.featureclass.aliasname Set pgeolayer = pfeaturelayer Set pgeolayer.renderer = pmgeolayer.renderer pmap.addlayer pfeaturelayer Next Set pactiveview = pmap pactiveview.extent = pmapcontrol.extent papplication.savedocument CommonDialog1.FileName papplication.shutdown 207

208 CreateNewDoc = True Exit Function End Function 2. 提高篇 2.1. 缩略图的实现 2.2. FeatureLayer 显示 Symbol 的定制 2.3. 空间查询的综合应用 2.4. 图形编辑的综合应用 2.5. グラフの重ね合わせ表示と印刷 ArcMap 提供了种类丰富, 功能强大的 GRAPH 作成机能, 并可以将作成的 GRAPH 保存为 GRF 文件, 但并不能同时显示多张 GRAPH, 例如同时显示一个地区的地下水位的折线图和降雨量柱状图, 这时候我们需要自己开发这样的功能 本机能的主要内容 : 图 16 ArcMap 的 GRAPH 作成机能 208

209 グラフ的打开, 显示, 编辑, 保存. 重ね合わせて印刷, 打印纸张大小和方向的设定, 背景色的设定,GRID 的设定,TITLE 的设定和编辑.Border 的设定. 画面的扩大表示, 移动表示, 全范围表示, 文件的导出等. 画面一览 : 1. グラフの重ね合わせて表示画面的初始表示 : 2. GRF 文件的打开和显示 图

210 3. GRAPH 的编辑 图 印刷预览 图

211 具体功能请参照实例程序. 图 20 以下为部分重要代码 : 1. 文件的打开 ShowGraph 関数 Private Sub cmdopen1_click() On Error GoTo EH comfiledialog.cancelerror = False With comfiledialog.dialogtitle = "Open File".DefaultExt = "grf".filter = "Graph Files(*.grf) *.grf ".ShowOpen End With g_grffilepathname1 = comfiledialog.filename If g_grffilepathname1 = "" Then m_isgraphshow1 = False m_iscomestandalone = True ShowGraph EH: MsgBox m_strformname & " に関数 cmdopen1_click エラー :" & vbcrlf & Err.Description,_ vbcritical + vbokcancel, g_strerrtitle 211

212 Public Sub ShowGraph() On Error GoTo EH Dim pdoc As IMxDocument Dim pmap As IMap Set pdoc = ThisDocument Set pmap = pdoc.focusmap 'Create Graph 'Dim pdatagraph As IDataGraph Dim pdatagraphproperties As IDataGraphProperties Dim pgraphwindow As IDataGraphWindow Dim pdatagraphs As IDataGraphs Set g_pdatagraph1 = New DataGraph g_pdatagraph1.loadfromfile g_grffilepathname1 g_pdatagraph1.reloadalways = True g_pdatagraph1.attach MapControl1.hwnd g_pdatagraph1.draw m_isgraphshow1 = True EH: MsgBox m_strformname & " に関数 ShowGraph エラー :" & vbcrlf & Err.Description,_ vbcritical + vbokcancel, g_strerrtitle 2. グラフの編集 Private Sub cmdedit1_click() On Error GoTo EH Dim pdatagraphproperties As IDataGraphProperties Dim pgraphwindow As IDataGraphWindow Dim pdatagraphs As IDataGraphs If m_isgraphshow1 = False Then Dim pdoc As IMxDocument Dim pmap As IMap Set pdoc = ThisDocument Set pmap = pdoc.focusmap Set pgraphwindow = New DataGraphWindow Set pgraphwindow.datagraph = g_pdatagraph1 Set pgraphwindow.application = Application 'Add the graph to the system Set pdatagraphs = pdoc 'QI pdatagraphs.reset 212

213 pdatagraphs.add g_pdatagraph1 ShowGraph Set pdatagraphproperties = g_pdatagraph1 'QI pgraphwindow.show True Set pgraphwindow = Nothing Set pdatagraphs = Nothing EH: MsgBox m_strformname & " に関数 cmdedit1_click エラー :" & vbcrlf & Err.Description,_ vbcritical + vbokcancel, g_strerrtitle 3. 印刷プレビュー Private Sub cmdprintpreview_click() On Error GoTo EH If m_isgraphshow1 = False And m_isgraphshow2 = False Then If m_isgraphshow1 = True And m_isgraphshow2 = True Then Set g_printgraph1 = New DataGraph Set g_printgraph1 = g_pdatagraph1 Set g_printgraph2 = New DataGraph Set g_printgraph2 = g_pdatagraph2 frmtwographprint.show EH: MsgBox m_strformname & " に関数 cmdprintpreview_click エラー :" & vbcrlf_ & Err.Description, vbcritical + vbokcancel, g_strerrtitle 4. グラフ合わせて印刷画面の初期化 Private Sub UserForm_Initialize() On Error GoTo EH Dim pmapframe Dim pelement Dim penvelope As esricore.imapframe As esricore.ielement As esricore.ienvelope PageLayoutControl1.Page.Orientation = 1 'Portrait:1 ;Landscape:2 PageLayoutControl1.PageLayout.Page.Orientation = 1 PageLayoutControl1.PageLayout.Page.FormID = esripageforma4 If Not PageLayoutControl1.Printer Is Nothing Then PageLayoutControl1.Printer.Paper.Orientation = 1 Set pmapframe = PageLayoutControl1.GraphicsContainer._ 213

214 FindFrame(PageLayoutControl1.ActiveView.FocusMap) Set pelement = pmapframe Set penvelope = New esricore.envelope penvelope.putcoords 1, 1, 20, 29 pelement.geometry = penvelope PageLayoutControl1.Refresh Dim pdgelem As IDataGraphElement Set pdgelem = New DataGraphElement Set pdgelem.datagraph = g_printgraph1 Dim pelem As IElement Set pelem = pdgelem Dim pgc As IGraphicsContainer Set pgc = PageLayoutControl1.GraphicsContainer Dim penv As IEnvelope Set penv = New Envelope penv.xmin = 2 penv.xmax = 19 penv.ymin = 14 penv.ymax = 26 pelem.geometry = penv pgc.addelement pelem, 0 Dim pdgelem2 As IDataGraphElement Set pdgelem2 = New DataGraphElement Set pdgelem2.datagraph = g_printgraph2 Dim pelem2 As IElement Set pelem2 = pdgelem2 Dim penv2 As IEnvelope Set penv2 = New Envelope penv2.xmin = 2 penv2.xmax = 19 penv2.ymin = 2 penv2.ymax = 13 pelem2.geometry = penv2 pgc.addelement pelem2, 0 PageLayoutControl1.Refresh opta4.value = True optportrait.value = True UpdateArrayAndListBoxFromStyleGallery "Backgrounds",_ m_pstylesarray(1), lstbackground UpdateArrayAndListBoxFromStyleGallery "Borders", m_pstylesarray(2), lstborder g_strtitle = " グラフの重ね合わせ " 'Create an element and grab hold of the IElement interface Set m_ptitleelement = New TextElement 214

215 'Grab hold of the ITextElement interface through the element Set m_ptextelement = m_ptitleelement 'Create a text symbol and grab hold of the ITextSymbol interface Set m_ptextsymbol = New TextSymbol 'Set text symbol properties m_ptextsymbol.text = g_strtitle m_ptextsymbol.size = 30 'Set geometry property m_ptitleelement.geometry = CreateEnvelope(140, 64, 180, 30) 'Set text element properties m_ptextelement.symbol = m_ptextsymbol m_ptextelement.text = g_strtitle 'Add the element PageLayoutControl1.AddElement m_ptitleelement 'Refresh the new graphic element PageLayoutControl1.Refresh esriviewgraphics, m_ptitleelement 'Remove All Parameters Set pmapframe = Nothing Set pelement = Nothing Set penvelope = Nothing Set pdgelem = Nothing Set pelem = Nothing Set pgc = Nothing Set penv = Nothing Set pdgelem2 = Nothing Set pelem2 = Nothing Set penv2 = Nothing EH: MsgBox m_strformname & " に関数 UserForm_Initialize エラー :" & vbcrlf_ & Err.Description, vbcritical + vbokcancel, g_strerrtitle 5. エクスポート Private Sub cmdexport_click() On Error GoTo EH comfiledialog.cancelerror = False With comfiledialog.dialogtitle = "Open File".DefaultExt = "jpg".filter = "Jpg Files(*.jpg) *.jpg PDF Files(*.pdf)_ *.pdf BMP Files(*.bmp) *.bmp TIFF Files(*.tif) *.tif".showopen End With Dim ExportName As String ExportName = comfiledialog.filename 215

216 Dim pactiveview As IActiveView Dim pexporter As IExporter Dim penv As IEnvelope Dim exportframe As tagrect Dim dpi As Integer Dim xmin As Double Dim ymin As Double Dim xmax As Double Dim ymax As Double Dim hdc As Long Set pactiveview = PageLayoutControl1.ActiveView Set penv = New Envelope If baspubfileutil.getfileextention(exportname) = "jpg" Then Set pexporter = New JpegExporter exportframe = pactiveview.exportframe penv.putcoords exportframe.left, exportframe.top,_ exportframe.right, exportframe.bottom dpi = 300 'Set a high resolution With pexporter.pixelbounds = penv.exportfilename = ExportName.Resolution = dpi End With ElseIf baspubfileutil.getfileextention(exportname) = "pdf" Then Set pexporter = New PDFExporter exportframe = pactiveview.exportframe penv.putcoords exportframe.left, exportframe.top,_ exportframe.right, exportframe.bottom dpi = 300 'Set a high resolution With pexporter.pixelbounds = penv.exportfilename = ExportName.Resolution = dpi End With ElseIf baspubfileutil.getfileextention(exportname) = "bmp" Then Set pexporter = New DibExporter exportframe = pactiveview.exportframe penv.putcoords exportframe.left, exportframe.top,_ exportframe.right, exportframe.bottom dpi = 100 With pexporter.pixelbounds = penv.exportfilename = ExportName End With ElseIf baspubfileutil.getfileextention(exportname) = "tif" Then Set pexporter = New TiffExporter exportframe = pactiveview.exportframe penv.putcoords exportframe.left, exportframe.top, _ exportframe.right, exportframe.bottom 216

217 dpi = 100 With pexporter.pixelbounds = penv.exportfilename = ExportName End With Set penv = pexporter.pixelbounds penv.querycoords xmin, ymin, xmax, ymax exportframe.left = xmin exportframe.top = ymin exportframe.right = xmax exportframe.bottom = ymax 'Do the export hdc = pexporter.startexporting pactiveview.output hdc, dpi, exportframe, Nothing, Nothing pexporter.finishexporting EH: MsgBox m_strformname & " に関数 cmdexport_click エラー :" & vbcrlf & Err.Description,_ vbcritical + vbokcancel, g_strerrtitle 2.6. バッファ処理 ArcMap 自身具有一个功能叫 バッフア処理, 画面如下 : 图 21 这个处理的功能和使用 ItopologicalOperator 接口的 Buffer 方法有一定的相似之 217

218 处. 图 22 但是, 当处理的 Shape 文件是带有经纬度坐标系的文件时,2 者处理的结果是不一样的. 例如, 一个点的 Shape 文件是带有投影坐标系的文件时, 对这个文件做バッフア処理后得到的结果为正圆 : 218

219 图 23 而这个点的 Shape 文件是带有经纬度坐标系的文件时, 对这个文件做バッフア処 理后得到的结果为椭圆 : 图 24 下面我们以实例来介绍如何实现一个类似的功能 : 首先, 新建一个工程, 添加一个点的 Shape 文件, 并使用宏添加一个按扭. 219

220 然后, 添加如下处理代码 : Private Sub UIButtonControl1_Click() Dim pmxdocument As IMxDocument Dim pmap As IMap Dim pactiveview As IActiveView Dim pfeatureclass As IFeatureClass Dim pfeaturelayer As IFeatureLayer Dim pbufferfeaturelayer As IFeatureLayer Set pmxdocument = ThisDocument Set pmap = pmxdocument.focusmap Set pfeaturelayer = pmap.layer(0) 图 25 Set pbufferfeaturelayer = New FeatureLayer If MakeBuffer(pFeatureLayer, pbufferfeaturelayer) = False Then Else pmap.addlayer pbufferfeaturelayer バッフア処理関数 : Public Function MakeBuffer(ByVal ppointfeaturelayer As IFeatureLayer, ByRef poutfeaturelayer As IFeatureLayer) As Boolean On Error GoTo ErrorHandler Dim ppointfeatureclass As IFeatureClass Dim ppointgeodataset As IGeoDataset Dim ppointspreference As ISpatialReference Dim PolyBufferType As esribuffertype Dim BufferUnits As esriunits Dim MapUnits As esriunits Dim psourcespatialreference As ISpatialReference Dim pbufferspatialreference As ISpatialReference Dim poutputspatialreference As ISpatialReference Dim BufferSpatialReferenceType Dim TargetSpatialReferenceType Dim pfeaturecursorbuffer Dim pfeaturecursor Dim pfeatureclass Dim pfeatureclassname Dim pworkspacename Dim pdatasetname Dim DissolveBuffers Dim pbufferprocessingparameter Dim pfeaturecursorbuffer2 Dim ptrackcancel As esribufferspatialreferencetype As esribufferspatialreferencetype As IFeatureCursorBuffer As IFeatureCursor As IFeatureClass As IFeatureClassName As IWorkspaceName As IDatasetName As Boolean As IBufferProcessingParameter As IFeatureCursorBuffer2 As ITrackCancel 220

221 Dim pworkspacefactory Dim pfeatureworkspace Dim poutfclass As IWorkspaceFactory As IFeatureWorkspace As IFeatureClass Check to see whether file exists, If Exist, Then delete them. If FileExists(OUTFILEPATH & "\" & OUTFILENAME & ".shp") Then _ Delete_File (OUTFILEPATH & "\" & OUTFILENAME & ".shp") If FileExists(OUTFILEPATH & "\" & OUTFILENAME & ".shx") Then _ Delete_File (OUTFILEPATH & "\" & OUTFILENAME & ".shx") If FileExists(OUTFILEPATH & "\" & OUTFILENAME & ".dbf") Then _ Delete_File (OUTFILEPATH & "\" & OUTFILENAME & ".dbf") If FileExists(OUTFILEPATH & "\" & OUTFILENAME & ".prj") Then _ Delete_File (OUTFILEPATH & "\" & OUTFILENAME & ".prj") Set ppointfeatureclass = ppointfeaturelayer.featureclass Set ppointgeodataset = ppointfeatureclass Set ppointspreference = ppointgeodataset.spatialreference Set pfeaturecursor = ppointfeatureclass.search(nothing, False) Set psourcespatialreference = ppointspreference Set poutputspatialreference = ppointspreference Set pfeatureclassname = New FeatureClassName Set pdatasetname = pfeatureclassname pdatasetname.name = OUTFILENAME & ".shp" Set pworkspacename = New WorkspaceName pworkspacename.pathname = OUTFILEPATH pworkspacename.workspacefactoryprogid = "esricore.shapefileworkspacefactory.1" Set pdatasetname.workspacename = pworkspacename pfeatureclassname.featuretype = esriftsimple pfeatureclassname.shapetype = esrigeometrypolygon pfeatureclassname.shapefieldname = "Shape" Set pfeaturecursorbuffer = New FeatureCursorBuffer PolyBufferType = esribufferoutsideincludeinside DissolveBuffers = False BufferUnits = esrikilometers MapUnits = esridecimaldegrees BufferSpatialReferenceType = esrifeaturesetoptimizedspatialreference TargetSpatialReferenceType = esrimapspatialreference Set pbufferprocessingparameter = pfeaturecursorbuffer Set pfeaturecursorbuffer2 = pfeaturecursorbuffer Set pbufferprocessingparameter.featureclass = ppointfeatureclass Set pfeaturecursorbuffer.featurecursor = pfeaturecursor pfeaturecursorbuffer.polygonbuffertype = PolyBufferType バッファ間の境界線を削除しますか? 221

222 pfeaturecursorbuffer.dissolve = False バッファ距離の単位 pfeaturecursorbuffer.units(mapunits) = BufferUnits バッファを作成する方法 pfeaturecursorbuffer.valuedistance = 15 pbufferprocessingparameter.adjustcirclesforprojection = True pbufferprocessingparameter.simplifyshapes = False pbufferprocessingparameter.generaterings = True pbufferprocessingparameter.inputhaspolygons = False Set pfeaturecursorbuffer2.sourcespatialreference= psourcespatialreference pbufferprocessingparameter.bufferspatialreference= BufferSpatialReferenceType Set pfeaturecursorbuffer2.bufferspatialreference = Nothing pbufferprocessingparameter.targetspatialreference= TargetSpatialReferenceType Set pfeaturecursorbuffer2.targetspatialreference = poutputspatialreference Set pfeaturecursorbuffer2.dataframespatialreference = poutputspatialreference Set ptrackcancel = New CancelTracker Set pfeaturecursorbuffer.canceltrack = ptrackcancel pbufferprocessingparameter.saveasgraphics = False pfeaturecursorbuffer.buffer pfeatureclassname Set pfeatureclassname = Nothing Set pdatasetname = Nothing Set pworkspacename = Nothing Set pfeaturecursorbuffer = Nothing Set pbufferprocessingparameter = Nothing Set pfeaturecursorbuffer2 = Nothing Set ptrackcancel = Nothing Set pfeaturecursor = Nothing Set pfeatureclass = Nothing Set psourcespatialreference = Nothing Set poutputspatialreference = Nothing Set pworkspacefactory = New ShapefileWorkspaceFactory Set pfeatureworkspace = pworkspacefactory.openfromfile(outfilepath, 0) Set poutfclass = pfeatureworkspace.openfeatureclass(outfilename) Set poutfeaturelayer.featureclass = poutfclass poutfeaturelayer.name = " バッフア処理結果 " MakeBuffer = True Exit Function MakeBuffer = False End Function 运行结果为 : 222

223 图 Voronio 作成 2.8. 数据处理加速 地图分块处理 2.9. MapControl 的使用 运用 PageLayout 控件打印图形 附录 ArcGIS 的 GUID 一览表 223