[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/