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" 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

            

        '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

    End If

    

    pGxApp.Refresh location

    Exit Sub

    

Err:

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

End Sub

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

• 新規のパーソナルジオデータベースを作成するために、追加したボタンをクリックします。