Howto: 使用VBA创建一个新的个人数据库

摘要：
本文介绍了如何使用VBA代码来创建一个新的个人数据库。
内容：
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()
CreateGeodb
End Sub

Private Sub CreateGeodb()
Dim pGxApp As IGxApplication
Set pGxApp = Application
Dim pSelObj As IGxObject
Set pSelObj = pGxApp.SelectedObject
Debug.Print pSelObj.Category
If pSelObj.Category = "Folder" Or pSelObj.Category = "Folder Connection" Then
Dim location As String
location = pSelObj.FullName
Dim name As String
name = "mydb"
Dim mypath As String
mypath = location & "\" & name & ".mdb"
Dim bWorkspExist As Boolean
bWorkspExist = PgdbExists(mypath)
If bWorkspExist = False Then
Call createAccessWorkspace(location, name)
Call AddGeodb(mypath)
pGxApp.Refresh location
MsgBox mypath & " has been created.", vbInformation
Else
MsgBox "The " & name & " PGDB already exists in the current location.", vbExclamation
Exit Sub
End If
Else
MsgBox "A Personal Geodatabase cannot be created at this location." & vbNewLine & "Please select a folder location.", vbExclamation
Exit Sub
End If
End Sub

Private Function PgdbExists(mypath As String) As Boolean
Dim pGPValue As IGPValue
Set pGPValue = New DEWorkspace
pGPValue.SetAsText mypath
Dim pDEUtil As IDEUtilities
Set pDEUtil = New DEUtilities
PgdbExists = pDEUtil.Exists(pGPValue)
End Function
''
'' createAccessWorkspace
'' NOTE:
'' Location does not have to contain ending '\'
'' Name should not contain .mdb extension
Public Function createAccessWorkspace(location As String, name As String) _
As IWorkspaceName

On Error GoTo EH
Set createAccessWorkspace = Nothing

' create the Access Workspace factory
Dim pWorkspaceFactory As IWorkspaceFactory
Set pWorkspaceFactory = New AccessWorkspaceFactory

Dim pWorkspaceName As IWorkspaceName
Set pWorkspaceName = pWorkspaceFactory.Create(location, name, Nothing, 0)

Set createAccessWorkspace = pWorkspaceName
Exit Function

EH:
MsgBox Err.Number, vbInformation, "createAccessWorkspace"
End Function

Sub AddGeodb(mypath As String)
Dim pwf As IWorkspaceFactory
Set pwf = New AccessWorkspaceFactory
Dim pfws As IFeatureWorkspace
Set pfws = pwf.OpenFromFile(mypath, 0)
End Sub
6．点击新建的button即可创建一个新的个人数据库了。





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


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