这次分享打开选择文件夹窗口的模块,如果把参数WenJian设为True,这样除了可以选择文件夹,还可选择文件。如果把参数RootFolder填一个文件夹路径,这样就会只能选择这个文件夹以及子文件夹和文件,不能选择此文件夹以外的其他内容。
Option ExplicitPrivate 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 LongPrivate 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 TypePrivate Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const S_OK = &H0Public 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 IfEnd Function
Option ExplicitPrivate 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 LongPrivate 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 TypePrivate Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const S_OK = &H0Public 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 IfEnd Function
Private Sub Command1_Click()
Text1.Text = BrowseFolder(Me.hWnd)
End Sub
Text2.Text = BrowseFolder(Me.hWnd, , True)