Enregistrer fichier dans plusieurs répertoires

Version imprimable

06/08/2019, 23h55
GADENSEB

Enregistrer fichier dans plusieurs répertoires

Bonjour le Forum
Je souhaiterais enregistrer, a l'enregistrement ou fermeture, un fichier word dans plusieurs sous-dossiers répartis dans un répertoire.

Je vous explique mon schéma
- Ouverture du fichier : je scanne un répertoire et ses sous-répertoires pour trouver tous les fichiers du méme nom
- J'enregistre ces cibles dans une ou plusieurs variables
- A l'enregistrement/fermeture du fichier : un pop-up me demande de confirmer l'écrasement des cibles contenues dans les variables précédentes.
- Écrasement ou non des cibles.
- Enregistrement du fichier dans le dossier ou je l'ai ouvert.....

Je décris la procédure car je ne suis pas a l'aise avec les vba word,
mais je suis plus à l'aise avec les vba Excel
Est*ce la mm chose ??

Merci à vous
07/08/2019, 04h14
Invité

Citation:

Envoyé par GADENSEB

Bonjour,

Citation:

Est*ce la mm chose ??

Oui. Faites votre code sous Excel et transposez le sous Word une fois au point.

Un exemple qui peut vous servir : word-vba-concatener-fichiers-dat-sauvegarde-rtf-partir-document-word-docm.
L'exemple contient un liste à liste dans un userform et une matrice qui permet de mémoriser vos choix. Il y aura juste une modification de la procédure de chargement des fichiers pour réaliser une recherche récursive dans les sous dossiers.
11/08/2019, 15h16
GADENSEB

Bonjour
Merci de la réponse !
je me lance sur excel et je reviens !!!!

bonne am

4 pièce(s) jointe(s)

Bonjour Eric

J'ai réussi à avancer sur ce projet grâce à job75, pour la version Excel que je remercie au passage.
Cela fonctionne parfaitement.

Comme au début de mon post je cherche a faire cette version de macro en VBA-Word

J'ai créer une macro qui fonctionne sur tous les fichiers word pas le biais d'un bouton dans la barre de tâches

J'ai un soucis de déclaration de variable "Chemin" dans
Pièce jointe 497887

Pièce jointe 497891

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
Dim fso As Object, liste, n& 'mémorise les variablesSub pfichiers()
'
' pfichiers Macro
'
'
Dim fso As Object, liste, n& 'mémorise les variables
 
 
 
 
 
 
 
 
If MsgBox("Nouvel Emplacement ?", vbYesNo, "Demande de confirmation") = vbYes Then
 
Application.FileDialog(msoFileDialogSaveAs).Show
 
 
End If
 
 
Dim debut$, chemin As Long, nom$
With ThisWorkbook
    debut = "E:\Logiciels\00 - PROJETS"
    chemin = .Path
    nom = LCase(.Name) 'minuscules
    Set fso = CreateObject("Scripting.FileSystemObject")
    ReDim liste(0) 'RAZ
    n = 0 'RAZ
    ListeRecursive fso.getfolder(debut), nom
    Application.DisplayAlerts = False
    If n Then
        For n = 0 To UBound(liste)
            .SaveAs liste(n)
        Next
    End If
    MsgBox IIf(n, n, "Aucun") & " fichier" & IIf(n > 1, "s", "") & " écrasé" & IIf(n > 1, "s", "") & " dans les sous-dossiers"
    .SaveAs chemin & "\" & nom
End With
Set fso = Nothing
End Sub
 
 
Sub ListeRecursive(f As Object, nom$)
Dim sf As Object, fich As Object
For Each sf In f.subfolders
    For Each fich In fso.getfolder(sf).Files
        If LCase(fich.Name) = nom Then
            ReDim Preserve liste(n)
            liste(n) = sf & "\" & nom
            n = n + 1
        End If
    Next fich
    ListeRecursive fso.getfolder(sf), nom
Next sf
End Sub
 
 
End Sub

Comment doit-on déclarer dans word ?

En te remerciant.

16/08/2019, 11h02
Invité

Citation:

Envoyé par GADENSEB

Bonjour,

