Howto: 使用VBA代码在指定的位置创建一个表

摘要：
介绍使用VB或VBA通过程序创建一个表，该过程可以通过在ArcCatalog里点击按钮完成。 如果选择的是一个文件夹，将创建一个DBASE（DBF）表，如果选择的是一个Geodatabase，将创建一个Geodatabase表。
内容：
1． 运行ArcCatalog； 2． 创建一个新的UIButtonControl A． 选择Tools——Customize打开自定义对话框； B． 选择Commands页； C． 在类别列表框里选择UIControls； D． 在保存下拉框里选择Untitled将按钮保存到当前地图文档，选择Normal的话会保存到Normal文档，从而影响机器上的所有mxd文档； E． 点击新建UIControl； F． 选择UIButtonControl，点击创建； G． 拖拽新创建的UIButtonControl到指定的toolbar上； H． 关闭自定义对话框。 如果已经有个存在的UIbuttonControl或者想要修改一下该控件的名字，那么该控件的事件代码需要做相应的更改。 3． 打开Visual Basic Editor。 在ArcCatalog里选择Tools——Macros——Visual Basic Editor 4． 在工程浏览窗口，展开Normal（Normal.gxt）项，选择ArcCatalog Objects——ThisDocument。右键点击，选择View Code。 5． 粘贴下述代码到指定的模块： Private Sub UIButtonControl1_Click()

On Error GoTo Err

Dim pGxApp As IGxApplication
Set pGxApp = Application

Dim pSelObj As IGxObject
Set pSelObj = pGxApp.SelectedObject

Dim location As String
location = pSelObj.FullName 'read the full path to workspace

Dim tableName As String
tableName = InputBox("Please Enter the Name of the New Table:", "New Table", "New_Table")

If tableName = "" Then Exit Sub 'exit if nothing is entered

Dim mypath As String
Dim bTableExist As Boolean

'check for existence of the table name

'concatenate location and table name

If pSelObj.Category = "Personal Geodatabase" Or pSelObj.Category = "Spatial Database Connection" Or pSelObj.Category = "File Geodatabase" Then

bTableExist = CheckGdbTableExists(location, tableName)
mypath = location & "\" & tableName

ElseIf pSelObj.Category = "Folder" Or pSelObj.Category = "Folder Connection" Then

mypath = location & "\" & tableName & ".dbf"
bTableExist = CheckFileExists(mypath)

End If

'create table if table name does not exist

If bTableExist = False Then

'Declare and define index and text Fields

Dim pOIDField As IFieldEdit
Set pOIDField = New Field
pOIDField.Type = esriFieldTypeOID
pOIDField.Name = "OID"

Dim pField As IFieldEdit
Set pField = New Field
pField.Type = esriFieldTypeString
pField.Name = "FIELD1"
pField.Length = 10

'Collect the fields into a fields collection

Dim pFieldsEdit As IFieldsEdit
Set pFieldsEdit = New Fields
pFieldsEdit.AddField pOIDField
pFieldsEdit.AddField pField

'Prepare the required arguments for CreateTable

Dim pFields As IFields
Set pFields = pFieldsEdit

Dim strConfigWord As String
strConfigWord = ""

Dim pFeatureWorkspace As IFeatureWorkspace

'set up the correct workspace factory depending on what was selected

If pSelObj.Category = "Personal Geodatabase" Then

' Instantiate Access Workspace Factory

Dim pAccessFactory As IWorkspaceFactory
Set pAccessFactory = New AccessWorkspaceFactory

Dim pAccessWorkspace As IWorkspace
Set pAccessWorkspace = pAccessFactory.OpenFromFile(pSelObj.FullName, 0)
Set pFeatureWorkspace = pAccessWorkspace

ElseIf pSelObj.Category = "Spatial Database Connection" Then

'exit if it is not a workspace

If Not TypeOf pGxApp.SelectedObject.InternalObjectName.Open Is IWorkspace Then Exit Sub


'read the connection properties: server, service ...

Dim pWksp As IWorkspace
Set pWksp = pGxApp.SelectedObject.InternalObjectName.Open

Dim pPropSet As IPropertySet
Set pPropSet = pWksp.ConnectionProperties

Dim varNames As Variant, varValues As Variant
pPropSet.GetAllProperties varNames, varValues

Dim pSdeFactory As IWorkspaceFactory
Set pSdeFactory = New SdeWorkspaceFactory

Dim pSdeWorkspace As IWorkspace
Set pSdeWorkspace = pSdeFactory.Open(pPropSet, 0) 'open with the connection properties

Set pFeatureWorkspace = pSdeWorkspace

ElseIf pSelObj.Category = "Folder" Or pSelObj.Category = "Folder Connection" Then

Dim pShapefileFactory As IWorkspaceFactory
Set pShapefileFactory = New ShapefileWorkspaceFactory

'Open the folder

Dim pFolderWorkspace As IWorkspace
Set pFolderWorkspace = pShapefileFactory.OpenFromFile(pSelObj.FullName, 0)

Set pFeatureWorkspace = pFolderWorkspace

ElseIf pSelObj.Category = "File Geodatabase" Then

' Instantiate Access Workspace Factory

Dim pFileGDBFactory As IWorkspaceFactory
Set pFileGDBFactory = New FileGDBWorkspaceFactory

Dim pFileGDBWorkspace As IWorkspace
Set pFileGDBWorkspace = pFileGDBFactory.OpenFromFile(pSelObj.FullName, 0)

Set pFeatureWorkspace = pFileGDBWorkspace

'anything else that was selected is not possible to create a table into

Else

MsgBox "A Table Cannot be Created at This Location." & vbNewLine & "Please Select a Geodatabase or Folder Location.", vbInformation, "Cannot Create Table"

Exit Sub

End If

'Create the table

Dim pTable As ITable
Set pTable = pFeatureWorkspace.CreateTable(tableName, pFields, Nothing, Nothing, strConfigWord)

Else

MsgBox "The " & tableName & " Table Already Exists at This Location.", vbExclamation

UIButtonControl1_Click

End If

pGxApp.Refresh location

Exit Sub

Err:
MsgBox Err.Description, vbCritical, "Error Creating Table"

End Sub
6． 粘贴以下代码到模块：

Private Function CheckFileExists(FileName As String) As Boolean

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
CheckFileExists = fso.fileExists(FileName)

End Function

'modified from a posting by Neil Clemmons, esri discussion forum

Private Function CheckGdbTableExists(sWorkspace As String, sTable As String) As Boolean

'this will fail to find an existing sde table because
'the code will not read the username and concatenate
'with the name of the table for sde table names

On Error Resume Next

Dim pAccessFactory As IWorkspaceFactory
Set pAccessFactory = New AccessWorkspaceFactory
Dim pAccessWorkspace As IWorkspace

Set pAccessWorkspace = pAccessFactory.OpenFromFile(sWorkspace, 0)
Dim pFeatureWorkspace As IFeatureWorkspace
Set pFeatureWorkspace = pAccessWorkspace
Dim pTable As ITable
Set pTable = pFeatureWorkspace.OpenTable(sTable)

If pTable Is Nothing Then
CheckGdbTableExists = False

Else
CheckGdbTableExists = True
End If

End Function




创建时间：2006-05-25
最近更新： 2010-06-17


【原文链接】
http://support.esrichina.com.cn/2006/0525/814.html