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

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

Хочу узнать как можно в CommonDialog открыть папку (Указать её путь). Я оттолкнулся от CommonDialog.FileName программно отбросил имя открывамого файла и таким образом получил путь к папке.
Private Sub Command3_Click()
 
Dim prob As String: otbras As Integer: nach_schet As Integer
Dim prob1 As String: probila As String
Dim prob2 As String
Dim chisla As Integer: Dim vseti As String
prob = ':'
probila = ' ': vseti = '\ '
nach_schet = 0: chisla = 1
 
On Error GoTo ErrorHandler
CommonDialog1.ShowOpen
If ShowOpen = 0 Then prob1 = CommonDialog1.FileName
 
Do Until prob = Left(prob2, 1) ' Ищет значёк :
If probila = Left(prob2, 1) Then nach_schet = 1 ' Ищет значёк   (длину файла)
If vseti = Left(prob2, 2) Then otbras = otbras - 1: Exit Do 'Исли открываем по сети то опрашиваем \
otbras = otbras + nach_schet
prob2 = Right(prob1, chisla)
chisla = chisla + 1
Loop
 
Text1 = Left(prob1, otbras + 1) 'Отбрасывает в пути ******** те. имя файла
Exit Sub
ErrorHandler:
End Sub
Но это всё реальный геморрой. Подскажите как сократить код. Или какую-то функцию. А может заменить CommonDialog чем либо другим. p.s.Воспользовался CommonDialog потому что есть доступ к сети. А к примеру DriveListBox видит только ситевые диски, а не рабочую группу.

Код к задаче: «Как в CommonDialog открыть папку? - VB»

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


СОХРАНИТЬ ССЫЛКУ