VB - [VB] Créer une arborescence compléte de répertoires

Catégories - Programmation - VB

users_user-20.html - [VB] Créer une arborescence compléte de répertoires

Une petite procédure qui permet de créer tous les dossiers innexistants d'un chemin.

Code:

Public Sub CreateAllDir(ByVal sPath As String)
Dim oFS As FileSystemObject
Dim sStr As String
Dim oCol As Collection
Dim i As Integer
Set oFS = New FileSystemObject
Set oCol = New Collection
sStr = sPath
While sStr <> ""
oCol.Add sStr
sStr = oFS.GetParentFolderName(sStr)
Wend
For i = oCol.Count To 1 Step -1
If Not oFS.FolderExists(oCol(i)) Then
oFS.CreateFolder oCol(i)
End If
Next i
Set oFS = Nothing
Set oCol = Nothing
End Sub

Commentaires

[VB] Créer une arborescence compléte de répertoires...

Un autre méthode beaucoup plus rapide (50%) qui utilise les API et non le FileSystemObject (donc pas de DLL à lier/trimballer)

Code:

Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type SECURITY_ATTRIBUTES
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" _
(ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" _
(ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Public Sub rMkDir(sPath As String)
Dim sTmp As String
Dim iIndex As Integer
Dim iLen As Integer
Dim iEnd As Integer
Dim SecAttrib As SECURITY_ATTRIBUTES
With SecAttrib
.lpSecurityDescriptor = &O0
.bInheritHandle = False
.nLength = Len(SecAttrib)
End With
iLen = Len(sPath)
sTmp = Left(sPath, 2)
If sTmp = "\\" Then
iIndex = InStr(3, sPath, "\")
End If
Do
iEnd = InStr(iIndex + 1, sPath, "\")
If iEnd = 0 Then
iEnd = iLen
End If
sTmp = Mid(sPath, 1, iEnd)
If Not FolderExists(sTmp) Then
Call CreateDirectory(sTmp, SecAttrib)
End If
iIndex = iEnd + 1
Loop While iEnd <> iLen
End Sub
Private Function FolderExists(sFolder As String) As Boolean
Dim hFile As Long
Dim WFD As WIN32_FIND_DATA
sFolder = UnQualifyPath(sFolder)
hFile = FindFirstFile(sFolder, WFD)
FolderExists = (hFile <> INVALID_HANDLE_VALUE) And _
(WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY)
Call FindClose(hFile)
End Function
Private Function UnQualifyPath(ByVal sFolder As String) As String
sFolder = Trim$(sFolder)
If Right$(sFolder, 1) = "\" Then
UnQualifyPath = Left$(sFolder, Len(sFolder) - 1)
Else
UnQualifyPath = sFolder
End If
End Function

Par Poire, Publié le 10/11/2004 @ 11:04:57

Poster un commentaire

Utilisateur	(Inscription)
Mot de passe