Option Explicit
' --------------------------------------------------------- 
' Funktion: CheckPath 
' Eingestellt von: Andre Schau 
' Datum: 5. Juno 2006 
' Kommentar: 
' Parameter: strPath, 
'            optional iPathSep 0 mit "\", 1 ohne "\" 
' Rückgabe: Erfolg: "", ansonsten Fehlermeldung 
' Aufruf: 
Sub Call_CheckPath()
'Variablendeklarationen 
'String 
Dim errMsg$
'Pfad anlegen und Ergbenis der Variablen errMsg zuweisen 
errMsg = CheckPath("C:\test\willi\sehrwild", True)
'Wenn errMsg etwas enthaelt, dann Meldung ausgeben 
If errMsg <> "" Then MsgBox errMsg
End Sub
' --------------------------------------------------------- 
Private Function CheckPath(ByVal strPath As String, _
        Optional ByVal booCreatePath As Boolean) As String
'Rueckgabewert "" zuweisen 
CheckPath = ""
'Parameter auswerten 
'Wenn Pfadangabe leer, ohne ":" oder kuerzer als 3 Zeichen dann 
If strPath = "" Or Mid(strPath, 2, 1) <> ":" Or Len(strPath) <= 3 Then
  'Rueckgabewert Text zuweisen 
  CheckPath = "Kein gültiger Pfad: "
  'Funktion verlassen 
  Exit Function
'Ende Wenn Pfadangabe leer, ... 
End If
'Wenn rechts kein \, dann \ hinzufuegen 
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'Variablendeklaration 
'String 
Dim strTmpPath$
'integer 
Dim iCounter%, iCounter2%
'Wenn Pfadpruefung Nullstring ergibt, dann 
If Dir(strPath, vbDirectory) = vbNullString Then
  'Wenn der Pfad nicht erzeugt werden soll, dann 
  If Not booCreatePath Then
    'Rueckgabewert Text zuweisen 
    CheckPath = "Pfad bzw. Ordner existiert nicht!"
    'Funktion verlassen 
    Exit Function
  'Oder 
  Else
    'temporaeren Pfadstring (LW) erstellen 
    strTmpPath = Left(strPath, 3)
    'Pfad rechten Teil vom Pfad (ohne LW-Angabe) zuweisen 
    strPath = Right(strPath, Len(strPath) - 3)
    'Schleife solange Pfad kein Leerstring 
    Do
      'temporaeren Pfadstring um eine Verzeichnisebene 
      'erweitert setzen 
      strTmpPath = strTmpPath + "\" + _
          Mid(strPath, 1, InStr(strPath, "\") - 1)
      'Pfad rechten Teil vom Pfad ohne ' 
      'erste Verzeichnisebene zuweisen 
      strPath = Right(strPath, Len(strPath) - InStr(strPath, "\"))
      'Bei Fehler zu Fehlerbehandlung gehen 
      On Error GoTo errorhandler
      'Wenn Pfadpruefung Nullstring ergibt, 
      'dann Verzeichnisebene anlegen 
      If Dir(strTmpPath, vbDirectory) = vbNullString Then _
         MkDir strTmpPath
      'Fehlerbehandlung aufheben 
      On Error GoTo 0
    'Ende Schleife solange Pfad kein Leerstring 
    Loop Until strPath = ""
  'Ende Wenn der Pfad nicht erzeugt werden soll, dann 
  End If
'Ende Wenn Pfadpruefung Nullstring ergibt, dann 
End If
'Funktion verlassen 
Exit Function
'Fehlerbehandlung 
errorhandler:
'Rueckgabewert Fehlernummer und Fehlerbeschreibung zuweisen 
CheckPath = Err.Number & " " & Err.Description
End Function