ArcEngine_开发文档(ArcGIS AO开发)

ArcEngine 开发

1. 基础篇

1.1. 开发环境

1.1.1. 如何在ArcMap的VBA环境中编程

ArcMap是ArcGIS家族的成员之一，它内置了一种集成编程环境―VBA（Visaul Basic for Apllications）。通过VBA编程，用户不但可以扩展ArcMap的菜单、工具条等，而且可以完成大多数用户的特定需求。

ArcMap中VBA编程的方法有两种,一种是写VBA宏,另一种是创建UIControl并在其事件中写入实现用户需求的代码。下面列出两种方法的一般步骤。

方法一：写VBA宏（直接在VBA编辑器中编辑函数和过程）

1、如图1，单击菜单栏中的命令,选择的项, 直接启动ArcMap的VBA编辑器；或者选择的项，进入如图2所示Macro对话框，在“Macro Name”文本框中输入要创建的宏的名称，并点按钮，启动VBA编辑器。

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

-1-

图2 Macro对话框

2、在图3所示的窗口中，用户可以根据实际选择在Normal节点或者Project

节点的ThisDocument、Forms、Modules中编写宏（函数或过程），Normal节点下所写的宏系统自动保存，除非用户删除，否则它将始终存在并在任何工程中都有效；而在Project节点下所写得宏随工程保存（如不保存工程，则宏也将不被保存），并只在工程中有效。

图3 VBA编辑器（VBE）

-2-

3、运行VBA宏

在VBA编辑器中写好VBA代码后，有两种方式运行：第一，点击VBA编辑器工具条中的

（运行）按钮，可立即运行写好的代码；第二，退出VBA编辑器，

重新启动Macro对话框，如图2，选择要运行的VBA宏名称，点击按钮即可运行相应的VBA宏。

方法二：创建UIControl（交互式VBA编程）

1、用鼠标右击任何工具栏（条），在弹出的上托式菜单中选择菜单项,如图4，进入图5所示的Customize对话框。

图4 启动“Customize”对话框

2、切换到“Customize”对话框的“Commands”页，选中“UIControls”后点击按钮，进入图6所示的“New UIControl”对话框。

3、在“New UIControl”对话框中，用户可根据需要选择UIControl类型：

UIButtonControl：创建Button； UIToolControl：创建与Map交互的Tool； UIEditBoxControl：创建EditBox；

-3-

UIComboBoxControl：创建ComboBox。

最后点击按钮只创建UIControl或者点击按钮创建UIControl并进入VBA编辑器。与方法一不同，此时应在UIControl的事件中进行VBA编程。

图5 Customize对话框

图6 New UIControl对话框

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

-4-

1.1.2. 如何在VB环境中利用ArcObjects组件开发ActiveX DLL

1.1.1节讨论了如何在ArcGis的VBA环境中编程，虽然通过这种方式可以完成大多数用户的定制需求，但是，在某些情况下，对于特殊的应用，用户需要脱离ArcGIS环境而在VB开发环境中开发外部独立的应用程序，这种外部独立的应用程序有两种形式： ActiveX DLL和Standard EXE。Standard EXE的开发将在1.1.4中讨论，本节将讨论ActiveX DLL的开发，其关键是引用ArcObjects对象库和实现ArcObjects接口（例如ICommand,ITool,IToolBar等）。

下面介绍在VB环境利用ArcObjects组件开发ActiveX DLL的一般步骤。 1、启动VB开发环境，在图7所示的“New Project”对话框中选择“ActiveX DLL”项,并点击<打开>按钮，进入VBE环境。

图7 New Project对话框

2、引用ArcObjects对象库：首先点击菜单中的项，如图8，进入对象库引用对话框，如图9。

-5-

? 程序说明

程序在类模块中实现Icommand接口来创建自己的按钮(Button) ? 代码

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) End Sub

Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE ICommand_Bitmap = m_pPicture End Property

