Открытие стандартного диалогового окна выбора папки 2
'Обеспечивает дополнительную возможность выбора только "Сетевого 'Окружения", а также папок ПРОГРАММЫ и ГЛАВНОЕ МЕНЮ
Private 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
Public Enum BrowseType BrowseForFolders = &H1 BrowseForComputers = &H1000 BrowseForPrinters = &H2000 BrowseForEverything = &H4000 End Enum
Private Const MAX_PATH = 260 Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Private Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BrowseInfo) As Long Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, ListId As Long) As Long
Public Function BrowseFolders(hWndOwner As Long, sMessage As String, Browse As BrowseType, ByVal RootFolder As FolderType) As String Dim Nullpos As Integer Dim lpIDList As Long Dim res As Long Dim sPath As String Dim BInfo As BrowseInfo Dim RootID As Long
SHGetSpecialFolderLocation hWndOwner, RootFolder, RootID BInfo.hWndOwner = hWndOwner BInfo.lpszTitle = lstrcat(sMessage, "") BInfo.ulFlags = Browse If RootID <> 0 Then BInfo.pIDLRoot = RootID lpIDList = SHBrowseForFolder(BInfo) If lpIDList <> 0 Then sPath = String(MAX_PATH, 0) res = SHGetPathFromIDList(lpIDList, sPath) Call CoTaskMemFree(lpIDList) Nullpos = InStr(sPath, vbNullChar) If Nullpos <> 0 Then sPath = Left(sPath, Nullpos - 1) End If End If BrowseFolders = sPath End Function
Private Sub Command1_Click() 'следующие вызовы функции сработали нормально MsgBox BrowseFolders(hwnd, "Select a Folder", BrowseForFolders, CSIDL_DESKTOP) '+весь компьютер 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_DRIVES) '+только устройства 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_NETHOOD) '+только сеть 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_PROGRAMS) '+папка Программы 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_STARTMENU) '+Главное меню
'результат действия следующих кодов вызвал недоумение... 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_BITBUCKET) '-корзина 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_CONTROLS) '-панель управления 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_FONTS) '-папка со шрифтами 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_NETWORK) '-NetHood 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_PERSONAL) '-Мои документы 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_PRINTERS) '-Принтеры 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_RECENT) '-RECENT 'MsgBox BrowseFolders(hWnd, "Select a Folder", BrowseForFolders, CSIDL_SENDTO) '-SENDTo End Sub
Если Вас заинтересовала или понравилась информация программирование на Visual Basic - "Открытие стандартного диалогового окна выбора папки 2", Вы можете поставить закладку в социальной сети или в своём блоге на данную страницу: Так же Вы можете задать вопрос по работе этого модуля или примера через форму обратной связи, в сообщение обязательно указывайте название или ссылку на статью!