[VBA Excel sur Word] Ajouter pied de page

[Anthonymctm]

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 :

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 :

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 )

Voilà voilà

 

[Anthonymctm]

Ok, alors j'ai contourné le problème en ouvrant un fichier word modèle plutôt qu'en essayant d'ouvrir un pied de page modèle.
Ca me simplifie un peu mon code au passage

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