Private Property Get ICommand_Caption() As String ICommand_Caption = \End Property

Private Property Get ICommand_Category() As String ICommand_Category = \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 = \End Property

Private Sub ICommand_OnClick()

'加入按下按钮时实现的功能代码。在这里，

'按钮按下时显示ArcMap的Document的Tittle Dim pDocument As IDocument

-11-

Set pDocument = m_pApplication.Document MsgBox pDocument.Title End Sub

Private Sub ICommand_OnCreate(ByVal hook As Object) '获取ArcMap的Application实例? Set m_pApplication = hook End Sub

Private Property Get ICommand_Tooltip() As String ICommand_Tooltip = \End Property

1.2.2. 如何创建定制的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) End Sub

Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE ICommand_Bitmap = m_pBitmap

-12-

End Property

Private Property Get ICommand_Caption() As String ICommand_Caption = \End Property

Private Property Get ICommand_Category() As String ICommand_Category = \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 = \End Property

Private Property Get ICommand_Name() As String ICommand_Name = \End Property

Private Sub ICommand_OnClick() '加入按下按钮时实现的功能代码 MsgBox \End Sub

Private Sub ICommand_OnCreate(ByVal hook As Object) '获取ArcMAP的Application实例 Set m_pApplication = hook End Sub

Private Property Get ICommand_Tooltip() As String ICommand_Tooltip = \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

-13-

Private Function ITool_OnContextMenu(ByVal X As Long, ByVal Y As Long) As Boolean '在这里可以加入用户代码，点击Mouse右键时显示一个定制的context menu End Function

Private Sub ITool_OnDblClick()

'在这里加入Mouse双击时的功能代码 End Sub

Private Sub ITool_OnKeyDown(ByVal keyCode As Long, ByVal Shift As Long) End Sub

Private Sub ITool_OnKeyUp(ByVal keyCode As Long, ByVal Shift As Long) End Sub

Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, _

ByVal X As Long, ByVal Y As Long)

'加入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) & \ End If End Sub

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) = \End Sub

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) = \End Sub

Private Sub ITool_Refresh(ByVal hDC As esriCore.OLE_HANDLE) End Sub

1.2.3. 如何创建定制的工具条(Tool Bar)

本例要实现的是如何创建定制的工具条(Tool Bar)。就必须在类模块中实现IToolBarDef接口。IToolBarDef接口包括 Caption、ItemCount及Name三个属性和GetItemInfo方法。 ? 要点

通过在类模块中实现IToolBarDef接口。IToolBarDef接口包括 Caption、

-14-

ItemCount及Name三个属性和GetItemInfo方法。

·ItemCount属性表示ToolBar显示的条目(Button、Tool或其它控件)数。 · GetItemInfo方法定义工具条上各条目的CLSID，其中，参数pos表示条目在ToolBar中的位置，itemDef 是定义相应位置的条目的IItemDef 对象。

·工具条条目的CLSID分为两种：

1、系统CLSID，代表ArcGIS的一个功能，其引用方式为\命令名称\，如\、\等。

2、用户定制CLSID，表示用户自己定义的功能。其引用方式为\工程名称.定制功能类名称\，如\ ToolBarDef.ClsBar \。必须注意，这里“定制功能类名称”是工程中实现的一个功能类名称，“工程名称”即为当前工程的名称（不是DLL文件名，也不是工具条的名称），每次新建一个工程时，系统默认的工程名在某些情况下无法使用（在中文版的VB中是一个乱字符），必须改名后方能用。 ? 程序说明

程序在类模块中实现IToolBarDef接口来创建自己的工具条(ToolBar)。 ? 代码

Option Explicit

Implements IToolBarDef

Private Property Get IToolBarDef_Caption() As String IToolBarDef_Caption = \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 = \ itemDef.Group = False Case 1

'系统条目

itemDef.ID = \ itemDef.Group = False End Select End Sub

