Discussion :

[adkheir]

bonjour
Tous mes fichiers office sont éparpillés dans les partition de mon disque dur et je sollicite une aide de votre part pour créer un code vba qui peut balayer tout le disque pour créer des liens de mes fichiers .doc* ou .xls* dans une page excel en vue de les retrouver plus facilement pour Microsoft office 2003 , 2010 et open office
merci
cordialement

[Marc-L]

Bonjour, bonjour,

au lieu de vouloir une mini usine à gaz en VBA,

le plus simple est d'utiliser la recherche de Windows puis d'ordonner les fichiers dans des dossiers …

[Invité]

J’ai fait ce genre d’usine à gaz pour une migration office 2003 vers 2010 ça à duré 6 heure.
Ceci dit, la macro faisait également la conversion 2010.
Mais 6 heur juste pour rapatrier les fichiers alors bonjour Windows explorer ira plus vite que ça ; je ne me serai pas lancé si j’avais pas d’autre intensions.

[defluc]

J'ai fait cela il y a des années et c'était très rapide. Mais, je ne suis pas sûr que je le retrouverais.

J'utilisais une procédure récursive dans une application Delphi avec ulilisation des activex de excel.

[Invité]

http://www.developpez.net/forums/d13...r/#post7361484

[adkheir]

merci pour ces réponses mais apparemment ma question n’étais du tout clair enfin tout ce que je recherches c'est d'avoir des liens pour mes fichiers *.xls ,*. *.doc et *.odt dans une page unique excel.
cordialement

[Invité]

effectivement tu n'as pas été très clair, je croyais que tu cherchais de l'aide.
en te proposant ce lien c'est ce que je pensai faire. bien sur le code méritait une adaptation à ton problème, mais je pensai que le sujet était proche du tien.
je me suis trompé, c'est pas grave on oubli.

[defluc]

Une question bien formulée c’est 100% de la solution (rdurupt) !

Et je n'ai toujours pas compris la question. Qu'est-ce ce que tu entends par «lien» dans la phrase

Tous mes fichiers office sont éparpillés dans les partition de mon disque dur et je sollicite une aide de votre part pour créer un code vba qui peut balayer tout le disque pour créer des liens de mes fichiers .doc* ou .xls* dans une page excel en vue de les retrouver plus facilement pour Microsoft office 2003 , 2010 et open office

.

[adkheir]

Et je n'ai toujours pas compris la question. Qu'est-ce ce que tu entends par «lien» dans la phrase .

Bonsoir et merci pour votre aide
je met en pièces jointes un fichier qui fait un listing de tous mes fichiers offices sauf a chaque fois il m'affiches des erreurs du genre erreur d’exécution 76 ou 52

[nibledispo]

Bonjour,

Ton fichier ne s'ouvre pas . Message " erreur de compilation dans module 1" et ensuite "mot de passe" quand on appui sur un bouton.

Cordialement,

[adkheir]

Bonjour
voila j'ai supprimé le mot de passe , pour les erreur je sélectionne chercher dans ordinateur il y a message "erreur d’exécution 79 mais si je cherche dans la partition c: il y a erreur d’exécution 52
cordialement

[Marc-L]

