如何在VB中实现打开目录对话框？

Question

'调用目录，即那个目录树窗口
Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String
     Dim iNull As Integer
     Dim lpIDList As Long
     Dim lResult As Long
     Dim sPath As String
     Dim udtBI As BrowseInfo
     With udtBI
        .hwndOwner = hwndOwner
        .lpszTitle = lstrcat(sPrompt, "名称")
        .ulFlags = BIF_RETURNONLYFSDIRS
     End With
     lpIDList = SHBrowseForFolder(udtBI)
     If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        lResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)
        'If iNull <> 0 Then
        '    sPath = Left$(sPath, iNull - 1)
        'End If
     End If
     BrowseForFolder = sPath
End Function

Answer 1

Private Const BIF_RETURNONLYFSDIRS As Long = &H1Private Type BROWSEINFO
    hOwner As Long
    pidRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End TypePrivate Declare Function SHBrowseForFolder Lib "shell32.dll" _
        Alias "SHBrowseForFolderA" (ipBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
        Alias "SHGetPathFromIDListA" (ByVal pid1 As Long, ByVal pszPath As String) As LongPrivate Function GetFolder(Optional Title As String, Optional hwnd, Optional default As String) As String
    Dim bi As BROWSEINFO
    Dim pid1 As Long
    Dim folder As String
    
    folder = VBA.String(255, VBA.Chr(0))
    
    With bi
        If VBA.IsNumeric(hwnd) Then .hOwner = hwnd
        .ulFlags = BIF_RETURNONLYFSDIRS
        .pidRoot = 0
        If Title <> "" Then
            .lpszTitle = Title & VBA.Chr(0)
        Else
            .lpszTitle = "Please choose the ForFolder" & VBA.Chr(0)
        End If
    End With
    
    pid1 = SHBrowseForFolder(bi)
    
    If SHGetPathFromIDList(ByVal pid1, ByVal folder) Then
        GetFolder = VBA.Left(folder, VBA.InStr(folder, VBA.Chr(0)) - 1)
    Else
        GetFolder = default
    End If
End Function这样使用：
lblDrPhotoPath.Caption = GetFolder("Please choose the photos' path ", Me.hwnd, VBA.Trim(lblDrPhotoPath.Caption))

Answer 2

Private Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPrivate Function GetBrowseFolder(msg) As String   Dim pidl As Long
   Dim pos As Integer
   Dim path As String
   Dim bi As BROWSEINFO
  
  'Fill the BROWSEINFO structure with the needed data,
  'show the browse dialog, and if the returned value
  'indicates success (1), retrieve the user's
  'selection contained in pidl
   With bi
      .hOwner = Me.hWnd
      .pidlRoot = CSIDL_DESKTOP
      .lpszTitle = msg
      .ulFlags = BIF_RETURNONLYFSDIRS
   End With   pidl = SHBrowseForFolder(bi)
 
   path = Space$(512)
     
   If SHGetPathFromIDList(ByVal pidl, ByVal path) = 1 Then
      pos = InStr(path, Chr$(0))
      GetBrowseFolder = Left(path, pos - 1)
   End IfEnd FunctionPrivate Sub Command1_Click()
    Dim msg As String
    dim  fld as string
    msg = "请选择文件夹"
    fld = GetBrowseFolder(msg)
    debug.print fld 
End Sub