Private Property Get IToolBarDef_ItemCount() As Long

IToolBarDef_ItemCount = 2 End Property

-15-

接口，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 ErrorHandler:

sDir = Dir(sFilePath & sFileName & \ If (sDir = \

MsgBox (sFileName & \文件不存在\ Exit Sub End If

'Get the ITable from the geodatabase

Set pWorkspaceFactory = New TextFileWorkspaceFactory

Set pWorkspace = pWorkspaceFactory.OpenFromFile(sFilePath, 0) Set pFeatureWorkspace = pWorkspace

Set pTable = pFeatureWorkspace.OpenTable(sFileName & \

'Add the table

Add_Table_TOC pTable Exit Sub ErrorHandler:

MsgBox Err.Description End Sub

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 ErrorHandler:

'Get the ITable from the geodatabase

Set pWorkspaceFactory = New ShapefileWorkspaceFactory

Set pWorkspace = pWorkspaceFactory.OpenFromFile(sFilePath, 0) Set pFeatureWorkspace = pWorkspace

-31-

Set pTable = pFeatureWorkspace.OpenTable(sFileName) 'Add the table Add_Table_TOC pTable Exit Sub ErrorHandler:

MsgBox Err.Description End Sub

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 ErrorHandler: 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 Exit Sub ErrorHandler:

MsgBox Err.Description End Sub

Private Sub UIButtonControl1_Click()

Dim pVBProject As VBProject

On Error GoTo ErrorHandler:

Set pVBProject = ThisDocument.VBProject

'Add text file to ArcMap. Dont include .txt extension

AddTextFile pVBProject.FileName & \ 'Add dBASE file to ArcMap

AddDBASEFile pVBProject.FileName & \ Exit Sub ErrorHandler:

MsgBox Err.Description End Sub

1.3.3. 如何连接GeoDataBase文件

本例实现的是连接一个GeoDataBase文件，并在ArcMap中加载该GeoDataBase文件的一个表。

-32-

? 要点

定义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 ErrorHandler: sDir = Dir(sAllFileName) If (sDir = \

MsgBox (\文件不存在\ Exit Sub End If

'Create a new AccessWorkspaceFactory object and open a GeoDataBaseFile Set pWorkspaceFactory = New AccessWorkspaceFactory

Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(sAllFileName, 0)

'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 Exit Sub ErrorHandler:

MsgBox Err.Description End Sub

Private Sub UIButtonControl1_Click()

Dim pVBProject As VBProject On Error GoTo ErrorHandler:

-33-

Set pVBProject = ThisDocument.VBProject

OpenGeoDataBaseFile pVBProject.FileName & \& \\ Exit Sub ErrorHandler:

MsgBox Err.Description End Sub

1.3.4. 如何连接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 Dim pDataset As IDataset Dim pEnumDataset As IEnumDataset

Dim pFeatureClassC As IFeatureClassContainer Dim pFeatureLayer As IFeatureLayer Dim pMxDocument As IMxDocument Dim pMap As IMap Dim nNumber As Integer Dim sWorkspace As String

On Error GoTo ErrorHandler:

-34-

sWorkspace = Dir(sFilePath, vbDirectory) If (sWorkspace = \ MsgBox (\文件不存在\ Exit Sub End If

Set pWorkspaceFactory = New ArcInfoWorkspaceFactory Set pPropertySet = New PropertySet 'canada is an arcinfoworkspace

pPropertySet.SetProperty \ '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 End If 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 End If Exit Sub ErrorHandler:

MsgBox Err.Description End Sub

Private Sub UIButtonControl1_Click()

Dim pVBProject As VBProject On Error GoTo ErrorHandler:

Set pVBProject = ThisDocument.VBProject

ConnectCoverageFile pVBProject.FileName & \ Exit Sub ErrorHandler:

-35-

MsgBox Err.Description End Sub

1.3.5. 如何连接栅格文件

本例实现的是如何在当前激活的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 ErrorHandler:

sRasterFile = Dir(sFilePath & sFileName) If (sRasterFile = \ MsgBox (\文件不存在\ Exit Sub End If

'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 Exit Sub ErrorHandler:

MsgBox Err.Description End Sub

Private Sub UIButtonControl1_Click()

-36-

Dim pVBProject As VBProject On Error GoTo ErrorHandler:

Set pVBProject = ThisDocument.VBProject

AddRasterFile pVBProject.FileName & \ Exit Sub ErrorHandler:

MsgBox Err.Description End Sub

1.3.6. 如何创建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 ErrorHandler:

sNewShapeFileName = Dir(sFilePath & sFileName & \ If (sNewShapeFileName <> \ MsgBox (\文件已经存在\ Exit Sub End If

sShapeFieldName = \

'Open the folder to contain the shapefile as a workspace Set pWorkspaceFactory = New ShapefileWorkspaceFactory

Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(sFilePath, 0)

-37-

'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 = \

.Type = esriFieldTypeSmallInteger End With

pFieldsEdit.AddField pField

Set pField = New esriCore.Field Set pFieldEdit = pField With pFieldEdit

.Name = \

.Type = esriFieldTypeInteger End With

pFieldsEdit.AddField pField

Set pField = New esriCore.Field Set pFieldEdit = pField With pFieldEdit

.Name = \

.Type = esriFieldTypeSingle End With

pFieldsEdit.AddField pField

Set pField = New esriCore.Field Set pFieldEdit = pField With pFieldEdit .Precision = 5 .Scale = 5

.Name = \

.Type = esriFieldTypeDouble End With

pFieldsEdit.AddField pField

-38-

Set pField = New esriCore.Field Set pFieldEdit = pField With pFieldEdit .Length = 30 .Name = \

.Type = esriFieldTypeString End With

pFieldsEdit.AddField pField

Set pField = New esriCore.Field Set pFieldEdit = pField With pFieldEdit .Name = \

.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 & \ If (sNewShapeFileName = \ MsgBox (\ Else

MsgBox (\ End If Exit Sub ErrorHandler:

MsgBox Err.Description End Sub

Private Sub UIButtonControl1_Click()

Dim pVBProject As VBProject On Error GoTo ErrorHandler:

Set pVBProject = ThisDocument.VBProject

'Dont include .shp extension

CreatShapeFile pVBProject.FileName & \ Exit Sub ErrorHandler:

MsgBox Err.Description End Sub

Private Sub UIButtonControl1_Click()

Dim pVBProject As VBProject On Error GoTo ErrorHandler:

Set pVBProject = ThisDocument.VBProject

'Dont include .shp extension

CreatShapeFile pVBProject.FileName & \ Exit Sub ErrorHandler:

-39-

MsgBox Err.Description End Sub

1.3.7. 如何创建DBF文件

本例要实现的是如何创建一个单独的DBF文件。 ? 要点

首先设定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 ErrorHandler:

Dim pFeatureWorkspace As IFeatureWorkspace Dim pWorkspaceFactory As IWorkspaceFactory

Dim FileFolder As New Scripting.FileSystemObject Dim pFieldsEdit As esriCore.IFieldsEdit Dim pFieldEdit As esriCore.IFieldEdit Dim pFields As IFields Dim pField As IField Dim sDir As String

'Open the Workspace

Set pWorkspaceFactory = New ShapefileWorkspaceFactory If Not FileFolder.FolderExists(sFilePath) Then MsgBox \路径不存在\ Exit Function End If

sDir = Dir(sFilePath & sFileName & \ If (sDir <> \

MsgBox (\文件已存在\ Exit Function End If

Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(sFilePath, 0)

'if a fields collection is not passed in then create one

-40-

本文来源：https://www.bwwdw.com/article/27c6.html