Macro instable Copier/Coller

[Anthonymctm]

Bonjour à tous,

Après un dur labeur et grâce à votre aide je suis parvenu a faire une macro qui export mes données excel sous Word, j'ai récemment opté pour un copier coller en tant qu'image :

.CopyPicture Appearance:=xlScreen, Format:=xlPicture
.paste

Pour remplacer l'ancien :

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

La macro s'exécute beaucoup plus rapidement, je n'ai plus les bugs liés aux liaisons et c'est bien plus facile de gérer des images.

En revanche la macro semble instable. Parfois elle fonctionne, parfois non. Je dirais que sur 10 exécutions, 6 fonctionnent.
Ça à l'air aléatoire, sans que je ne change rien au fichier (ou que je clique ailleurs)

Quand ça ne fonctionne pas c'est tantôt la ligne du .CopyPicture Appearance:=xlScreen, Format:=xlPicture qui est surlignée et parfois la ligne du .Paste

Vous trouverez un fichier exemple joint qui reproduit le même phénomène ainsi que le code en question ci dessous :

Function exist(feuille As String, nom As String) As Boolean
exist = False
On Error Resume Next
    x = Sheets(feuille).Range(nom).Address
    If Err.Number = 0 Then exist = True
On Error GoTo 0
End Function

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")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With obj.Selection
        .Paste
       ' .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      'Placement:=wdInLine, DisplayAsIcon:=False
     '   .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, _
      '  Placement:=wdInLine, DisplayAsIcon:=False
        .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
        .Paste
        .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
        .Paste
        .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

 

[Anthonymctm]

Ok merci, je comprends mieux.

Et tu saurais me dire comment inclure ça dans mon code ?

Sur google je vois qu'il ya des notions de 32bits.
Ce sera bon que Excel soit sous 32 comme 64 ?

 

[patricktoulon]

bonsoir

un exemple rapido

#If win64 Then
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
#Else
    '32 bits
    Private Declare Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As Integer) As Long
#End If

Sub test()
Dim Avail&
Sheets(1).Range("A1:C4").CopyPicture xlScreen, xlBitmap

Avail = 3
'0 ou 14 ou 2  pour 0=image bitmap(xlbitmap) ou 14=metafile(xlpicture) 2=Cf_bitmap screencapture par les touches
Do: DoEvents: Avail = IsClipboardFormatAvailable(0): Debug.Print Avail: Loop While Avail = 3
 Sheets(3).Pictures.Paste
End Sub

 

[job75]

Bonsoir,

Je pense qu'il faut être sûr que l'instruction Paste s'exécute donc :

- en début de la macro export_excel_to_word mettre l'instruction On Error Resume Next

- remplacer le bloc With/End With par :

        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

qui compte les Shapes dans Word.

Fichier joint.

A+

 

[patricktoulon]

re
bien vu job75
pas si mal le while shapes.count même pour excel quand on veux se passer des apis

 

[Anthonymctm]

Bonjour Job, Bonjour Patrick,

Merci à tous les deux pour votre aide !

J'ai opté pour la méthode de Job qui plus simple à mettre en place pour moi.
Par contre on est d'accord, dans le fichier Exemple tu n'as pas mis le On Error Resume Next ?

Je l'ai mis au tout début, c'est bon ?

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

Merci encore !

 

[job75]

Par contre on est d'accord, dans le fichier Exemple tu n'as pas mis le On Error Resume Next ?

Je l'ai mis au tout début, c'est bon ?

Oui je l'ai oublié, pas de problème.