贴上代码：

Imports System.Text
Imports System.Runtime.InteropServices

Public Class OpenFolder_OK

    Private Delegate Function fbCallBack(ByVal hWnd As Integer,ByVal uMsg As Integer,ByVal lParam As Integer,ByVal lpData As Integer) As Integer

    Private initpath As String = "C:/"

    Private Structure BROWSEINFO
        Dim hOwner As Integer
        Dim pidlRoot As Integer
        Dim pszDisplayName As String
        Dim lpszTitle As String
        Dim ulFlags As Integer
        Dim lpfn As fbCallBack
        Dim lParam As Integer
        Dim iImage As Integer
    End Structure

    Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (ByVal lpBrowseInfo As IntPtr) As Integer
    Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pIdl As Integer,ByVal pszPath As StringBuilder) As Integer
    Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Integer,ByVal wMsg As Integer,ByVal wParam As Integer,ByVal lParam As Integer) As Integer

    Private Const WM_USER As Integer = &H400
    Private Const BFFM_INITIALIZED As Integer = 1
    Private Const BFFM_SELCHANGED As Integer = 2
    'Private Const BIF_BROWSEINCLUDEFILES As Integer = &H4000
    Private Const BIF_DONTGOBELOWDOMAIN As Integer = &H2
    Private Const BFFM_SETSELECTIONA As Integer = (WM_USER + 102)
    Private Const BFFM_SETSTATUSTEXT As Integer = &H464
    Private Const BIF_RETURNONLYFSDIRS As Integer = &H1

    Dim pnt As IntPtr
    Dim BIptr As IntPtr
    Dim pIdl As Integer

    Private Sub Button1_Click(ByVal sender As System.Object,ByVal e As System.EventArgs) Handles Button1.Click
        Try

            pnt = Nothing
            BIptr = Nothing
            pIdl = Nothing

            If Not My.Computer.FileSystem.DirectoryExists(initpath) Then
                MsgBox(initpath & " not exist")
                Exit Try
            End If

            Dim BI As BROWSEINFO
            Dim sPath As StringBuilder
            Dim txtPath As String

            With BI
                .hOwner = Me.Handle
                .pszDisplayName = Space(260)
                .lpszTitle = "打开文件"
                .ulFlags = BIF_RETURNONLYFSDIRS
                .lpfn = AddressOf BrowseCallBackProc
                .lParam = Marshal.StringToHGlobalAnsi(initpath)
            End With

            txtPath = ""
            BIptr = Marshal.AllocHGlobal(Marshal.SizeOf(BI))
            Marshal.StructureToPtr(BI,BIptr,False)

            pIdl = SHBrowseForFolder(BIptr)

            If pIdl = 0 Then Exit Try
            sPath = New StringBuilder(255)
            SHGetPathFromIDList(pIdl,sPath)

            txtPath = sPath.ToString
            TextBox1.Text = txtPath
            initpath = txtPath
            Marshal.FreeHGlobal(pIdl)

        Catch ex As Exception
            MsgBox(ex.ToString)
        Finally
            Marshal.FreeHGlobal(BIptr)
            Marshal.FreeHGlobal(pnt)
        End Try

    End Sub

    Public Function BrowseCallBackProc(ByVal hWnd As Integer,ByVal lpData As Integer) As Integer

        Try

            Select Case uMsg
                Case BFFM_INITIALIZED
                    Call SendMessage(hWnd,BFFM_SETSELECTIONA,&H1,lpData)
                Case BFFM_SELCHANGED
                    SendMessage(hWnd,BFFM_SETSTATUSTEXT,lpData)
            End Select

        Catch Ex As Exception
            Throw Ex
        End Try
        Return 0
    End Function

End Class