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