微信公众号搜"智元新知"关注
微信扫一扫可直接关注哦！

vb中 打开文件夹浏览框的方法总结

分类：VB作者：编程之家
众所周知，在vb中如果是打开某一个文件的话，非常简单，使用CommonDialog组件即可轻松完成，但是他只能选择文件，之后或许选取的文件路径，而如果想要浏览文件夹，就没这么方便了。

这里介绍3个办法来实现文件夹浏览。

第一个非常简单，利用Shell对象
程序代码
'引用Microsoft Shell Controls And Automation
Dim ShellA As New Shell
Private Sub Command1_Click() '建立一个按钮对象
Dim Shellb As Shell32.Folder
Set Shellb = ShellA.browseForFolder(0,"选择文件夹",0)
ShellA.Open b
End Sub

记得一定要引用Microsoft Shell Controls And Automation

第二种方法，我们同样利用shell对象，但是加几个函数

程序代码

'引用Microsoft Shell Controls And Automation
Private shlShell As Shell32.Shell
Private shlFolder As Shell32.Folder
Private Const BIF_RETURNONLYFSDirs = &H1
Private Sub Command1_Click() '
If shlShell Is nothing Then
Set shlShell = New Shell32.Shell
End If
Set shlFolder = shlShell.browseForFolder(Me.hWnd,"请选择文件夹",BIF_RETURNONLYFSDirs)
If Not shlFolder Is nothing Then
MsgBox shlFolder.Items.Item.Path'测试
End If
End Sub



上面2个方法的结果如图：


第三个方法，是利用API来操作。

程序代码
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 Type browseInfo
hWndOwner As Long
pIDLRoot As Long
pszdisplayName As Long
lpszTitle As Long
ulFlagsAs Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Sub Command1_Click()
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tbrowseInfo As browseInfo
szTitle = App.Path
With tbrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat(szTitle,"")
.ulFlags = BIF_RETURNONLYFSDirs + BIF_DONTGOBELOWDOMAIN
End With

lpIDList = SHbrowseForFolder(tbrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList,sBuffer
sBuffer = Left(sBuffer,InStr(sBuffer,vbNullChar) - 1)
MsgBox sBuffer
End If
End Sub



如果希望对话框中有“新建文件夹”，那么就给.ulFlags 加上BIF_USENEWUI属性，BIF_RETURNONLYFSDirs 的意思是仅仅返回文件夹。
效果如图：


同时我也打包2个完整的利用此API的代码，有意者请自己学习了。


第4个方法。
其实是第三个方法的改进，就是打开对话框后，自动定位到当前文件夹位置 。

程序代码

'Objects: 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 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 Function

Private 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



效果如图：



看了这个代码后，你会发现它确实定位到了当前文件夹，但是他有一个问题就是，没有选定当前文件夹。咱们继续看方法5.

第5个方法。
他同样是第3个方法的加强版，不过这个方法应当是最为完美的方法，不仅定位到当前文件夹，而且选定它。
建立一个模块文件

程序代码

'form1
''Module1:
Option Explicit
Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_RETURNONLYFSDirs = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSelectION = (WM_USER + 102)

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long,ByVal lParam As String) As Long
Private Declare Function SHbrowseForFolder Lib "shell32" (lpbi As browseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long,ByVal lpString2 As String) As Long

Private Type browseInfo
hWndOwnerAs Long
pIDLRoot As Long
pszdisplayName As Long
lpszTitleAs Long
ulFlagsAs Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type

Private m_CurrentDirectory As String 'The current directory
Public Function browseForFolder(owner As Form,Title As String,StartDir As String) As String
Dim lpIDList As Long
Dim szTitle As String
Dim sBuffer As String
Dim tbrowseInfo As browseInfo
m_CurrentDirectory = StartDir & vbNullChar

szTitle = Title
With tbrowseInfo
.hWndOwner = owner.hWnd
.lpszTitle = lstrcat(szTitle,"")
.ulFlags = BIF_RETURNONLYFSDirs + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
.lpfnCallback = GetAddressofFunction(AddressOf browseCallbackProc)'get address of function.
End With

lpIDList = SHbrowseForFolder(tbrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList,vbNullChar) - 1)
browseForFolder = sBuffer
Else
browseForFolder = ""
End If

End Function

