Discussion :

[Badgraf]

Bonjour à tous ! Je vous présente rapidement mon cas : je suis seconde année de DUT informatique. Pour valider mon diplôme, je termine l'année par un stage. On me demande de reprendre un programme VBA pour Excel. La 1ère version était codée pour Excel 2002 et 2003, et je dois l'adapter pour 2007.

Jusqu'à maintenant, je n'ai rencontré aucun souci de compatibilité et tout marche correctement. Sauf que voilà, il fallait que ça arrive, j'ai (enfin ?) une erreur entre les versions : la fonction FileSearch des anciennes versions ne fonctionne plus sur 2007.

J'ai cherché sur internet des solutions, et j'ai trouvé ceci :

File Search ne fonctionne plus sous excel 2007. Voici une solution de contournement pour récupérer la liste des fichiers contenus dans un dossier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Public Function getDir(path As String, sortie As String) As Variant
 Dim fList() As String
 Dim iPosition As Long
 Dim iSize As Long
 Dim sFile As String
 Dim fRange As Excel.Range
 Const iIncrement As Long = 50
 
 iSize = iIncrement
 ReDim fList(1 To iSize)
 'vous pouvez indiquer *.* pour obtenir la liste de tous les fichiers ou filtrer par l'extension
 sFile = Dir(path & IIf(Right(path, 1) = "", "", "") & "*.xls")
 
 Do While Len(sFile)
 iPosition = iPosition + 1
 If iPosition > iSize Then
 iSize = iSize + iIncrement
 ReDim Preserve fList(1 To iSize)
 End If
 fList(iPosition) = sFile
 sFile = Dir
 Loop
 
 If iSize > iPosition Then
 ReDim Preserve fList(1 To iPosition)
 End If
 
 Set fRange = Range(sortie).Resize(iPosition, 1)
 fRange.Value = WorksheetFunction.Transpose(fList)
 fRange.Sort key1:=fRange.Cells(1), order1:=xlAscending
 getDir = fRange.Value
 
 End Function

pour utiliser cette fonction depuis une macro, en utilisant l'adresse du répertoire située en A1 et pour restituer la liste des fichiers dans en E1, E2 ...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Public Sub FileSearch2007()
 Dim v As Variant
 v = getDir(Feuil1.Cells(1, 1), "E1")
end sub

Si tu as besoin en plus de lister les sous répertoires utilise plutôt cette macro :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Public Ligne As Long
 
Sub RechercheFichiers()
   Ligne = 0
   racine = "e:\donnees\daniel\mpfe" 'Mets ici ton dossier pricipal
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set dossier_racine = fso.getfolder(racine)
   Lit_dossier dossier_racine
End Sub
Sub Lit_dossier(ByRef dossier)
  For Each d In dossier.SubFolders
    Lit_dossier d
  Next
  For Each f In dossier.Files
       Ligne = Ligne + 1
       ActiveSheet.Hyperlinks.Add Cells(Ligne, 1), f.Path, 
TextToDisplay:=f.Name
       'Cells(Ligne, 1) = f.Path
  Next
End Sub

La solution me parait bien compliquée par rapport au code de mon employeur...qui elle, tient en 3 lignes :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Set fs = Application.FileSearch
 
With fs
    .MatchTextExactly = True
    .Filename = nomcherche
 
    If .Execute > 0 Then
        MsgBox "Ce nom existe déjà " & .FoundFiles.Count & _
            " fiche(s) trouvée."
        For i = 1 To .FoundFiles.Count
'            MsgBox .FoundFiles(i)
        Next i
    Else
'        MsgBox "Création " & nomcherche
' on crée maintenant la fiche technique
        chemin_ftm = chemindonnees + "0FICHE TECHNIQUE MODELE.xls"
 
        Workbooks.Open Filename:=chemin_ftm
        Range("F2").Select
        ActiveCell = nomfiche
        Range("f5").Select
        Etc...

A la place du "etc", on a la suite du "remplissage" de la table, donc rien ne change ici selon les versions, c'est pas le problème.

