Application.FileSearch sous 2010

New_Flo2002

XLDnaute Nouveau
Bonjour à tous,

Il y a bien longtemps que je ne suis pas venu sur ce forum, j'en ai d'ailleurs perdu tous mes acces !

Je vous avoue que c'est un sérieux problème (pour moi) qui me fais revenir vers vous (je suis assez interressé sur ce sujet mais j'esperes dépanner un ou deux débutant en échange :)

Mon problème a déjà abordé dans de nombreux sujets mais je n'arrive pas à appliquer les solutions porposées à mon code.

Pour faire simple, ce code est dans un fichier excel qui va lire dans des fichiers excel pour récupérer des informations.

Ci-dessous un extrait du fameux code qui fonctionnait sous 2003 avec la variable fs qui est mon plus gros soucis :



Option Explicit
Public P_RAN1, P_GRO As String
Public P_FIL1 As String, P_FIL2 As String, P_FIL3 As String

Sub H_ACCess1b(v_ver As Byte, X As String, V_continu As Byte, _
V_formule As Byte)

If V_continu = 2 And Range("M_CONT_B") = 1 And Range("M_CIR") = 2 Then
Set P_RAN1 = Range("M" & Range("M_CIR") & "_MAR2")
Else: Set P_RAN1 = Range("M" & Range("M_CIR") & "_MAR1")
End If


Application.SheetsInNewWorkbook = 1
Application.ScreenUpdating = False
Dim Db_1 As Byte, Db_2 As Byte
Dim Di_1 As Integer, Di_2 As Integer, Di_3 As Integer, Di_4 As Integer
Dim Ds_1 As String, Ds_2 As String
Dim fs, uf1_l1
Dim F_FIL As String
Dim i_cum As Integer

Range("M_1_DATA").Cells(1, 1).Value = X
Range("M_" & v_ver & "_DATA3").Copy
Range("M_1_DATA2").PasteSpecial Paste:=xlPasteValues
uf1_l1 = Range("M_1_DATA1")
UserForm2.ListBox1.List() = uf1_l1
UserForm2.Show

If UserForm2.TextBox1 = 2 Then
MsgBox ("SELECTION ANNULEE")
End
End If

If Range("M_MD1") <> 1 And V_formule = 2 Then
MsgBox ("SELECTION ANNULEE : PAS DE RECALCUL SUR LES MOIS")
End
End If

Calculate
'-------------------------------------------------------------
Di_3 = 1: Di_4 = 1
If V_continu = 2 Then Di_4 = P_RAN1.Rows.Count
If V_continu = 3 Then
Di_4 = Range("M_MF1")
Di_3 = Range("M_MD1")
End If

'Si Génération en continu
For Di_2 = Di_3 To Di_4
If V_continu = 2 Then Range("M_1_DATA1").Cells(2, 2) = P_RAN1.Cells(Di_2, 1)
Calculate
If V_continu <> 3 Then
P_FIL1 = Range("M_FILE1").Cells(1, Range("M_CIR")) & ".xls"
P_FIL2 = Range("M_FILE2").Cells(1, Range("M_CIR")) & ".xls"
ElseIf V_continu = 3 Then
P_FIL1 = Left(Range("M_FILE1").Cells(1, Range("M_CIR")), 7) & T_T2(Di_2) & ".xls"
P_FIL2 = Left(Range("M_FILE1").Cells(1, Range("M_CIR")), 7) & T_T2(Di_2 - 1) & ".xls"
End If
P_FIL3 = Range("M_FILE3").Cells(1, Range("M_CIR")) & ".xls"
P_GRO = Range("M_GRO").Cells(1, Range("M_CIR"))