Ce serait bien de poster le code (en le balisant avec l'icône #) afin que tout le monde en profite !

Sinon la commande DOS Dir est vraiment rapide …

[adkheir]

bonsoir
voiic le code en question seulement il ya une erreur a ce niveau "
Fichier = Dir$(sChemin & "\*.*")"

cordialement

Code vb :

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
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
Option Explicit

Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean

Dim NbFichiers As Long, NbDossiers As Long
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim r As Long, rDOC As Long, rXLS As Long, rPPT As Long, sTypeFich As String
Dim TypeF() As Variant

Private Sub ListeFichiers(sDossier As String)
    DoEvents
    Application.ScreenUpdating = False
    QueryPerformanceCounter Dep

    ShFichiers.Cells.Clear
    r = 0: NbDossiers = 0: NbFichiers = 0
    rDOC = 4: rXLS = 4:  rPPT = 4

    ListeFichiersDansDossier sDossier, True
    Tri
    With ShFichiers
        .Columns("A:D").ColumnWidth = 14.86
        .Columns("A:D").Columns.AutoFit
    End With
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1

    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    With Application
        .StatusBar = "Dossiers : " & NbDossiers & " /  Fichiers : " & NbFichiers & " / " & sTypeFich & " : " & r & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
        .ScreenUpdating = True
    End With
End Sub

'   Late Binding
Private Sub ListeFichiersDansDossier(sChemin As String, bInclureSousDossiers As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String
Dim sPath As String, i As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)

    Fichier = Dir$(sChemin & "\*.*")
    Do While Len(Fichier) > 0
        NbFichiers = NbFichiers + 1
        sPath = sChemin & "\" & Fichier

        For i = LBound(TypeF) To UBound(TypeF)
            If UCase(FSO.GetExtensionName(Fichier)) Like UCase(TypeF(i)) Then
                r = r + 1
                Select Case TypeF(i)
                    Case TypeF(0)
                        rDOC = rDOC + 1
                        ShFichiers.Hyperlinks.Add Anchor:=ShFichiers.Range("A" & rDOC), _
                                                  Address:=sPath, TextToDisplay:=CStr(Fichier)
                    Case TypeF(1)
                        rXLS = rXLS + 1
                        ShFichiers.Hyperlinks.Add Anchor:=ShFichiers.Range("B" & rXLS), _
                                                  Address:=sPath, TextToDisplay:=CStr(Fichier)
                    Case TypeF(2)
                        rPPT = rPPT + 1
                        ShFichiers.Hyperlinks.Add Anchor:=ShFichiers.Range("C" & rPPT), _
                                                  Address:=sPath, TextToDisplay:=CStr(Fichier)
                End Select
            End If
        Next i
        Fichier = Dir$()
        Application.StatusBar = "Dossiers : " & NbDossiers & " /  Fichiers : " & NbFichiers & " / " & sTypeFich & " : " & r
    Loop

    If bInclureSousDossiers Then
        For Each Dossier In Dossier.SubFolders
            NbDossiers = NbDossiers + 1
            ListeFichiersDansDossier Dossier.Path, True
        Next Dossier
    End If

    Set Dossier = Nothing
    Set FSO = Nothing
End Sub

Sub SelDossier()
Dim sChemin As String, i As Long

    TypeF = Array("doc*", "xls*", "ppt*")
    sTypeFich = ""
    For i = LBound(TypeF) To UBound(TypeF)
        sTypeFich = sTypeFich & " " & TypeF(i)
    Next i

    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Dossier à traiter"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then ListeFichiers .SelectedItems(1)
        ShFichiers.Range("A5").Select
    End With
End Sub

Sub Tri()
    With ShFichiers
        .Range("A5:A" & Rows.Count).Sort Key1:=Range("A5"), Order1:=xlAscending
        .Range("B5:B" & Rows.Count).Sort Key1:=Range("B5"), Order1:=xlAscending
        .Range("C5:C" & Rows.Count).Sort Key1:=Range("C5"), Order1:=xlAscending
    End With
End Sub

[Marc-L]

Je ne comprends pas cette production gazière ne cherchant pas uniquement les fichiers Excel !

Et puis si FSO est utilisé, pas besoin de la fonction VBA Dir …


La commande Dir du DOS évoquée n'a rien à voir avec le VBA …

[Invité]

je te renouvelle ma proposition!

Code :

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

1
2
3
4
5
6
7
 
Private Sub ListeFichiersDansDossier(sChemin As String, bInclureSousDossiers As Boolean)
Dim Fso As Object, Dossier As Object, Fichier As String
Dim sPath As String, I As Long
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Dossier = Fso.GetFolder(sChemin)

ton problème vient du fait que tu utilises une méthode procédurale. quand tu descend dans les répertoire pas de problème c'est quand tu remonte (tu quitte la sub),le FSO ne mémorise pas l'emplacement où tu te trouvais. quand tu refais un dir tu le fais avec un chemin étrange, voilà ton erreur.

il faut définir un FSO pour chaque répertoire dynamiquement.

un module de classe permet de faire ça.

[adkheir]

Bonjour
simple et efficace merci RDurupt
une question peut on ajouter a la recherche les fichiers open office ?
cordialement

[Invité]

oui bien sur, comme je ne connais pas les extensions open Office, je vais te monter pour les TXT.

Code Zone de déclaration Module1 :

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

1
2
Public r As Long, rDOC As Long, rXLS As Long, rPPT As Long, sTypeFich As String
Public rTXT As Long

attention, je ne récupère que les extension pas de point!
je ne fais pas de like mais instr pas * dans l'extension.

Code Module11 Sub test() :

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

1
2
3
r = 0: NbDossiers = 0: NbFichiers = 0
    rDOC = 4: rXLS = 4:  rPPT = 4: rTXT = 4
TypeF = Array("doc", "xls", "ppt", "txt")

Code ClsRep.TestFile :

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
 Select Case TypeF(I)
                    Case TypeF(0)
                        rDOC = rDOC + 1
                        Ws.Hyperlinks.Add Anchor:=ShFichiers.Range("A" & rDOC), _
                                                  Address:=Rep & "\" & MonFich.Name, TextToDisplay:=CStr(MonFich.Name)
                           If Trim("" & Ws.Range("A" & rDOC)) = "" Then rDOC = rDOC - 1
                    Case TypeF(1)
                        rXLS = rXLS + 1
                        Ws.Hyperlinks.Add Anchor:=ShFichiers.Range("B" & rXLS), _
                                                  Address:=Rep & "\" & MonFich.Name, TextToDisplay:=CStr(MonFich.Name)
                       If Trim("" & Ws.Range("B" & rXLS)) = "" Then rXLS = rXLS - 1
                    Case TypeF(2)
                        rPPT = rPPT + 1
                        Ws.Hyperlinks.Add Anchor:=ShFichiers.Range("C" & rPPT), _
                                                  Address:=Rep & "\" & MonFich.Name, TextToDisplay:=CStr(MonFich.Name)
                         If Trim("" & Ws.Range("C" & rPPT)) = "" Then rPPT = rPPT - 1
                   Case TypeF(3)
                        rTXT = rTXT + 1
                        Ws.Hyperlinks.Add Anchor:=ShFichiers.Range("D" & rTXT), _
                                                  Address:=Rep & "\" & MonFich.Name, TextToDisplay:=CStr(MonFich.Name)
                         If Trim("" & Ws.Range("D" & rTXT)) = "" Then rTXT = rTXT - 1
                End Select

[Marc-L]

J'ai retrouvé un vieux code tout simple avec une procédure récursive utilisant seulement la fonction VBA Dir sans FSO …

Sinon les liens pourraient être évités au profit du double clic …

[adkheir]

bonsoir
j'ai voulu lancer la macro sous open office mais elle affiche une erreur , quelqu'un a une idée !
merci de votre aide
cordialement

[Invité]

je t'es expliqué comment faire au poste 17!