[VBA Excel sur Word] Ajouter pied de page

Version imprimable

1 pièce(s) jointe(s)

Bonjour le forum,

Grace à l'aide du forum il y a quelque mois, j'étais parvenu à bricoler une macro (qui fonctionne très bien) qui me permet de créer un fichier Word à partir de mes zones d'impression définies.

J'essaye maintenant d'ajouter un beau pied de page qui ressemble à ça : Pièce jointe 575030

Je ne connais pas la méthode pour y parvenir. Je vais vous montrer ce que j'ai tenté (vers la fin de la macro)
Le fichier qui lance la macro est utilisé par plusieurs utilisateurs (donc plusieurs pc)
Voici la macro :

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
Sub ET_Excel_to_word()
    On Error Resume Next
    Dim obj As Object, newObj As Object, sh As Worksheet, myFile$, n As Byte, nn As Byte, MonPDP As String, MonChemin As String, wdSeekCurrentPageFooter
 
Application.ScreenUpdating = False
    Set obj = CreateObject("Word.Application")
    obj.Visible = True
    Set newObj = obj.Documents.Add
     With obj.Selection.PageSetup
        .TopMargin = (20)
        .LeftMargin = (20)
        .RightMargin = (20)
        .BottomMargin = (0)
        .HeaderDistance = (0)
        .FooterDistance = (15)
    End With
 
