Comptage de Folder

Sub testFILE() Const ctePourLecture = 1 Const ctePourEcrire = 2 Const ctePourAjouter = 8 Dim objFSO, objDossier, objFichier, objResultat Dim Repertoire, NomFichierTxt 'On Error Resume Next Repertoire = "D:\test" NomFichierTxt = "Resultat.txt" Set objFSO = CreateObject("Scripting.FileSystemObject") Set objDossier = objFSO.GetFolder(Repertoire) Set objResultat = objFSO.CreateTextFile((Repertoire & "\" & NomFichierTxt), ctePourEcrire) If (objDossier.Files.Count > 0) Then For Each objFichier In objDossier.Files If (InStr(1, objFichier.Name, ".xls", 1) > 0) Then objResultat.WriteLine objFichier.Name End If Next End If objResultat.Close Set objResultat = Nothing Set objDossier = Nothing Set objFSO = Nothing End Sub

Je viens de trouver juste à l'instant ^^ :

Code:

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
 
 
Sub TESTFOLDER()
 
 
  Const ctePourLecture = 1
  Const ctePourEcrire = 2
  Const ctePourAjouter = 8
''''''''''''''''''''
''''''''''Ajout d'un nouvel objet SubFolders
''''''''''''''''''''
  Dim objFSO, objDossier, objFichier, objResultat, objSubFolders
  Dim Repertoire, NomFichierTxt
  Set objResultat = Nothing
  'On Error Resume Next
  'Repertoire = sharepointFolder.Path
  Repertoire = "D:"
  NomFichierTxt = "Resultat1.txt"
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objDossier = objFSO.GetFolder(Repertoire)
  Set objDrive = objFSO.GetDrive(Repertoire)
 
  Set objResultat = objFSO.CreateTextFile(("D:" & "\" & NomFichierTxt), ctePourEcrire)
 
MsgBox objFSO.GetFolder(Repertoire)
''''''''''''''''''''''''''
''''''''''Utilisation
'''''''''''''''''''''''''
  If (objDossier.SubFolders.Count > 0) Then
 
 
     For Each objSubFolders In objDossier.SubFolders
        If (InStr(1, objSubFolders.Name, "_PL", 1) > 0) Then
            objResultat.WriteLine objSubFolders.Name
        End If
     Next
 
   End If
 
  objResultat.Close
  Set objResultat = Nothing
  Set objDossier = Nothing
  Set objFSO = Nothing
 
End Sub

Et ca marche !!!

(Un bon café résous toujours les problèmes les plus simples ^^ ! )

Merci d'avoir lu !