如何进行目录选择

Option Explicit'**********获得系统特殊目录**********************
Private Type SHITEMID
    cb As Long
    abID As Byte
End TypePrivate Type ITEMIDLIST  'idl
    mkid As SHITEMID
End Type#If UNICODE Then
    Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListW" (ByVal pidl As Long, ByVal szPath As Long) As Long
#Else
    Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal szPath As String) As Long
#End IfPrivate Declare Function SHGetSpecialFolderLocation Lib "SHELL32.DLL" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As LongPrivate Const MAX_PATH = 255
'Public Const MAX_NAME = 40
Private Const NOERROR = 0'*******************************
Private Enum SHELLFOLDERS            ' Shell Folder Path Constants...
    CSIDL_DESKTOP = &H0&            ' ..\WinNT\profiles\username\Desktop
    CSIDL_PROGRAMS = &H2&           ' ..\WinNT\profiles\username\Start Menu\Programs
    CSIDL_STARTMENU = &HB&          ' ..\WinNT\profiles\username\Start Menu
    CSIDL_CONTROLS = &H3
    CSIDL_PRINTERS = &H4
    CSIDL_PERSONAL = &H5
    CSIDL_FAVORITES = &H6
    CSIDL_STARTUP = &H7
    CSIDL_RECENT = &H8
    CSIDL_SENDTO = &H9
    CSIDL_BITBUCKET = &HA
    CSIDL_DESKTOPDIRECTORY = &H10
    CSIDL_DRIVES = &H11
    CSIDL_NETWORK = &H12
    CSIDL_NETHOOD = &H13
    CSIDL_FONTS = &H14
    CSIDL_TEMPLATES = &H15
End EnumPrivate Declare Function GetSystemDirectory Lib "Kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long'******* API声明：使用系统文件存取对话框 *********
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As LongPrivate Type OPENFILENAME
    lStructSize As Long
    hwnd As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End TypePrivate Const OFN_HIDEREADONLY = &H4
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_EXPLORER = &H80000
Private Const OFN_LONGNAMES = &H200000
Private Const OFN_NODEREFERENCELINKS As Long = &H100000
Private Const OFN_ENABLEHOOK As Long = &H20
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER Or OFN_LONGNAMES Or OFN_NODEREFERENCELINKS'****************************************'******* API声明：使用系统目录浏览对话框 *********
Private Declare Function SHBrowseForFolder Lib "SHELL32.DLL" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 'ITEMIDLIST
Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
Private Const BIF_VALIDATE = &H20
Private Const BIF_USENEWUI = &H40
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_EDITBOX = &H10
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Public Function BrowseFolder(ByVal st As String, lHwnd As Long, Optional ByVal iStyle As Long = CSIDL_DESKTOP) As String
Dim BI As BROWSEINFO
Dim idl As ITEMIDLIST
Dim rtn&, pidl&, sPath$    BI.hOwner = lHwnd
    rtn& = SHGetSpecialFolderLocation(ByVal lHwnd, iStyle, idl)
    BI.pidlRoot = idl.mkid.cb
    BI.lpszTitle = st
    BI.ulFlags = BIF_RETURNONLYFSDIRS
    pidl& = SHBrowseForFolder(BI)
    sPath$ = Space$(512)
    rtn& = SHGetPathFromIDList(ByVal pidl&, ByVal sPath$)
    If rtn& Then
        BrowseFolder = StripTerminator(sPath$)
    Else
        BrowseFolder = ""
    End If
End FunctionPrivate Function StripTerminator(ByVal sInput As String) As String    Dim ZeroPos As Integer
    ZeroPos = InStr(1, sInput, vbNullChar)
    If ZeroPos > 0 Then
        StripTerminator = Left$(sInput, ZeroPos - 1)
    Else
        StripTerminator = sInput
    End If
    
End Function