bonjour à tous deux
3 fonctions pour le faire
'créer un répertoire et ses répertoires parents s'ils n'existent pas
Sub test()
'merçi aux auteurs
S$ = 'D:\\Dossier\\Dossier1\\Dossier2\\DossierFin'
MsgBox CBool(CreeChemin(S))
End Sub
Function CreeChemin(S$)
'adaptation pour Excel 97 d'une fonction de Dana DeLouis
'(contribution de Dave Peterson) (mpep, avril 2002)
'Valeurs retournées :
' -1 : succès
' 1 : erreur (caractère invalide dans le chemin)
' 2 : erreur (le lecteur n'existe pas)
' 3 : erreur (lecteur amovible non prêt)
' 4 : erreur (le lecteur est un lecteur de cdrom)
' 5 : erreur (le dossier est en fait un fichier sans extension...)
Dim j%, FSO As Object, Drv$, tmpDir$, sDir$
Dim pos1%, pos2%, Arr, NbRep%
'// Vérifie la validité des noms des répertoires à créer
S = Trim(S)
j = 0
j = j + InStr(1, S, '/')
j = j + InStr(3, S, ':') ' the ':' in C:\\
j = j + InStr(1, S, '*')
j = j + InStr(1, S, '?')
j = j + InStr(1, S, '>')
j = j + InStr(1, S, '<')
j = j + InStr(1, S, '|')
j = j + InStr(1, S, '''')
If j > 0 Then
CreeChemin = 1 'caractère invalide dans le chemin
Exit Function
End If
'Vérifie la validité du lecteur racine du chemin
Set FSO = CreateObject('Scripting.FileSystemObject')
With FSO
Drv = .GetDriveName(S) & Application.PathSeparator ' ie C:\\
'// Valid Drive? (as in A:\\, C:\\, D:\\ ...etc)
If Not .DriveExists(Drv) Then
CreeChemin = 2 'le lecteur n'existe pas
Exit Function
End If
'// Is Drive Ready (as in no Floppy in A
?
If Not .getdrive(Drv).IsReady Then
CreeChemin = 3 'lecteur amovible non prêt
Exit Function
End If
'// Unable if CD-Rom
If .getdrive(Drv).DriveType = 4 Then
CreeChemin = 4 'le lecteur est un lecteur de cdrom
Exit Function
End If
'construire un tableau avec les noms des différents
'répertoires du chemin, sans utiliser Split (Excel 2000 et +)
If Right(S, 1) = '\\' Then S = Left(S, Len(S) - 1)
NbRep = Len(S) - Len(Application.Substitute(S, '\\', ''))
ReDim Arr(NbRep - 1)
pos1 = 3
Do
pos2 = InStr(pos1 + 1, S, '\\')
If pos2 = 0 Then
tmp = Mid(S, pos1 + 1)
Else: tmp = Mid(S, pos1 + 1, pos2 - pos1 - 1)
End If
pos1 = pos2: i = i + 1
Arr(i - 1) = tmp
Loop While i < NbRep
'// First test each branch for a File with no Extension!
sDir = Drv
For j = 0 To UBound(Arr)
sDir = .BuildPath(RTrim$(sDir), Arr(j))
If .FileExists(sDir) Then
CreeChemin = 5 'le dossier est en fait un fichier sans extension...
Exit Function
ElseIf Not .FolderExists(sDir) Then
Exit For ' Does not exist..No need to continue
End If
Next j
' Everything looks Ok, so make Directories
sDir = Drv
For j = 0 To UBound(Arr)
sDir = .BuildPath(RTrim$(sDir), Arr(j))
If Not .FolderExists(sDir) Then .CreateFolder sDir
Next j
End With
Set FSO = Nothing
CreeChemin = -1
End Function
'2 fonctions pour créer un répertoire et, si besoin,
'les sous-répertoires pour y accéder.
Public Function Create_Dir(S As String)
'Al Omari, mpep
'd'après la fonction Dir_Make de Dana DeLouis (voir plus bas)
'inclut la possibilité de créer un répertoire sur une machine distante
'(chemin de type '\\\\server1\\dir1\\dir2')
Dim V As Variant
Dim j As Integer
Dim sDir As String
Dim drv As String
Dim fs As Object
Const vblf2 = vbLf & vbLf
'// Check for invalid Windows Characters...
S = Trim(S)
j = 0
j = j + InStr(1, S, '/')
j = j + InStr(3, S, ':') ' the ':' in C:\\
j = j + InStr(1, S, '*')
j = j + InStr(1, S, '?')
j = j + InStr(1, S, '>')
j = j + InStr(1, S, '<')
j = j + InStr(1, S, '|')
j = j + InStr(1, S, '''') 'added 4/9/2002 cf Dave Peterson, mpep
If j > 0 Then
MsgBox 'Folder ' & S & vbLf & 'has invalid Characters / : * '' ? < > |'
Exit Function
End If
Set fs = CreateObject('Scripting.FileSystemObject')
With fs
If Left(S, 2) = '\\\\' Then drv = Mid(S, 1, InStr(3, S, '\\')) _
Else drv = .GetDriveName(S) & Application.PathSeparator ' ie C:\\
'// Break apart string s
If Left(S, 2) = '\\\\' Then S = Mid(S, InStr(3, S, '\\'), Len(S))
V = Split(Trim(S), '\\')
sDir = drv
For j = 1 To UBound(V)
sDir = .BuildPath(RTrim$(sDir), V(j))
If Not .FolderExists(sDir) Then .CreateFolder sDir
Next j
End With
Set fs = Nothing
End Function
Sub test()
S$ = 'C:\\Dir1\\Dir2\\Dir3'
' MsgBox Dir_Make(S)
Create_Dir S
End Sub
au revoir