Je n'arrive pas trop à voir la ressemblance entre la solution trouvée sur le net et le code de mon employeur. Je voudrais donc savoir s'il existe une fonction de recherche toute bête dans Excel 2007 pour éviter d'avoir à créer cinquante mille fonctions supplémentaires. Je souhaiterais une fonction qui fait une simple recherche par nom de fichier dans un seul et même dossier (toutes les fiches techniques sont sauvegardées dans le même dossier, il n'y a pas de sous dossier, d'autre dossier, etc...).

Je vous remercie d'avance pour vos solutions.

[casefayere]

Bonsoir,
je ne regarde pas ton code mais t'en envoies un, analyses le et adaptes à ton cas, mais il faut auparavant installer le composant classefilesearch que tu trouveras ici
http://silkyroad.developpez.com/vba/classefilesearch/

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub partienom_Change()
Dim i As Long, stmessage As String
'---------------------------------------------------------------------------------------------
ListBoxARCHIVES.Clear
nomfeuil = ActiveSheet.Name
Set Recherche = ClFileSearch.Nouvelle_Recherche
r = ThisWorkbook.Path & "\" & "archives_" & nomfeuil
With Recherche
    'répertoire pour lancer la recherche
    .FolderPath = r
    'inclu les sous-dossiers dans la recherche
    .SubFolders = True
    '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_DateCreated
    .Extension = "*" & partienom & "*.pdf"
    'procède à la recherche et capture le nombre de fichiers trouvés
    inombre = .Execute
    stmessage = VBA.Format(inombre, "0"" fichiers trouvés""")
    For i = 1 To .FoundFilesCount
        nom = .Files(i).strfileName
        'nom2 = .Files(i).strpathName & "\" & nom
        ListBoxARCHIVES.AddItem nom 'nom du fichier
    Next i
End With
 
    If inombre = 0 Then
        MsgBox "0" & " fichier trouvé"
    End If
 
End Sub

bon courage

[Badgraf]

Alors, j'ai également trouvé cette solution. Toutefois, elle ne correspond pas à ce que mon employeur réclame. En effet, ce programme sera diffusé à ses clients, et le programme seul. Si tous les utilisateurs doivent installer un composant supplémentaire et l'activer, je vais me faire taper sur les doigts car c'est tout sauf pratique, surtout pour l'utilisateur lambda.

Résultat...bien compliqué pour peu de chose. Je ne comprend pas qu'une simple fonction de recherche ne soit pas livrée avec Excel...c'est assez surprenant :/

Merci tout de même pour le lien (que je connaissait déjà en fin de compte), mais cela ne correspond pas à ma demande :/

[casefayere]

Je viens de voir ce fichier joint qui pourrait peut-etre te donner des idées

[Badgraf]

Hum...je vais étudier ça, je vous redis demain ou jeudi ce qu'il en est (demain, je ne suis pas sûr de pouvoir m'occuper de ça, je dois partir en déplacement avec mon employeur). Merci encore !

[Didier Gonard]

Bonjour,

c'est bien de donner ton niveau, sinon c'est bien aussi de donner ce qui ne va pas, le nec serait d'y ajouter précisément ce que tu veux faire...

Si c'est détecter si un dossier ou fichier existe pour renvoyer un message si oui ; ou le créer si non, tu peux faire appel aux bonnes vielles commandes MsDos ou assimilées avec un mixte du FSO qui reste compatible.

pour te donner une piste, je te joint des exemples qui tournent piqués dans une de mes applis, mais vu ton environnement, tu dois voir le parallèle, sinon redemande

Routine appelée pour lors de la création client, créée les dossiers et sous dossiers voulus avec tranferts de modèles ad-hoc.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub CreaDosEtTransContainer(ByVal strCible As String, ByVal Chemcreados As String)
Dim I As Integer
Dim J As Integer
Dim W As Integer
Dim tabNomdos As Variant
Dim strDosACop As String
Dim pp
Dim xfso As New FileSystemObject
Dim objFold 'As Folder
Dim objFichier As File
 
tabNomdos = Array("CORRESPONDANCES", "ANALYSES", "PROPALS", "RENDEMENT COMMERCIAL")
 
