用老掉牙代码出来的结果,名字一长就漏馅了。
ExpertExchange上掏钱买,高达9.8分的代码,也仅仅只能够让你在EditBox中显示完整路径而已。
这才是完美呈现下效果。支持Unicode, 遇到特殊字符不会乱码。而且即然不打算让用户生成新文件夹,那编辑窗口也应该屏蔽之。并用它来显示完整的文件路径。有兴趣的可以自己打开Windows7的磁盘管理看看。这才是真正完全拥有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 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 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 = &H10000Private 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
' 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, 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 FunctionPrivate 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&
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 = &HCPublic 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&
Case BFFM_SELCHANGED
sBuffer = Space(MAX_PATH)
lRet = SHGetPathFromIDList(lParam, StrPtr(sBuffer))
CoTaskMemFree lpIDList
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)))
End If
End Select
errhandler:
BrowseCallbackProc = 0
End Function
ExpertExchange上掏钱买,高达9.8分的代码,也仅仅只能够让你在EditBox中显示完整路径而已。
这才是完美呈现下效果。支持Unicode, 遇到特殊字符不会乱码。而且即然不打算让用户生成新文件夹,那编辑窗口也应该屏蔽之。并用它来显示完整的文件路径。有兴趣的可以自己打开Windows7的磁盘管理看看。这才是真正完全拥有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 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 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 = &H10000Private 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
' 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, 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 FunctionPrivate 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&
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 = &HCPublic 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&
Case BFFM_SELCHANGED
sBuffer = Space(MAX_PATH)
lRet = SHGetPathFromIDList(lParam, StrPtr(sBuffer))
CoTaskMemFree lpIDList
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)))
End If
End Select
errhandler:
BrowseCallbackProc = 0
End Function
SHGetPathFromIDList lpIDList, StrPtr(sBuffer)
那就请你贴出一样效果的图和你的“短代码”。不要光说P话。VB6
支持Unicode
EditBox显示完整路径 -这上ExpertExchange买得给钱的
仅作为搜索用时,屏蔽EditBox
Const MAX_PATH_UNICODE = 2 * MAX_PATH - 1
代码写少了2个地方MAX_PATH_UNICODE和StrPtr,自己改一下就成。
这下编辑框彻底和Windows7的系统行为一致了。碰到楼上这种素质,彻底无语,最后一次发此代码。
Private Const EM_NOSETFOCUS = (&H1500 + 7) Call SendMessage(Fhwnd, EM_SETREADONLY, True, ByVal 0&)
Call SendMessage(Fhwnd, EM_NOSETFOCUS, 0&, ByVal 0&)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 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 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 = &H10000Private 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 FunctionPrivate 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 = &H8Public 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 lParam Then CoTaskMemFree lParam
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
这是一个人人为我,我为人人的论坛。
论坛有你这号人来注册,真是丢人现眼。敢情我卖给你,你还很乐意一样。那你自己主动掏钱呗。这里面用到的消息MSDN上搜不到,代码从来没有人发布过,你白白得到这些东西,还这个样子,只充分证明一句话,水至清则无鱼,人至贱则无敌。
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 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 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 = &H10000Private 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 FunctionPrivate 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 = &H8Public 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
是买不到呀,你问微软他说是Internal Use,都懒得给你公布常数值啊。问你该怎么办?上ExpertExchange掏钱买,只买到了显示完整路径的代码,想弄得和Windows7一样,即能清晰显示完整路径,又让用户明显的知道这文本框是不可编辑的,没戏。
在整个工程里没用到
不是垃圾代码是啥?
在整个工程里也没用到
Private Const BIF_UAHINT = &H100
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
全都没用到
2.能够让用户设置初始文件夹
3.不知道Public Const MAX_PATH_UNICODE = 2 * MAX_PATH - 1在极端情况下会产生什么问题,标准是用MAX_PATH =260&
没有用到的Constants不要紧呀。VB编译时会自动去掉。完整点好,这样你可以添加Flags去实现你要的功能,例如:.ulFlags = IIf(IncludeFiles, BIF_BROWSEINCLUDEFILES, BIF_RETURNONLYFSDIRS) + BIF_DONTGOBELOWDOMAIN + BIF_USENEWUI + _
IIf(IncludeNewFolderButton, 0&, BIF_NONEWFOLDERBUTTON)
那是个经典的去处。