【vb精品源码栏目提醒】:网学会员--在 vb精品源码编辑为广大网友搜集整理了:VB打开文件夹浏览框的方法总结 - 其它资料绩等信息,祝愿广大网友取得需要的信息,参考学习。
vb 中 5 种打开文件夹浏览框的方法总结文章录入:浣花溪 责任编辑:snow 1038 【字体:小 大】by daokers 众所周知,在
vb 中如果是打开某一个文件的话,非常简单,使用 CommonDialog 组件即可轻松完成,但是他只能选择文件,之后或许选取的文件路径,而如果想要浏览文件夹,就没这么方便了。
这里介绍 3 个办法来实现文件夹浏览。
第一个非常简单,利用 Shell 对象 程序代码引用 Microsoft Shell Controls And AutomationDim ShellA As New ShellPrivate Sub Command1_Click 建立一个按钮对象Dim Shellb As FolderSet Shellb ShellA.BrowseForFolder0 选择文件夹 0ShellA.Open bEnd Sub记得一定要引用 Microsoft Shell Controls And Automation第二种方法,我们同样利用 shell 对象,但是加几个函数程序代码引用 Microsoft Shell Controls And AutomationPrivate shlShell As Shell32.ShellPrivate shlFolder As Shell32.FolderPrivate Const BIF_RETURNONLYFSDIRS H1Private Sub Command1_Click If shlShell Is Nothing Then Set shlShell New Shell32.Shell End If Set shlFolder shlShell.BrowseForFolderMe.hWnd 请 选 择 文 件 夹 BIF_RETURNONLYFSDIRS If Not shlFolder Is Nothing Then MsgBox shlFolder.Items.Item.Path 测试 End IfEnd Sub上面 2 个方法的结果如图:第三个方法,是利用 API 来操作。
程序代码Private Const BIF_RETURNONLYFSDIRS 1Private Const BIF_DONTGOBELOWDOMAIN 2Private Const MAX_PATH 260Private Declare Function SHBrowseForFolder Lib Shell32 lpbi As BrowseInfo As LongPrivate Declare Function SHGetPathFromIDList Lib Shell32 ByVal pidList As Long ByVallpBuffer As String As LongPrivate Declare Function lstrcat Lib kernel32 Alias lstrcatA ByVal lpString1 As String ByVallpString2 As String As LongPrivate 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 LongEnd TypePrivate 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 lstrcatszTitle .ulFlags BIF_RETURNONLYFSDIRS BIF_DONTGOBELOWDOMAIN End With lpIDList SHBrowseForFoldertBrowseInfo If lpIDList Then sBuffer SpaceMAX_PATH SHGetPathFromIDList lpIDList sBuffer sBuffer LeftsBuffer InStrsBuffer vbNullChar - 1 MsgBox sBuffer End IfEnd 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 AsBrowseInfo As Long Private Declare Function SHGetPathFromIDList Lib shell32 ByVal pidListAs Long ByVal lpBuffer As String As Long Private Declare Function lstrcat Lib kernel32 Alias lstrcatA ByVallpString1 As String ByVal lpString2 As String As Long Private Declare Function LocalAlloc Lib kernel32 ByVal uFlags AsLong ByVal uBytes As Long As Long Private Declare Sub CopyMemory Lib kernel32 Alias RtlMoveMemorypDest 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 MyAddressOfAddressOfX 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 lstrcatszTitle .ulFlags BIF_RETURNONLYFSDIRS BIF_DONTGOBELOWDOMAIN .lpfnCallback MyAddressOfAddressOf BrowseForFolders_CallbackProc Ret LocalAllocLPTR VBA.LensPath 1 CopyMemory ByVal Ret ByVal sPath VBA.LensPath 1 .lParam Ret End With lpIDList SHBrowseForFoldertBrowseInfo If lpIDList Then sBuffer VBA.SpaceMAX_PATH SHGetPathFromIDList lpIDList sBuffer sBuffer VBA.LeftsBuffer VBA.InStrsBuffer vbNullChar - 1 MsgBox sBuffer End If End Sub Module1: Option Explicit Private Declare Function SendMessage Lib user32 Alias SendMessageAByVal hWnd As Long ByVal wMsg As Long ByVal wParam AsLong 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_CallbackProcByVal hWnd As Long ByValuMsg As Long ByVal lParam As Long ByVal lpData As Long AsLong If uMsg BFFM_INITIALIZED Then SendMessage hWnd BFFM_SETSelectIONA True ByVal lpData End If End Function效果如图:看了这个代码后,你会发现它确实定位到了当前文件夹,但是他有一个问题就是,没有选定当前文件夹。
咱们继续看方法 5.第 5 个方法。
他同样是第 3 个方法的加强版,不过这个方法应当是最为完美的方法,不仅定位到当前文件夹,而且选定它。
建立一个模块文件程序代码form1Module1:Option ExplicitPrivate Const BIF_STATUSTEXT H4Private Const BIF_RETURNONLYFSDIRS 1Private Const BIF_DONTGOBELOWDOMAIN 2Private Const MAX_PATH 260Private Const WM_USER H400Private Const BFFM_INITIALIZED 1Private Const BFFM_SELCHANGED 2Private Const BFFM_SETSTATUSTEXT WM_USER 100Private Const BFFM_SETSelectION WM_USER 102Private Declare Function SendMessage Lib user32 Alias SendMessageA ByVal hWnd As LongByVal wMsg As Long ByVal wParam As Long ByVal lParam As String As LongPrivate Declare Function SHBrowseForFolder Lib shell32 lpbi As BrowseInfo As LongPrivate Declare Function SHGetPathFromIDList Lib shell32 ByVal pidList As Long ByVallpBuffer As String As LongPrivate Declare Function lstrcat Lib kernel32 Alias lstrcatA ByVal lpString1 As String ByVallpString2 As String As LongPrivate 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 LongEnd TypePrivate m_CurrentDirectory As String The current directoryPublic Function BrowseForFolderowner 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 lstrcatszTitle .ulFlags BIF_RETURNONLYFSDIRS BIF_DONTGOBELOWDOMAIN BIF_STATUSTEXT .lpfnCallback GetAddressofFunctionAddressOf BrowseCallbackProc get address offunction. End With lpIDList SHBrowseForFoldertBrowseInfo If lpIDList Then sBuffer SpaceMAX_PATH SHGetPathFromIDList lpIDList sBuffer sBuffer LeftsBuffer InStrsBuffer vbNullChar - 1 BrowseForFolder sBuffer Else BrowseForFolder End IfEnd FunctionPrivate Function BrowseCallbackProcByVal hWnd As Long ByVal uMsg As Long ByVal lp As LongByVal 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 SendMessagehWnd BFFM_SETSelectION 1 m_CurrentDirectory Case BFFM_SELCHANGED sBuffer SpaceMAX_PATH ret SHGetPathFromIDListlp sBuffer If ret 1 Then Call SendMessagehWnd BFFM_SETSTATUSTEXT 0 sBuffer End If End Select BrowseCallbackProc 0End FunctionPrivate Function GetAddressofFunctionadd As Long As Long GetAddressofFunction addEnd Function建立一个窗口和一个按钮 程序代码Option ExplicitPrivate getdir As StringPrivate Sub Command1_Click getdir BrowseForFolderMe Select A Directory Text1.Text If Lengetdir 0 Then Exit Sub Text1.Text getdirEnd SubPrivate Sub Form_Load Text1.Text CurDirEnd Sub最终结果如图:上面是对
vb 中调用文件夹对话框的一个总结,个人认为第 5 个方法是最为完美的,这也是从国外坛子淘到的不得不说,国外对
源码共享还是走在我们前面的。
摘自红色黑客联盟www.7747.net 原文:http://www.7747.net/kf/201003/45541.html