DominoArea.org [Archive]

Code : Tout sélectionner

Sub Initialize
filelevel1$ = Dir$("C:\", ATTR_DIRECTORY)
While (filelevel1$ <> "")
If Instr(1, filelevel1$,".")=0 Then Call sub1(filelevel1$)
' The line below triggers the error "Illegal Function Call"
filelevel1$ = Dir$()
Wend
End Sub

Sub sub1(level1 As Variant)
If Instr(1, level1,".")=0 Then filelevel2$ = Dir$("C:\"+level1+"\*.*")
While (filelevel2$ <> "")
' Perform desired operation on file in sub-directory
' Below accesses next file in sub-directory
filelevel2$=Dir()
Wend
End Sub

Code : Tout sélectionner

Sub Initialize
Dim filelist() As String
count=0
Filelevel1$ = Dir$("C:\", ATTR_DIRECTORY)
While (filelevel1$ <> "")
Redim Preserve Filelist(count)
Filelist(count) = Filelevel1$
count = count + 1
Filelevel1$=Dir$()
Wend
For i = 0 To count-1
filelevel1$ = Filelist(i)
If Instr(1, filelevel1$,".")=0 Then
' We have a sub-dir:
Call sub1(filelevel1$)
Else
'We have a file. Perform desired check or operation
End If
Next
End Sub

Sub sub1(level1 As Variant)
If Instr(1, level1,".")=0 Then filelevel2$ = Dir$("C:\"+level1+"\*.*")
While (filelevel2$ <> "")
' Perform desired operation on file in sub-directory
' Below accesses next file in sub-directory
filelevel2$=Dir()
Wend
End Sub

Code : Tout sélectionner

Function DirectoryListeRecursif(wPath As String, nbRecursif As Integer) As Variant
   
   Dim lstPath List As String
   Dim lstPath2 List As String
   Dim i As Integer
   Dim DirResult As String
   Dim vrPath As Variant
   Dim path As String
   
   On Error Goto ErreurHandle
   
   If Trim(wPath) = "" Then
      lstPath(0) = ""
      DirectoryListeRecursif = lstPath
      Erase lstPath
      Exit Function
   End If
   If Right(Trim(wPath),1) = "\" Then
      Path = Trim(wPath)
   Else
      Path = Trim(wPath)+"\"
   End If
   
   DirResult = Dir$(Path,16)
   While (DirResult <> "")
      Select Case Trim(DirResult)
      Case ".",".."
      Case Else         
         lstPath(Path+DirResult) = Path+DirResult
      End Select
      DirResult=Dir$()
   Wend
   
   If nbRecursif = True Then
      Forall value In lstPath
         If Trim(Cstr(value)) <> "" Then
            If Trim(Dir$(Cstr(value),0)) = "" Then
               vrPath = DirectoryListeRecursif(Cstr(value), nbRecursif)
               Forall value2 In vrPath
                  If Trim(Cstr(value2))<>"" Then
                     If Trim(Dir$(Cstr(value2),0)) <> "" Then
                        lstPath2(Cstr(value2)) = Cstr(value2)
                     End If
                  End If
               End Forall
            Else
               lstPath2(Cstr(value)) = Cstr(value)
            End If
         End If
      End Forall
   End If   
   
   Erase lstPath
   
   DirectoryListeRecursif = lstPath2
   Erase lstPath2
   Exit Function
ErreurHandle:
   Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   Erase lstPath   
   Erase lstPath2
   lstPath(0) = ""
   DirectoryListeRecursif = lstPath
   Erase lstPath
   Exit Function
End Function

stloje a écrit:La fonction Dir () fonctionne uniquement que sur le répertoire où il se trouve. Il faut changer de répertoire avec la fonction Chdir () et refaire un Dir () par la suite. Il ne faut pas oublier de passer en paramètre la valeur 16 pour préciser que ce sont des répertoires que tu cherches, sinon je crois que Dir () tout seul sera suffisant. Ne pas oublier : lorsque tu utilises la fonction ChDir (), Notes force Window a placer un sémaphore sur le répertoire pour indiquer qu'il est occupé par un programme. Si tu dois supprimer le répertoire, il faudra que tu changes de répertoire avec le ChDir (), sinon il y aura violation de partage.

Code : Tout sélectionner

Private Function ManageDirectory (Byval dirPath As String)
Dim pos As Integer
Dim isDrive As Boolean
Dim firstDir As String

'on vérifie s'il y a un lecteur et on le position dessus
pos = Instr (dirPath, ":")
If pos > 0 Then
Chdrive (Left (dirPath, pos - 1))
Chdir ("")
dirPath = Right (dirPath, Len (dirPath) - pos - 1)
isDrive = True
Else
isDrive = False
End If

'on extrait le premier répertoire
pos = Instr (pos + 1, dirPath, "")
If pos = 0 Then
firstDir = dirPath
Else
firstDir = Left (dirPath, pos - 1)
End If

'on vérifie l'existence du premier répertoire
Const ATTR_DIRECTORY = 16
If Dir (firstDir, ATTR_DIRECTORY) <Then> 0 Then
Chdir (firstDir)
ManageDirectory (Right (dirPath, Len (dirPath) - pos))
End If
Else
Mkdir (firstDir)
's'il y a encore un répertoire à vérifier
If Instr (dirPath, "") > 0 Then
Chdir (firstDir)
ManageDirectory (Right (dirPath, Len (dirPath) - pos))
End If
End If
'pour éviter de bloquer le répertoire en violation de partage
'il faut revenir à la racine
If isDrive = True Then Chdir ("")
End Function