分享:打开选择文件夹窗口的模块

「已注销」 2010-04-21 12:50:39

这次分享打开选择文件夹窗口的模块，如果把参数WenJian设为True，这样除了可以选择文件夹，还可选择文件。如果把参数RootFolder填一个文件夹路径，这样就会只能选择这个文件夹以及子文件夹和文件，不能选择此文件夹以外的其他内容。



Option Explicit



Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (LpBrowseInfo As BROWSEINFO) As Long

Private Declare Function SHGetPathFromIDlist Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal Pidl As Long, ByVal pszPath As String) As Long

Private Declare Function SHILCreateFromPath Lib "shell32.dll" (ByVal pszPath As String, ppidl As Long, rgflnOut As Long) As Long



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_BROWSEINCLUDEFILES = &H4000

Private Const S_OK = &H0



Public Function BrowseFolder(ByVal hWnd As Long, Optional Title As String, Optional WenJian As Boolean = False, Optional RootFolder As String) As String

Dim BI As BROWSEINFO, Pidl As Long, FolderPath As String, RootPidl As Long



    FolderPath = Space(8192)



    With BI

        If IsNumeric(hWnd) Then .hOwner = hWnd

        If WenJian = False Then

            .ulFlags = BIF_RETURNONLYFSDIRS

        Else

            .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_BROWSEINCLUDEFILES

        End If

        If Title <> "" Then

            .lpszTitle = Title

        Else

            .lpszTitle = "请选择文件夹或文件"

        End If

        If RootFolder <> "" Then

            RootFolder = StrConv(RootFolder, vbUnicode)

            If SHILCreateFromPath(RootFolder, RootPidl, ByVal 0) = S_OK Then .pidlroot = RootPidl

        End If

    End With



    Pidl = SHBrowseForFolder(BI)

    If SHGetPathFromIDlist(Pidl, FolderPath) Then

        BrowseFolder = Left(FolderPath, InStr(FolderPath, vbNullChar) - 1)

    Else

        BrowseFolder = ""

    End If



End Function