本帖最后由 takeshi999 于 2016-4-7 16:13 编辑
- Option Explicit
- ' Define user type to reduce the number of #If VBA7 statements
- ' Can't eliminate them...
- Private Type LongPtr_T
- #If VBA7 Then
- Value As LongPtr
- ' Compare automatically resized LongPtr to fixed size Long and LongLong
- #Else
- Value As Long
- #End If
- End Type
- ' Win32 data type. Different signatures for different versions of VBA
- Private Type BROWSEINFO
- #If VBA7 Then
- hWndOwner As LongPtr
- pIDLRoot As LongPtr
- pszDisplayName As Long
- lpszTitle As String
- ulFlags As Long
- lpfnCallback As LongPtr
- lParam As Long
- iImage As Long
- #Else
- hWndOwner As Long
- pIDLRoot As Long
- pszDisplayName As Long
- lpszTitle As String
- ulFlags As Long
- lpfnCallback As Long
- lParam As Long
- iImage As Long
- #End If
- End Type
- Private Const MAX_PATH = 260
- 'Directories only
- Private Const BIF_RETURNONLYFSDIRS = &H1&
- 'Windows 2000 (Shell32.dll 5.0) extended dialog
- Private Const BIF_NEWDIALOGSTYLE = &H40
- ' show edit box
- Private Const BIF_EDITBOX = &H10&
- Private Const WM_USER = &H400
- Private Const BFFM_INITIALIZED = 1
- Private Const BFFM_SELCHANGED = 2
- Private Const BFFM_SETSTATUSTEXTA = (WM_USER + 100)
- Private Const BFFM_SETSELECTIONA = (WM_USER + 102)
- Private Const BFFM_SETEXPANDED = (WM_USER + 16)
- Private m_sDefaultFolder As String
- Public Const SWP_NOMOVE = 2
- Public Const SWP_NOSIZE = 1
- Private Const SWP_NOZORDER = 4
- Private Type RECT
- Left As Long
- Top As Long
- Right As Long
- Bottom As Long
- End Type
- ' Win32 API declarations. Different signatures for different versions of VBA.
- ' Note the mandatory use of PtrSafe keyword in VBA7.
- #If VBA7 Then
- Private Declare PtrSafe Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
- Private Declare PtrSafe Function SHBrowseForFolder Lib "Shell32" (lpbi As BROWSEINFO) As Long
- Private Declare PtrSafe Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As LongPtr, ByVal lpBuffer As String) As Long
- Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal hMem As LongPtr)
- Private Declare PtrSafe Function SetWindowPos Lib "USER32" (ByVal hWnd As LongPtr, _
- ByVal hWndInsertAfter As LongPtr, _
- ByVal x As Long, _
- ByVal y As Long, _
- ByVal cx As Long, _
- ByVal cy As Long, _
- ByVal wFlags As Long) As Long
- Private Declare PtrSafe Function GetWindowRect Lib "user32.dll" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
- #Else
- 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 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 Sub CoTaskMemFree Lib "ole32" (ByVal hMem As Long)
- Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, _
- ByVal hWndInsertAfter As Long, _
- ByVal x As Long, _
- ByVal y As Long, _
- ByVal cx As Long, _
- ByVal cy As Long, _
- ByVal wFlags As Long) As Long
- Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hWnd As Long, lpRect As RECT) As Long
- #End If
- Private lastKnownPosition As RECT
- Private lockLastKnownPosition As Boolean
- Public Function BrowseForFolder() As String
- Dim tBI As BROWSEINFO
- Dim lngPIDL As LongPtr_T
- Dim strPath As String
-
- With tBI
- .lpszTitle = "Select the folder you want to use."
- ' TO DO: Do you want the new UI? Or the initial selected folder visible when the dialog opens?
- ' Choose one of the following:
- ' New UI. Selected folder is probably out of view.
- .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE Or BIF_EDITBOX
- ' ... or ...
- ' Old UI. Selected folder is scrolled into view when dialog opens.
- '.ulFlags = .ulFlags = BIF_RETURNONLYFSDIRS
- ' ... or ...
- ' Old UI with edit box. Selected folder is scrolled into view when dialog opens.
- ' Focus defaults to the edit box making the selected folder less obvious in the tree.
- '.ulFlags = .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_EDITBOX
-
- .lpfnCallback = GetAddress(AddressOf BrowseCallbackProc).Value
- End With
-
- lockLastKnownPosition = True
- lngPIDL.Value = SHBrowseForFolder(tBI)
- If (lngPIDL.Value <> 0) Then
- ' get path from ID list
- strPath = Space$(MAX_PATH)
- SHGetPathFromIDList lngPIDL.Value, strPath
- strPath = Left$(strPath, InStr(strPath, Chr$(0)) - 1)
- ' release list
- CoTaskMemFree lngPIDL.Value
- End If
- BrowseForFolder = strPath
- End Function
- ' Callback function for Win32 API.
- ' Must conform to the expected method signature therefore cannot use our LongPtr_t
- #If VBA7 Then
- Private Function BrowseCallbackProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
- #Else
- Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
- #End If
- ' If dialog has been initialised, record its current location
- If Not lockLastKnownPosition Then
- GetWindowRect hWnd, lastKnownPosition
- End If
-
- Select Case uMsg
- Case BFFM_INITIALIZED
- ' Start recording the dialogs location
- lockLastKnownPosition = False
-
- If Len(m_sDefaultFolder) > 0 Then
- ' Move the dialog to the last recorded position
- SetWindowPos hWnd, 0, lastKnownPosition.Left, lastKnownPosition.Top, 0, 0, SWP_NOSIZE + SWP_NOZORDER
- ' Set the selected folder
- SendMessage hWnd, BFFM_SETSELECTIONA, True, ByVal m_sDefaultFolder
- End If
- Case BFFM_SELCHANGED
- SendMessage hWnd, BFFM_SETEXPANDED, True, ByVal m_sDefaultFolder
- End Select
- End Function
- ' Workaround for syntax limitation of AddressOf. Can only use in a function call, not an assignment
- #If VBA7 Then
- Private Function GetAddress(nAddress As LongPtr) As LongPtr_T
- #Else
- Private Function GetAddress(nAddress As Long) As LongPtr_T
- #End If
- Dim address As LongPtr_T
- address.Value = nAddress
- GetAddress = address
- End Function
|
发表于 2016-4-5 16:12:43
发表于 2016-4-5 17:05:12
发表于 2016-4-7 16:35:28
