怎么调用windows的"浏览文件夹"对话框,我想选择我要的文件夹!急!

Question

 使用 ShellExecute API函数 

Answer 1

Private Type BrowseInfo
    lngHwnd        As Long
    pIDLRoot       As Long
    pszDisplayName As Long
    lpszTitle      As Long
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End TypePrivate Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260Private 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 LongPrivate Function BrowseForFolder(ByVal lngHwnd As Long, ByVal strPrompt As String) As String    On Error GoTo ehBrowseForFolder 'Trap for errors    Dim intNull As Integer
    Dim lngIDList As Long, lngResult As Long
    Dim strPath As String
    Dim udtBI As BrowseInfo    'Set API properties (housed in a UDT)
    With udtBI
        .lngHwnd = lngHwnd
        .lpszTitle = lstrcat(strPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With    'Display the browse folder...
    lngIDList = SHBrowseForFolder(udtBI)    If lngIDList <> 0 Then
        'Create string of nulls so it will fill in with the path
        strPath = String(MAX_PATH, 0)        'Retrieves the path selected, places in the null
         'character filled string
        lngResult = SHGetPathFromIDList(lngIDList, strPath)        'Frees memory
        Call CoTaskMemFree(lngIDList)        'Find the first instance of a null character,
         'so we can get just the path
        intNull = InStr(strPath, vbNullChar)
        'Greater than 0 means the path exists...
        If intNull > 0 Then
            'Set the value
            strPath = Left(strPath, intNull - 1)
        End If
    End If    'Return the path name
    BrowseForFolder = strPath
    Exit Function 'AbortehBrowseForFolder:    'Return no value
    BrowseForFolder = EmptyEnd FunctionPrivate Sub Command1_Click()
aa = BrowseForFolder(Me.hWnd, "")
MsgBox aa
End Sub

Answer 2

Option Explicit'**********获得系统特殊目录**********************
Type SHITEMID
    cb As Long
    abID As Byte
End TypePublic 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 LongPublic Const MAX_PATH = 255
'Public Const MAX_NAME = 40
Private Const NOERROR = 0'*******************************
Public 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
End Enum
'******* 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_RETURNONLYFSDIRS = &H1
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_EDITBOX = &H55
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_BROWSEFORPRINTER = &H2000
'*************************************************Public Function DialogFile(ByVal f As Form, ByVal wMode As Integer, ByVal szDialogTitle As String, ByVal szFilename As String, ByVal szFilter As String, ByVal szDefDir As String) As String
Dim X As Long, OFN As OPENFILENAME, szFile As String, szFileTitle As String    OFN.lStructSize = Len(OFN)
    OFN.hwnd = f.hwnd
    OFN.lpstrTitle = szDialogTitle
    OFN.lpstrFile = szFilename & String$(250 - Len(szFilename), 0)
    OFN.nMaxFile = 255
    OFN.lpstrFileTitle = String$(255, 0)
    OFN.nMaxFileTitle = 255
    OFN.lpstrFilter = szFilter
    OFN.nFilterIndex = 1
    OFN.lpstrInitialDir = szDefDir
    OFN.Flags = OFS_FILE_OPEN_FLAGS Or OFN_EXPLORER Or OFN_HIDEREADONLY Or OFN_ENABLEHOOK
       
    If wMode = 1 Then
        OFN.Flags = OFN.Flags Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
        X = GetOpenFileName(OFN)
    Else
        OFN.Flags = OFN.Flags Or OFN_OVERWRITEPROMPT Or OFN_PATHMUSTEXIST
        X = GetSaveFileName(OFN)
    End If
    
    If X <> 0 Then
        szFile = StripTerminator(OFN.lpstrFile)
        DialogFile = szFile
    Else
        DialogFile = ""
    End If
End FunctionPublic Function BrowseFolder(ByVal st As String, ctl As Form) As String
Dim BI As BROWSEINFO
Dim idl As ITEMIDLIST
Dim rtn&, pidl&, sPath$BI.hOwner = ctl.hwnd
rtn& = SHGetSpecialFolderLocation(ByVal BI.hOwner, ByVal 17, idl)
BI.pidlRoot = idl.mkid.cb
BI.lpszTitle = st
BI.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_BROWSEFORCOMPUTER Or BIF_EDITBOX
pidl& = SHBrowseForFolder(BI)
sPath$ = Space$(512)
rtn& = SHGetPathFromIDList(ByVal pidl&, ByVal sPath$)
If rtn& Then
BrowseFolder = RelPath(StripTerminator(sPath$))
Else
BrowseFolder = ""
End If
End FunctionPublic Function GetSystemFolderPath(ByVal hwnd As Long, ByVal Id As SHELLFOLDERS, sfpath As String) As Long
    Dim rc As Long                                      ' Return code
    Dim pidl As ITEMIDLIST                                    ' ptr to Item ID List
    Dim cbPath As Long                                  ' char count of path
    Dim szPath As String                                ' String var for path
    szPath = Space(MAX_PATH)                            ' Pre-allocate path string for api call
    rc = SHGetSpecialFolderLocation(hwnd, Id, pidl)       ' Get pidl for Id...
    If (rc = 0) Then                                    ' If success is 0
#If UNICODE Then
        rc = SHGetPathFromIDList(pidl.mkid.cb, StrPtr(szPath))  ' Get Path from Item Id List
#Else
        rc = SHGetPathFromIDList(pidl.mkid.cb, szPath)          ' Get Path from Item Id List
#End If
        If (rc = 1) Then                                ' If success is 1
            szPath = Trim$(szPath)                      ' Fix path string
            cbPath = Len(szPath)                        ' Get length of path
            If (Asc(Right(szPath, 1)) = 0) Then cbPath = cbPath - 1 ' Adjust path length
            If (cbPath > 0) Then sfpath = Left$(szPath, cbPath) ' Adjust path string variable
            GetSystemFolderPath = True                  ' Return success
        End If
    End If
End Function

Answer 3

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 Sub Form_Load()
    'KPD-Team 1998
    'URL: http://www.allapi.net/
    '[email protected]
    Dim iNull As Integer, lpIDList As Long, lResult As Long
    Dim sPath As String, udtBI As BrowseInfo    With udtBI
        'Set the owner window
        .hWndOwner = Me.hWnd
        'lstrcat appends the two strings and returns the memory address
        .lpszTitle = lstrcat("C:\", "")
        'Return only if the user selected a directory
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With    'Show the 'Browse for folder' dialog
    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        'Get the path from the IDList
        SHGetPathFromIDList lpIDList, sPath
        'free the block of memory
        CoTaskMemFree lpIDList
        iNull = InStr(sPath, vbNullChar)
        If iNull Then
            sPath = Left$(sPath, iNull - 1)
        End If
    End If    MsgBox sPath
End Sub

Answer 4

Private Sub Command1_Click()
'引用 Microsoft Shell Controls And Automation
Const BIF_EDITBOX = &H10
Const BIF_STATUSTEXT = &H4
Const BIF_RETURNFSANCESTORS = &H8
Const BIF_VALIDATE = &H20
Const BIF_BROWSEFORCOMPUTER = &H1000
Const BIF_RETURNONLYFSDIRS = 1
Const BIF_DONTGOBELOWDOMAIN = 2
Dim x As New Shell32.Shell
Dim y As Shell32.Folder
Set y = x.BrowseForFolder(Me.hWnd, "aa", 1)'法1:
If Not y Is Nothing Then
   MsgBox y.ParentFolder.ParseName(y.Title).Path
End If
'====================================
'法2:
If Not y Is Nothing Then
  Dim sFoldersPath As String
  Dim sPath As String
  sPath = y.Title
  sFoldersPath = y.Title
  Do Until y.ParentFolder Is Nothing
      sFoldersPath = y.ParentFolder & "\" & sFoldersPath
      If VBA.InStr(sPath, ":") = 0 Then
        If Not y.ParentFolder Like "*:*" Then
            sPath = y.ParentFolder & "\" & sPath
        Else
            sPath = VBA.Mid(y.ParentFolder, VBA.InStr(y.ParentFolder, ":") - 1, 2) & "\" & sPath
            'Exit Do
        End If
      End If
      Set y = y.ParentFolder
  Loop
  If VBA.Len(VBA.Trim(sPath)) > 0 Then
      MsgBox "Path: " & sPath & vbCrLf & "Folder Path: " & sFoldersPath
  End If
End If
End Sub

Answer 5

我的方法：
Public Declare Function SHBrowseForFolder _
        Lib "shell32.dll" Alias "SHBrowseForFolderA" _
        (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList _
        Lib "shell32.dll" _
        (ByVal pidl As Long, _
        pszPath As String) As LongPublic Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlage As Long
    lpfn As Long
    lparam As Long
    iImage As Long
End TypePublic Function ShowDir(MehWnd As Long, _
        DirPath As String, _
        Optional Title As String = "请选择文件夹：", _
        Optional flage As Long = &H1, _
        Optional DirID As Long) As Long
    Dim BI As BROWSEINFO
    Dim TempID As Long
    Dim TempStr As String
    
    TempStr = String$(255, Chr$(0))
    With BI
        .hOwner = MehWnd
        .pidlRoot = 0
        .lpszTitle = Title + Chr$(0)
        .ulFlage = flage
        
    End With
    
    TempID = SHBrowseForFolder(BI)
    DirID = TempID
    
    If SHGetPathFromIDList(ByVal TempID, ByVal TempStr) Then
        DirPath = Left$(TempStr, InStr(TempStr, Chr$(0)) - 1)
        ShowDir = -1
        
    Else
        ShowDir = 0
        
    End If
    
End Function

Answer 6

http://ygyuan.go.163.com/
http://ygyuan.3322.net/有源程序,可以指定默认目录!