VB 选择目录对话框实现（API）

Private  Type BrowseInfo
    hWndOwner  As   Long
    pIDLRoot  As   Long
    pszDisplayName  As   Long
    lpszTitle  As   Long
    ulFlags  As   Long
    lpfnCallback  As   Long
    lParam  As   Long
    iImage  As   Long
End  Type
Const  BIF_RETURNONLYFSDIRS  =   1
Const  MAX_PATH  =   260
Private   Declare   Sub  CoTaskMemFree  Lib   " ole32.dll "  ( ByVal  hMem  As   Long )
Private   Declare   Function  lstrcat  Lib   " kernel32 "   Alias   " lstrcatA "  ( ByVal  lpString1  As   String ,  ByVal  lpString2  As   String )  As   Long
Private   Declare   Function  SHBrowseForFolder  Lib   " shell32 "  (lpbi  As  BrowseInfo)  As   Long
Private   Declare   Function  SHGetPathFromIDList  Lib   " shell32 "  ( ByVal  pidList  As   Long ,  ByVal  lpBuffer  As   String )  As   Long

Private   Function  getFolder( ByVal  title  As   String )  As   String
     Dim  iNull  As   Integer , lpIDList  As   Long , lResult  As   Long
     Dim  sPath  As   String , udtBI  As  BrowseInfo
     With  udtBI
         ' 设置弹出的对话框的父窗口句柄
        .hWndOwner  =   Me .hWnd
        .lpszTitle  =  lstrcat(title,  "" )  ' 标题
        .ulFlags  =  BIF_RETURNONLYFSDIRS
     End   With

    lpIDList  =  SHBrowseForFolder(udtBI)
     If  lpIDList  Then
        sPath  =   String $(MAX_PATH,  0 )
        SHGetPathFromIDList lpIDList, sPath
        CoTaskMemFree lpIDList
        iNull  =   InStr (sPath, vbNullChar)
         If  iNull  Then
            sPath  =   Left $(sPath, iNull  -   1 )
         End   If
     End   If
    getFolder  =  sPath
End Function

Private   Sub  Command1_Click()
Text1.Text  =  getFolder( " 请选择文件夹 " )
End Sub