Verzeichnis auswählen, Standard-Pfad?

Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare 

Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetDirectory(Optional Msg As String) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function



Sub DirAuswahl()
Verzeichnisse = ""
Dim sMsg As String, sPath As String
sMsg = "Wählen Sie bitte einen Ordner aus:"
sPath = GetDirectory(sMsg)
If sPath <> "" Then Verzeichnisse = sPath
End Sub



Sub neuesVerzeichnis()
Dim sDir As String
sDir = GetDirectory
If sDir = "" Then Exit Sub
If Right(sDir, 1) <> "\" Then sDir = sDir & "\"
SendKeys "{end}"
sDir = InputBox("Neuen Verzeichnisnamen eingeben:", , sDir)
If sDir = "" Then Exit Sub
On Error GoTo ERRORHANDLER
MkDir sDir
Verzeichnisse = sDir
Exit Sub
ERRORHANDLER:
MsgBox "Das Verzeichnis konnte nicht erstellt werden!"
End Sub