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 "路径不存在" & vbCr & sFilePath

        Exit Function

    End If

    sDir = Dir(sFilePath & sFileName & ".dbf")

    If (sDir <> "") Then

        MsgBox ("文件已存在")

        Exit Function

    End If

    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

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

    End If

    Exit Function

ErrorHandler:

    MsgBox Err.Description

End Function

Private Sub UIButtonControl1_Click()

    Dim pVBProject              As VBProject

    Dim pTable                  As ITable

On Error GoTo ErrorHandler:

    Set pVBProject = ThisDocument.VBProject

    'Dont include .dbf extension

    Set pTable = CreateDBF (pVBProject.FileName & "\..\..\..\.." & "\data\", "MyDBFFile")

    Exit Sub

ErrorHandler:

    MsgBox Err.Description

End Sub