VBA: создание диалога "Выбор папки"

Ответы на вопросы, чаще всего задаваемые в форумах VBStreets. Для тех, кому лень искать.
corgi
ToyMan
ToyMan
 
Сообщения: 1367
Зарегистрирован: 01.10.2002 (Вт) 9:59
Откуда: Россия, Москва

VBA: создание диалога "Выбор папки"

Сообщение corgi » 26.05.2004 (Ср) 18:24

1. создаем модуль и в него копируем следующий код:
Код: Выделить всё
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

Вернуться в Популярные вопросы

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 12

    TopList