[VBA] Coller en tant qu'image

Anthonymctm

XLDnaute Occasionnel
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
VB:
 .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. :confused:
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. :cool:

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

Idem avec
Code:
'   .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 :
Code:
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 !
 

Pièces jointes

  • Test XL-WD (1).xlsm
    857.5 KB · Affichages: 6

Statistiques des forums

Discussions
311 729
Messages
2 081 970
Membres
101 852
dernier inscrit
dthi16088