For n = 1 To 3
    If exist("En_tête", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("En_tête").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
       With obj.Selection
            nn = newObj.InlineShapes.Count + 1
            While newObj.InlineShapes.Count < nn: DoEvents: .Paste: Wend 'en attente de l'exécution
            .InsertBreak Type:=6
        End With
     End If
Next
For n = 1 To 15
    If exist("Descriptif", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Descriptif").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With obj.Selection
            nn = newObj.InlineShapes.Count + 1
            While newObj.InlineShapes.Count < nn: DoEvents: .Paste: Wend 'en attente de l'exécution
            .InsertBreak Type:=6
        End With
    End If
Next
For n = 1 To 5
    If exist("Carac_tech", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Carac_tech").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With obj.Selection
            nn = newObj.InlineShapes.Count + 1
            While newObj.InlineShapes.Count < nn: DoEvents: .Paste: Wend 'en attente de l'exécution
            .InsertBreak Type:=6
        End With
    End If
Next
ThisWorkbook.Worksheets("CGV").Range("CGV").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    With obj.Selection
            nn = newObj.InlineShapes.Count + 1
            While newObj.InlineShapes.Count < nn: DoEvents: .Paste: Wend 'en attente de l'exécution
    End With
 
 newObj.Sections(1).Footers(1).PageNumbers.Add (1)
 
    'obj.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add _
      ' PageNumberAlignment:=wdAlignPageNumberRight
 
'!!!!!!!!!!! Ce que j'essaye d'ajouter !!!!!!!!!!!!
MonChemin = VBA.Environ("UserProfile") & "\AppData\Roaming\Microsoft\Document Building Blocks\1036\16\Building Blocks.dotx"
newObj.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    newObj.Templates(MonChemin).BuildingBlockEntries("MCTM_PDP").Insert Where:=Selection.Range, RichText:=True
 
 
 
'!!!!!!!!!!! La suite de la macro !!!!!                 
   Application.CutCopyMode = False
    myFile = Replace(ActiveWorkbook.Name, "xlsm", "docx")   'remplacer "docx" par l'extension qui convient, si nécessaire
    newObj.SaveAs Filename:=Application.ActiveWorkbook.Path & "\" & myFile
 Application.ScreenUpdating = True
    MsgBox "Export vers Word terminé", vbInformation + vbOKOnly, "Export vers Word"
 
    obj.Activate
    Set obj = Nothing
    Set newObj = Nothing
End Sub

L'enregistreur de macro sur word m'a donné ce code, j'ai isolé le début du chemin pour que ça s'adapte en fonction de l'utilisateur.
Ca fonctionne si je lance le bout de code par word, mais pas depuis excel.

Je pensais à deux options :
-Mettre le pied de page sur un dossier partager sur notre réseau (je ne sais pas comment faire)
-réécrire dans la macro le pied de page directement (je ne sais pas comment faire non plus :aie:)

Voilà voilà :D

15/07/2020, 11h48
Philippe Tulliez

Bonjour,
Le pied de page doit-il être différent suivant critère ?
Si pas, je passerais tout simplement par un modèle Word créé manuellement que j'ouvrirais depuis Excel
15/07/2020, 11h57
Anthony47

Citation:

Envoyé par Philippe Tulliez

Bonjour,
Le pied de page doit-il être différent suivant critère ?
Si pas, je passerais tout simplement par un modèle Word créé manuellement que j'ouvrirais depuis Excel

Bonjour Philippe,

Non, il sera tout le temps identique.

Tu peux me détailler un peu la manip et ce que j'aurai à changer dans mon code ?

Si je comprend bien, je prépare un modèle que j'enregistre dans un dossier partagé.
Ensuite à la place de générer un nouveau fichier word, j'ouvre le modèle.

Bonjour Anthony,
Voici un exemple de l'ouverture d'un nouveau document Word, basé sur un modèle, ici nommé myTemplate.docx se trouvant dans un sous-répertoire nommé Template
Pour que cette procédure fonctionne, il faut référencer la bibliothèque Microsoft Word nn.n Object Library soit pour Office 2010, Microsoft Word 14.0 Object Library

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub OpenWordTemplate()
  ' Nécessite de référencer Microsoft Word nn.n Object Library
  ' Déclaration
  Const SubFolder As String = "Template"            ' Sous-répertoire où se trouve le modèle
  Const TemplateName As String = "myTemplate.docx"  ' Nom du modèle
  Dim appWrd As Word.Application
  Dim wrdDoc As Word.Document
  Dim appPath As String, wrdFullName As String
  '
  appPath = ThisWorkbook.Path
  wrdFullName = appPath & "\" & SubFolder & "\" & TemplateName
  Set appWrd = CreateObject("Word.Application")
  '
  With appWrd
   Set wrdDoc = .Documents.Add(Template:=wrdFullName)  ' Ouvre un nouveau docment basé sur un modèle
  .Visible = True                                      ' Rend visible l'application
  .Activate                                            ' Active l'application
  End With
  ' Fin de procédure
  Set appWrd = Nothing: Set wrdDoc = Nothing
End Sub

Je suis parvenu à adapter ton code, ça fonctionne très bien !

Je m'étais juste fait avoir par le appPath qui supposait que le modèle soit dans le même dossier que le fichier Excel.

Comme les utilisateurs ne seront pas toujours connectés au serveur, j'effectue un test pour changer de chemin et chercher le modèle sur leur bureau.

Comme je sens que ça va arriver, j'ai prévu le cas où ils ne sont pas connectés au serveur et le fichier sur leur bureau n'existe plus.

Peut-tu me dire si tout te parait bon ou si quelque chose de choque dans mon code (procédure, variable, autre)

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
Sub ET_Excel_to_word()
On Error Resume Next
Dim myFile$, n As Byte, nn As Byte, appWrd As Word.Application, wrdDoc As Word.Document, wrdFullName As String, MyPath, Chemin$, TemplateName$
Application.ScreenUpdating = False
 
TemplateName = "Pied de page.docx" ' Nom du modèle
Chemin = "\\srv-dom\Commun\Transfert - Partage\Anthony - Ne pas supprimer\Devis\" ' Sous-répertoire où se trouve le modèle
MyPath = Dir(Chemin & TemplateName)
If MyPath = "" Then
Chemin = VBA.Environ("UserProfile") & "\desktop\"
End If
MyPath = Dir(Chemin & TemplateName)
If MyPath = "" Then
Set appWrd = CreateObject("Word.Application")
appWrd.Visible = True
Set wrdDoc = appWrd.Documents.Add
MsgBox "Attention les pieds de page n'ont pas été chargés"
GoTo ajoutpage
End If
 
wrdFullName = Chemin & TemplateName
Set appWrd = CreateObject("Word.Application")
With appWrd
    Set wrdDoc = .Documents.Add(Template:=wrdFullName)  ' Ouvre un nouveau docment basé sur un modèle
    .Visible = True                                      ' Rend visible l'application
    .Activate                                            ' Active l'application
End With
 
ajoutpage:
For n = 1 To 3
    If exist("En_tête", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("En_tête").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With appWrd.Selection
            nn = wrdDoc.InlineShapes.Count + 1
            While wrdDoc.InlineShapes.Count < nn: DoEvents: .Paste: Wend 'en attente de l'exécution
            .InsertBreak Type:=6
        End With
        '.PasteSpecial Link:=True, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False
        '.PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
    End If
Next
For n = 1 To 15
    If exist("Descriptif", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Descriptif").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With appWrd.Selection
            nn = wrdDoc.InlineShapes.Count + 1
            While wrdDoc.InlineShapes.Count < nn: DoEvents: .Paste: Wend 'en attente de l'exécution
            .InsertBreak Type:=6
        End With
    End If
Next
For n = 1 To 5
    If exist("Carac_tech", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Carac_tech").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With appWrd.Selection
            nn = wrdDoc.InlineShapes.Count + 1
            While wrdDoc.InlineShapes.Count < nn: DoEvents: .Paste: Wend 'en attente de l'exécution
            .InsertBreak Type:=6
        End With
    End If
Next
ThisWorkbook.Worksheets("CGV").Range("CGV").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    With appWrd.Selection
            nn = wrdDoc.InlineShapes.Count + 1
            While wrdDoc.InlineShapes.Count < nn: DoEvents: .Paste: Wend 'en attente de l'exécution
    End With
 
'newObj.Sections(1).Footers(1).PageNumbers.Add (1) 'option 1
'appWrd.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.AddPageNumberAlignment:=wdAlignPageNumberRight 'option 2
'MonChemin = VBA.Environ("UserProfile") & "\AppData\Roaming\Microsoft\Document Building Blocks\1036\16\Building Blocks.dotx" 'option 3
'appWrd.ActivePane.View.SeekView = wdSeekCurrentPageFooter
'appWrd.Templates(MonChemin).BuildingBlockEntries("MCTM_PDP").Insert Where:=Selection.Range, RichText:=True
 
Application.CutCopyMode = False
myFile = Replace(ActiveWorkbook.Name, "xlsm", "docx")   'remplacer "docx" par l'extension qui convient, si nécessaire
wrdDoc.SaveAs Filename:=Application.ActiveWorkbook.Path & "\" & myFile
 
appWrd.Activate
Set appWrd = Nothing
Set wrdDoc = Nothing
Application.ScreenUpdating = True
MsgBox "Export vers Word terminé", vbInformation + vbOKOnly, "Export vers Word"
End Sub

Merci beaucoup :zoubi:

15/07/2020, 19h49
Philippe Tulliez

Bonjour,
Pour rendre pérenne une application, je privilégie toujours les sous-dossiers ce qui permet de déplacer l'ensemble d'un dossier vers n'importe quel endroit du réseau.
Parmi les sous-dossiers, j'en ai un nommé Config qui contient entre autres un ou plusieurs fichiers suffixés Ini donc si l'adresse esr différente par utilisateur, je choisi de définir ces chemins dans un fichier ini du nom de l'utilisateur et qui contient donc les chemins propres à chaque utilisateur
Il faut éviter de "Hard coder" afin de maintenir aisément l'application