Option Explicit
' --------------------------------------------------------- 
' Funktion: CreatePath 
' Eingestellt von: Andre Schau 
' Datum: 5. Juno 2006 
' Kommentar: Erfolgsmeldung auch bei Vorhandensein des Pfades 
' Fehlendes Laufwerk führt nicht zu Fehler im Ablauf 
' Parameter: strPath (abschliessender \ nicht relevant) 
' Rückgabe: Fehlernummer 
' Hinweis:  siehe auch API-Funktion zur Pfaderstellung 
' Aufruf: 
Sub CreatePath()
'Variablendeklarationen 
'Long 
Dim loBack As Long
'Pfad erzeugen und Ergebnis Variable loBack zuweisen 
loBack = CreatePath_("M:\Ordner1\Ordner2\Ordner3\")
'Wenn Fehlernummer <> 0 dann Fehler ausgeben 
If loBack <> 0 Then MsgBox Error(loBack)
End Sub
' --------------------------------------------------------- 
Function CreatePath_(strPath As String) As Long
'Variablendeklarationen 
'Integer 
Dim iCnt%
'Variant 
Dim arrFolder
'Bei Fehler zu Fehlerbehandlung gehen 
On Error GoTo errorhandler
'Pfad in einzelne Verzeichnisse splitten 
arrFolder = Split(strPath, "\")
'Schleife über alle Verzeichnisse 
For iCnt1 = 0 To Ubound(arrFolder)
  'Wenn kein Unterverzeichnis enthalten (Leerstring) 
  If Len(Dir(arrFolder(iCnt1), vbDirectory)) < 1 Then
    'Ordner anlegen 
    MkDir arrFolder(iCnt1)
  'Ende Wenn kein Unterverzeichnis enthalten 
  End If
  'Pfad schrittweise wieder zusammensetzen 
  If Ubound(arrFolder) > iCnt1 Then arrFolder(iCnt1 + 1) = _
     arrFolder(iCnt1) + "\" + arrFolder(iCnt1 + 1)
'Naechste Schleife über alle Verzeichnisse 
Next
errorhandler:
'Fehlernummer übergeben, ohne Fehler = 0 
CreatePath_ = Err.Number
End Function