Discussion :

[PasdeSalade]

Bonjour à tous et toutes.
Je désire renseigner en pied de page le nom du fichier Word avec son chemin donc j’insère un champ libellé ainsi FILENAME \p
Mais voilà, je ne désire pas afficher tout le chemin en intégralité, juste le nom du dossier parent.
Dans mon exemple j'ai comme résultat /Users/Moi/Documents/Formation/Word/Faux SMS AMELIE.docx alors que je n'ai besoin que de Word/Faux SMS AMELIE.docx
Auriez-vous une astuce, si possible sans vba ?
Merci beaucoup.

[Invité]

Bonjour,

Sans VBA : non, mais vous aurez peut-être des réponses.
Faites signe si la solution VBA vous intéresse.

[PasdeSalade]

Bonjour,

Sans VBA : non, mais vous aurez peut-être des réponses.
Faites signe si la solution VBA vous intéresse.

Bonjour, bah si pas moyen autrement, je veux bien l'astuce svp.
Merci.

[Invité]

Dans un module standard :

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
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
114
115
116
117
118
119
 
Option Explicit
 
Sub M01_MettreEnPlaceLeChemin()
 
    M02_CheminDansVariableDoc ActiveDocument
    M03_MajLeCheminDansPiedDePage ActiveDocument
    M04_GestionDesFenetres
 
End Sub
 
Sub M02_CheminDansVariableDoc(ByVal DocEnCours As Document)
 
Dim I As Integer
Dim LeChemin As String
Dim TableauChemin As Variant
 
    LeChemin = CheminDansVariable(DocEnCours, 0)
    With DocEnCours
         If .Variables.Count = 0 Then
            .Variables.Add Name:="Chemin", Value:=LeChemin
         Else
            For I = 1 To .Variables.Count
               If .Variables(I).Name = "LeChemin" Then
                  .Variables(I).Value = LeChemin
                  Exit For
               End If
 
            Next I
         End If
 
    End With
 
End Sub
 
 
Function CheminDansVariable(ByVal DocEnCours As Document, ByVal NbAntiSlashs As Integer) As String
 