MkDir Chemcreados 'crée le dossier  Chemcreados passé en argument
    For W = 1 To UBound(tabNomdos) 'crée les sous dossiers fixes + argument
        MkDir Chemcreados & "\" & tabNomdos(W) & "--" & strCible
    Next W
 
For I = 1 To UBound(tabNomdos)
    Set objFold = xfso.GetFolder(gvStrChemS0 & gvStrChemS8 & gvStrChemS9 & gvStrChemS11 & "Container " & tabNomdos(I) & "\") 'renvoie le dossier à traiter
    For Each objFichier In objFold.Files
            objFichier.Copy (Chemcreados & "\" & tabNomdos(I) & "--" & strCible & "\")
    Next objFichier
Next I
Set objFold = Nothing
Set objFichier = Nothing
End Sub

Fonction qui évite les doublons :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Function DoublonsDos(ByVal strCible As String, ByVal bytNbTestDoublon As Byte, Optional ByVal Chemcreados As String, Optional ByVal lstChoixCcialTrsft As String) As Boolean
Dim Chemcreados2 As String
 
DoublonsDos = True
Select Case bytNbTestDoublon
    Case 1
        Chemcreados2 = Chemcreados & Mid(gvStrChemS5, 1, Len(gvStrChemS5) - 5) & "_" & lstChoixCcialTrsft & "\" & strCible
        If Dir(Chemcreados2, vbDirectory) <> "" Then MsgBox "Ce dossier existe déjà dans le répertoire Prospects de la cible." _
         & vbCrLf & vbCrLf & "Vérifiez vos données et recommencez ou abandonnnez", , gvStrCliS: DoublonsDos = False: Exit Function
        Chemcreados2 = Chemcreados & Mid(gvStrChemS6, 1, Len(gvStrChemS6) - 5) & "_" & lstChoixCcialTrsft & "\" & strCible
        If Dir(Chemcreados2, vbDirectory) <> "" Then MsgBox "Ce dossier existe déjà dans le répertoire Clients de la cible" _
         & vbCrLf & vbCrLf & "Vérifiez vos données et recommencez ou abandonnnez", , gvStrCliS: DoublonsDos = False: Exit Function
        Chemcreados2 = Chemcreados & Mid(gvStrChemS7, 1, Len(gvStrChemS7) - 5) & "_" & lstChoixCcialTrsft & "\" & strCible
        If Dir(Chemcreados2, vbDirectory) <> "" Then MsgBox "Ce dossier existe déjà dans le répertoire Contacts de la cible" _
         & vbCrLf & vbCrLf & "Vérifiez vos données recommencez ou abandonnnez", , gvStrCliS: DoublonsDos = False: Exit Function
    Case 2
        Chemcreados = gvStrChemS0 & gvStrChemS1 & gvStrChemS2 & gvStrChemS3 & gvStrChemS5 & strCible
        If Dir(Chemcreados, vbDirectory) <> "" Then MsgBox "Ce dossier existe déjà dans le répertoire Prospects." _
         & vbCrLf & vbCrLf & "Vérifiez vos données et - ou changez le nom dans la case ""nom du dossier serveur"" et recommencez ou abandonnnez", , gvStrCliS: DoublonsDos = False: Exit Function
        Chemcreados = gvStrChemS0 & gvStrChemS1 & gvStrChemS2 & gvStrChemS3 & gvStrChemS6 & strCible
        If Dir(Chemcreados, vbDirectory) <> "" Then MsgBox "Ce dossier existe déjà dans le répertoire Clients" _
         & vbCrLf & vbCrLf & "Vérifiez vos données et - ou changez le nom dans la case ""nom du dossier serveur"" et recommencez ou abandonnnez", , gvStrCliS: DoublonsDos = False: Exit Function
 '.../... ect...
End Select
 
End Function

Celles-ci sont appelées dans divers endroits du code genre..

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Private Sub cmdCreaProspect_Click()
'.../...
If DoublonsDos(strCible, bytNbTestDoublon) = False Then Exit Sub
'.../...
Case "ListSus"
        Chemcreados = gvStrChemS0 & gvStrChemS1 & gvStrChemS2 & gvStrChemS3 & gvStrChemS5 & strCible
'.../...
        Call CreaDosEtTransContainer(strCible, Chemcreados)
'.../...