'Teste l'existence d'une extraction Db_1 = 2 autrement
'Db_1 = 3 si normal ou 4 si CUMUL
Db_1 = 0
Calculate
Set fs = Application.FileSearch
fs.LookIn = Range("M_DIR2")
fs.Filename = P_FIL1
fs.Execute
If fs.FoundFiles.Count = 1 Then
If UCase(fs.FoundFiles(1)) = UCase(Range("M_DIR2") & "\" & P_FIL1) Then
Db_1 = 2
Else: Db_1 = 3
End If
Else: Db_1 = 3
End If

'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

Merci par avance pour toute aide meme un petit exemple basé sur ce code.

Pour info, j'ai commencé avec ClFileSearch.Nouvelle_Recherche proposé sur le net mais je bloque sur le fs.


Dim i As Long
Dim Recherche As ClFileSearch.ClasseFileSearch
Dim FileName As String

Set Recherche = ClFileSearch.Nouvelle_Recherche

With Recherche
'Définit le répertoire de recherche
.FolderPath = Range("M_DIR2")

'Définit la recherche dans les sous dossiers (True / False)
.SubFolders = False

'Option de tri:
'(Sort_None, sort_Name, sort_Path, sort_Size, sort_DateCreated, sort_LastModified, sort_Type)
'Pas de tri si le paramètre n'est pas spécifié.
.SortBy = sort_Name

'Option pour rechercher un type de fichier
'(Renvoie tous les fichiers si non spécifié)
'.Extension = "*.doc"

'Execute la recherche
.Execute

'Boucle sur le tableau pour afficher le résultat de la recherche
'(.FoundFilesCount renvoie le nombre de fichiers trouvés)
For i = 1 To .FoundFilesCount

FileName = .Files(i).strFileName 'nom du fichier
' Range("P_FIL1").Value = Filename
' M_DIR2.Value .Files(i).strPathName 'chemin
'If .FoundFilesCount = 1 Then
If UCase(FileName) = UCase(P_FIL1) Then
Db_1 = 2
GoTo suite
Else: Db_1 = 3
End If
'Else: Db_1 = 3
'End If


Next

End With

suite:
Set Recherche = Nothing

'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx
'Set fs = Application.FileSearch
'fs.LookIn = Range("M_DIR2")
'fs.Filename = P_FIL1
'fs.Execute
'If fs.FoundFiles.Count = 1 Then
' If UCase(fs.FoundFiles(1)) = UCase(Range("M_DIR2") & "\" & P_FIL1) Then
' Db_1 = 2
'Else: Db_1 = 3
'End If
' Else: Db_1 = 3
'End If
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX


Merci

Florent
 

New_Flo2002

XLDnaute Nouveau
Re : Application.FileSearch sous 2010

Merci à tous ceux qui m'ont apporté ce début de réponse mais je ne m'en sort pas....

Concrètement mon problème est sur ce niveau :

Set fs = Application.FileSearch => Set fs = CreateObject("Scripting.FileSystemObject")
fs.LookIn = Range("M_DIR2") => comment on fait ?
fs.Filename = P_FIL1 => fs.getfilename (P_FIL1) ???
fs.Execute=> comment on fait ?
If fs.FoundFiles.Count = 1 Then=> comment on fait ?
If UCase(fs.FoundFiles(1)) = UCase(Range("M_DIR2") & "\" & P_FIL1) Then=> comment on fait ?
Db_1 = 2
Else: Db_1 = 3
End If
Else: Db_1 = 3
End If

En rouge mon bricolage et mes interrogations

Auriez vous un exemple simple avec ce que je cherche à faire ci-dessus à savoir :
regarder dans le répertoire
trouver le nom du fichier
compter le nombre de fichier


Merci pour votre aide précieuse

Florent
 

MJ13

XLDnaute Barbatruc
Re : Application.FileSearch sous 2010

Bonjour à tous

Voici un exemple pour avoir la liste des fichiers d'un dossier.

Code:
Sub Liste_Fichiers()
'Liste des Fichiers d'un dossier avec le nom du dossier en B1
    'On Error Resume Next
    Range(Cells(2, 1), Cells(65536, 2)).Clear
     Dim i  As Integer, z As String
     ChDrive Left(Cells(1, 2), 1)
     ChDir Cells(1, 2).Value
     
    i = 1
    z = Dir("*.*", 1)
    
    While z <> ""
          If z <> ThisWorkbook.Name Then ActiveSheet.Cells(i + 1, 1).Value = z
          i = i + 1
          z = Dir
    Wend
End Sub
 

New_Flo2002

XLDnaute Nouveau
Re : Application.FileSearch sous 2010

Bonjour à tous, et merci pour ces premières informations.

J'ai commencé à utiliser le code de MJ13 et cela donnerait le code ci-dessous :

Dim i As Integer, z As String
ChDrive (Left(Range("M_DIR2"), 1))
ChDir (Range("M_DIR2").Value)
'
' i = 1
z = Dir("*.*", 1)
'
While z <> ""
' If z <> ThisWorkbook.Name Then ActiveSheet.Cells(i + 1, 1).Value = z
' i = i + 1
z = Dir

If UCase(Range("M_DIR2") & "\" & z) = UCase(Range("M_DIR2") & "\" & P_FIL1) Then
Db_1 = 2
Else: Db_1 = 3
End If

Wend

Avant d'aller plus loins dans mon code, cela vous semble-t-il cohérent ?

Encore merci pour votre support
 

coco_lapin

XLDnaute Impliqué

coco_lapin

XLDnaute Impliqué
Re : Application.FileSearch sous 2010

Bonjour MJ13,

Je suis parti du code de JNP que j'ai adapté pour mon application (voir en annexe son code du 30/11/2010 19H40 du lien que j'ai donné un peu plus haut) et voir l'application de marmotte 18 (02/12/2010 15H46 du même lien).

J'avais aussi essayé ton code (un peu plus haut dans ce fil) qui donne la liste des fichiers d'un répertoire. Il fonctionne très bien. J'ai plutôt utilisé celui de JNP qui prend en compte les sous-répertoires.

Option Explicit
Dim I As Long
Sub Test()
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Chemin = "C:\Users\JNP\Documents\"
I = 1
Application.ScreenUpdating = False
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each Fichier In Dossier.Files
Cells(I, 1) = Dossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
Next
ListeFichier (Chemin)
Application.ScreenUpdating = True
End Sub
Function ListeFichier(Chemin As String) As String
Dim Dossier As Object, SousDossier As Object, Fichier As Object
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each SousDossier In Dossier.SubFolders
ListeFichier (Chemin & SousDossier.Name & "\")
For Each Fichier In SousDossier.Files
Cells(I, 1) = SousDossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
Next
Next
End Function
 

Discussions similaires