|
|
图是用历遍装配体的，只出来表头，下面代码是历遍文件夹的，也是在论坛抄的，
Option Explicit
' 定义用户类型以减少#If VBA7语句的数量
' 不能删除他们...
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数据类型. 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 PtrSafe 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 PtrSafe Function SHBrowseForFolder Lib "Shell32" (lpbi As BROWSEINFO) As Long
Private Declare PtrSafe Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal hMem As Long)
Private Declare PtrSafe 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 PtrSafe 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 = "选择一个要输出文件属性的文件夹."
' 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
|
|
[复制链接]
发表于 2021-1-18 16:06:58
楼主
鲁公网安备 37028502190335号