Folder-Dialog
Versuch' mal dies hier:

Private Declare Function SHBrowseForFolder Lib "shell32" _
    (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
    (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
    (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2

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
Private Const MAX_PATH = 260
         
Public Function PathDialog(Optional szTitle As String = "", Optional hWnd As Long = 0)
' Anzeige aller Verzeichnisse
' liefert den ausgewählten Pfad zurück
On Error GoTo Er
Dim lpIDList As Long, sBuffer As String, tBrowseInfo As BrowseInfo
  With tBrowseInfo
    If hWnd = 0 Then
      .hWndOwner = Application.hWndAccessApp
    Else
      .hWndOwner = hWnd
    End If
    .lpszTitle = lstrcat(szTitle, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
  End With
  lpIDList = SHBrowseForFolder(tBrowseInfo)
  If (lpIDList) Then
    sBuffer = String(MAX_PATH, 0)
    SHGetPathFromIDList lpIDList, sBuffer
    PathDialog = left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
  Else
    PathDialog = ""
  End If

Ex:
  On Error Resume Next
  Exit Function

Er:
  MsgBox "PathDialog: " & Err.Description
  Resume Ex
End Function
Reinhard