[VBA] Coller en tant qu'image

[Anthonymctm]

Bonjour à tous,

Avec l'aide du forum j'étais parvenu à créer un super code vba qui me permet de créer des plages nommées sur différents onglets qui correspondent à mes sauts de page, puis je lance une macro qui génère un fichier Word puis copie chacune des plages précédemment faites et va les coller les unes à la suite des autres en ajoutant un petit saut de page.

Dans le code je fais le collage avec ce bout de code

 .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
Placement:=wdInLine, DisplayAsIcon:=False

Mais je ne parviens pas à mettre le mode d'actualisation des liaisons en mode manuel, du coup le fichier word bug puisqu'il actualise en permanence et ça fait tout ramer.
Après réflexion je me dis que l’intérêt d'avoir des liaisons est assez limité pour mon utilisation. Du coup je souhaite les enlever.

Mais si je passe Link: sur False, ça ne fonctionne pas correctement, ça me copie le même onglet à chaque fois.

Idem avec

'   .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, _
      '  Placement:=wdInLine, DisplayAsIcon:=False

En fait, il faudrait simplement que ça fasse un copier en tant qu'image comme si je le faisais manuellement. Mais je ne connais pas la modification dans le code a effectuer.

Ci-joint un fichier exemple et ci-dessous le code en question :

Sub export_excel_to_word()
    Dim obj As Object
    Dim newObj As Object
    Dim sh As Worksheet
    Dim myFile
Application.ScreenUpdating = False


    Set obj = CreateObject("Word.Application")
    obj.Visible = True
    Set newObj = obj.Documents.Add
' obj.Selection.ParagraphFormat.LeftIndent = (20)
      With obj.Selection.PageSetup
        .TopMargin = (20)
        .LeftMargin = (17.5)
        .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")).Copy
        With obj.Selection
        .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      Placement:=wdInLine, DisplayAsIcon:=False
     '   .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, _
      '  Placement:=wdInLine, DisplayAsIcon:=False
      '.PasteAndFormat (wdChartPicture)
        .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")).Copy
        With obj.Selection
        .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      Placement:=wdInLine, DisplayAsIcon:=False
        .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")).Copy
        With obj.Selection
        .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      Placement:=wdInLine, DisplayAsIcon:=False
        .InsertBreak Type:=6
        End With
    End If
Next
   
newObj.Sections(1).Footers(1).PageNumbers.Add (2)

    'obj.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add _
      ' PageNumberAlignment:=wdAlignPageNumberRight
                   
   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

Merci à tous !

 

[Anthonymctm]

J'y suis parvenu en modifiant la fonction de copier par .copyPicture mais la macro est un peu instable, voir ce topic : https://www.excel-downloads.com/threads/macro-instable-copier-coller.20039269/