1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
| Option Explicit
Private Sub Test_CreerUneHierarchieDeRepertoires()
Call CreerUneHierarchieDeRepertoires("C:\Test1\Test2\Test3\Test4\")
End Sub
Private Sub CreerUneHierarchieDeRepertoires(prmCheminAccesFichier As String)
On Error GoTo Err_CreerUneHierarchieDeRepertoires
Dim cheminAccesFichier As String: cheminAccesFichier = prmCheminAccesFichier
'Fait sauter le \ à la fin du chemin si il existe
If Right(cheminAccesFichier, 1) = "\" Then
cheminAccesFichier = Left(cheminAccesFichier, Len(cheminAccesFichier) - 1)
End If
'récupère le disque
Dim disque As String: disque = Left(cheminAccesFichier, 1)
'Supprime le disque du chemin
cheminAccesFichier = Mid(cheminAccesFichier, 4)
'Récupère la liste des répertoires qui compose le chemin
Dim nomRepertoire As Variant: nomRepertoire = Split(cheminAccesFichier, "\")
Dim chemin As String
chemin = disque & ":"
Dim i As Long: For i = LBound(nomRepertoire) To UBound(nomRepertoire)
chemin = chemin & "\" & nomRepertoire(i)
MkDir chemin
Next i
Exit_CreerUneHierarchieDeRepertoires:
Exit Sub
Err_CreerUneHierarchieDeRepertoires:
Select Case Err.Number
Case 75
'OK, le répertoire existe déjà passe au suivant
Resume Next
Case Else
MsgBox "Erreur : " & Err.Number & ", " & Err.Description, vbExclamation
End Select
Resume Exit_CreerUneHierarchieDeRepertoires
End Sub |
Partager