Je n'ai pas ouvert les fichiers, mais si la procédure jointe est lancée depuis Word, cela ne peut pas être With ThisWordBook, mais With ActiveDocument.
17/08/2019, 07h57
GADENSEB

Hello.
Une erreur de débutant de ma part.
Je regarde cela dans la journée.
Merci a toi

Citation:

Envoyé par GADENSEB

Bonjour,

Ce code fonctionne :

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
 
Option Explicit
 
Dim Fso As Object, Liste, N& 'mémorise les variables
 
Sub EcraserFichiers()
 
Dim Debut$, Chemin$, Nom$, ListeDesFichiers$
 
 
        If MsgBox("Nouvel Emplacement ?", vbYesNo, "Demande de confirmation") = vbYes Then
           Application.Dialogs(wdDialogFileSaveAs).Show
        End If
 
        With ActiveDocument
 
             ListeDesFichiers$ = "Liste des fichiers écrasés : " & Chr(10)
 
             Debut = "E:\Logiciels\00 - PROJETS"
             Chemin = .Path
             Nom = LCase(.Name) 'minuscules
             Set Fso = CreateObject("Scripting.FileSystemObject")
             N = 0 'RAZ
             ReDim Liste(N) 'RAZ
             ListeRecursive Fso.getfolder(Debut), Nom
 
             Application.DisplayAlerts = False
             If N Then
                For N = 0 To UBound(Liste)
                    .SaveAs Liste(N)
                    ListeDesFichiers$ = ListeDesFichiers$ & Mid(Liste(N), Len(Debut) + 1) & Chr(10)
                    'Debug.Print Liste(n)
                Next
             End If
             MsgBox IIf(N, N, "Aucun") & " fichier" & IIf(N > 1, "s", "") & " écrasé" & IIf(N > 1, "s", "") & " dans les sous-dossiers" & Chr(10) & ListeDesFichiers
 
             .SaveAs chemin & "\" & nom
        End With
 
        Application.DisplayAlerts = True
 
        Set Fso = Nothing
 
End Sub
 
Sub ListeRecursive(f As Object, Nom$)
 
Dim Sf As Object, Fich As Object
 
    For Each Sf In f.subfolders
        For Each Fich In Fso.getfolder(Sf).Files
            If LCase(Fich.Name) = Nom Then
                ReDim Preserve Liste(N)
                Liste(N) = Sf & "\" & Nom
                N = N + 1
            End If
        Next Fich
        ListeRecursive Fso.getfolder(Sf), Nom
    Next Sf
 
End Sub

17/08/2019, 15h27
GADENSEB

C'est génial
cela fonctionne parfaitement

bonne am et merci encore

Rebonsoir

Le code fonctionne super bien mais je voudrais rajouter un niveau de validation par l'utilisateur

au moment du déclenchement, je voudrais valider la liste des cibles du futur écrasement avec qqc comme cela :

Code:

If MsgBox("Merci de confirmer la suppression dans ?" & Chr(10) & ListeDesFichiers, vbYesNo, "Demande de confirmation") = vbYes Then

ou le placer dans le code ?

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
Option Explicit 
Dim Fso As Object, Liste, N& 'mémorise les variables
 
 
 
 
Sub MULTILOCALISATIONS()
 
 
 
 
 
 
 
Dim Debut$, Chemin$, Nom$, ListeDesFichiers$
 
 
        If MsgBox("Nouvel Emplacement ?", vbYesNo, "Demande de confirmation") = vbYes Then
           Application.Dialogs(wdDialogFileSaveAs).Show
        End If
 
        With ActiveDocument
 
             ListeDesFichiers$ = "Liste des fichiers écrasés : " & Chr(10)
 
             Debut = "E:\Logiciels\00 - PROJETS"
             Chemin = .Path
             Nom = LCase(.Name) 'minuscules
             Set Fso = CreateObject("Scripting.FileSystemObject")
             N = 0 'RAZ
             ReDim Liste(N) 'RAZ
             ListeRecursive Fso.getfolder(Debut), Nom
 
 
 
             Application.DisplayAlerts = False
             If N Then
                For N = 0 To UBound(Liste)
                    .SaveAs Liste(N)
                    ListeDesFichiers$ = ListeDesFichiers$ & Mid(Liste(N), Len(Debut) + 1) & Chr(10)
                    'Debug.Print Liste(n)
                Next
             End If
             MsgBox IIf(N, N, "Aucun") & " fichier" & IIf(N > 1, "s", "") & " écrasé" & IIf(N > 1, "s", "") & " dans les sous-dossiers" & Chr(10) & ListeDesFichiers
 
             .SaveAs Chemin & "\" & Nom
 
 
        Application.DisplayAlerts = True
 
        Set Fso = Nothing
     End If
     End With
