Как в CommonDialog открыть папку? - VB

Узнай цену своей работы

Формулировка задачи:

Хочу узнать как можно в CommonDialog открыть папку (Указать её путь). Я оттолкнулся от CommonDialog.FileName программно отбросил имя открывамого файла и таким образом получил путь к папке.
Но это всё реальный геморрой. Подскажите как сократить код. Или какую-то функцию. А может заменить CommonDialog чем либо другим. p.s.Воспользовался CommonDialog потому что есть доступ к сети. А к примеру DriveListBox видит только ситевые диски, а не рабочую группу.

Решение задачи: «Как в CommonDialog открыть папку?»

textual
Листинг программы
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

ИИ поможет Вам:


  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

9   голосов , оценка 3.889 из 5