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