有人知道通用对话框怎么取得不带文件名的路径吗?

Question

有人知道通用对话框怎么取得不带文件名的路径吗?

Answer 1

'½¨Ò»¸öÄ£¿éModule£¬¸´ÖÆÈçÏ´úÂëµ½ÀïÃæ
Option ExplicitDeclare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As String) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
    ByVal pidl As Long, _
    ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _
    lpBrowseInfo As BROWSEINFO) As Long
Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End TypePrivate Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2Dim xStartPath As StringFunction SelectDir(Optional StartPath As String, Optional Titel As String) As String
    Dim iBROWSEINFO As BROWSEINFO
    With iBROWSEINFO
        .lpszTitle = IIf(Len(Titel), Titel, "ÇëÑ¡ÔñÎļþ¼Ð")
        .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_DONTGOBELOWDOMAIN
        If Len(StartPath) Then
        xStartPath = StartPath & vbNullChar
        .lpfnCallback = GetAddressOf(AddressOf CallBack)
        End If
    End With
    Dim xPath As String, NoErr As Long: xPath = Space$(512)
    NoErr = SHGetPathFromIDList(SHBrowseForFolder(iBROWSEINFO), xPath)
    SelectDir = IIf(NoErr, Left$(xPath, InStr(xPath, Chr(0)) - 1), "")
End FunctionFunction GetAddressOf(Address As Long) As Long
    GetAddressOf = Address
End FunctionFunction CallBack(ByVal hWnd As Long, _
                  ByVal Msg As Long, _
                  ByVal pidl As Long, _
                  ByVal pData As Long) As Long
    Select Case Msg
        Case 1
            Call SendMessage(hWnd, 1126, 1, xStartPath)
        Case 2
            Dim sDir As String * 64, tmp As Long
            tmp = SHGetPathFromIDList(pidl, sDir)
            If tmp = 1 Then SendMessage hWnd, 1124, 0, sDir
    End Select
End Function
Public Function mkSubDir(ByVal sDirPath As String) As Boolean
    On Error GoTo errHandle
    Dim astr() As String
    Dim i As Long
    Dim sTmpPath As String
    astr = Split(sDirPath, "\")
    sTmpPath = astr(0)
    For i = 1 To UBound(astr)
        sTmpPath = sTmpPath & "\" & astr(i)
        If Dir(sTmpPath, vbDirectory) = "" Then MkDir sTmpPath
    Next
    Erase astr
    mkSubDir = True
    Exit Function
errHandle:
    mkSubDir = False
End FunctionPrivate Sub Command1_Click()
    Dim strDir As String
    strDir = SelectDir("C:\", vbNullString) '¼ÙÉè³õʼ·¾¶Îª"C:\"
    Caption = strDir
End Sub

Answer 2

‘建一个模块Module，复制如下代码到里面
Option ExplicitDeclare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As String) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
    ByVal pidl As Long, _
    ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _
    lpBrowseInfo As BROWSEINFO) As Long
Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End TypePrivate Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2Dim xStartPath As StringFunction SelectDir(Optional StartPath As String, Optional Titel As String) As String
    Dim iBROWSEINFO As BROWSEINFO
    With iBROWSEINFO
        .lpszTitle = IIf(Len(Titel), Titel,“请选择文件夹”)
        .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_DONTGOBELOWDOMAIN
        If Len(StartPath) Then
        xStartPath = StartPath & vbNullChar
        .lpfnCallback = GetAddressOf(AddressOf CallBack)
        End If
    End With
    Dim xPath As String, NoErr As Long: xPath = Space$(512)
    NoErr = SHGetPathFromIDList(SHBrowseForFolder(iBROWSEINFO), xPath)
    SelectDir = IIf(NoErr, Left$(xPath, InStr(xPath, Chr(0)) - 1), "")
End FunctionFunction GetAddressOf(Address As Long) As Long
    GetAddressOf = Address
End FunctionFunction CallBack(ByVal hWnd As Long, _
                  ByVal Msg As Long, _
                  ByVal pidl As Long, _
                  ByVal pData As Long) As Long
    Select Case Msg
        Case 1
            Call SendMessage(hWnd, 1126, 1, xStartPath)
        Case 2
            Dim sDir As String * 64, tmp As Long
            tmp = SHGetPathFromIDList(pidl, sDir)
            If tmp = 1 Then SendMessage hWnd, 1124, 0, sDir
    End Select
End Function
Public Function mkSubDir(ByVal sDirPath As String) As Boolean
    On Error GoTo errHandle
    Dim astr() As String
    Dim i As Long
    Dim sTmpPath As String
    astr = Split(sDirPath, "\")
    sTmpPath = astr(0)
    For i = 1 To UBound(astr)
        sTmpPath = sTmpPath & "\" & astr(i)
        If Dir(sTmpPath, vbDirectory) = "" Then MkDir sTmpPath
    Next
    Erase astr
    mkSubDir = True
    Exit Function
errHandle:
    mkSubDir = False
End FunctionPrivate Sub Command1_Click()
    Dim strDir As String
    strDir = SelectDir("C:\", vbNullString) ‘假设初始路径为"C:\"
    Caption = strDir
End Sub

Answer 3

好像没这么复杂吧，加一个Flag的值好像就可以了