Private Function browseCallbackProc(ByVal hWnd As Long,ByVal lp As Long,ByVal pData As Long) As Long
Dim lpIDList As Long
Dim ret As Long
Dim sBuffer As String
On Error Resume Next
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd,BFFM_SETSelectION,1,m_CurrentDirectory)
Case BFFM_SELCHANGED
sBuffer = Space(MAX_PATH)

ret = SHGetPathFromIDList(lp,sBuffer)
If ret = 1 Then
Call SendMessage(hWnd,BFFM_SETSTATUSTEXT,sBuffer)
End If
End Select
browseCallbackProc = 0
End Function
Private Function GetAddressofFunction(add As Long) As Long
GetAddressofFunction = add
End Function



建立一个窗口和一个按钮

程序代码
Option Explicit
Private getdir As String
Private Sub Command1_Click()
getdir = browseForFolder(Me,"Select A Directory",Text1.Text)
If Len(getdir) = 0 Then Exit Sub Text1.Text = getdir
End Sub
Private Sub Form_Load()
Text1.Text = CurDir
End Sub



最终结果如图：


上面是对vb中调用文件夹对话框的一个总结，个人认为第5个方法是最为完美的，这也是从国外坛子淘到的

不得不说，国外对源码共享还是走在我们前面的。

====================

VB选择文件夹(比较顺眼的)

Public Declare Function SHbrowseForFolder Lib "shell32.dll" Alias "SHbrowseForFolderA" (lpbrowseInfo As broWSEINFO) As Long

Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long,ByVal pszPath As String) 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
Public Type SHITEMID
cb As Long
abID As Byte
End Type
Public Type ITEMIDLIST
mkid As SHITEMID
End Type

Function getFolder(frm As Form,Optional Flags As Long = 1) As String
On Error Resume Next
Dim BI As broWSEINFO
Dim IDL As ITEMIDLIST
Dim r As Long
Dim pidl As Long
Dim tmpPath As String
Dim pos As Integer

BI.hOwner = frm.hwnd
BI.pidlRoot = 0&
BI.lpszTitle = "请选择路径："
'bi.ulFlags = BIF_RETURNONLYFSDirs
'BIF_DEFAULT = 0x0000,
'BIF_broWSEFORCOmpuTER = 0x1000,效果不明
'BIF_broWSEFORPRINTER = 0x2000,效果不明
'BIF_broWSEINCLUDEFILES = 0x4000,效果不明
'BIF_broWSEINCLUDEURLS = 0x0080,效果不明
'BIF_DONTGOBELOWDOMAIN = 0x0002,;效果不明
'BIF_EDITBox = 0x0010,带文件夹名称编辑框
'BIF_NEWDIALOGstyle = 0x0040,带新建文件夹
'BIF_NONEWFOLDERBUTTON = 0x0200,没有菜单
'BIF_RETURNFSANCESTORS = 0x0008,效果不明
'BIF_RETURNONLYFSDirs = 0x0001,;默认
'BIF_SHAREABLE = 0x8000,效果不明
'BIF_STATUSTEXT = 0x0004,;效果不明
'BIF_UAHINT = 0x0100,效果不明
'BIF_VALIDATE = 0x0020,效果不明
'BIF_NOTRANSLATETARGETS = 0x0400,效果不明

BI.ulFlags = Flags
'get the folder
pidl = SHbrowseForFolder(BI)

tmpPath = Space$(512)
r = SHGetPathFromIDList(ByVal pidl,ByVal tmpPath)
getFolder = ""

If r Then
pos = InStr(tmpPath,Chr$(0))
tmpPath = Trim(Left(tmpPath,pos - 1))
If Right(tmpPath,1) <> "\" Then tmpPath = tmpPath & "\"
getFolder = Trim(tmpPath)
End If
End Function

=======================

[VB]用API打开浏览文件夹对话框，选择文件夹

Option Explicit

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_NEWDIALOGSTYLE = &H40 '新样式（有新建文件夹按钮，可调整对话框大小）
Private Const BIF_NONEWFOLDERBUTTON = &H200 '新样式中，没有新建按钮（只调大小）

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long,_
ByVal pszPath As String) As Long
Private Declare Function SHbrowseForFolder Lib "shell32.dll" Alias "SHbrowseForFolderA" _
(lpbrowseInfo As broWSEINFO) As Long

