Visual Basic, .NET, ASP, VBA, VBScript
 
  Библиотека кодов  
  Работа с Common Dialog  
     
  Дополнение: Открытие стандартного окна выбора папок/файлов  
  Данный пример является дополнением к "Открытие стандартного окна выбора папок/файлов", но обеспечивает дополнительную возможность выбора только "Сетевого Окружения", а также папок ПРОГРАММЫ и ГЛАВНОЕ МЕНЮ

Вам понадобится элемент CommandButton
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
 
     
  VBNet online (всего: 52050)  
 

Логин:

Пароль:

Регистрация, забыли пароль?


В чате сейчас человек
 
     
  VBNet рекомендует  
   
     
  Лучшие материалы  
 
ActiveX контролы (112)
Hitman74_Library (36119)
WindowsXPControls (20739)
FlexGridPlus (19374)
DSMAniGifControl (18295)
FreeButton (15157)
Примеры кода (546)
Parol (18027)
Passworder (9299)
Screen saver (7654)
Kerish AI (5817)
Folder_L (5768)
Статьи по VB (136)
Мое второе впечатление... (11236)
VB .NET: дорога в будущее (11161)
Основы SQL (9225)
Сообщения Windows в Vi... (8788)
Классовая теория прогр... (8619)
 
     
Техническая поддержка MTW-хостинг | © Copyright 2002-2011 VBNet.RU | Пишите нам