End Sub
 
Sub ListeRecursive(f As Object, Nom$)
 
Dim Sf As Object, Fich As Object
 
    For Each Sf In f.subfolders
        For Each Fich In Fso.getfolder(Sf).Files
            If LCase(Fich.Name) = Nom Then
                ReDim Preserve Liste(N)
                Liste(N) = Sf & "\" & Nom
                N = N + 1
            End If
        Next Fich
        ListeRecursive Fso.getfolder(Sf), Nom
    Next Sf
 
End Sub

en te remerciant

Citation:

Envoyé par GADENSEB

Bonjour,

Plusieurs possibilités :

La plus simple serait de poser la question à l'intérieur de la procédure ListeRecursive.
L'autre offrant plus de lisibilité et moins d'"irritant" serait un liste à liste dans un Userform comme dans l'exemple indiqué dans un de mes précédents messages.

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
 
Option Explicit
 
Dim Fso As Object, Liste() As Variant, N&, Debut$ 'mémorise les variables
 
Sub EcraserFichiers()
 
Dim Chemin$, Nom$, ListeDesFichiers$
Dim NbFichiersEcrases As Integer
 
        If MsgBox("Nouvel Emplacement ?", vbYesNo, "Demande de confirmation") = vbYes Then
           Application.Dialogs(wdDialogFileSaveAs).Show
        End If
 
        With ActiveDocument
 
             ListeDesFichiers$ = Chr(10)
 
             Debut = "E:\Logiciels\00 - PROJETS"
             Chemin = .Path
             Nom = LCase(.Name) 'minuscules
             Set Fso = CreateObject("Scripting.FileSystemObject")
             N = 0 'RAZ
             ListeRecursive Fso.getfolder(Debut), Nom
 
             Application.DisplayAlerts = False
             NbFichiersEcrases = 0
             If N Then
                For N = LBound(Liste, 1) To UBound(Liste, 1)
                       .SaveAs Liste(N)
                       ListeDesFichiers$ = ListeDesFichiers$ & Mid(Liste(N), Len(Debut) + 1) & Chr(10)
                       NbFichiersEcrases = NbFichiersEcrases + 1
                Next
             End If
             MsgBox IIf(NbFichiersEcrases, NbFichiersEcrases, "Aucun") & " fichier" & IIf(NbFichiersEcrases > 1, "s", "") & " écrasé" & IIf(NbFichiersEcrases > 1, "s", "") & " dans les sous-dossiers" & Chr(10) & ListeDesFichiers
 
        End With
 
        Application.DisplayAlerts = True
 
        Set Fso = Nothing
 
End Sub
 
Sub ListeRecursive(f As Object, Nom$)
 
Dim Sf As Object, Fich As Object
 
    For Each Sf In f.subfolders
        For Each Fich In Fso.getfolder(Sf).Files
            If LCase(Fich.Name) = Nom Then
               If MsgBox("Merci de confirmer la suppression dans ?" & Chr(10) & Mid(Sf, Len(Debut) + 1), vbYesNo, "Demande de confirmation") = vbYes Then
                  ReDim Preserve Liste(N)
                  Liste(N) = Sf & "\" & Nom
                 N = N + 1
               End If
 
            End If
        Next Fich
        ListeRecursive Fso.getfolder(Sf), Nom
    Next Sf
 
End Sub

17/09/2019, 21h07
GADENSEB

Bonsoir,
Je n'avais pas vu ta réponse.
Désolé
Cela marche nikel
Merci à toi
bonne soirée