Macro extraction liste de fichiers - Pb compatibilité EXCEL 2003 - 2007 ?

massol

XLDnaute Junior
Bonjour,

La macro ci-dessous permet d’extraire dans EXCEL la liste des fichiers situés à un emplacement donné (y compris réseau) avec un filtre donné. Cette application fonctionne parfaitement sur XP SP3 (EXCEL 2003) mais par contre pose problème sur windows 7 (excel 2007).

A l’exécution de la macro « maj_liste_fichier2 », j’ai un message d’erreur.

Mon souci vient du fait que je dispose d’un poste windows 7 (EXCEL 2007) et de plusieurs postes windows XP SP3 (EXCEL 2003) et que cette application doit fonctionner sur les deux OS.

Je suppose qu’il y a des problèmes de compatibilité entre les versions d’EXCEL (2003 à 2007) ?

Si vous connaissez la correction à apporter à cette macro (pour un fonctionnement sur les 2 OS), je suis bien évidemment preneur. En vous remerciant par avance.


Cordialement.


:):) MACRO "maj_liste_fichier2 :):)

'Option Private Module

'J. Walkenbach
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public ligne_en_cours_pour_les_fichiers As Long
Public variable_desactivation_userfom_event As Boolean
Public liste_des_fichiers_tableaux(65000)
Public no_repertoire As Long
' Ajout MMA
Public mma_repertoire_dur As String
Public mma_filtre_dur As String
Public mma_range_dur As String
' Fin ajout MMA

Sub maj_liste_fichier2()

' Ajout MMA
mma_repertoire_dur = "\\Srv2000\USERS\DONNEES_TECHNIQUES\FICHES_MATIERES"
mma_filtre_dur = "*.*"
mma_range_dur = "B16"
' Fin ajout MMA

' Ajout MMA : On efface une partie de la feuille
Range("B16:B65000").Select
Selection.ClearContents
' Fin ajout MMA

Range("B15").Select
Selection.AutoFilter Field:=1
Range("C15").Select
ActiveWindow.SmallScroll ToRight:=2
Selection.AutoFilter Field:=2
Range("D15").Select
Selection.AutoFilter Field:=3

Call foobar

Range("G15").Select
Range("B16:D5285").Sort Key1:=Range("C15"), Order1:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Range("A1").Select

'active_calcul
End Sub
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
'Définit le Bureau comme dossier racine
bInfo.pidlRoot = 0&
'Invite de la boite de dialogue
If IsMissing(Msg) Then
bInfo.lpszTitle = "Selectionnez un dossier."
Else
bInfo.lpszTitle = Msg
End If
'Type de renvoi : dossier
' bInfo.ulFlags = &H1
'Type de renvoi : fichier
bInfo.ulFlags = &H4000
'Affiche la boite de dialogue
x = SHBrowseForFolder(bInfo)
ChDrive Left(ThisWorkbook.path, 1)
'Traite le résultat
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

'Liste des fichiers d'un répertoire
'John Walkenbach, mpep

Sub listfiles(r As Integer)
Dim directory
Dim I
Dim sFil As String
' Which directory?
directory = mma_repertoire_dur
ChDir directory
' Get the files
sFil = Dir(mma_filtre_dur)
Do While sFil <> "" '
Cells(r, 3) = directory & "\" & sFil
'Cells(r, 3) = Mid(.FoundFiles(i), Len(Range("repertoire").Value) + 2, Len(.FoundFiles(i)) - Len(Range("repertoire").Value) + 1)
r = r + 1
ligne_en_cours_pour_les_fichiers = ligne_en_cours_pour_les_fichiers + 1
sFil = Dir
Loop
End Sub
Sub renvoie_liste_repertoire(directory2 As String)
Dim I As Long
Dim myname2 As String
myname2 = Dir(directory2, vbDirectory) ' Extrait la première entrée.

Do While myname2 <> "" ' Commence la boucle.
If myname2 <> "." And myname2 <> ".." Then
' Utilise une comparaison au niveau du bit pour
' vérifier que MyName est un dossier.
If (GetAttr(directory2 & myname2) _
And vbDirectory) = vbDirectory Then
liste_des_fichiers_tableaux(no_repertoire) = myname2
Call renvoie_liste_repertoire(directory2 & myname2)
no_repertoire = no_repertoire + 1
End If ' représente un dossier.
End If
myname2 = Dir ' Extrait l'entrée suivante.
Loop
End Sub
Sub foobar()
Dim fso As Object
Dim strName As String
Dim strArr(1 To 65536, 1 To 1) As String, I As Long
Dim directory As String
directory = mma_repertoire_dur
Dim strDir As String
strDir = directory
Const searchTerm As String = "projects"

Let strName = Dir$(strDir & "\" & mma_filtre_dur)
Do While strName <> vbNullString
Let I = I + 1
Let strArr(I, 1) = strDir & "\" & strName
Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(strDir), strArr(), I, searchTerm) ---> le débogeur se positionne à cette ligne ...Set fso = Nothing
If I > 0 Then
Range(mma_range_dur).Resize(I).Value = strArr
End If
End Sub

Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr() As String, _
ByRef I As Long, _
ByRef searchTerm As String)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.path & "\" & mma_filtre_dur)
Do While strName <> vbNullString
Let I = I + 1
Let strArr(I, 1) = SubFolder.path & "\" & strName
Let strName = Dir$()
Loop
Call recurseSubFolders(SubFolder, strArr(), I, searchTerm)
Next

Range("A1").Select

End Sub
 

Discussions similaires

Réponses
12
Affichages
225