Code vba pour retrouver fichiers office et open office

Version imprimable

09/01/2014, 14h09
adkheir

Code vba pour retrouver fichiers office et open office

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
09/01/2014, 15h04
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 …
09/01/2014, 15h12
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.
09/01/2014, 15h20
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.
09/01/2014, 16h38
Invité

http://www.developpez.net/forums/d13...r/#post7361484
11/01/2014, 17h43
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
11/01/2014, 18h40
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.
11/01/2014, 19h26
defluc

Citation:

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

Citation:

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

.
11/01/2014, 21h15
adkheir

1 pièce(s) jointe(s)

Citation:

Envoyé par defluc

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
12/01/2014, 02h35
nibledispo

code VBA pour retrouver office

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,
12/01/2014, 06h33
adkheir

1 pièce(s) jointe(s)

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
13/01/2014, 11h03
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 …

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

cordialement

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
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

13/01/2014, 19h58
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 …

1 pièce(s) jointe(s)

bonjour,

je te renouvelle ma proposition!
Code:

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.

15/01/2014, 07h29
adkheir

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

bonjour,

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

Code:

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:

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

Code:

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

15/01/2014, 10h48
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 …
26/01/2014, 22h32
adkheir

impossible sous open oofice

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
26/01/2014, 23h33
Invité

Bonsoir,

je t'es expliqué comment faire au poste 17!
26/01/2014, 23h44
adkheir

merci pour cette reponse rapide seulement en exécutant le fichier avec open office calc il ne reconnait pas les macro intégrés ou il affiche une erreur de structure.
merci
cordialement
27/01/2014, 08h52
Invité

Place la version ou tu as intégré les extebtion open office je regarderai sur un session open office.

Il y a déjà une disparitz entre les versions excel alors avec office?!