Dim I As Integer
Dim TableauChemin As Variant
 
    CheminDansVariable = ""
    With DocEnCours
         TableauChemin = Split(.Path, "\")
         For I = UBound(TableauChemin) - NbAntiSlashs To UBound(TableauChemin)
            CheminDansVariable = CheminDansVariable & TableauChemin(I) & "\"
         Next I
         CheminDansVariable = CheminDansVariable & DocEnCours.Name
    End With
 
End Function
 
Sub M03_MajLeCheminDansPiedDePage(ByVal DocEnCours As Document)
 
 Dim I As Integer
 
    With DocEnCours
            If .Sections(1).Footers(1).Exists Then
               With .Sections(1).Footers(1)
                    .Range.Select
                    With Selection
                         If .Fields.Count > 0 Then
                            For I = 1 To .Fields.Count
                               If InStr(1, .Fields(I).Code, "DOCVARIABLE  LeChemin", vbTextCompare) > 0 Then
                                   .Fields(I).Select
                                   Selection.Range.Text = CheminDansVariable(DocEnCours, 0)
                               End If
                            Next I
                         Else
                            .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
                                 "DOCVARIABLE  LeChemin", PreserveFormatting:=True
                         End If
                    End With
              End With
            End If
    End With
 
End Sub
 
Sub M04_GestionDesFenetres()
 
    With ActiveWindow
 
        If .View.SplitSpecial <> wdPaneNone Then .Panes(2).Close
 
        With .ActivePane.View
             If .Type = wdNormalView Or .Type = wdOutlineView Then .Type = wdPrintView
        End With
 
        .ActivePane.View.SeekView = wdSeekCurrentPageHeader
        If .View.SplitSpecial = wdPaneNone Then
            .ActivePane.View.Type = wdPrintView
        Else
            .View.Type = wdPrintView
        End If
 
        .ActivePane.View.SeekView = wdSeekMainDocument
        If .View.SplitSpecial = wdPaneNone Then
            .ActivePane.View.Type = wdPrintView
        Else
            .View.Type = wdPrintView
        End If
 
    End With
 
End Sub
 
 
Sub TestM02_CheminDansVariableDoc()
 
    M02_CheminDansVariableDoc ActiveDocument
 
End Sub
 
Sub TestM03_MajLeCheminDansPiedDePage()
 
    M03_MajLeCheminDansPiedDePage ActiveDocument
 
End Sub

Dans le module ThisDocument de votre fichier :

Code :

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

1
2
3
4
5
6
7
8
9
 
Option Explicit
 
 
Private Sub Document_Open()
 
        M01_MettreEnPlaceLeChemin
 
End Sub

Si ces procédures sont placées dans un fichier modèle, il vous faut d'abord générer le fichier et le rouvrir une fois sauvegardé.

Ci-dessous, 1 fichier modèle :

[PasdeSalade]

Merci je verrai pour mes prochaines créations car je voudrais maintenant modifier mes fichiers pour avoir cette info, mais j'en ai plus d'une centaine alors ...
Je pensais que ce serait plus simple
Bonne journée.

[Invité]

Une mise à jour en masse serait possible en ouvrant chaque fichier d'un ou de répertoires et en allant coller l'information directement dans le pied de page et sans faire de mise à jour automatique. Le plus simple pour faire cela est de le faire depuis Excel pour peu que vous maîtrisiez VBA.

[Invité]

Soit un onglet Excel baptisé "Liste des fichiers" organisé comme ci-dessous.
Deux contrôles ActiveX :

• Lister les fichiers : Dresse la liste des fichiers docm, docx et Doc du répertoire choisi sans recherche récursive dans les répertoires en aval.
• Lancer la mise à jour : Met à jour les pieds de page des fichiers Word. Attention, risque d'écrasement des contenus existants.

Pièce jointe 585853

Pour dresser la liste, dans un module standard :

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
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
 
Option Explicit
 
Sub ListerTousLesFichiersDoc(ByVal FeuilleRestitution As Worksheet, ByVal TitreRestitution As Long, ByVal LeDossier As String)
 
' D'après un mix des messages de Misange, Laurent Longre, Frédéric Sigonneau, Laurent Daures anciens du Mpfe sur Excelabo
' Dans cette configuration, nécessite de référencer les DLL "Microsoft Scripting Runtime" et "Microsoft Word"
 
Dim Fso As Scripting.FileSystemObject
Dim Dossier As Folder, SousRep As Folder
Dim Fichiers As Files
Dim MonFichier As File
Dim LigneEnCours As Long
 
 
    On Error GoTo Fin
 
 
    Application.ScreenUpdating = False
 
    If VerifierLeChemin(LeDossier) = False Then
       MsgBox "Le répertoire recherché n'existe pas !", vbCritical
       GoTo Fin
    End If
 
 
    LigneEnCours = TitreRestitution + 1
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Dossier = Fso.GetFolder(LeDossier)
 
 
    If Dossier.Files.Count > 0 Then
       Set Fichiers = Dossier.Files
       For Each MonFichier In Fichiers
               Select Case Fso.GetExtensionName(MonFichier)
                    Case "docm", "docx", "doc"
                       With FeuilleRestitution
                            .Cells(LigneEnCours, 1) = MonFichier.Name  '.Name
                            .Cells(LigneEnCours, 2) = Dossier.Name
                            .Cells(LigneEnCours, 3) = MonFichier.DateCreated
                            .Cells(LigneEnCours, 4) = MonFichier.DateLastModified
                            .Hyperlinks.Add Anchor:=.Cells(LigneEnCours, 5), Address:=MonFichier.Path, TextToDisplay:=CStr(LigneEnCours - TitreRestitution)
                            LigneEnCours = LigneEnCours + 1
                       End With
                End Select
 
        Next MonFichier
        Set Fichiers = Nothing
    End If
 
 
    ' Traitement récursif des sous dossiers
    'For Each SousRep In Dossier.SubFolders
 
    '        If SousRep.Files.Count > 0 Then
    '           Set Fichiers = SousRep.Files
    '           For Each MonFichier In Fichiers
    '               With FeuilleRestitution
    '                    .Cells(LigneEnCours, 1) = MonFichier.Name  '.Name
    '                    .Cells(LigneEnCours, 2) = SousRep.Name
    '                    .Cells(LigneEnCours, 3) = MonFichier.DateCreated
    '                    .Cells(LigneEnCours, 4) = MonFichier.DateLastModified
    '                    .Hyperlinks.Add Anchor:=.Cells(LigneEnCours, 5), Address:=MonFichier.Path & "\" & MonFichier.Name, TextToDisplay:=CStr(LigneEnCours - TitreRestitution)
    '                    LigneEnCours = LigneEnCours + 1
    '               End With
    '           Next MonFichier
    '           Set Fichiers = Nothing
    '         End If
    ' Next SousRep
 
     GoTo Fin
 
Fin:
 
  Application.ScreenUpdating = True
  Set Fichiers = Nothing
  Set Dossier = Nothing
  Set Fso = Nothing
 
 
End Sub
 
 
Function VerifierLeChemin(ByVal Chemin2 As String) As Boolean
 
Dim Fso As Object
 
    VerifierLeChemin = False
    Set Fso = CreateObject("Scripting.FileSystemObject")
    VerifierLeChemin = Fso.FolderExists(Chemin2)
    Set Fso = Nothing
 
End Function

Pour mettre à jour les fichiers Word :

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
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
 
Option Explicit
 
 
Sub MajTousLesFichiersDoc()
 
Dim I As Long, DerniereLigne As Long
Dim ShFichiers As Worksheet
Dim AireFichiers As Range
Dim Repertoire As String, Chemin As String, ChaineAMemoriser As String
Dim WordApp As Word.Application, WordDoc As Word.Document, WordSelection As Word.Selection
 
    On Error GoTo Fin
 
    Set ShFichiers = Sheets("Liste des fichiers")
    With ShFichiers
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set AireFichiers = .Range(.Cells(11, 1), .Cells(DerniereLigne, 1))
         Repertoire = .Range("RepertoireFichiers")
    End With
 
   Set WordApp = CreateObject("Word.Application")
   With WordApp
        .Visible = True
        Set WordSelection = .Selection
   End With
 
    For I = 1 To AireFichiers.Count
        With AireFichiers(I)
             Chemin = Repertoire & "\" & AireFichiers(I).Value
             ChaineAMemoriser = .Offset(0, 1) & "\" & .Value
             Set WordDoc = WordApp.Documents.Open(Chemin)
 
             If WordDoc.Sections(1).Footers(1).Exists Then
                With WordDoc.Sections(1).Footers(1)
                     .Range.Text = ChaineAMemoriser
                End With
              End If
 
             GererLesFenetres WordApp
             WordDoc.Close savechanges:=True
             Set WordDoc = Nothing
       End With
 
    Next I
 
 
Fin:
 
   Application.ScreenUpdating = True
 
   WordApp.Quit
   Set WordApp = Nothing
   Set WordSelection = Nothing
 
   Set ShFichiers = Nothing
   Set AireFichiers = Nothing
 
End Sub
 
 
 
Sub GererLesFenetres(ByVal WordApp2 As Word.Application)
 
    With WordApp2.ActiveWindow
 
        If .View.SplitSpecial <> wdPaneNone Then .Panes(2).Close
 
        With .ActivePane.View
             If .Type = wdNormalView Or .Type = wdOutlineView Then .Type = wdPrintView
        End With
 
        .ActivePane.View.SeekView = wdSeekCurrentPageHeader
        If .View.SplitSpecial = wdPaneNone Then
            .ActivePane.View.Type = wdPrintView
        Else
            .View.Type = wdPrintView
        End If
 
        .ActivePane.View.SeekView = wdSeekMainDocument
        If .View.SplitSpecial = wdPaneNone Then
            .ActivePane.View.Type = wdPrintView
        Else
            .View.Type = wdPrintView
        End If
 
    End With
 
End Sub

Dans le module de l'onglet Liste des fichiers :

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
 
Option Explicit
 
Private Sub BoutonListerLesFichiers_Click()
 
        ListerTousLesFichiersDoc Sheets("Liste des fichiers"), 10, Range("RepertoireFichiers")
        MsgBox "Fin de traitement !", vbInformation
 
End Sub
 
 
Private Sub BoutonMaj_Click()
 
        MajTousLesFichiersDoc
        MsgBox "Fin de mise à jour !", vbInformation
 
End Sub