在csdn找到的,据说是斑竹的代码,你试试
'许添加的控件: Form1、Command1、Module1
'Form1中的代码:
Option Explicit
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
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 Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Const LPTR = (&H0 Or &H40)
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
Private Function MyAddressOf(AddressOfX As Long) As Long
MyAddressOf = AddressOfX
End FunctionPrivate Sub Command1_Click()
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
Dim Ret As Long
szTitle = "This is the title"
Dim sPath As String
sPath = VBA.InputBox("初始路径:", , "C:\program files")
With tBrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
.lpfnCallback = MyAddressOf(AddressOf BrowseForFolders_CallbackProc)
Ret = LocalAlloc(LPTR, VBA.Len(sPath) + 1)
CopyMemory ByVal Ret, ByVal sPath, VBA.Len(sPath) + 1
.lParam = Ret
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = VBA.Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = VBA.Left(sBuffer, VBA.InStr(sBuffer, vbNullChar) - 1)
MsgBox sBuffer
End If
End Sub'Module1中的代码:
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Private Const BFFM_INITIALIZED As Long = 1
Public Function BrowseForFolders_CallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
If uMsg = BFFM_INITIALIZED Then
SendMessage hWnd, BFFM_SETSELECTIONA, True, ByVal lpData
End If
End Function
'许添加的控件: Form1、Command1、Module1
'Form1中的代码:
Option Explicit
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
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 Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Const LPTR = (&H0 Or &H40)
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
Private Function MyAddressOf(AddressOfX As Long) As Long
MyAddressOf = AddressOfX
End FunctionPrivate Sub Command1_Click()
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
Dim Ret As Long
szTitle = "This is the title"
Dim sPath As String
sPath = VBA.InputBox("初始路径:", , "C:\program files")
With tBrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
.lpfnCallback = MyAddressOf(AddressOf BrowseForFolders_CallbackProc)
Ret = LocalAlloc(LPTR, VBA.Len(sPath) + 1)
CopyMemory ByVal Ret, ByVal sPath, VBA.Len(sPath) + 1
.lParam = Ret
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = VBA.Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = VBA.Left(sBuffer, VBA.InStr(sBuffer, vbNullChar) - 1)
MsgBox sBuffer
End If
End Sub'Module1中的代码:
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Private Const BFFM_INITIALIZED As Long = 1
Public Function BrowseForFolders_CallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
If uMsg = BFFM_INITIALIZED Then
SendMessage hWnd, BFFM_SETSELECTIONA, True, ByVal lpData
End If
End Function
http://www.mvps.org/vbnet/index.html?code/browse/browsefolders.htm
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public 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
Const BIF_RETURNONLYFSDIRS = &H1
Function OpenDir(HWnd As Long)
Dim bi As BROWSEINFO
Dim r As Long
Dim pidl As Long
Dim path As String
Dim pos As Integer
bi.hOwner = HWnd
'展开根目录
bi.pidlRoot = 0&
'列表框标题
bi.lpszTitle = "请选择文件保存路径:"
'规定只能选择文件夹,其他无效
bi.ulFlags = BIF_RETURNONLYFSDIRS
'调用API函数显示列表框
pidl = SHBrowseForFolder(bi)
'利用API函数获取返回的路径
path = Space$(512)
r = SHGetPathFromIDList(ByVal pidl&, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
OpenDir = Left(path, pos - 1)
Else
OpenDir = ""
End If
End Function
' 原创,参考API-Guide
--------------------------------------------------------------------
直接调用该模块即可。
--------------------------------------------------------------------
另,HWnd可以直接用Form的HWnd属性。
--------------------------------------------------------------------
Made by Thirdapple's Studio
' form 中
'程序如下:
Private Sub cmdLocation_Click() '为 command
Dim LocDir As BROWSEINFO
Dim RetVal As Boolean, PidLoc As Long
Dim Path As String
Dim Pos As Integer
LocDir.hOwner = Me.hWnd
LocDir.lpszTitle = "请选择一个目录:"
LocDir.ulFlags = BIF_RETURNONLYFSDIRS
'PidLoc是一个返回值,指向用户定位的目录对应的ID,还不是目录
PidLoc = SHBrowseForFolder(LocDir)
Path = Space(512)
'用SHGetPathFromIDList()API把PidLoc对应的ID转换成对应的目录
RetVal = SHGetPathFromIDList(ByVal PidLoc, ByVal Path)
If RetVal Then
'去掉后面多余的ASCII码为0的字符
Pos = InStr(Path, Chr$(0))
'txtPath就是要求输入路径的那个文本框
txtPath.Text = Left(Path, Pos - 1) txtPath.SetFocus
End If
End Sub'---------------------------------------------
' bas 中
Option ExplicitPublic Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long'可见只有一个参数BROWSEINFO,这是一个类型,定义如下:
Public 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'hOwner是父窗口的hWnd
'lpszTitle是显示在该窗口上方的提示文字标题
'ulFlags是设置显示的是什么类型,这里设置为显示文件目录系统
'pidlRoot为NULL(不设置任何值的时候)表示从桌面开始显示,即显示所有磁盘,包括网上邻居……
'PidLoc是返回值,表示用户选择的目录对应的ID
'这个ID还要用SHGetPathFromIDList()API转换为对应的目录才能用'SHGetPathFromIDList()API的申明如下:
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long'另外还要申明一些常量,用于ulFlags的设置:
Public Const BIF_RETURNONLYFSDIRS = &H1 '<---我用的是这个,显示所有磁盘……
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000