Главная страницаОбратная связьКарта сайта

Открытие стандартного диалогового окна выбора папки 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

Public Enum FolderType
CSIDL_BITBUCKET = 10
CSIDL_CONTROLS = 3
CSIDL_DESKTOP = 0
CSIDL_DRIVES = 17
CSIDL_FONTS = 20
CSIDL_NETHOOD = 18
CSIDL_NETWORK = 19
CSIDL_PERSONAL = 5
CSIDL_PRINTERS = 4
CSIDL_PROGRAMS = 2
CSIDL_RECENT = 8
CSIDL_SENDTo = 9
CSIDL_STARTMENU = 11
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", Вы можете поставить закладку в социальной сети или в своём блоге на данную страницу:

Так же Вы можете задать вопрос по работе этого модуля или примера через форму обратной связи, в сообщение обязательно указывайте название или ссылку на статью!
   


Copyright © 2008 - 2017 Дискета.info