Public Function GetFolderName(hWnd As Long,Text As String) As String Dim bi As broWSEINFO Dim pidl As Long Dim path As String With bi .hOwner = hWnd .pidlRoot = 0& '根目录，一般不需要改 .lpszTitle = Text .ulFlags = BIF_RETURNONLYFSDirs '根据需要调整 End With pidl = SHbrowseForFolder(bi) path = Space$(512) If SHGetPathFromIDList(ByVal pidl,ByVal path) Then GetFolderName = Left(path,InStr(path,Chr(0)) - 1) End If End Function

版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。

相关推荐

VB Format函数
Format[$] ( expr [ , fmt ] ) format 返回变体型 format$ 强制返回为文本 -------------------------------- 数字类型的格式化 --------------------------------     固定格式参数：     General Number 普通数字，如可以用来去掉千位分隔号     format$("100,1
vb6/ASP FORMAT MM/DD/YYYY
VB6或者ASP 格式化时间为 MM/dd/yyyy 格式，竟然没有好的办法， Format 或者FormatDateTime 竟然结果和系统设置的区域语言的日期和时间格式相关。意思是尽管你用诸如 Format(Now, "MM/dd/yyyy")，如果系统的设置格式区域语言的日期和时间格式分隔符是"-",那他还会显示为 MM-dd-yyyy     只有拼凑： <%response.write
VB.net 捕获项目全局异常
在项目中添加如下代码：新建窗口来显示异常信息。 Namespace My ‘全局错误处理，新的解决方案直接添加本ApplicationEvents.vb 到工程即可 ‘添加后还需要一个From用来显示错误。如果到这步还不会则需要先打好基础啦 ‘======================================================== ‘以下事件
实现用VB.Net/(C#)开发K/3 BOS 插件的真正可行方法
转了这一篇文章，原来一直想用C#做k3的插件开发，vb没有C#用的爽呀，这篇文章写与2011年，看来我以前没有认真去找这个方法呀。 https://blog.csdn.net/chzjxgd/article/details/6176325 金蝶K3 BOS的插件官方是用VB6编写的，如果  能用.Net下的语言工具开发BOS插件是一件很愉快的事情，其中缘由不言而喻，而本文则是个人首创，实现在了用V
vb，wps，excel 分裂
Sub 分列() ‘以空格为分隔符，连续空格只算1个。对所选中的单元格进行处理 Dim m As Range, tmpStr As String, s As String Dim x As Integer, y As Integer, subStr As String If MsgBox("确定要分列处理吗？请确定分列的数据会覆盖它后面的单元格！", _
VB文件 hash 查看器
  窗体代码 1 Private Sub Text1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) 2 Dim path As String, hash As String 3 For Each fil
VB.NET MYSQL DataGridView 增删改查INSERT,SELECT,UPDATE,DELETE
  Imports MySql.Data.MySqlClient Public Class Form1 ‘ GLOBAL DECLARATIONS Dim conString As String = "Server=localhost;Database=net2;Uid=root;Pwd=123456;" Dim con As New MySqlConnection
VB.NET 使用ADODB連接資料庫滙出到EXCEL
‘導入命名空間 Imports ADODB Imports Microsoft.Office.Interop   Private Sub A1() Dim Sql As String Dim Cnn As New ADODB.Connection Dim Rs As New ADODB.Recordset Dim S As String   S = "Provider=OraOLEDB.Oracl
vb.net 多线程運用 ping
Imports System.IO Imports System.Threading Imports System.Diagnostics Public Class Form1 Dim A(254) As String    Function ping(ByVal IP As Integer) As String Dim IPAddress As String IPAddress = "10.0.
VB等待进程结束
VB运行EXE程序，并等待其运行结束 参考：https://blog.csdn.net/useway/article/details/5494084 Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Pr
苹果市值2025年有望达4万亿美元
pythonJavaScriptjavaHTMLPHPreactjsC#AndroidCSSNode.jssqlrpython-3.xMysqLjQueryc++pandasFlutterangularIOSdjangolinuxswifttypescript路由器JSON路由器设置无线路由器h3c华三华三路由器设置华三路由器电脑软件教程arraysdocker软件图文教程Cvue.jslaravelspring-boot