這是老掉牙的SHBrowseForFolder代碼，文件夾的名字一長就露馬腳了。
ExpertExchange上掏錢買，高達(dá)9.8分的代碼，也僅僅只能夠讓你在EditBox中顯示完整路徑而已。 這才是完美呈現(xiàn)的最后效果。支持Unicode, 遇到特殊字符不會亂碼。而且即然不打算讓用戶生成新文件夾，那編輯窗口也應(yīng)該屏蔽之。并用它來顯示完整的文件路徑。有興趣的可以自己打開Windows7的磁盤管理看看。編輯框屏蔽鍵盤和修改但支持復(fù)制，這才是完全擁有Windows 7特性的文件夾瀏覽。 
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 '拿了就得還，保持系統(tǒng)干凈一點(diǎn) 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("請指定文件夾或驅(qū)動(dòng)器，程序?qū)⒆詣?dòng)搜索出文件的最新位置") 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 |
|
|
