小说 the common law:发一个掏钱还不一定买得到, 真正完美的SHBrowseForFolder浏览文件夹方法

这是老掉牙的SHBrowseForFolder代码，文件夹的名字一长就露马脚了。
2011-5-14 14:49 上传下载附件 (32.69 KB)

ExpertExchange上掏钱买，高达9.8分的代码，也仅仅只能够让你在EditBox中显示完整路径而已。

这才是完美呈现的最后效果。支持Unicode, 遇到特殊字符不会乱码。而且即然不打算让用户生成新文件夹，那编辑窗口也应该屏蔽之。并用它来显示完整的文件路径。有兴趣的可以自己打开Windows7的磁盘管理看看。编辑框屏蔽键盘和修改但支持复制，这才是完全拥有Windows 7特性的文件夹浏览。

2011-5-14 14:53 上传下载附件 (35.73 KB)

Option Explicit
Private Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderW" (lpbi As BrowseInfo) As Long
'Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
'Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long

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 Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_EDITBOX = &H10
Private Const BIF_BROWSEINCLUDEURLS = &H80
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_VALIDATE = &H20
Private Const BIF_NEWDIALOGSTYLE = &H40
Private Const BIF_USENEWUI = BIF_EDITBOX Or BIF_NEWDIALOGSTYLE
Private Const BIF_UAHINT = &H100
Private Const BIF_NONEWFOLDERBUTTON = &H200
Private Const BIF_NOTRANSLATETARGETS = &H400
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const BIF_SHAREABLE = &H8000
Private Const BIF_BROWSEFILEJUNCTIONS = &H10000

Private Function BrowseForFolder(TitleInfo As String) As String
  Dim lpIDList As Long
  Dim szTitleInfo() As Byte
'  Dim szTitle As String
  Dim sBuffer As String
  Dim tBrowseInfo As BrowseInfo
'  m_CurrentDirectory = StartDir & vbNullChar
  szTitleInfo = TitleInfo & vbNullChar
'  szTitle = Title
  With tBrowseInfo
    .hWndOwner = hwnd
    .lpszTitle = VarPtr(szTitleInfo(0))
'    .lpszTitle = lstrcat(szTitle, "") 老掉牙的无效指针，淘汰之
'    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT 旧样式
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_USENEWUI + BIF_NONEWFOLDERBUTTON
    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
  End With
  lpIDList = SHBrowseForFolder(tBrowseInfo)
  If (lpIDList) Then
    sBuffer = Space(MAX_PATH)
    SHGetPathFromIDList lpIDList, StrPtr（sBuffer）
    CoTaskMemFree lpIDList '拿了就得还，保持系统干净一点
    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    BrowseForFolder = sBuffer
  Else
    BrowseForFolder = ""
  End If
  
End Function
Private Function GetAddressofFunction(Add As Long) As Long
  GetAddressofFunction = Add
End Function

Private Sub Command1_Click()
Me.Caption = BrowseForFolder("请指定文件夹或驱动器，程序将自动搜索出文件的最新位置")
End Sub
在模块中加入下面的代码

Option Explicit
Public Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListW" (ByVal pidList As Long, ByVal lpBuffer As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
'Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Public Const MAX_PATH = 260&
Public Const MAX_PATH_UNICODE = 2 * MAX_PATH - 1
Private Const BFFM_INITIALIZED = 1&
Private Const BFFM_SELCHANGED = 2&
Private Const WM_USER = &H400
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Const WM_SETTEXT = &HC
Private Const EM_SETREADONLY = &HCF
Private Const EM_NOSETFOCUS = (&H1500 + 7)
Private Const WM_KILLFOCUS = &H8

Public Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
    Dim lpIDList As Long
  Dim lRet As Long
  Dim sBuffer As String
  Dim Fhwnd As Long
  Dim sysDir As String
  Dim szPath() As Byte
  
  sysDir = Environ("SystemDrive") & "\"
  
  On Error GoTo errhandler
  Select Case uMsg
    Case BFFM_INITIALIZED
      Call SendMessage(hwnd, BFFM_SETSELECTION, True, ByVal sysDir)
      Fhwnd = FindWindowEx(hwnd, 0, "Edit", vbNullString)
      Call SendMessage(Fhwnd, WM_SETTEXT, 0, ByVal sysDir)
'      EnableWindow Fhwnd, 0&
      Call SendMessage(Fhwnd, EM_SETREADONLY, True, ByVal 0&)
      Call SendMessage(Fhwnd, EM_NOSETFOCUS, 0&, ByVal 0&)
      
      
    Case BFFM_SELCHANGED
      sBuffer = Space(MAX_PATH_UNICODE)
      
      lRet = SHGetPathFromIDList(lParam, StrPtr(sBuffer))
            If lRet = 1 Then
'        Call SendMessageT(hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
        Fhwnd = FindWindowEx(hwnd, 0, "Edit", vbNullString)
        szPath = sBuffer
        Call SendMessageLong(Fhwnd, WM_SETTEXT, 0, VarPtr(szPath(0)))
        Call SendMessage(Fhwnd, WM_KILLFOCUS, 0&, ByVal 0&)
   
      End If
      
  End Select
errhandler:
  BrowseCallbackProc = 0
End Function