- Код: Выделить всё
Public Const dhcMaxPath = 260
Public Const dhcNoError = 0&
Public Const dhcErrorExtendedError = 1208&
Public Const MAX_PATH = 260
Public Declare Function SHGetSpecialFolderLocation Lib "Shell32.DLL" (ByVal hwndOwner As Long, ByVal Folder As Long, ByRef idl As Long) As Long ' Shell types
Public Declare Function SHBrowseForFolder Lib "Shell32.DLL" (ByRef bi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "Shell32.DLL" (ByVal idl As Long, ByVal Path As String) As Integer
Public Type BrowseInfo
hwndOwner As Long ' Owner
pidlRoot As Long ' Can be null
strDisplayName As String ' Rcvs display name of folder (32 bytes)
strTitle As String ' title/instructions for user
ulFlags As Long ' 0 or BIF constants
' You won't use any of the following fields, from VBA.
lpfn As Long ' Address for callback: use NULL
lParam As Long ' Passes to callback
iImage As Long ' index to the system image list
End Type
Public Function dhBrowseForFolder( _
ByVal lngCSIDL As Long, ByVal lngBifFlags As Long, strFolder As String, _
Optional ByVal hWnd As Long = 0, _
Optional strTitle As String = "Select Directory") As Long
Dim usrBrws As BrowseInfo
Dim lngReturn As Long
Dim lngIDL As Long
If SHGetSpecialFolderLocation(hWnd, lngCSIDL, lngIDL) = 0 Then
With usrBrws
.hwndOwner = hWnd
.pidlRoot = lngIDL
.strDisplayName = String$(dhcMaxPath, vbNullChar)
.strTitle = strTitle
.ulFlags = lngBifFlags
End With
lngIDL = SHBrowseForFolder(usrBrws)
If lngIDL Then
strFolder = String$(dhcMaxPath, vbNullChar)
If SHGetPathFromIDList(lngIDL, strFolder) Then
strFolder = dhTrimNull(strFolder)
lngReturn = dhcNoError
Else
strFolder = dhTrimNull(usrBrws.strDisplayName)
lngReturn = dhcNoError
End If
Else
lngReturn = dhcErrorExtendedError
End If
Else
lngReturn = dhcErrorExtendedError
End If
dhBrowseForFolder = lngReturn
End Function
Private Function dhTrimNull(ByVal strValue As String) As String
Dim intPos As Integer
intPos = InStr(strValue, vbNullChar)
Select Case intPos
Case 0
dhTrimNull = strValue
Case 1
dhTrimNull = ""
Case Is > 1
dhTrimNull = Left$(strValue, intPos - 1)
End Select
End Function
2. Используем следующим образом:
- Код: Выделить всё
Dim a As Long, strFolder As String
a = dhBrowseForFolder(a, a, strFolder, 0, "Dыберите каталог")
If a = 1 Then
MsgBox "Пользователь нажал 'Отмену'"
Else: MsgBox strFolder