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 = "フォルダ" Or pSelObj.Category = "フォルダ コネクション" 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 & "が作成されました。", vbInformation
        Else
            MsgBox name & "パーソナル ジオデータベースは現在の場所にすでに存在します。", vbExclamation
            Exit Sub
        End If
    Else
        MsgBox "この場所にパーソナル ジオデータベースを作成することはできません。" & vbNewLine & "フォルダの場所を選択してください。", 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

''
'' AccessWorkspaceFactory（パーソナル ジオデータベースを作成するために必要なワークスペース ファクトリ）を作成します。
'' メモ：
''   パス名の最後に'\'を含める必要はありません。
''   名前に拡張子（.mdb）を含めてはいけません。

Public Function createAccessWorkspace(location As String, name As String) _
           As IWorkspaceName

    On Error GoTo EH
    Set createAccessWorkspace = Nothing
    
    ' AccessWorkspaceFactoryを作成します。
    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