Как в 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 открыть папку?»

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